hbro 1.2.0.0 → 1.3.0.0
raw patch · 48 files changed
+2203/−2249 lines, 48 filesdep +aesondep +data-default-classdep +fast-loggerdep −data-defaultdep −hsloggerdep −stmdep ~classy-preludedep ~lensdep ~lifted-async
Dependencies added: aeson, data-default-class, fast-logger, monad-logger, optparse-applicative, resourcet, stm-chans
Dependencies removed: data-default, hslogger, stm
Dependency ranges changed: classy-prelude, lens, lifted-async, lifted-base, monad-control, mtl, webkitgtk3
Files
- README.rst +5/−3
- executable/Main.hs +2/−2
- hbro.cabal +54/−67
- library/Control/Monad/Logger/Extended.hs +13/−0
- library/Control/Monad/Reader/Extended.hs +65/−0
- library/Graphics/Rendering/Pango/Extended.hs +16/−0
- library/Graphics/UI/Gtk/General/General/Extended.hs +20/−0
- library/Graphics/UI/Gtk/WebKit/Lifted.hs +20/−10
- library/Graphics/UI/Gtk/WebKit/Lifted/WebView.hs +27/−15
- library/Hbro.hs +21/−26
- library/Hbro/Boot.hs +122/−59
- library/Hbro/Clipboard.hs +16/−10
- library/Hbro/Config.hs +20/−25
- library/Hbro/Core.hs +79/−50
- library/Hbro/Defaults.hs +134/−0
- library/Hbro/Dyre.hs +28/−17
- library/Hbro/Error.hs +29/−17
- library/Hbro/Event.hs +112/−0
- library/Hbro/Gdk/KeyVal.hsc +4/−1
- library/Hbro/Gui.hs +51/−246
- library/Hbro/Gui/Buildable.hs +0/−10
- library/Hbro/Gui/Builder.hs +41/−0
- library/Hbro/Gui/MainView.hs +288/−0
- library/Hbro/Gui/NotificationBar.hs +46/−51
- library/Hbro/Gui/PromptBar.hs +193/−114
- library/Hbro/Gui/PromptBar/Hooks.hs +0/−53
- library/Hbro/Gui/PromptBar/Signals.hs +0/−89
- library/Hbro/Gui/StatusBar.hs +14/−11
- library/Hbro/Hooks.hs +0/−94
- library/Hbro/IPC.hs +64/−42
- library/Hbro/IPC/Hooks.hs +0/−37
- library/Hbro/IPC/Signals.hs +0/−42
- library/Hbro/K.hs +0/−165
- library/Hbro/Keys.hs +84/−71
- library/Hbro/Keys/Model.hs +95/−120
- library/Hbro/Keys/Monadic.hs +0/−45
- library/Hbro/Keys/Signals.hs +0/−39
- library/Hbro/Logger.hs +93/−48
- library/Hbro/Options.hs +87/−143
- library/Hbro/Prelude.hs +68/−127
- library/Hbro/Signals.hs +0/−41
- library/Hbro/WebView/Hooks.hs +0/−83
- library/Hbro/WebView/Signals.hs +187/−177
- library/Hbro/Webkit/WebSettings.hs +0/−73
- library/Network/URI/Extended.hs +37/−0
- library/Network/URI/Monadic.hs +0/−26
- library/System/Glib/Attributes/Extended.hs +49/−0
- library/System/Process/Extended.hs +19/−0
README.rst view
@@ -15,7 +15,7 @@ A web browser retrieves, renders and traverses web pages, period. `Keep It Simple, Stupid`_- The program should be written with simplicity in mind, and without obsession for performance, features or release frequency. It should boot instantly, consume little memory and offer an uncluttered graphical interface. The code should be easy to grasp (well, as long as you speak Haskell...) to encourage users to hack it. Simplicity provides lightness, scalability, stability and maintainability.+ The application should be written with simplicity in mind, and without obsession for performance, features or release frequency. It should boot instantly, consume little memory and offer an uncluttered graphical interface. The code should be easy to grasp (well, as long as you speak Haskell...) to encourage users to hack it. Simplicity provides lightness, scalability, stability and maintainability. Extensible Configuration system should allow users to implement extra features. External programs should be able to query/command the web browser.@@ -55,9 +55,11 @@ Installation ------------ -At the moment, *hbro* depends on the *integer-simple* package, which means you won't be able to build it using a standard GHC that uses the *integer-gmp* package. This distinction is `documented here`_, and the reason for this constraint is `explained there`_.+Up until GHC 7.8, *hbro* requires the *integer-simple* package, which means you won't be able to build it using a standard GHC installation that uses the *integer-gmp* package. This distinction is `documented here`_, and the reason for this constraint is `explained there`_. +Starting with GHC 7.10, the *integer-gmp* package was completely rewritten and *integer-simple* is no longer required. + Configuration ------------- @@ -69,7 +71,7 @@ The graphical layout is described in an XML file that is parsed by GtkBuilder_. This file is looked for in several places with the following order of priority: -- the value from commandline option ``-u``;+- the value from commandline option ``-U``; - the file ``~/.config/hbro/ui.xml``; - the file ``examples/ui.xml`` bundled with the package.
executable/Main.hs view
@@ -1,7 +1,7 @@ module Main where -import Hbro+import Hbro -- Default main function provided as example main :: IO ()-main = hbro doNothing+main = hbro def
hbro.cabal view
@@ -1,8 +1,8 @@ Name: hbro-Version: 1.2.0.0-Synopsis: Minimal KISS-compliant browser+Version: 1.3.0.0+Synopsis: Minimal extensible web-browser Description: Cf README-Homepage: https://bitbucket.org/k0ral/hbro+Homepage: https://github.com/k0ral/hbro Category: Browser,Web License: OtherLicense@@ -19,42 +19,39 @@ Source-repository head Type: git Location: https://github.com/k0ral/hbro.git-Source-repository head- Type: hg- Location: https://bitbucket.org/k0ral/hbro-Source-repository head- Type: hg- Location: https://hgweb.twyk.org/hbro Library Build-depends:+ aeson, base == 4.*, bytestring,- classy-prelude,+ classy-prelude >= 0.9.4, cond, containers,- data-default,+ data-default-class, dyre >= 0.8.8, errors,+ fast-logger, glib, gtk3 >= 0.13,- hslogger, -- http-conduit, -- http-conduit-browser, -- http-types,- integer-simple,- lens,- lifted-async,- lifted-base,- mtl >= 2.2.1,- monad-control,+ lens >= 4.4,+ lifted-async >= 0.6,+ lifted-base >= 0.2.3.3,+ mtl >= 2.2,+ monad-control >= 1.0,+ monad-logger >= 0.3.6.2, network-uri,+ optparse-applicative >= 0.11, pango, parsec, process,+ resourcet, safe, semigroups,- stm,+ stm-chans, system-fileio, text, -- text-icu,@@ -62,57 +59,47 @@ transformers, transformers-base, unix,- webkitgtk3 >= 0.13,+ webkitgtk3 >= 0.13.1.2, zeromq4-haskell+ if impl(ghc < 7.10)+ Build-depends: integer-simple+ Exposed-modules:- Hbro,- Hbro.Boot,- Hbro.Clipboard,- Hbro.Config,- Hbro.Core,- Hbro.Error,- Hbro.Gdk.KeyVal,- Hbro.Gui,- Hbro.Gui.Buildable,- Hbro.Gui.NotificationBar,- Hbro.Gui.PromptBar,- Hbro.Gui.PromptBar.Hooks,- Hbro.Gui.PromptBar.Signals,- Hbro.Gui.StatusBar,- Hbro.Hooks,- Hbro.IPC,- Hbro.IPC.Hooks,- Hbro.K,- Hbro.Keys,- Hbro.Keys.Model,- Hbro.Keys.Monadic,- Hbro.Keys.Signals,- Hbro.Logger,- Hbro.Options,- Hbro.Prelude,- Hbro.Signals,- Hbro.Webkit.WebSettings- Hbro.WebView.Hooks,- Hbro.WebView.Signals,- Network.URI.Monadic+ Control.Monad.Logger.Extended+ , Control.Monad.Reader.Extended+ , Graphics.Rendering.Pango.Extended+ , Graphics.UI.Gtk.General.General.Extended+ , Hbro+ , Hbro.Boot+ , Hbro.Clipboard+ , Hbro.Config+ , Hbro.Core+ , Hbro.Defaults+ , Hbro.Error+ , Hbro.Event+ , Hbro.Gdk.KeyVal+ , Hbro.Gui.Builder+ , Hbro.Gui.MainView+ , Hbro.Gui.NotificationBar+ , Hbro.Gui.PromptBar+ , Hbro.Gui.StatusBar+ , Hbro.IPC+ , Hbro.Keys+ , Hbro.Keys.Model+ , Hbro.Logger+ , Hbro.Prelude+ , Hbro.WebView.Signals+ , Network.URI.Extended+ , System.Glib.Attributes.Extended+ , System.Process.Extended Other-modules:- Graphics.UI.Gtk.WebKit.Lifted,- Graphics.UI.Gtk.WebKit.Lifted.WebView,- -- Hbro.CFunctions,- Hbro.Dyre,- Hbro.IPC.Signals,- Paths_hbro- Extensions:- ConstraintKinds,- DeriveDataTypeable,- FlexibleContexts,- FlexibleInstances,- FunctionalDependencies,- GeneralizedNewtypeDeriving,- MultiParamTypeClasses,- NoImplicitPrelude,- OverloadedStrings,- RankNTypes+ Graphics.UI.Gtk.WebKit.Lifted+ , Graphics.UI.Gtk.WebKit.Lifted.WebView+ -- , Hbro.CFunctions+ , Hbro.Dyre+ , Hbro.Gui+ , Hbro.Options+ , Paths_hbro -- Build-tools: hsc2hs -- C-sources: cbits/cbits.c -- Include-dirs: include
+ library/Control/Monad/Logger/Extended.hs view
@@ -0,0 +1,13 @@+module Control.Monad.Logger.Extended (module X, module Control.Monad.Logger.Extended) where++-- {{{ Imports+import Control.Monad.Logger as X++import Data.Text+-- }}}++debug, info, warning, error :: (MonadLogger m) => Text -> m ()+debug = logDebugN+info = logInfoN+warning = logWarnN+error = logErrorN
+ library/Control/Monad/Reader/Extended.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+-- | This module provides a generic way to combine multiple `MonadReader` contexts into a single one.+--+-- == Example+-- > {-# LANGUAGE TupleSections #-}+-- >+-- > f :: (MonadReader r m, Has A r, Has B r) => m ()+-- > f = do+-- > (a :: A) <- ask+-- > (b :: B) <- ask+-- > doSomething a b+-- >+-- > main = let a = makeA :: A+-- > b = makeB :: B+-- > in flip runReaderT (a, ()) . withReaderT (b,) $ f+--+module Control.Monad.Reader.Extended+ ( module X+ , Has(..)+ , ask+ , asks+ ) where++-- {{{ Imports+import Control.Monad.Reader as X (MonadReader, runReaderT,+ withReaderT)+import qualified Control.Monad.Reader as Reader+-- }}}++data HTrue+data HFalse++type family Embedded r t acc where+ Embedded r () acc = HFalse+ Embedded r (r, a) acc = acc+ Embedded r (a, b) acc = Embedded r b HTrue+++class Has' embedded a t where get' :: embedded -> t -> a++instance Has' HFalse a (a, t) where+ get' _ (a, _) = a++instance (Has a t') => Has' HTrue a (t, t') where+ get' _ (_, t') = get t'++class Has a t where get :: t -> a++-- | This instance means @t = (t1, (t2, (... , (tn, ()) ...) )@ such that @a = ti@ for some i+instance Has' (Embedded a t HFalse) a t => Has a t where+ get = get' (undefined :: Embedded a t HFalse)++-- | Replacement for 'Control.Monad.Reader.ask'.+ask :: (MonadReader r m, Has a r) => m a+ask = Reader.asks get++-- | Replacement for 'Control.Monad.Reader.asks'.+asks :: (MonadReader r m, Has a r) => (a -> b) -> m b+asks f = Reader.asks (f . get)
+ library/Graphics/Rendering/Pango/Extended.hs view
@@ -0,0 +1,16 @@+module Graphics.Rendering.Pango.Extended (module X, module Graphics.Rendering.Pango.Extended) where++import Graphics.Rendering.Pango.Enums as X+++allItalic, allBold :: PangoAttribute+allItalic = AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic}+allBold = AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold}++black, gray, red, green, blue, yellow :: Color+black = Color 0 0 0+gray = Color 32767 32767 32767+red = Color 65535 0 0+green = Color 0 65535 0+blue = Color 0 0 65535+yellow = Color 65535 65535 0
+ library/Graphics/UI/Gtk/General/General/Extended.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Graphics.UI.Gtk.General.General.Extended+ ( module X+ , module Graphics.UI.Gtk.General.General.Extended+ ) where++-- {{{ Imports+import Hbro.Prelude++import Graphics.UI.Gtk.General.General as X+-- }}}++-- | Lifted alias for 'postGUISync'+gSync :: MonadIO m => IO a -> m a+gSync = io . postGUISync++-- | Lifted alias for 'postGUIAsync'+gAsync :: MonadIO m => IO a -> m ()+gAsync = io . postGUIAsync . void
library/Graphics/UI/Gtk/WebKit/Lifted.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} -- | Some lifted functions from 'Graphics.UI.Gtk.WebKit'. -- Designed to be imported as @qualified@. module Graphics.UI.Gtk.WebKit.Lifted (@@ -7,30 +11,36 @@ downloadGetUri, -- * 'NetworkRequest' downloadGetSuggestedFilename,-) where+-- * 'WebDataSource'+ dataSourceGetData+ ) where -- {{{ Imports-import Hbro.Error-import Hbro.Prelude+import Hbro.Error+import Hbro.Prelude --- import Graphics.UI.Gtk.General.General as GTK-import qualified Graphics.UI.Gtk.WebKit.Download as W-import Graphics.UI.Gtk.WebKit.NetworkRequest (NetworkRequest)+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.WebDataSource as W -import Network.URI.Monadic+import Network.URI.Extended -- }}} -- | Error message-unavailableFileName, unavailableURI :: Text+unavailableData, unavailableFileName, unavailableURI :: Text+unavailableData = "No data available in the web frame." unavailableFileName = "No file name available" unavailableURI = "No URI available" networkRequestGetUri :: (MonadIO m, MonadError Text m) => NetworkRequest -> m URI-networkRequestGetUri r = parseURIReference =<< io (W.networkRequestGetUri r) <!> unavailableURI+networkRequestGetUri r = parseURIReferenceM =<< io (W.networkRequestGetUri r) <!> unavailableURI downloadGetUri :: (MonadIO m, MonadError Text m) => W.Download -> m URI-downloadGetUri d = parseURI =<< io (W.downloadGetUri d) <!> unavailableURI+downloadGetUri d = parseURIM =<< io (W.downloadGetUri d) <!> unavailableURI downloadGetSuggestedFilename :: (MonadIO m, MonadError Text m) => W.Download -> m Text downloadGetSuggestedFilename d = io (W.downloadGetSuggestedFilename d) <!> unavailableFileName++dataSourceGetData :: (MonadIO m, MonadError Text m) => WebDataSource -> m ByteString+dataSourceGetData ds = io (webDataSourceGetData ds) <!> unavailableData
library/Graphics/UI/Gtk/WebKit/Lifted/WebView.hs view
@@ -1,7 +1,12 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} -- | Some lifted functions from 'Graphics.UI.Gtk.WebKit.WebView'. -- Designed to be imported as @qualified@. module Graphics.UI.Gtk.WebKit.Lifted.WebView- ( webViewGetUri+ ( webViewUri+ , webViewGetUri , webViewGetIconUri , webViewTryGetFaviconPixbuf , webViewGetTitle@@ -11,14 +16,18 @@ ) where -- {{{ Imports-import Hbro.Error-import Hbro.Prelude+import Hbro.Error+import Hbro.Prelude -import Graphics.UI.Gtk.Gdk.Pixbuf-import Graphics.UI.Gtk.WebKit.WebView as Export hiding(webViewGetUri, webViewGetIconUri, webViewGetTitle, webViewTryGetFaviconPixbuf)-import qualified Graphics.UI.Gtk.WebKit.WebView as W+import Graphics.UI.Gtk.Gdk.Pixbuf+import Graphics.UI.Gtk.General.General.Extended+import Graphics.UI.Gtk.WebKit.WebView as Export hiding (webViewGetIconUri, webViewGetTitle, webViewGetUri, webViewTryGetFaviconPixbuf,+ webViewUri)+import qualified Graphics.UI.Gtk.WebKit.WebView as W -import Network.URI.Monadic+import System.Glib.Attributes++import Network.URI.Extended -- }}} -- | Error message@@ -27,21 +36,24 @@ unavailableURI = "No available URI." titleUnavailable = "No available title." +-- | 'W.webViewUri' with 'Text'+webViewUri :: ReadAttr WebView (Maybe Text)+webViewUri = W.webViewUri -webViewGetUri :: (BaseIO m, MonadError Text m) => WebView -> m URI-webViewGetUri = gSync . W.webViewGetUri >=> maybe (throwError unavailableURI) return >=> parseURI+webViewGetUri :: (MonadIO m, MonadError Text m) => WebView -> m URI+webViewGetUri = gSync . W.webViewGetUri >=> maybe (throwError unavailableURI) return >=> parseURIM -webViewGetIconUri :: (BaseIO m, MonadError Text m) => WebView -> m URI-webViewGetIconUri = gSync . W.webViewGetIconUri >=> maybe (throwError unavailableURI) return >=> parseURI+webViewGetIconUri :: (MonadIO m, MonadError Text m) => WebView -> m URI+webViewGetIconUri = gSync . W.webViewGetIconUri >=> maybe (throwError unavailableURI) return >=> parseURIM -webViewTryGetFaviconPixbuf :: (BaseIO m, MonadError Text m) => WebView -> Int -> Int -> m Pixbuf+webViewTryGetFaviconPixbuf :: (MonadIO m, MonadError Text m) => WebView -> Int -> Int -> m Pixbuf webViewTryGetFaviconPixbuf webView width height = gSync (W.webViewTryGetFaviconPixbuf webView width height) >>= maybe (throwError unavailableFavicon) return -webViewGetTitle :: (BaseIO m, MonadError Text m) => WebView -> m Text+webViewGetTitle :: (MonadIO m, MonadError Text m) => WebView -> m Text webViewGetTitle = gSync . W.webViewGetTitle >=> maybe (throwError titleUnavailable) return -loadHtmlString :: (BaseIO m) => Text -> URI -> WebView -> m ()+loadHtmlString :: (MonadIO m) => Text -> URI -> WebView -> m () loadHtmlString html uri webView = gAsync $ W.webViewLoadHtmlString webView html (tshow uri) -loadString :: (BaseIO m) => Text -> URI -> WebView -> m ()+loadString :: (MonadIO m) => Text -> URI -> WebView -> m () loadString html uri webView = gAsync $ W.webViewLoadString webView html Nothing (tshow uri)
library/Hbro.hs view
@@ -1,28 +1,23 @@ module Hbro ( module X) where -import Hbro.Boot as X--- import Hbro.Clipboard--- import Hbro.Config-import Hbro.Core as X-import Hbro.Error as X-import Hbro.Gdk.KeyVal as X--- import Hbro.Gui-import Hbro.Gui.Buildable as X--- import Hbro.Gui.NotificationBar--- import Hbro.Gui.PromptBar--- import Hbro.Gui.StatusBar--- import Hbro.Hooks-import Hbro.IPC as X--- import Hbro.IPC.Hooks-import Hbro.K as X--- import Hbro.Keys--- import Hbro.Keys.Model-import Hbro.Keys.Monadic as X--- import Hbro.Keys.Signals--- import Hbro.Options--- import Hbro.Signals--- import Hbro.Signals.PromptBar-import Hbro.Prelude as X--- import Hbro.Webkit.WebSettings--- import Hbro.WebView.Hooks--- import Hbro.WebView.Signals+import Hbro.Boot as X+-- import Hbro.Clipboard+-- import Hbro.Config+import Hbro.Core as X+import Hbro.Defaults as X+import Hbro.Error as X+import Hbro.Event as X+import Hbro.Gdk.KeyVal as X+-- import Hbro.Gui+import Hbro.Gui.Builder as X+import Hbro.Gui.MainView as X+-- import Hbro.Gui.NotificationBar+-- import Hbro.Gui.PromptBar+-- import Hbro.Gui.StatusBar+import Hbro.IPC as X+-- import Hbro.Keys+-- import Hbro.Keys.Model+-- import Hbro.Logger as X+-- import Hbro.Options+import Hbro.Prelude as X+-- import Hbro.WebView.Signals
library/Hbro/Boot.hs view
@@ -1,90 +1,153 @@-module Hbro.Boot (hbro) where+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+module Hbro.Boot (Settings(..), hbro) where -- {{{ Imports-import Hbro.Config as Config-import Hbro.Core as Core-import Hbro.Dyre as Dyre-import Hbro.Error-import Hbro.Gui as Gui-import Hbro.Hooks as Hooks-import Hbro.IPC as IPC (routine)-import Hbro.K as K-import Hbro.Options as Options-import Hbro.Signals as Signals-import Hbro.Logger-import Hbro.Prelude-import Hbro.Webkit.WebSettings as Settings+import Hbro.Config as Config+import Hbro.Core as Core+import Hbro.Defaults+import Hbro.Dyre as Dyre+import Hbro.Error+import Hbro.Event+import Hbro.Gui as Gui+import Hbro.Gui.MainView+import Hbro.IPC as IPC (CommandMap,+ bindCommands)+import Hbro.Keys as Keys+import Hbro.Logger+import Hbro.Options as Options+import Hbro.Prelude -import Control.Concurrent.Async.Lifted-import Control.Lens hiding((??))-import Control.Monad.Reader hiding(guard, mapM_, msum, when)+import Control.Concurrent.Async.Lifted+import Control.Lens hiding ((<|), (??), (|>))+import Control.Monad.Trans.Resource -import Filesystem+import Data.Version hiding (Version) -import Graphics.UI.Gtk.General.General as Gtk+import Filesystem -import Paths_hbro+import Graphics.UI.Gtk.General.General as Gtk -import System.Posix.Signals-import System.ZMQ4.Monadic (runZMQ)+import Network.URI.Extended++import qualified Paths_hbro as Package++import System.Posix.Process+import System.Posix.Signals+import qualified System.ZMQ4 as ZMQ (version) -- }}} --- | Main function to call in the configuration file (cf file @Hbro/Main.hs@).-hbro :: K () -> IO ()-hbro setup = void . runMaybeT $ do+-- | What users can configure.+data Settings = Settings+ { configuration :: Config+ , commandMap :: forall m r . God r m => CommandMap m+ , keyMap :: forall m r . God r m => KeyMap m+ , startUp :: forall m r . God r m => m ()+ }++instance Default Settings where+ def = Settings+ { configuration = def+ , commandMap = defaultCommandMap+ , keyMap = defaultKeyMap+ , startUp = debug "No start-up script defined"+ }++getDataFileName :: (MonadIO m, Functor m) => Text -> m FilePath+getDataFileName file = fpFromText . pack <$> io (Package.getDataFileName $ unpack file)++-- | Main function to call in the configuration file. Cf @Hbro/Main.hs@ as an example.+hbro :: Settings -> IO ()+hbro settings = do options <- parseOptions - Dyre.wrap (options^.dyreModeL)- (\x -> withAsyncBound guiThread (mainThread x))- (setup, options)+ case options of+ Left Rebuild -> Dyre.recompile >>= mapM_ putStrLn+ Left Version -> printVersions+ Right runOptions -> runResourceT . runThreadedLoggingT (runOptions^.logLevelL) $ Dyre.wrap (runOptions^.dyreModeL)+ (withAsyncBound guiThread . mainThread)+ (settings, runOptions) -- | Gtk main loop thread.-guiThread :: IO ()+guiThread :: (ControlIO m, MonadLogger m) => m () guiThread = do- async $ do+ io . async $ do installHandler sigINT (Catch onInterrupt) Nothing installHandler sigTERM (Catch onInterrupt) Nothing- initGUI >> mainGUI- debugM "hbro.main" "GUI thread correctly exited."- where onInterrupt = logInterrupt >> gAsync mainQuit- logInterrupt = infoM "hbro.main" "Received interrupt signal."+ io $ initGUI >> mainGUI+ debug "GUI thread correctly exited."+ where onInterrupt = logInterrupt >> postGUIAsync mainQuit+ logInterrupt = putStrLn "Received interrupt signal." -mainThread :: (ControlIO m) => (K (), CliOptions) -> Async (StM IO ()) -> m ()-mainThread (customSetup, options) uiThread = logErrors_ $ do- -- Signals- signals <- Signals.initialize- hooks <- Hooks.initialize+mainThread :: (ControlIO m, MonadThrow m, MonadThreadedLogger m, MonadResource m)+ => (Settings, CliOptions) -> Async () -> m ()+mainThread (settings, options) uiThread = void . runExceptT . logErrors $ do+ uiFiles <- getUIFiles options+ (builder, mainView, promptBar, statusBar, notifBar) <- asum $ map Gui.initialize uiFiles - -- GUI- uiFiles <- getUIFiles options- gui <- asum $ map Gui.initialize uiFiles- attachGuiSignals gui signals+ socketURI <- getSocketURI options+ keySignal <- newSignal KeyMapPressed+ config <- io . newTVarIO $ configuration settings - -- K monad- globalStatus <- K.init gui hooks signals+ flip runReaderT (config, ())+ . withReaderT (mainView, )+ . withReaderT (statusBar, )+ . withReaderT (promptBar, )+ . withReaderT (notifBar, )+ . withReaderT (builder, )+ . withReaderT (keySignal, )+ . withAsync (bindCommands socketURI (commandMap settings)) . const $ do+ bindKeys (mainView^.keyPressedHandlerL) keySignal (keyMap settings) - -- IPC- socketURI <- getSocketURI options+ addHandler (mainView^.linkClickedHandlerL) defaultLinkClickedHandler+ addHandler (mainView^.loadRequestedHandlerL) defaultLoadRequestedHandler+ addHandler (mainView^.newWindowHandlerL) defaultNewWindowHandler+ addHandler (mainView^.titleChangedHandlerL) defaultTitleChangedHandler - io . (`runReaderT` globalStatus) . runExceptT $ do- resetKeyBindings- Settings.resetAll- lift customSetup+ startUp settings - debugM "hbro.boot" . ("Start-up configuration: \n" ++) . describe =<< Config.get id+ debug . ("Start-up configuration: \n" ++) . describe =<< Config.get id - logErrors_ $ maybe goHome load (options^.startURIL)+ maybe goHome (load <=< getStartURI) (options^.startURIL)+ io $ wait uiThread - io . withAsyncList (Hooks.routines globalStatus signals hooks) $ \_ -> do- withAsync (runZMQ $ IPC.routine socketURI (signals^._ipcSignals)) $ \_ ->- wait uiThread+ debug "All threads correctly exited." - debugM "hbro.main" "All threads correctly exited." -- | Return the list of available UI files (from configuration and package)-getUIFiles :: (BaseIO m) => CliOptions -> m [FilePath]+getUIFiles :: (MonadIO m, Functor m) => CliOptions -> m [FilePath] getUIFiles options = do fileFromConfig <- getAppConfigDirectory "hbro" >/> "ui.xml"- fileFromPackage <- fpFromText . pack <$> (io $ getDataFileName "examples/ui.xml")+ fileFromPackage <- getDataFileName "examples/ui.xml" return $ catMaybes [options^.uiFileL, Just fileFromConfig, Just fileFromPackage]++-- | Return socket URI used by this instance+getSocketURI :: (MonadIO m, Functor m) => CliOptions -> m Text+getSocketURI options = maybe getDefaultSocketURI (return . normalize) $ options^.socketPathL+ where+ normalize = ("ipc://" ++) . fpToText+ getDefaultSocketURI = do+ dir <- fpToText <$> io (getAppCacheDirectory "hbro")+ pid <- io getProcessID+ return $ "ipc://" ++ dir ++ "/hbro." ++ tshow pid++-- | Parse 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 :: (MonadIO m, MonadError Text m) => URI -> m URI+getStartURI uri = do+ fileURI <- io . isFile . fpFromText $ tshow uri+ workingDir <- io getWorkingDirectory++ parseURIReferenceM ("file://" ++ fpToText workingDir ++ "/" ++ tshow uri) <| fileURI |> return uri+ -- maybe abort return =<< logErrors (parseURIReference fileURI')++printVersions :: IO ()+printVersions = do+ (a, b, c) <- ZMQ.version+ putStrLn $ "hbro v" ++ pack (showVersion Package.version)+ putStrLn $ "0MQ library v" ++ intercalate "." (map tshow [a, b, c])
library/Hbro/Clipboard.hs view
@@ -1,31 +1,37 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} -- | Designed to be imported as @qualified@. module Hbro.Clipboard where -- {{{ Imports-import Hbro.Error-import Hbro.Logger-import Hbro.Prelude+import Hbro.Error+import Hbro.Logger+import Hbro.Prelude -import Graphics.UI.Gtk.General.Clipboard-import Graphics.UI.Gtk.General.Selection+import Graphics.UI.Gtk.General.Clipboard+import Graphics.UI.Gtk.General.General.Extended+import Graphics.UI.Gtk.General.Selection -- }}} + -- | Write given 'Text' to the selection-primary clipboard-write :: (BaseIO m) => Text -> m ()+write :: (BaseIO m, MonadLogger m) => Text -> m () write = write' selectionPrimary -- | Write given text to the given clipboard-write' :: (BaseIO m) => SelectionTag -> Text -> m ()+write' :: (BaseIO m, MonadLogger m) => SelectionTag -> Text -> m () write' tag text = do- debugM "hbro.clipboard" $ "Writing to clipboard: " ++ text+ debug $ "Writing to clipboard: " ++ text gSync (clipboardGet tag) >>= gAsync . (`clipboardSetText` text) -- | Read clipboard's content. Both 'selectionPrimary' and 'selectionClipboard' are inspected (in this order).-read :: (BaseIO m) => ExceptT Text m Text+read :: (BaseIO m, Alternative m, MonadError Text m) => m Text read = read' selectionPrimary <|> read' selectionClipboard -- | Return the content from the given clipboard.-read' :: (BaseIO m, MonadError Text m) => SelectionTag -> m Text+read' :: (Alternative m, MonadError Text m, BaseIO m) => SelectionTag -> m Text read' tag = do clipboard <- gSync $ clipboardGet tag result <- newEmptyMVar
library/Hbro/Config.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-} -- | General configuration parameters. -- The recommended way to import this module is: -- @@@ -9,46 +14,36 @@ -- * Types Config , homePageL- , HasConfig(..) -- * Getter/setter , get , set ) where -- {{{ Imports-import Hbro.Prelude+import Hbro.Prelude -import Control.Lens hiding(set)+import Control.Lens hiding (set) import qualified Control.Lens as L (set)-import Control.Monad.Reader -import Network.URI (URI)-import qualified Network.URI as N+import Network.URI (URI)+import qualified Network.URI as N -- }}} -- | Custom settings provided by the user-data Config = Config- { _homePage :: URI+declareLenses [d|+ data Config = Config+ { homePageL :: URI }--makeLensesWith ?? ''Config $ lensRules- & lensField .~ (\name -> Just (tailSafe name ++ "L"))-+ |] instance Describable Config where- describe c = "Home page = " ++ (tshow $ c^.homePageL)+ describe c = "Home page = " ++ tshow (c^.homePageL) instance Default Config where- def = Config- { _homePage = fromJust . N.parseURI $ "https://duckduckgo.com/"- }--class HasConfig t where _config :: Lens' t (TVar Config)--instance HasConfig (TVar Config) where _config = id+ def = Config $ fromJust . N.parseURI $ "https://duckduckgo.com/" -get :: (MonadReader r m, BaseIO m, HasConfig r) => Lens' Config a -> m a-get l = return . view l =<< atomically . readTVar =<< askL _config+get :: (MonadIO m, MonadReader r m, Has (TVar Config) r) => Lens' Config a -> m a+get l = return . view l =<< atomically . readTVar =<< ask -set :: (MonadReader r m, BaseIO m, HasConfig r) => Lens' Config a -> a -> m ()-set l v = atomically . (`modifyTVar` L.set l v) =<< askL _config+set :: (MonadIO m, MonadReader r m, Has (TVar Config) r) => Lens' Config a -> a -> m ()+set l v = atomically . (`modifyTVar` L.set l v) =<< ask
library/Hbro/Core.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} module Hbro.Core ( -- * Types CaseSensitivity(..)@@ -11,6 +16,7 @@ , getFavicon , getLoadProgress , getPageTitle+ , getPageData -- * Browsing , goHome , load@@ -23,27 +29,33 @@ , printPage , searchText , searchText_+ , spawnHbro+ , spawnHbro' , quit+ , saveWebPage , executeJSFile ) where -- {{{ Imports-import Graphics.UI.Gtk.WebKit.Lifted.WebView+import Graphics.UI.Gtk.WebKit.Lifted+import Graphics.UI.Gtk.WebKit.Lifted.WebView -import Hbro.Config as Config-import Hbro.Error-import Hbro.Gui as Gui-import Hbro.Logger hiding(initialize)-import Hbro.Prelude as H+import Hbro.Config as Config+import Hbro.Dyre+import Hbro.Error+-- import Hbro.Gui as Gui+import Hbro.Gui.MainView+import Hbro.Logger+import Hbro.Prelude as H -import Control.Monad.Reader hiding(guard, unless)+import Graphics.UI.Gtk.Gdk.Pixbuf (Pixbuf)+import Graphics.UI.Gtk.General.General.Extended+import Graphics.UI.Gtk.WebKit.WebDataSource+import Graphics.UI.Gtk.WebKit.WebFrame -import Graphics.UI.Gtk.Gdk.Pixbuf (Pixbuf)-import Graphics.UI.Gtk.General.General-import Graphics.UI.Gtk.WebKit.WebDataSource-import Graphics.UI.Gtk.WebKit.WebFrame+import Network.URI.Extended -import Network.URI.Monadic+import System.Process.Extended -- }}} -- {{{ Types@@ -69,36 +81,40 @@ -- }}} -- {{{ Getters-getCurrentURI :: (BaseIO m, MonadReader t m, HasGUI t, MonadError Text m) => m URI-getCurrentURI = webViewGetUri =<< Gui.get webViewL+getCurrentURI :: (MonadIO m, MonadReader r m, Has MainView r, MonadError Text m) => m URI+getCurrentURI = webViewGetUri =<< getWebView -getFaviconURI :: (BaseIO m, MonadReader t m, HasGUI t, MonadError Text m) => m URI-getFaviconURI = webViewGetIconUri =<< Gui.get webViewL+getFaviconURI :: (MonadIO m, MonadReader r m, Has MainView r, MonadError Text m) => m URI+getFaviconURI = webViewGetIconUri =<< getWebView -getFavicon :: (BaseIO m, MonadReader t m, HasGUI t, MonadError Text m) => Int -> Int -> m Pixbuf-getFavicon w h = (\v -> webViewTryGetFaviconPixbuf v w h) =<< Gui.get webViewL+getFavicon :: (MonadIO m, MonadReader r m, Has MainView r, MonadError Text m) => Int -> Int -> m Pixbuf+getFavicon w h = (\v -> webViewTryGetFaviconPixbuf v w h) =<< getWebView -getLoadProgress :: (BaseIO m, MonadReader t m, HasGUI t) => m Double-getLoadProgress = gSync . webViewGetProgress =<< Gui.get webViewL+getLoadProgress :: (MonadIO m, MonadReader r m, Has MainView r) => m Double+getLoadProgress = gSync . webViewGetProgress =<< getWebView -getPageTitle :: (BaseIO m, MonadReader t m, HasGUI t, MonadError Text m) => m Text-getPageTitle = webViewGetTitle =<< Gui.get webViewL+getPageTitle :: (MonadIO m, MonadReader r m, Has MainView r, MonadError Text m) => m Text+getPageTitle = webViewGetTitle =<< getWebView++-- | Return the HTML code of the current webpage.+getPageData :: (MonadIO m, MonadReader r m, Has MainView r, MonadError Text m) => m ByteString+getPageData = dataSourceGetData =<< io . webFrameGetDataSource =<< io . webViewGetMainFrame =<< getWebView -- }}} -- {{{ Browsing-goHome :: (BaseIO m, MonadReader t m, HasGUI t, HasConfig t, MonadError Text m) => m ()+goHome :: (MonadIO m, MonadLogger m, MonadReader r m, Has MainView r, Has (TVar Config) r, MonadError Text m) => m () goHome = load =<< Config.get homePageL -load :: (BaseIO m, MonadReader t m, HasGUI t, MonadError Text m) => URI -> m ()+load :: (MonadIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadError Text m) => URI -> m () load uri = do- debugM "hbro.core" $ "Loading URI: " ++ tshow uri+ debug $ "Loading URI: " ++ tshow uri -- void . logErrors $ do -- currentURI <- getURI -- guard (currentURI /= uri') -- Browser.advance currentURI -- load' uri'- webview <- Gui.get webViewL+ webview <- getWebView gSync . webViewLoadUri webview $ show uri' where@@ -110,51 +126,70 @@ -- } --- load' :: (MonadBaseControl IO m, MonadReader t m, HasGUI t, HasHTTPClient t, MonadError Text m) => URI -> m ()+-- load' :: (MonadBaseControl IO m, MonadReader GUI m, HasHTTPClient t, MonadError Text m) => URI -> m () -- load' uri = do -- page <- Client.retrieve uri -- -- render page =<< Client.getURI -- render page uri -reload, goBack, goForward :: (BaseIO m, MonadReader t m, HasGUI t, MonadError Text m) => m ()+reload, goBack, goForward :: (MonadIO m, MonadReader r m, Has MainView r, MonadLogger m) => m () -- reload = load =<< Client.getURI -- goBack = load' =<< Browser.stepBackward =<< getURI -- goForward = load' =<< Browser.stepForward =<< getURI-reload = gAsync . webViewReload =<< Gui.get webViewL-goBack = gAsync . webViewGoBack =<< Gui.get webViewL-goForward = gAsync . webViewGoForward =<< Gui.get webViewL+reload = gAsync . webViewReload =<< getWebView+goBack = do+ gAsync . webViewGoBack =<< getWebView+ unlessM (gSync . webViewCanGoBack =<< getWebView) $ warning "Unable to go back."+goForward = do+ gAsync . webViewGoForward =<< getWebView+ unlessM (gSync . webViewCanGoForward =<< getWebView) $ warning "Unable to go forward." -reloadBypassCache, stopLoading :: (BaseIO m, MonadReader t m, HasGUI t) => m ()-reloadBypassCache = Gui.get webViewL >>= gAsync . webViewReloadBypassCache >> logDebug "Reloading without cache."-stopLoading = Gui.get webViewL >>= gAsync . webViewStopLoading >> logDebug "Stopped loading"+reloadBypassCache, stopLoading :: (MonadIO m, MonadLogger m, MonadReader r m, Has MainView r) => m ()+reloadBypassCache = getWebView >>= gAsync . webViewReloadBypassCache >> debug "Reloading without cache."+stopLoading = getWebView >>= gAsync . webViewStopLoading >> debug "Stopped loading" -- }}} -- {{{-searchText :: (BaseIO m, MonadReader t m, HasGUI t) => CaseSensitivity -> Direction -> Wrap -> Text -> m Bool+searchText :: (MonadIO m, MonadLogger m, MonadReader r m, Has MainView r) => CaseSensitivity -> Direction -> Wrap -> Text -> m Bool searchText s d w text = do- logDebug $ "Searching text: " ++ text- v <- Gui.get webViewL+ debug $ "Searching text: " ++ text+ v <- getWebView gSync $ webViewSearchText v text (toBool s) (toBool d) (toBool w) -searchText_ :: (BaseIO m, MonadReader t m, HasGUI t) => CaseSensitivity -> Direction -> Wrap -> Text -> m ()+searchText_ :: (MonadIO m, Functor m, MonadLogger m, MonadReader r m, Has MainView r) => CaseSensitivity -> Direction -> Wrap -> Text -> m () searchText_ s d w text = void $ searchText s d w text -printPage :: (BaseIO m, MonadReader t m, HasGUI t) => m ()-printPage = gAsync . webFramePrint =<< gSync . webViewGetMainFrame =<< Gui.get webViewL+printPage :: (MonadIO m, MonadReader r m, Has MainView r) => m ()+printPage = gAsync . webFramePrint =<< gSync . webViewGetMainFrame =<< getWebView -- }}} +-- | Spawn another browser instance.+spawnHbro :: (MonadIO m, MonadLogger m) => m ()+spawnHbro = do+ executable <- getHbroExecutable+ spawn (fpToText executable) []++-- | Spawn another browser instance and load the given URI at start-up.+spawnHbro' :: (MonadIO m, MonadLogger m) => URI -> m ()+spawnHbro' uri = do+ executable <- getHbroExecutable+ spawn (fpToText executable) ["-u", tshow uri]+ -- | Terminate the program.-quit :: (BaseIO m) => m ()+quit :: (MonadIO m) => m () quit = gAsync mainQuit -- {{{ Misc+saveWebPage :: (ControlIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadError Text m) => FilePath -> m ()+saveWebPage file = writeFileE' file =<< getPageData+ -- | Execute a javascript file on current webpage.-executeJSFile :: (BaseIO m, MonadReader r m) => FilePath -> WebView -> m ()+executeJSFile :: (MonadIO m, MonadLogger m) => FilePath -> WebView -> m () executeJSFile filePath webView' = do- debugM "hbro.core" $ "Executing Javascript file: " ++ fpToText filePath+ debug $ "Executing Javascript file: " ++ fpToText filePath script <- readFile filePath let script' = asText . unwords . map (++ "\n") . lines $ script @@ -171,9 +206,3 @@ _mainResource <- webDataSourceGetMainResource dataSource _subResources <- webDataSourceGetSubresources dataSource return ()----- {{{ Util-logDebug :: (BaseIO m) => Text -> m ()-logDebug = debugM "hbro.core"--- }}}
+ library/Hbro/Defaults.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Hbro.Defaults where++-- {{{ Imports+import Hbro.Clipboard as Clipboard+import Hbro.Config (Config)+import Hbro.Core+import Hbro.Error+import Hbro.Event+import Hbro.Gdk.KeyVal+import Hbro.Gui as Gui+import Hbro.Gui.MainView+import Hbro.Gui.NotificationBar+import Hbro.Gui.PromptBar as Prompt+import Hbro.Gui.StatusBar+import Hbro.IPC+import Hbro.Keys as Keys+import Hbro.Keys.Model (singleKey, (.|))+import Hbro.Logger+import Hbro.Prelude+import Hbro.WebView.Signals++import Control.Monad.Trans.Resource++import Data.Map as Map hiding (foldl,+ map)++import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.Builder as Gtk+import Graphics.UI.Gtk.Gdk.EventM as Gtk+import Graphics.UI.Gtk.General.General.Extended+import Graphics.UI.Gtk.WebKit.WebView+import Graphics.UI.Gtk.Windows.Window++import Network.URI.Extended++import System.Glib.Attributes.Extended+-- }}}++-- | A 'God' monad has access to everything.+type God r m = (ControlIO m, MonadLogger m, MonadError Text m, MonadResource m, MonadReader r m, Has (TVar Config) r, Has PromptBar r, Has NotificationBar r, Has StatusBar r, Has Gtk.Builder r, Has (Signal KeyMapPressed) r, Has MainView r, Alternative m)++defaultLinkClickedHandler :: (MonadIO m, MonadLogger m, MonadError Text m, MonadReader r m, Has MainView r)+ => Handler m LinkClicked+defaultLinkClickedHandler (uri, Gtk.MiddleButton) = spawnHbro' uri+defaultLinkClickedHandler (uri, _) = load uri++defaultLoadRequestedHandler :: (MonadIO m, MonadLogger m, MonadError Text m, MonadReader r m, Has MainView r) => URI -> m ()+defaultLoadRequestedHandler = load++defaultNewWindowHandler :: (MonadIO m, MonadLogger m) => URI -> m ()+defaultNewWindowHandler uri = spawnHbro' uri++defaultTitleChangedHandler :: (MonadIO m, MonadLogger m, MonadError Text m, MonadReader r m, Has Gtk.Builder r) => Text -> m ()+defaultTitleChangedHandler title = getMainWindow >>= \w -> set w windowTitle ("hbro | " ++ title) >> return ()++-- /!\ 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 (Hook KE ResourceOpened) where+-- def = Hook $ \(_uri, mimetype) -> do+-- return Hooks.Load <<| canRender mimetype |>> return Hooks.Download'+++-- | List of default supported requests.+defaultCommandMap :: God r m => CommandMap m+defaultCommandMap = Map.fromList+-- Get information+ [ "GET_URI" >: \_arguments -> Right . tshow <$> getCurrentURI+ , "GET_TITLE" >: \_arguments -> Right <$> getPageTitle+ , "GET_FAVICON_URI" >: \_arguments -> Right . tshow <$> getFaviconURI+ , "GET_LOAD_PROGRESS" >: \_arguments -> Right . tshow <$> getLoadProgress+-- Trigger actions+ , "LOAD_URI" >: \arguments -> case arguments of+ uri:_ -> parseURIReferenceM uri >>= load >> return (Right "OK")+ _ -> return . Left $ "Argument needed."+ , "STOP_LOADING" >: \_arguments -> stopLoading >> return (Right "OK")+ , "RELOAD" >: \_arguments -> reload >> return (Right "OK")+ , "RELOAD_BYPASS_CACHE" >: \_arguments -> reloadBypassCache >> return (Right "OK")+ , "GO_BACK" >: \_arguments -> goBack >> return (Right "OK")+ , "GO_FORWARD" >: \_arguments -> goForward >> return (Right "OK")+ , "ZOOM_IN" >: \_arguments -> zoomIn >> return (Right "OK")+ , "ZOOM_OUT" >: \_arguments -> zoomOut >> return (Right "OK")+ ]+++defaultKeyMap :: (God r m) => KeyMap m+defaultKeyMap = Map.fromList+-- Browse+ [ [_Alt .| _Left] >: goBack+ , [_Alt .| _Right] >: goForward+ , [_Control .| _Escape] >: stopLoading+ , [singleKey _F5] >: reload+ , [_Control .| _r] >: reload+ , [_Control .| _F5] >: reloadBypassCache+ , [_Alt .| _r] >: reloadBypassCache+ , [_Control .| _dead_circumflex] >: scrollH (Absolute 0)+ , [_Control .| _dollar] >: scrollH (Absolute 100)+ , [_Control .| _Home] >: scrollV (Absolute 0)+ , [_Control .| _End] >: scrollV (Absolute 100)+ , [_Alt .| _Home] >: goHome+-- Copy/paste+ , [_Control .| _c] >: getCurrentURI >>= Clipboard.write . tshow+ , [_Alt .| _c] >: getPageTitle >>= Clipboard.write+ , [_Control .| _v] >: Clipboard.read >>= parseURIReferenceM >>= load+ , [_Alt .| _v] >: Clipboard.read >>= parseURIReferenceM >>= spawnHbro'+-- Display+ , [_Control .| _plus] >: zoomIn+ , [_Control .| _minus] >: zoomOut+ , [_Control .| _b] >: asks asStatusBar >>= \s -> toggle_ s widgetVisible+ , [_Alt .| _b] >: asks asNotificationBar >>= \n -> toggle_ n widgetVisible+ , [_Control .| _u] >: getWebView >>= \v -> toggle_ v webViewViewSourceMode+-- Prompt+ , [_Control .| _o] >: uriPromptM "Open URI" "" >>= load+ , [_Alt .| _o] >: getCurrentURI >>= \uri -> uriPromptM "Open URI " (tshow uri) >>= load+-- Search+ , [singleKey _slash] >: ipromptM "Search " "" (searchText_ CaseInsensitive Forward Wrap)+ , [_Control .| _f] >: ipromptM "Search " "" (searchText_ CaseInsensitive Forward Wrap)+ , [singleKey _question] >: ipromptM "Search " "" (searchText_ CaseInsensitive Backward Wrap)+ , [_Control .| _n] >: searchText_ CaseInsensitive Forward Wrap =<< getPromptValueM+ , [_Control .| _p] >: searchText_ CaseInsensitive Backward Wrap =<< getPromptValueM+ , [_Control .| _h] >: gAsync . webViewUnMarkTextMatches =<< getWebView+-- Misc+ --, (_Control .| _i) >: openInspector+ , [_Control .| _s] >: promptM "Save webpage " "" >>= saveWebPage . fpFromText+ , [_Alt .| _Print] >: printPage+ , [_Control .| _t] >: spawnHbro+ , [_Control .| _w] >: quit+ ]
library/Hbro/Dyre.hs view
@@ -1,17 +1,24 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-} -- | Dynamic reconfiguration. Designed to be imported as @qualified@. module Hbro.Dyre ( Mode(..)+ , getHbroExecutable , wrap , recompile ) where -- {{{ Imports-import Hbro.Logger-import Hbro.Prelude+import Hbro.Logger+import Hbro.Prelude -import Config.Dyre-import Config.Dyre.Compile-import Config.Dyre.Paths+import Config.Dyre+import Config.Dyre.Compile+import Config.Dyre.Paths -- }}} -- | How dynamic reconfiguration process should behave.@@ -22,7 +29,7 @@ instance Default Mode where def = Normal -- | Describe various paths used for dynamic reconfiguration-describePaths :: BaseIO m => m Text+describePaths :: MonadIO m => m Text describePaths = io $ do (a, b, c, d, e) <- getPaths baseParameters return . unlines $ map pack@@ -33,17 +40,21 @@ , "Lib directory: " ++ e ] +getHbroExecutable :: (MonadIO m) => m FilePath+getHbroExecutable = io $ do+ (a, _, _, _, _) <- getPaths baseParameters+ return . fpFromText $ pack a+ -- Dynamic reconfiguration settings-parameters :: Mode -> (a -> IO b) -> Params (Either Text a)-parameters mode main = baseParameters+parameters :: (Functor m, MonadIO m, MonadLogger m, StM m () ~ ()) => (RunInBase m IO) -> Mode -> (a -> m b) -> Params (Either Text a)+parameters runInIO mode main = baseParameters { configCheck = mode /= Vanilla- , realMain = main'+ , realMain = runInIO . main' }- where- main' (Left e) = errorM "hbro.dyre" e- main' (Right x) = do- debugM "hbro.dyre" . ("Dynamic reconfiguration paths:\n" ++) =<< describePaths- void $ main x+ where main' (Left e) = error e+ main' (Right x) = do+ debug . ("Dynamic reconfiguration paths:\n" ++) =<< describePaths+ void $ main x baseParameters :: Params (Either Text a) baseParameters = defaultParams@@ -54,12 +65,12 @@ , includeCurrentDirectory = False } -wrap :: (BaseIO m) => Mode -> (a -> IO b) -> a -> m ()-wrap mode main args = io . wrapMain (parameters mode main) $ Right args+wrap :: (ControlIO m, MonadLogger m, StM m () ~ ()) => Mode -> (a -> m b) -> a -> m ()+wrap mode result args = liftBaseWith $ \runInIO -> wrapMain (parameters runInIO mode result) (Right args) -- | Launch a recompilation of the configuration file-recompile :: (BaseIO m) => m (Maybe Text)+recompile :: (MonadIO m) => m (Maybe Text) recompile = io $ do customCompile baseParameters map pack <$> getErrorString baseParameters
library/Hbro/Error.hs view
@@ -1,29 +1,41 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-} module Hbro.Error ( module X, module Hbro.Error) where -- {{{ Imports-import Hbro.Logger-import Hbro.Prelude+import Hbro.Prelude -import Control.Error.Util as X (note, hush)-import Control.Monad.Except as X (MonadError(..), ExceptT, runExceptT, withExceptT)-import Control.Monad.Trans.Maybe as X+import Control.Error.Safe+import Control.Error.Util as X (hush, note)+import Control.Monad.Except as X (ExceptT, MonadError (..),+ runExceptT) -- }}} --- | Convert a 'Maybe' value into a 'MonadError' monad.+-- {{{ Fail+-- | 'MonadError' with trivial error.+type MonadFail m = MonadError () m++-- | 'throwError' for 'MonadFail'.+die :: MonadFail m => m a+die = throwError ()++-- | 'runErrorT' with trivial error.+runFailT :: (Monad m) => ExceptT () m a -> m (Maybe a)+runFailT = return . rightMay <=< runExceptT++-- | Lift a 'Maybe' value into a 'MonadFail' computation+liftMaybe :: (MonadFail m) => Maybe a -> m a+liftMaybe = maybe (throwError ()) return+-- }}}++-- | Lift an 'Either' value into a 'MonadError' computation+liftEither :: (MonadError e m) => Either e a -> m a+liftEither = either throwError return+ failWith :: (MonadError e m) => Maybe a -> e -> m a failWith x e = either throwError return $ note e x -- | Monadic and infix version of 'failWith' (<!>) :: (MonadError e m) => m (Maybe a) -> e -> m a (<!>) f e = f >>= (`failWith` e)---- | Like 'runExceptT', except that the error is automatically logged, then discarded.-logErrors :: (BaseIO m) => ExceptT Text m a -> m (Maybe a)-logErrors = runExceptT >=> either (\e -> errorM "hbro.error" e >> return Nothing) (return . Just)--logErrors' :: (BaseIO m) => ExceptT e m a -> m (Maybe a)-logErrors' = return . either (const Nothing) Just <=< runExceptT---- | Like 'logErrors', but discards the result.-logErrors_ :: (BaseIO m) => ExceptT Text m a -> m ()-logErrors_ = void . logErrors
+ library/Hbro/Event.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Hbro.Event (+-- * Types+ Event(..)+ , Signal+ , Handler+-- * Signal manipulation+ , newSignal+ , emit+ , emit'+ , closeSignal+ , closeSignal'+ , listenTo+-- * Handlers+ , addHandler+ , addRecursiveHandler+ , deleteHandlers+ ) where++-- {{{ Imports+import Hbro.Prelude++import Control.Concurrent.Async.Lifted+import Control.Concurrent.STM.TMChan+import Control.Monad.Logger.Extended+import Control.Monad.Trans.Resource++import Data.Function (fix)+-- }}}++-- | An event type is defined by its input type.+class (Show e) => Event e where+ type Input e :: *+ type Input e = ()++ describeInput :: e -> Input e -> Maybe Text++-- | A signal notifies the occurrence of an event.+data (Event e) => Signal e = Signal e (TMChan (Input e)) (TVar [ReleaseKey])++-- | Event handler.+type Handler m a = Input a -> m ()++instance (Event e) => Describable (Signal e) where+ describe (Signal e _ _) = tshow e++-- | 'Signal' exports no constructor, use this function instead.+newSignal :: (BaseIO m, Event e) => e -> m (Signal e)+newSignal e = Signal e <$> io newBroadcastTMChanIO <*> io (newTVarIO [])++-- | Blocks until signal is received.+waitFor :: (MonadIO m) => TMChan a -> m (Maybe a)+waitFor = atomically . readTMChan++-- | Trigger an event.+emit :: (Event e, MonadIO m, MonadLogger m) => Signal e -> Input e -> m ()+emit signal@(Signal e _ h) input = do+ forM_ (describeInput e input) $ debug . ("Event triggered: " ++)+ handlers <- atomically $ readTVar h+ when (null handlers) . forM_ (describeInput e input) $ debug . (++) "No handler for event: "+ emit' signal input++-- | Like 'emit', but doesn't log anything.+emit' :: (Event e, MonadIO m) => Signal e -> Input e -> m ()+emit' (Signal _ s _) input = atomically $ writeTMChan s input++-- | Close a signal and all its attached hooks.+closeSignal :: (Event e, MonadIO m, MonadLogger m, MonadResource m) => Signal e -> m ()+closeSignal signal = debug "Closing signal." >> closeSignal' signal++-- | Like 'close', but doesn't log anything.+closeSignal' :: (Event e, MonadIO m, MonadResource m) => Signal e -> m ()+closeSignal' signal@(Signal _ s _) = atomically (closeTMChan s) >> deleteHandlers signal++-- | Asynchronously wait for the next event.+listenTo :: (Event a, MonadIO m) => Signal a -> m (Async (Maybe (Input a)))+listenTo (Signal _ signal _) = io . async . waitFor =<< atomically (dupTMChan signal)++-- | Execute a function each time an event occurs.+addHandler :: (Event a, ControlIO m, MonadResource m) => Signal a -> (Handler m a) -> m ReleaseKey+addHandler (Signal _ s handlers) f = do+ signal <- atomically $ dupTMChan s++ result <- liftBaseWith $ \runInIO -> do+ runInIO . flip allocate cancel . async . fix $ \recurse ->+ waitFor signal >>= mapM_ (\x -> (runInIO $ f x) >> recurse)+ (releaseKey, (_ :: Async ())) <- restoreM result+ atomically $ modifyTVar handlers (releaseKey:)++ return releaseKey++-- | Generalized version of 'addHandler' where the callback function may recurse.+addRecursiveHandler :: (Event a, ControlIO m, MonadResource m) => Signal a -> b -> (b -> Input a -> m b) -> m ReleaseKey+addRecursiveHandler (Signal _ s handlers) init f = do+ signal <- atomically $ dupTMChan s++ result <- liftBaseWith $ \runInIO ->+ runInIO . flip allocate cancel . async . void . runInIO . flip fix init $ \recurse acc ->+ waitFor signal >>= mapM_ (f acc >=> recurse)+ (releaseKey, (_ :: Async ())) <- restoreM result+ atomically $ modifyTVar handlers (releaseKey:)++ return releaseKey++-- | Stop all handlers associated to the given signal.+deleteHandlers :: (Event e, MonadIO m, MonadResource m) => Signal e -> m ()+deleteHandlers (Signal _ _ handlers) = void . sequence . map release =<< atomically (readTVar handlers)
library/Hbro/Gdk/KeyVal.hsc view
@@ -1,4 +1,7 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, TupleSections #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} -- | Binding for GDK key constants defined in @gdk/gdkkeysyms.h@ module Hbro.Gdk.KeyVal where
library/Hbro/Gui.hs view
@@ -1,151 +1,69 @@-{-# LANGUAGE TemplateHaskell, ViewPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-} module Hbro.Gui (--- * Types- GUI- , HasGUI(..) -- * Basic- , get- , initialize+ initialize -- * Getter+ , getMainWindow , canRender- , isSourceMode , getDOM--- * Actions- , toggle- , render- , scroll- , scrollH- , scrollV- , setSourceMode- , toggleSourceMode- , zoomIn- , zoomOut--- * Misc- , Axis(..)- , Position(..)- , getObject ) where -- {{{ Imports-import Graphics.UI.Gtk.WebKit.Lifted.WebView--import Hbro.Error as Hbro-import Hbro.Gui.Buildable-import Hbro.Gui.NotificationBar (HasNotificationBar(..))-import qualified Hbro.Gui.NotificationBar as NotifBar-import Hbro.Gui.PromptBar (PromptBar, HasPromptBar(..))-import qualified Hbro.Gui.PromptBar as Prompt-import Hbro.Gui.PromptBar.Signals as Prompt-import Hbro.Gui.StatusBar-import Hbro.Logger hiding(initialize)-import Hbro.Prelude hiding(on)--import Control.Lens.Getter-import Control.Lens.Lens-import Control.Lens.Setter-import Control.Lens.TH-import Control.Monad.Reader hiding(join, mapM_, when)--import Data.Text (splitOn)--import Graphics.Rendering.Pango.Enums-import Graphics.UI.Gtk.Abstract.Container-import Graphics.UI.Gtk.Abstract.Widget-import qualified Graphics.UI.Gtk.Builder as Gtk-import Graphics.UI.Gtk.General.General as GTK-import Graphics.UI.Gtk.Misc.Adjustment-import Graphics.UI.Gtk.Scrolling.ScrolledWindow-import Graphics.UI.Gtk.WebKit.DOM.Document-import Graphics.UI.Gtk.Windows.Window--import Network.URI as N--import System.Glib.Attributes hiding(get, set)-import qualified System.Glib.Attributes as G (get, set)--- import System.Glib.GError-import System.Glib.Signals-import System.Glib.Types--- }}}---- {{{ Types-data Axis = Horizontal | Vertical deriving(Show)-data Position = Absolute Double | Relative Double deriving(Show)--data GUI = GUI- { _mainWindow :: Window- , _scrollWindow :: ScrolledWindow -- ^ 'ScrolledWindow' containing the webview- , _webView :: WebView- , _promptBar :: PromptBar- , _statusBar :: StatusBar- , _notificationBar :: NotifBar.NotificationBar- , _builder :: Gtk.Builder -- ^ Builder object created from XML file- }--makeLensesWith ?? ''GUI $ classyRules- & lensField .~ (\name -> Just (tail name ++ "L"))- & lensClass .~ (\name -> Just ("Has" ++ name, "_" ++ toLower name))---- | A 'GUI' can be built from an XML file.-instance Buildable GUI where- buildWith b = do- sWindow <- gSync $ Gtk.builderGetObject b castToScrolledWindow (asText "webViewParent")- webView <- gSync webViewNew+import Graphics.UI.Gtk.WebKit.Lifted.WebView () - gAsync $ containerAdd sWindow webView+import Hbro.Error as Hbro+import Hbro.Event+import Hbro.Gui.Builder+import Hbro.Gui.MainView hiding (initialize)+import qualified Hbro.Gui.MainView as MainView+import Hbro.Gui.NotificationBar (NotificationBar)+import qualified Hbro.Gui.NotificationBar as NotifBar+import Hbro.Gui.PromptBar (PromptBar, closedL)+import qualified Hbro.Gui.PromptBar as Prompt+import Hbro.Gui.StatusBar+import Hbro.Logger+import Hbro.Prelude hiding (on) - GUI <$> gSync (Gtk.builderGetObject b castToWindow (asText "mainWindow"))- <*> pure sWindow- <*> pure webView- <*> buildWith b- <*> buildWith b- <*> buildWith b- <*> pure b+import Control.Lens.Getter+import Control.Monad.Trans.Resource -instance HasNotificationBar GUI where _notificationbar = notificationBarL-instance HasPromptBar GUI where _promptbar = promptBarL+import Graphics.Rendering.Pango.Enums+import Graphics.UI.Gtk.Abstract.Widget+import qualified Graphics.UI.Gtk.Builder as Gtk+import Graphics.UI.Gtk.General.General.Extended (gAsync, gSync)+import qualified Graphics.UI.Gtk.General.General.Extended as Gtk+import Graphics.UI.Gtk.Windows.Window+import System.Glib.Signals hiding (Signal) -- }}} -get :: (MonadReader r m, BaseIO m, HasGUI r) => Lens' GUI a -> m a-get l = askL (_gui.l)----- {{{ Initialization-initialize :: (BaseIO m, MonadError Text m, MonadPlus m) => FilePath -> m GUI-initialize file = do- gui <- buildFrom file-- let webView = gui^.webViewL-- initializeWindow $ gui^.mainWindowL- initializeWebView webView- Prompt.initialize $ gui^.promptBarL- NotifBar.initialize $ gui^.notificationBarL+initialize :: (ControlIO m, Alternative m, MonadError Text m, MonadThreadedLogger m, MonadResource m)+ => FilePath -> m (Gtk.Builder, MainView, PromptBar, StatusBar, NotificationBar)+initialize (fpToText -> file) = do+ debug $ "Building GUI from " ++ file+ builder <- gSync Gtk.builderNew+ gSync . Gtk.builderAddFromFile builder $ unpack file - gAsync . widgetShowAll $ gui^.mainWindowL- runReaderT Prompt.hide (gui^.promptBarL)+ mainView <- MainView.initialize =<< MainView.buildFrom builder+ mainWindow <- initializeWindow =<< getWidget builder "mainWindow"+ promptBar <- Prompt.initialize =<< Prompt.buildFrom builder+ notifBar <- NotifBar.initialize =<< NotifBar.buildFrom builder+ statusBar <- StatusBar <$> getWidget builder "statusBox" - gAsync $ windowSetDefault (gui^.mainWindowL) (Just $ gui^.webViewL)+ let webView = mainView^.webViewL+ gAsync . widgetShowAll $ mainWindow+ Prompt.close promptBar - let closePrompt = widgetHide (gui^.promptBarL.boxL) >> widgetGrabFocus webView >> return ()- onEntryCancelled (gui^.promptBarL.entryL) $ const closePrompt- onEntryActivated (gui^.promptBarL.entryL) $ const closePrompt+ gAsync $ windowSetDefault mainWindow (Just webView)+ addHandler (promptBar^.closedL) (const . gAsync $ widgetGrabFocus webView) -- io $ scrolledWindowSetPolicy (gui^.scrollWindowL) PolicyNever PolicyNever -- io $ G.set (gui^.scrollWindowL) [ scrolledWindowHscrollbarPolicy := PolicyNever, scrolledWindowVscrollbarPolicy := PolicyNever] - return gui--buildFrom :: (BaseIO m, MonadError Text m, Buildable t) => FilePath -> m t-buildFrom (fpToText -> uiFile) = do- infoM "hbro.gui" $ "Building UI from: " ++ uiFile-- builder <- gSync Gtk.builderNew-- {-result <- -}- gSync $ Gtk.builderAddFromFile builder (unpack uiFile)- -- leftM throwError result-- buildWith builder+ return (builder, mainView, promptBar, statusBar, notifBar) -- TODO: catch IOException -- builderAddFromFile ::@@ -154,122 +72,9 @@ -- handler :: Gtk.BuilderError -> Text -> IO (Either Text a) -- handler e message = return . Left $ "Error while building GUI from [" ++ file ++ "]: " ++ message -initializeWindow :: (BaseIO m) => Window -> m ()-initializeWindow window = gAsync $ do+initializeWindow :: (MonadIO m) => Window -> m Window+initializeWindow window = do+ gAsync $ do widgetModifyBg window StateNormal (Color 0 0 5000)- void . on window deleteEvent $ gAsync GTK.mainQuit >> return False--initializeWebView :: (BaseIO m) => WebView -> m ()-initializeWebView webView = gAsync $ do- G.set webView [ widgetCanDefault := True ]- -- webViewSetMaintainsBackForwardList webView False- on webView closeWebView $ gAsync GTK.mainQuit >> return False- void . on webView consoleMessage $ \a b n c -> do- putStrLn "console message"- mapM_ putStrLn [a, b, tshow n, c]- return True- -- void . on webView resourceRequestStarting $ \frame resource request response -> do- -- uri <- webResourceGetUri resource- -- putStrLn $ "resource request starting: " ++ uri- -- -- print =<< webResourceGetData resource- -- putStrLn =<< (maybe (return "No request") (return . ("Request URI: " ++) . show <=< W.networkRequestGetUri) request)- -- putStrLn =<< (maybe (return "No response") (return . ("Response URI: " ++) . show <=< networkResponseGetUri) response)-- -- -- case (endswith ".css" uri || uri `endswith` ".png" || uri `endswith` ".ico") of- -- -- True -> (putStrLn "OK")- -- (maybe (return ()) (`networkRequestSetUri` "about:blank") request)--- }}}---- {{{ Actions--- | Toggle a widget's visibility-toggle :: (BaseIO m, WidgetClass a) => a -> m ()-toggle widget = do- visibility <- gSync $ G.get widget widgetVisible- gAsync $ (widgetHide <| visibility |> widgetShow) widget--canRender :: (BaseIO m, MonadReader t m, HasGUI t) => Text -> m Bool-canRender mimetype = gSync . (`webViewCanShowMimeType` mimetype) =<< get webViewL---render :: (MonadReader t m, HasGUI t, BaseIO m) => Text -> URI -> m ()-render page uri = do- debugM "hbro.gui" $ "Rendering <" ++ tshow uri ++ ">"- -- loadString page uri =<< get' webViewL-- -- debugM "hbro.gui" $ "Base URI: " ++ show (baseOf uri)-- loadString page (baseOf uri) =<< get webViewL- where- baseOf uri' = uri' {- uriPath = unpack . (`snoc` '/') . intercalate "/" . initSafe . splitOn "/" . pack $ uriPath uri'- }---- | Shortcut to 'scroll' horizontally or vertically.-scrollH, scrollV :: (BaseIO m, MonadReader t m, HasGUI t) => Position -> m ()-scrollH = scroll Horizontal-scrollV = scroll Vertical---- | Scroll WebView.-scroll :: (BaseIO m, MonadReader t m, HasGUI t) => Axis -> Position -> m ()-scroll axis percentage = scroll' axis percentage =<< get scrollWindowL---- General scrolling command-scroll' :: (BaseIO m) => Axis -> Position -> ScrolledWindow -> m ()-scroll' axis percentage scrollWindow = do- logDebug $ "Set scroll " ++ tshow axis ++ " = " ++ tshow percentage-- adj <- gSync . getAdjustment axis $ scrollWindow- page <- gSync $ adjustmentGetPageSize adj- current <- gSync $ adjustmentGetValue adj- lower <- gSync $ adjustmentGetLower adj- upper <- gSync $ adjustmentGetUpper adj-- let shift (Absolute x) = lower + x/100 * (upper - page - lower)- shift (Relative x) = current + x/100 * page- limit x = (x `max` lower) `min` (upper - page)-- gAsync . adjustmentSetValue adj $ limit (shift percentage)---getAdjustment :: (BaseIO m) => Axis -> ScrolledWindow -> m Adjustment-getAdjustment Horizontal = gSync . scrolledWindowGetHAdjustment-getAdjustment Vertical = gSync . scrolledWindowGetVAdjustment----- TODO: see if the lens system can be leveraged to get/set this property--- sourceMode :: Lens--isSourceMode :: (BaseIO m, MonadReader t m, HasGUI t) => m Bool-isSourceMode = gSync . webViewGetViewSourceMode =<< get webViewL--setSourceMode :: (BaseIO m, MonadReader t m, HasGUI t) => Bool -> m ()-setSourceMode value = get webViewL >>= gAsync . (`webViewSetViewSourceMode` value) >> logDebug ("Set source mode = " ++ tshow value)---- | Toggle source display. This needs to be done *before* loading an URI.-toggleSourceMode :: (BaseIO m, MonadReader t m, HasGUI t) => m ()-toggleSourceMode = setSourceMode . not =<< isSourceMode---zoomIn, zoomOut :: (BaseIO m, MonadReader t m, HasGUI t) => m ()-zoomIn = get webViewL >>= gAsync . webViewZoomIn >> logDebug "Zooming in."-zoomOut = get webViewL >>= gAsync . webViewZoomOut >> logDebug "Zooming out."--getDOM :: (BaseIO m, MonadReader t m, HasGUI t) => m (Maybe Document)-getDOM = gSync . webViewGetDomDocument =<< get webViewL---- | Return the casted 'GObject' corresponding to the given name (set in the builder's XML file)-getObject :: (BaseIO m, MonadReader t m, HasGUI t, GObjectClass a)- => (GObject -> a) -- ^ @castTo@ function- -> Text -- ^ Widget name- -> m a-getObject cast name = do- b <- get builderL- gSync $ Gtk.builderGetObject b cast name--- }}}----- {{{ Util-logDebug{-, logInfo-} :: (BaseIO m) => Text -> m ()-logDebug = debugM "hbro.gui"--- logInfo = infoM "hbro.gui"--- }}}+ void . on window deleteEvent $ gAsync Gtk.mainQuit >> return False+ return window
− library/Hbro/Gui/Buildable.hs
@@ -1,10 +0,0 @@-module Hbro.Gui.Buildable where---- {{{ Imports-import Hbro.Prelude--import Graphics.UI.Gtk.Builder--- }}}---- | UI elements that can be built from a @GtkBuilder@ object (that is: an XML file)-class Buildable a where buildWith :: (BaseIO m) => Builder -> m a
+ library/Hbro/Gui/Builder.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Hbro.Gui.Builder+ ( FromGObject(..)+ , getWidget+ , getMainWindow+ ) where++-- {{{ Imports+import Hbro.Prelude++import qualified Graphics.UI.Gtk.Builder as Gtk+import qualified Graphics.UI.Gtk.Display.Label as Gtk+import qualified Graphics.UI.Gtk.Entry.Entry as Gtk+import Graphics.UI.Gtk.General.General.Extended (gSync)+import qualified Graphics.UI.Gtk.Layout.HBox as Gtk+import qualified Graphics.UI.Gtk.Scrolling.ScrolledWindow as Gtk+import qualified Graphics.UI.Gtk.Windows.Window as Gtk++import System.Glib.Types+-- }}}+++-- | UI elements that can be built from a @GtkBuilder@ object (that is: an XML file)+class (GObjectClass a) => FromGObject a where+ cast :: GObject -> a++instance FromGObject Gtk.Entry where cast = Gtk.castToEntry+instance FromGObject Gtk.HBox where cast = Gtk.castToHBox+instance FromGObject Gtk.Label where cast = Gtk.castToLabel+instance FromGObject Gtk.ScrolledWindow where cast = Gtk.castToScrolledWindow+instance FromGObject Gtk.Window where cast = Gtk.castToWindow++-- | Return the casted 'GObject' corresponding to the given name (set in the builder's XML file)+getWidget :: (MonadIO m, FromGObject a) => Gtk.Builder -> Text -> m a+getWidget builder name = gSync $ Gtk.builderGetObject builder cast name++getMainWindow :: (MonadIO m, MonadReader r m, Has Gtk.Builder r) => m Gtk.Window+getMainWindow = (`getWidget` "mainWindow") =<< ask
+ library/Hbro/Gui/MainView.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module Hbro.Gui.MainView+ ( MainView+ , scrollWindowL+ , webViewL+ , downloadHandlerL+ , keyPressedHandlerL+ , linkClickedHandlerL+ , linkHoveredHandlerL+ , linkUnhoveredHandlerL+ , loadCommittedHandlerL+ , loadFailedHandlerL+ , loadFinishedHandlerL+ , loadRequestedHandlerL+ , loadStartedHandlerL+ , newWindowHandlerL+ , progressChangedHandlerL+ , scrolledHandlerL+ , titleChangedHandlerL+ , uriChangedHandlerL+ , zoomLevelChangedHandlerL+ , Axis(..)+ , Position(..)+ , getWebView+ , getWebSettings+ , getDOM+ , getAdjustment+ , Scrolled(..)+ , buildFrom+ , initialize+ , canRender+ , render+ , zoomIn+ , zoomOut+ , scrollH+ , scrollV+ ) where++-- {{{ Imports+import Hbro.Event+import Hbro.Gui.Builder+import Hbro.Keys as Keys+import Hbro.Logger+import Hbro.Prelude hiding (on)+import Hbro.WebView.Signals++import Control.Lens hiding (set, snoc)++import Data.Text (splitOn)++import qualified Graphics.UI.Gtk.Abstract.Container as Gtk+import Graphics.UI.Gtk.Abstract.Widget+import qualified Graphics.UI.Gtk.Builder as Gtk+import Graphics.UI.Gtk.General.General.Extended+import qualified Graphics.UI.Gtk.Misc.Adjustment as Gtk+import Graphics.UI.Gtk.Scrolling.ScrolledWindow+import Graphics.UI.Gtk.WebKit.DOM.Document+import Graphics.UI.Gtk.WebKit.Lifted.WebView hiding+ (LoadStatus (..))+import Graphics.UI.Gtk.WebKit.NetworkRequest+import Graphics.UI.Gtk.WebKit.WebPolicyDecision+import Graphics.UI.Gtk.WebKit.WebSettings++import Network.URI++import System.Glib.Attributes.Extended+import System.Glib.Signals hiding (Signal)+-- }}}++-- * Types+data Scrolled = Scrolled deriving(Show)+instance Event Scrolled where+ describeInput _ _ = Just "Scrolled"++declareLenses [d|+ data MainView = MainView+ { scrollWindowL :: ScrolledWindow -- ^ 'ScrolledWindow' containing the webview+ , webViewL :: WebView+ , downloadHandlerL :: Signal Download+ , keyPressedHandlerL :: Signal KeyPressed+ , linkClickedHandlerL :: Signal LinkClicked+ , linkHoveredHandlerL :: Signal LinkHovered+ , linkUnhoveredHandlerL :: Signal LinkUnhovered+ , loadCommittedHandlerL :: Signal LoadCommitted+ , loadFailedHandlerL :: Signal LoadFailed+ , loadFinishedHandlerL :: Signal LoadFinished+ , loadRequestedHandlerL :: Signal LoadRequested+ , loadStartedHandlerL :: Signal LoadStarted+ , newWindowHandlerL :: Signal NewWindow+ , progressChangedHandlerL :: Signal ProgressChanged+ -- , resourceOpenedHandlerL :: Signal ResourceOpened+ , scrolledHandlerL :: Signal Scrolled+ , titleChangedHandlerL :: Signal TitleChanged+ , uriChangedHandlerL :: Signal URIChanged+ , zoomLevelChangedHandlerL :: Signal ZoomLevelChanged+ }+ |]+++-- * Commonly used getters+getWebView :: (MonadReader r m, Has MainView r) => m WebView+getWebView = asks $ view webViewL++getWebSettings :: (MonadIO m, MonadReader r m, Has MainView r) => m WebSettings+getWebSettings = gSync . webViewGetWebSettings =<< asks (view webViewL)++getDOM :: (MonadIO m, MonadReader r m, Has MainView r) => m (Maybe Document)+getDOM = gSync . webViewGetDomDocument =<< asks (view webViewL)++getAdjustment :: (MonadIO m) => Axis -> ScrolledWindow -> m Gtk.Adjustment+getAdjustment Horizontal = gSync . scrolledWindowGetHAdjustment+getAdjustment Vertical = gSync . scrolledWindowGetVAdjustment+++-- * Others+data Axis = Horizontal | Vertical deriving(Show)+data Position = Absolute Double | Relative Double deriving(Show)++buildFrom :: (BaseIO m) => Gtk.Builder -> m MainView+buildFrom builder = do+ sWindow <- getWidget builder "webViewParent"+ webView <- gSync webViewNew++ gAsync $ Gtk.containerAdd sWindow webView+ MainView <$> pure sWindow+ <*> pure webView+ <*> newSignal Download+ <*> newSignal KeyPressed+ <*> newSignal LinkClicked+ <*> newSignal LinkHovered+ <*> newSignal LinkUnhovered+ <*> newSignal LoadCommitted+ <*> newSignal LoadFailed+ <*> newSignal LoadFinished+ <*> newSignal LoadRequested+ <*> newSignal LoadStarted+ <*> newSignal NewWindow+ <*> newSignal ProgressChanged+ -- <*> newSignal ResourceOpened+ <*> newSignal Scrolled+ <*> newSignal TitleChanged+ <*> newSignal URIChanged+ <*> newSignal ZoomLevelChanged+++initialize :: (ControlIO m, MonadLogger m) => MainView -> m MainView+initialize mainView = do+ set webView widgetCanDefault True+ -- set webView webViewSetMaintainsBackForwardList False+ gAsync . on webView closeWebView $ gAsync mainQuit >> return False+ gAsync . on webView consoleMessage $ \a b n c -> do+ putStrLn "console message"+ putStrLn $ unlines [a, b, tshow n, c]+ return True++ gAsync . on webView mimeTypePolicyDecisionRequested $ \_frame request mimetype decision -> io $ do+ uri <- networkRequestGetUri request :: IO (Maybe Text)+ -- debug $ "Opening resource [MIME type=" ++ mimetype ++ "] at <" ++ tshow uri ++ ">"+ renderable <- webViewCanShowMimeType webView (asText mimetype)+ case (uri, renderable) of+ (Just _, True) -> webPolicyDecisionUse decision+ (Just _, _) -> webPolicyDecisionDownload decision+ _ -> webPolicyDecisionIgnore decision+ return True++ -- void . on webView resourceRequestStarting $ \frame resource request response -> do+ -- uri <- webResourceGetUri resource+ -- putStrLn $ "resource request starting: " ++ uri+ -- -- print =<< webResourceGetData resource+ -- putStrLn =<< (maybe (return "No request") (return . ("Request URI: " ++) . show <=< W.networkRequestGetUri) request)+ -- putStrLn =<< (maybe (return "No response") (return . ("Response URI: " ++) . show <=< networkResponseGetUri) response)++ -- -- case (endswith ".css" uri || uri `endswith` ".png" || uri `endswith` ".ico") of+ -- -- True -> (putStrLn "OK")+ -- (maybe (return ()) (`networkRequestSetUri` "about:blank") request)++ attachDownload webView $ mainView^.downloadHandlerL+ attachKeyPressed webView $ mainView^.keyPressedHandlerL+ attachLinkHovered webView (mainView^.linkHoveredHandlerL) (mainView^.linkUnhoveredHandlerL)+ attachLoadCommitted webView $ mainView^.loadCommittedHandlerL+ attachLoadFailed webView $ mainView^.loadFailedHandlerL+ attachLoadFinished webView $ mainView^.loadFinishedHandlerL+ attachLoadStarted webView $ mainView^.loadStartedHandlerL+ attachNavigationRequest webView (mainView^.linkClickedHandlerL) (mainView^.loadRequestedHandlerL)+ attachNewWebView webView $ mainView^.newWindowHandlerL+ attachNewWindow webView $ mainView^.newWindowHandlerL+ attachProgressChanged webView $ mainView^.progressChangedHandlerL+ -- attachResourceOpened webView (mainView^.resourceOpenedHandler)+ attachScrolled mainView $ mainView^.scrolledHandlerL+ attachTitleChanged webView $ mainView^.titleChangedHandlerL+ attachUriChanged webView $ mainView^.uriChangedHandlerL+ attachZoomLevelChanged webView $ mainView^.zoomLevelChangedHandlerL++ initSettings webView++ return mainView+ where webView = mainView^.webViewL++canRender :: (MonadIO m, MonadReader r m, Has MainView r) => Text -> m Bool+canRender mimetype = gSync . (`webViewCanShowMimeType` mimetype) =<< asks (view webViewL)+++render :: (MonadReader r m, Has MainView r, MonadIO m, MonadLogger m) => Text -> URI -> m ()+render page uri = do+ debug $ "Rendering <" ++ tshow uri ++ ">"+ -- loadString page uri =<< get' webViewL++ -- debug $ "Base URI: " ++ show (baseOf uri)++ loadString page (baseOf uri) =<< asks (view webViewL)+ where+ baseOf uri' = uri' {+ uriPath = unpack . (`snoc` '/') . intercalate "/" . initSafe . splitOn "/" . pack $ uriPath uri'+ }+++-- | Set default settings+initSettings :: (MonadIO m, MonadLogger m, Functor m) => WebView -> m WebView+initSettings webView = do+ s <- gSync $ webViewGetWebSettings webView++ set s webSettingsAutoLoadImages True+ set s webSettingsAutoShrinkImages True+ set s webSettingsEnableDefaultContextMenu True+ set s webSettingsDefaultEncoding (asText "utf8")+ set s webSettingsEnableDeveloperExtras False+ set s webSettingsEnableDomPaste False+ set s webSettingsEnableHtml5Database False+ set s webSettingsEnableHtml5LocalStorage False+ set s webSettingsEnableOfflineWebApplicationCache False+ set s webSettingsEnablePageCache True+ set s webSettingsEnablePlugins False+ set s webSettingsEnablePrivateBrowsing False+ set s webSettingsEnableScripts False+ set s webSettingsEnableSpellChecking False+ set s webSettingsEnableSpatialNavigation False+ set s webSettingsEnableUniversalAccessFromFileUris True+ set s webSettingsEnableSiteSpecificQuirks False+ set s webSettingsEnableXssAuditor False+ set s webSettingsJSCanOpenWindowAuto False+ set s webSettingsMonospaceFontFamily (asText "inconsolata")+ set s webSettingsPrintBackgrounds True+ set s webSettingsResizableTextAreas True+ set s webSettingsSpellCheckingLang (Nothing :: Maybe Text)+ set s webSettingsTabKeyCyclesThroughElements True+ set s webSettingsUserStylesheetUri (Nothing :: Maybe Text)+ set s webSettingsZoomStep 0.1++ return webView+++zoomIn, zoomOut :: (MonadIO m, Functor m, MonadReader r m, Has MainView r) => m ()+zoomIn = getWebView >>= gAsync . webViewZoomIn+zoomOut = getWebView >>= gAsync . webViewZoomOut++-- | Shortcut to 'scroll' horizontally or vertically.+scrollH, scrollV :: (MonadIO m, Functor m, MonadLogger m, MonadReader r m, Has MainView r) => Position -> m ()+scrollH p = void . scroll Horizontal p =<< ask+scrollV p = void . scroll Vertical p =<< ask++-- | General scrolling command+scroll :: (MonadIO m, MonadLogger m) => Axis -> Position -> MainView -> m MainView+scroll axis percentage mainView = do+ debug $ "Set scroll " ++ tshow axis ++ " = " ++ tshow percentage++ adj <- getAdjustment axis $ mainView^.scrollWindowL+ page <- get adj Gtk.adjustmentPageSize+ current <- get adj Gtk.adjustmentValue+ lower <- get adj Gtk.adjustmentLower+ upper <- get adj Gtk.adjustmentUpper++ let shift (Absolute x) = lower + x/100 * (upper - page - lower)+ shift (Relative x) = current + x/100 * page+ limit x = (x `max` lower) `min` (upper - page)++ set adj Gtk.adjustmentValue $ limit (shift percentage)+ return mainView+++attachScrolled :: (ControlIO m, MonadLogger m) => MainView -> Signal Scrolled -> m (ConnectId Gtk.Adjustment)+attachScrolled mainView signal = do+ adjustment <- getAdjustment Vertical $ mainView^.scrollWindowL+ liftBaseWith $ \runInIO -> gSync . Gtk.onValueChanged adjustment . void . runInIO $ emit signal ()
library/Hbro/Gui/NotificationBar.hs view
@@ -1,77 +1,72 @@-{-# LANGUAGE TemplateHaskell #-}-module Hbro.Gui.NotificationBar (--- * Type- NotificationBar- , HasNotificationBar(..)+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Hbro.Gui.NotificationBar+ ( NotificationBar+ , buildFrom+ , asNotificationBar , initialize-) where+ ) where -- {{{ Imports--- import Hbro.Error-import Hbro.Gui.Buildable-import Hbro.Logger hiding(initialize)-import Hbro.Prelude--import Control.Lens-import Control.Monad.Reader+import Hbro.Error+import Hbro.Gui.Builder+import Hbro.Logger+import Hbro.Prelude -import Graphics.Rendering.Pango.Enums-import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.Builder-import Graphics.UI.Gtk.Display.Label+import Graphics.Rendering.Pango.Extended+import Graphics.UI.Gtk.Abstract.Misc+import Graphics.UI.Gtk.Abstract.Widget+import qualified Graphics.UI.Gtk.Builder as Gtk+import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.General.General.Extended -import System.Glib.Types-import System.Log.Formatter-import System.Log.Handler.Simple-import System.Log.Logger (addHandler, rootLoggerName, updateGlobalLogger)+import System.Glib.Types -- }}} --- TODO: color notifications depending on their level -- TODO: make it possible to expand the notification bar to display the last N log lines -- TODO: make it possible to change the log level -- {{{ Types-newtype NotificationBar = NotificationBar { _label :: Label }+-- | A 'NotificationBar' can be manipulated as a 'Label'.+data NotificationBar = NotificationBar Label -makeLensesWith ?? ''NotificationBar $ classyRules- & lensField .~ (\name -> Just (tailSafe name ++ "L"))- & lensClass .~ (\name -> Just ("Has" ++ name, "_" ++ toLower name))+-- | Useful to help the type checker+asNotificationBar :: NotificationBar -> NotificationBar+asNotificationBar = id -- | A 'NotificationBar' can be built from an XML file.-instance Buildable NotificationBar where- buildWith b = NotificationBar <$> gSync (builderGetObject b castToLabel $ asText "notificationLabel")+buildFrom :: (MonadIO m, Functor m) => Gtk.Builder -> m NotificationBar+buildFrom builder = NotificationBar <$> getWidget builder "notificationLabel" instance GObjectClass NotificationBar where toGObject (NotificationBar l) = toGObject l unsafeCastGObject = NotificationBar . unsafeCastGObject --- | A 'NotificationBar' can be manipulated as a 'Widget'. instance WidgetClass NotificationBar+instance MiscClass NotificationBar+instance LabelClass NotificationBar -- }}} -get' :: (MonadReader r m, BaseIO m, HasNotificationBar r) => Lens' NotificationBar a -> m a-get' l = askL $ _notificationbar.l---- modify' :: (MonadReader r m, BaseIO m, HasNotificationBar r) => (Status -> Status) -> m ()--- modify' f = io . atomically . (`modifyTVar` f) =<< asks (view _notificationBar)--initialize :: (BaseIO m) => NotificationBar -> m ()-initialize notifBar = io . updateGlobalLogger rootLoggerName $ addHandler (logHandler notifBar)-+initialize :: (ControlIO m, MonadThreadedLogger m) => NotificationBar -> m NotificationBar+initialize notifBar = do+ addLogHandler $ \(_loc, _source, level, message) -> void . runFailT $ do+ guard $ level >= LevelInfo+ write' message (logColor level) notifBar+ return notifBar -logHandler :: NotificationBar -> GenericHandler NotificationBar-logHandler notifBar = GenericHandler- { priority = INFO- , formatter = simpleLogFormatter "$msg"- , privData = notifBar- , writeFunc = \n t -> runReaderT (write t) n- , closeFunc = \_ -> return ()- }+logColor :: LogLevel -> Color+logColor LevelError = red+logColor LevelWarn = yellow+logColor _ = gray -write :: (BaseIO m, MonadReader r m, HasNotificationBar r) => String -> m ()-write text = do- label <- get' labelL+write :: (MonadIO m) => Text -> NotificationBar -> m NotificationBar+write message = write' message gray +write' :: (MonadIO m) => Text -> Color -> NotificationBar -> m NotificationBar+write' message color bar = do gAsync $ do- labelSetAttributes label [AttrForeground {paStart = 0, paEnd = -1, paColor = gray}]- labelSetMarkup label text+ labelSetAttributes bar [AttrForeground {paStart = 0, paEnd = -1, paColor = color}]+ labelSetText bar message+ return bar
library/Hbro/Gui/PromptBar.hs view
@@ -1,70 +1,116 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- | Designed to be imported as @qualified@. module Hbro.Gui.PromptBar ( -- * Types PromptBar- -- description- , HasPromptBar(..)+ , boxL+ , closedL+ , buildFrom , labelName , entryName , boxName -- * Functions , initialize- , open- , unhide- , hide+ , close , Hbro.Gui.PromptBar.clean -- * Prompts , prompt- , prompt'- , promptURI- , getEntryValue+ , uriPrompt+ , iprompt+ , getPromptValue+-- * Monadic versions+ , promptM+ , uriPromptM+ , ipromptM+ , getPromptValueM ) where -- {{{ Imports-import Hbro.Error-import Hbro.Gui.Buildable-import Hbro.Gui.PromptBar.Signals-import Hbro.Gui.PromptBar.Hooks hiding(clean, set)-import qualified Hbro.Gui.PromptBar.Hooks as Hooks-import Hbro.Logger hiding(initialize)-import Hbro.Prelude+import Hbro.Error+import Hbro.Event+import Hbro.Gdk.KeyVal+import Hbro.Gui.Builder+import Hbro.Logger+import Hbro.Prelude hiding (on) -import Control.Lens.Getter-import Control.Lens.Setter-import Control.Lens.Lens-import Control.Lens.TH-import Control.Monad.Reader hiding(when)+import Control.Concurrent.Async.Lifted+import Control.Lens.Getter+import Control.Lens.TH+import Control.Monad.Trans.Resource -import Graphics.Rendering.Pango.Enums-import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.Builder-import Graphics.UI.Gtk.Display.Label-import Graphics.UI.Gtk.Entry.Editable-import Graphics.UI.Gtk.Entry.Entry-import Graphics.UI.Gtk.Layout.HBox+import Graphics.Rendering.Pango.Extended+import Graphics.UI.Gtk.Abstract.Widget+import qualified Graphics.UI.Gtk.Builder as Gtk+import Graphics.UI.Gtk.Display.Label+import Graphics.UI.Gtk.Entry.Editable+import Graphics.UI.Gtk.Entry.Entry+import Graphics.UI.Gtk.Gdk.EventM as Gdk+import Graphics.UI.Gtk.General.General.Extended+import Graphics.UI.Gtk.Layout.HBox -import Network.URI.Monadic+import Network.URI.Extended++import System.Glib.Attributes.Extended+import System.Glib.Signals hiding (Signal) -- }}} -- {{{ Types--- | No exported constructor, please use 'buildWith'-data PromptBar = PromptBar- { _box :: HBox- , _description :: Label- , _entry :: Entry- }+data Closed = Closed deriving(Show)+instance Event Closed where+ describeInput _ _ = Just "Prompt closed." -makeLensesWith ?? ''PromptBar $ classyRules- & lensField .~ (\name -> Just (tail name ++ "L"))- & lensClass .~ (\name -> Just ("Has" ++ name, "_" ++ toLower name))+data Changed = Changed deriving(Show)+instance Event Changed where+ type Input Changed = Text+ describeInput _ = Just . (++) "Prompt value changed to: " +data Validated = Validated deriving(Show)+instance Event Validated where+ type Input Validated = Text+ describeInput _ = Just . (++) "Prompt validated with value: "++-- | No exported constructor, please use 'buildFrom'+declareLenses [d|+ data PromptBar = PromptBar+ { boxL :: HBox+ , descriptionL :: Label+ , entryL :: Entry+ , changedL :: Signal Changed+ , closedL :: Signal Closed+ , validatedL :: Signal Validated+ }+ |]+-- }}}+ -- | A 'PromptBar' can be built from an XML file.-instance Buildable PromptBar where- buildWith b = PromptBar <$> gSync (builderGetObject b castToHBox boxName)- <*> gSync (builderGetObject b castToLabel labelName)- <*> gSync (builderGetObject b castToEntry entryName)+buildFrom :: (ControlIO m, MonadLogger m, Applicative m) => Gtk.Builder -> m PromptBar+buildFrom builder = do+ entry <- getWidget builder entryName+ closedSignal <- newSignal Closed+ validated <- newSignal Validated + promptBar <- PromptBar <$> getWidget builder boxName+ <*> getWidget builder labelName+ <*> pure entry+ <*> newSignal Changed+ <*> pure closedSignal+ <*> pure validated++ onEntryChanged entry $ emit (promptBar^.changedL)+ onEntryCanceled entry . async $ close promptBar+ onEntryValidated entry $ emit validated++ return promptBar++ -- | Widget name used in the XML file that describes the UI labelName, entryName, boxName :: Text labelName = "promptDescription"@@ -74,99 +120,132 @@ -- | Error message promptInterrupted :: Text promptInterrupted = "Prompt interrupted."--- }}} -initialize :: (BaseIO m) => PromptBar -> m ()-initialize aPromptBar = gAsync $ do- description `labelSetAttributes` [allItalic, allBold]- description `labelSetAttributes` [AttrForeground {paStart = 0, paEnd = -1, paColor = gray}]- widgetModifyBase entry StateNormal black- widgetModifyText entry StateNormal gray- where- description = aPromptBar^.descriptionL- entry = aPromptBar^.entryL+initialize :: (MonadIO m) => PromptBar -> m PromptBar+initialize =+ withM_ descriptionL (gAsync . (`labelSetAttributes` [allItalic, allBold]))+ >=> withM_ descriptionL (gAsync . (`labelSetAttributes` [AttrForeground {paStart = 0, paEnd = -1, paColor = gray}]))+ >=> withM_ entryL (gAsync . (\e -> widgetModifyBase e StateNormal black))+ >=> withM_ entryL (gAsync . (\e -> widgetModifyText e StateNormal gray)) --- | Pops-up the prompt bar, filling it with given arguments.-open :: (BaseIO m, MonadReader t m, HasPromptBar t)- => Text -- ^ Description- -> Text -- ^ Pre-fill value- -> m ()-open a b = do- debugM "hbro.promptbar" "Opening prompt."- void . open' a b =<< askL _promptbar--open' :: (BaseIO m) => Text -> Text -> PromptBar -> m PromptBar-open' newDescription defaultText =- withM_ descriptionL (gAsync . (`labelSetText` newDescription))- >=> withM_ entryL (gAsync . (`entrySetText` defaultText))- >=> withM_ boxL (gAsync . widgetShow)- >=> withM_ entryL (gAsync . widgetGrabFocus)- >=> withM_ entryL (gAsync . (`editableSetPosition` (-1)))+open :: (MonadIO m) => Text -> Text -> PromptBar -> m PromptBar+open description defaultText =+ withM_ descriptionL (gAsync . (`labelSetText` description))+ >=> withM_ entryL (gAsync . (`entrySetText` defaultText))+ >=> withM_ boxL (gAsync . widgetShow)+ >=> withM_ entryL (gAsync . widgetGrabFocus)+ >=> withM_ entryL (gAsync . (`editableSetPosition` (-1))) -unhide, hide :: (BaseIO m, MonadReader t m, HasPromptBar t) => m ()-unhide = gAsync . widgetShow =<< askL (_promptbar.boxL)-hide = gAsync . widgetHide =<< askL (_promptbar.boxL)+close :: (ControlIO m, MonadLogger m) => PromptBar -> m PromptBar+close promptBar = do+ runFailT $ do+ guard =<< get (promptBar^.boxL) widgetVisible+ emit (promptBar^.closedL) ()+ gAsync . widgetHide $ promptBar^.boxL+ void $ clean promptBar+ return promptBar -- | Close prompt, that is: clean its content, signals and callbacks-clean :: (BaseIO m, MonadReader t m, HasPromptBar t, HasPromptHooks n t) => m ()-clean = do- gAsync . (`widgetRestoreText` StateNormal) =<< askL (_promptbar.entryL)- gAsync . (\e -> widgetModifyText e StateNormal gray) =<< askL (_promptbar.entryL)-- hide- Hooks.clean+clean :: (ControlIO m) => PromptBar -> m PromptBar+clean = withM_ entryL (gAsync . (`widgetRestoreText` StateNormal))+ >=> withM_ entryL (gAsync . (\e -> widgetModifyText e StateNormal gray)) -- {{{ Prompts--- | Same as 'prompt\'' without the value-changed callback-prompt :: (BaseIO m, MonadError Text m, MonadReader t m, HasPromptBar t, HasPromptHooks n t, BaseIO n)- => Text -- ^ Prompt description- -> Text -- ^ Initial value- -> m Text-prompt a b = prompt' a b (const $ return ())-- -- | Open prompt bar with given description and default value, -- register a callback to trigger when value is changed, and another one when value is validated.-prompt' :: (BaseIO m, MonadError Text m, MonadReader t m, HasPromptBar t, HasPromptHooks n t, BaseIO n)+prompt :: (ControlIO m, MonadLogger m, MonadError Text m) => Text -- ^ Prompt description -> Text -- ^ Pre-fill value- -> (Text -> n ()) -- ^ Callback triggered each time prompt value changes+ -> PromptBar -> m Text-prompt' description startValue f = do- clean- open description startValue- result <- newEmptyMVar+prompt description startValue promptBar = do+ clean promptBar+ open description startValue promptBar - Hooks.set onChangedL $ \(Changed x) -> f x- Hooks.set onCancelledL $ \_ -> putMVar result Nothing- Hooks.set onValidatedL $ \(Activated x) -> putMVar result (Just x)- takeMVar result <!> promptInterrupted+ cancelation <- listenTo $ promptBar^.closedL+ validation <- listenTo $ promptBar^.validatedL + result <- io $ waitEitherCancel cancelation validation+ close promptBar+ maybe (throwError promptInterrupted) return . join $ hush result --- | Same as 'prompt\'' for URI values-promptURI :: (BaseIO m, BaseIO n, MonadError Text m, MonadError Text n, MonadReader t m, MonadReader t n, HasPromptBar t, HasPromptHooks n t)- => Text -> Text -> m URI-promptURI description startValue = do- clean- open description startValue- checkURI (Changed startValue)+promptM :: (ControlIO m, MonadReader r m, Has PromptBar r, MonadLogger m, MonadError Text m) => Text -> Text -> m Text+promptM a b = prompt a b =<< ask - result <- newEmptyMVar - Hooks.set onChangedL checkURI- Hooks.set onCancelledL $ \_ -> putMVar result Nothing- Hooks.set onValidatedL $ \(Activated uri) -> putMVar result (Just uri)+iprompt :: (ControlIO m, MonadLogger m, MonadError Text m, MonadResource m)+ => Text+ -> Text+ -> (Text -> m ())+ -> PromptBar+ -> m ()+iprompt description startValue f promptBar = do+ clean promptBar - parseURIReference =<< takeMVar result <!> promptInterrupted+ update <- addHandler (promptBar^.changedL) f+ open description startValue promptBar + io . wait =<< listenTo (promptBar^.closedL)+ close promptBar+ release update -checkURI :: (BaseIO m, MonadReader t m, HasPromptBar t) => Changed -> m ()-checkURI (Changed v) = do- debugM "hbro.prompt" $ "Is URI ? " ++ tshow (isURIReference $ unpack v)- (gAsync . \e -> widgetModifyText e StateNormal (green <| isURIReference (unpack v) |> red)) =<< askL (_promptbar.entryL)+ipromptM :: (ControlIO m, MonadResource m, MonadReader r m, Has PromptBar r, MonadLogger m, MonadError Text m) => Text -> Text -> (Text -> m ()) -> m ()+ipromptM a b c = iprompt a b c =<< ask -getEntryValue :: (BaseIO m, MonadReader t m, HasPromptBar t) => m Text-getEntryValue = gSync . entryGetText =<< askL (_promptbar.entryL)+-- | Same as 'prompt' for URI values+uriPrompt :: (ControlIO m, MonadLogger m, MonadError Text m, MonadResource m)+ => Text+ -> Text+ -> PromptBar+ -> m URI+uriPrompt description startValue promptBar = do+ clean promptBar++ update <- addHandler (promptBar^.changedL) $ checkURI promptBar+ open description startValue promptBar++ validation <- listenTo $ promptBar^.validatedL+ cancelation <- listenTo $ promptBar^.closedL++ result <- io $ waitEitherCancel cancelation validation+ release update+ close promptBar+ parseURIReferenceM =<< maybe (throwError promptInterrupted) return (join $ hush result)+++uriPromptM :: (ControlIO m, MonadReader r m, Has PromptBar r, MonadLogger m, MonadError Text m, MonadResource m)+ => Text -> Text -> m URI+uriPromptM a b = uriPrompt a b =<< ask+++checkURI :: (MonadIO m, MonadLogger m) => PromptBar -> Text -> m ()+checkURI promptBar v = do+ debug $ "Is URI ? " ++ tshow (isURIReference $ unpack v)+ gAsync $ widgetModifyText (promptBar^.entryL) StateNormal (green <| isURIReference (unpack v) |> red)+++getPromptValue :: (MonadIO m) => PromptBar -> m Text+getPromptValue = gSync . entryGetText . view entryL++getPromptValueM :: (MonadIO m, MonadReader r m, Has PromptBar r) => m Text+getPromptValueM = getPromptValue =<< ask+++onEntryCanceled :: (ControlIO m, MonadLogger m, EntryClass t) => t -> m a -> m ()+onEntryCanceled entry f = liftBaseWith $ \runInIO -> gAsync . on entry keyPressEvent $ do+ key <- KeyVal <$> eventKeyVal+ io . when (key == _Escape) . void . runInIO $ void f+ return False++onEntryChanged :: (ControlIO m, MonadLogger m, EditableClass t, EntryClass t) => t -> (Text -> m ()) -> m ()+onEntryChanged entry f = liftBaseWith $ \runInIO -> gAsync . on entry editableChanged $ do+ value <- entryGetText entry+ void . runInIO $ f value++onEntryValidated :: (ControlIO m, MonadLogger m, EntryClass t) => t -> (Text -> m ()) -> m ()+onEntryValidated entry f = liftBaseWith $ \runInIO -> gAsync . on entry entryActivated $ do+ value <- entryGetText entry+ void . runInIO $ f value
− library/Hbro/Gui/PromptBar/Hooks.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Hbro.Gui.PromptBar.Hooks- ( PromptHooks- , onCancelledL- , onChangedL- , onValidatedL- , initHooks- , HasPromptHooks(..)- , clean- , set- ) where---- {{{ Imports--- import Hbro.Error-import Hbro.Gui.PromptBar.Signals-import Hbro.Prelude--import Control.Lens.Lens-import Control.Lens.Getter-import Control.Lens.Setter hiding(set)-import Control.Lens.TH-import Control.Monad.Reader hiding(when)--- }}}---- | No exported constructor, please use 'initHooks'-data PromptHooks m = PromptHooks- { _onCancelled :: TMVar (Cancelled -> m ())- , _onChanged :: TMVar (Changed -> m ())- , _onValidated :: TMVar (Activated -> m ())- }--makeLensesWith ?? ''PromptHooks $ lensRules- & lensField .~ (\name -> Just (tail name ++ "L"))--class HasPromptHooks n a | a -> n where _promptHooks :: Lens' a (PromptHooks n)-instance HasPromptHooks n (PromptHooks n) where _promptHooks = id--initHooks :: (BaseIO m) => m (PromptHooks n)-initHooks = io (PromptHooks <$> newEmptyTMVarIO <*> newEmptyTMVarIO <*> newEmptyTMVarIO)--clean :: (BaseIO m, MonadReader t m, HasPromptHooks n t) => m ()-clean = do- hooks <- askL _promptHooks- void . atomically $ do- tryTakeTMVar $ hooks^.onCancelledL- tryTakeTMVar $ hooks^.onChangedL- tryTakeTMVar $ hooks^.onValidatedL---set :: (BaseIO m, MonadReader t m, HasPromptHooks n t) => Lens' (PromptHooks n) (TMVar (x -> n ())) -> (x -> n ()) -> m ()-set l f = do- hook' <- askL $ _promptHooks.l- atomically $ writeTMVar hook' f
− library/Hbro/Gui/PromptBar/Signals.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Hbro.Gui.PromptBar.Signals (--- * Utils- onEntryCancelled,- onEntryChanged,- onEntryActivated,--- * Signals- Cancelled(..),- Changed(..),- Activated(..),- Signals,- cancelledL,- changedL,- validatedL,- initSignals,- attach,-) where---- {{{ Imports--- import Hbro.Error-import Hbro.Gdk.KeyVal-import Hbro.Logger-import Hbro.Prelude hiding(on)--import Control.Lens--import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.Entry.Editable-import Graphics.UI.Gtk.Entry.Entry-import Graphics.UI.Gtk.Gdk.EventM as Gdk--import System.Glib.Signals--- }}}----- {{{ Utils-onEntryCancelled :: (BaseIO m, EntryClass t) => t -> (Cancelled -> IO ()) -> m (ConnectId t)-onEntryCancelled theEntry f = gSync . on theEntry keyPressEvent $ do- key <- KeyVal <$> eventKeyVal- io . when (key == _Escape) $ do- value <- entryGetText theEntry- debugM "hbro.prompt" $ "Prompt cancelled with value: " ++ value- f (Cancelled value)- return False--onEntryChanged :: (BaseIO m, EditableClass t, EntryClass t) => t -> (Changed -> IO ()) -> m (ConnectId t)-onEntryChanged theEntry f = gSync . on theEntry editableChanged $ do- value <- entryGetText theEntry- debugM "hbro.prompt" $ "Prompt value changed to: " ++ value- f (Changed value)---onEntryActivated :: (BaseIO m, EntryClass t) => t -> (Activated -> IO ()) -> m (ConnectId t)-onEntryActivated theEntry f = gSync . on theEntry entryActivated $ do- value <- entryGetText theEntry- debugM "hbro.prompt" $ "Prompt activated with value: " ++ value- f (Activated value)--- }}}---- {{{ Types-data Cancelled = Cancelled Text-instance Describable Cancelled where describe _ = "PromptCancelled"--data Changed = Changed Text-instance Describable Changed where describe _ = "PromptChanged"--data Activated = Activated Text-instance Describable Activated where describe _ = "PromptActivated"--data Signals = Signals- { _cancelled :: TMVar Cancelled- , _changed :: TMVar Changed- , _validated :: TMVar Activated- }--makeLensesWith ?? ''Signals $ lensRules- & lensField .~ (\name -> Just (tail name ++ "L"))--- }}}--initSignals :: (BaseIO m) => m Signals-initSignals = io (Signals <$> newEmptyTMVarIO <*> newEmptyTMVarIO <*> newEmptyTMVarIO)---attach :: (BaseIO m, EditableClass t, EntryClass t) => t -> Signals -> m ()-attach entry signals = void $ sequence- [ onEntryCancelled entry $ void . atomically . tryPutTMVar (signals^.cancelledL)- , onEntryChanged entry $ void . atomically . tryPutTMVar (signals^.changedL)- , onEntryActivated entry $ void . atomically . tryPutTMVar (signals^.validatedL)- ]
library/Hbro/Gui/StatusBar.hs view
@@ -1,28 +1,31 @@-module Hbro.Gui.StatusBar where+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Hbro.Gui.StatusBar+ ( StatusBar(..)+ , asStatusBar+ , statusBarName+ ) where -- {{{ Imports-import Hbro.Gui.Buildable-import Hbro.Prelude+import Hbro.Prelude -import Graphics.UI.Gtk.Abstract.Widget-import Graphics.UI.Gtk.Builder-import Graphics.UI.Gtk.Layout.HBox+import Graphics.UI.Gtk.Abstract.Widget+import Graphics.UI.Gtk.Layout.HBox -import System.Glib.Types+import System.Glib.Types -- }}} -- | Status bar is just a horizontal layout that can host widgets. newtype StatusBar = StatusBar HBox --- | A 'StatusBar' can be built from an XML file.-instance Buildable StatusBar where- buildWith b = StatusBar <$> gSync (builderGetObject b castToHBox statusBarName)+asStatusBar :: StatusBar -> StatusBar+asStatusBar = id instance GObjectClass StatusBar where toGObject (StatusBar h) = toGObject h unsafeCastGObject g = StatusBar $ unsafeCastGObject g --- instance ObjectClass StatusBar instance WidgetClass StatusBar -- | Name used in XML file to build status bar.
− library/Hbro/Hooks.hs
@@ -1,94 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Hbro.Hooks- ( ResourceAction(..)- , LinkClickedHook(..)- , LoadRequestedHook(..)- , NewWindowHook(..)- , ResourceOpenedHook(..)- , TitleChangedHook(..)- , Hooks- , keyHooksL- , promptHooksL- , webViewHooksL- , initialize- , routines-) where---- {{{ Imports-import Hbro.Error-import qualified Hbro.Keys as Keys-import qualified Hbro.Keys.Signals as Keys-import qualified Hbro.IPC.Hooks as IPC-import Hbro.Signals hiding(initialize)-import Hbro.Gui.PromptBar.Signals hiding(Signals)-import Hbro.Gui.PromptBar.Hooks-import qualified Hbro.Gui.PromptBar.Hooks as Prompt-import Hbro.Logger hiding(initialize)-import Hbro.Prelude-import Hbro.WebView.Hooks hiding(Hooks)-import qualified Hbro.WebView.Hooks as WebView (Hooks, initHooks)-import Hbro.WebView.Signals hiding(Signals)--import Control.Lens.Getter-import Control.Lens.Lens-import Control.Lens.Setter-import Control.Lens.TH-import Control.Monad.Reader--- }}}----- {{{ Hooks-data Hooks m = Hooks- { _webViewHooks :: WebView.Hooks m- , _keyHooks :: Keys.Hooks m- , _ipcHooks :: TVar (IPC.Hooks m)- , _promptHooks :: PromptHooks m- }--makeLensesWith ?? ''Hooks $ lensRules- & lensField .~ (\name -> Just (tail name ++ "L"))--initialize :: (Functor n, BaseIO m, Default (Keys.Status n), Default (LinkClickedHook n),- Default (LoadRequestedHook n), Default (NewWindowHook n),- Default (ResourceOpenedHook n), Default (TitleChangedHook n),- Default (IPC.Hooks n))- => m (Hooks n)-initialize = io (Hooks <$> WebView.initHooks- <*> Keys.initializeHooks- <*> newTVarIO def- <*> Prompt.initHooks)--routines :: (ControlIO m) => a -> Signals -> Hooks (ExceptT Text (ReaderT a m)) -> [m ()]-routines globalContext signals hooks =--- WebView- [ dequeueRoutine globalContext (signals^._webViewSignals.downloadL) $ hooks^.webViewHooksL.onDownloadL- , dequeueRoutine globalContext (signals^._webViewSignals.linkHoveredL) $ hooks^.webViewHooksL.onLinkHoveredL- , dequeueRoutine globalContext (signals^._webViewSignals.linkClickedL) $ hooks^.webViewHooksL.onLinkClickedL- , dequeueRoutine globalContext (signals^._webViewSignals.loadFinishedL) $ hooks^.webViewHooksL.onLoadFinishedL- , dequeueRoutine globalContext (signals^._webViewSignals.loadRequestedL) $ hooks^.webViewHooksL.onLoadRequestedL- , dequeueRoutine globalContext (signals^._webViewSignals.loadStartedL) $ hooks^.webViewHooksL.onLoadStartedL- , dequeueRoutine globalContext (signals^._webViewSignals.newWindowL) $ hooks^.webViewHooksL.onNewWindowL- , dequeueRoutine globalContext (signals^._webViewSignals.resourceOpenedL) $ hooks^.webViewHooksL.onResourceOpenedL- , dequeueRoutine globalContext (signals^._webViewSignals.titleChangedL) $ hooks^.webViewHooksL.onTitleChangedL--- Keys- , Keys.dequeue globalContext (signals^._webViewSignals.keyPressedL) $ hooks^.keyHooksL--- IPC- , IPC.dequeue globalContext (signals^._ipcSignals) $ hooks^.ipcHooksL--- Prompt- , dequeueRoutine globalContext (signals^._promptSignals.cancelledL) $ hooks^.promptHooksL.onCancelledL- , dequeueRoutine globalContext (signals^._promptSignals.changedL) $ hooks^.promptHooksL.onChangedL- , dequeueRoutine globalContext (signals^._promptSignals.validatedL) $ hooks^.promptHooksL.onValidatedL- ]- -- where dequeueRoutine globalContext = dequeueRoutine globalContext---dequeueRoutine :: (ControlIO m, Describable s)- => a -> TMVar s -> TMVar (s -> ExceptT Text (ReaderT a m) ()) -> m ()-dequeueRoutine globalContext signal hook = forever $ do- arguments <- atomically $ takeTMVar signal- debugM "hbro.hooks" $ "Signal acknowledged [" ++ describe arguments ++ "]."-- (`runReaderT` globalContext) . logErrors' $ do- f <- (atomically $ tryReadTMVar hook) <!> ("Undefined hook: " ++ describe arguments)- handleIO (throwError . tshow) $ f arguments--- }}}
library/Hbro/IPC.hs view
@@ -1,63 +1,85 @@-{-# LANGUAGE TemplateHaskell, TupleSections #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} -- | Designed to be imported as @qualified@. module Hbro.IPC- ( routine- , sendMessage+ ( CommandMap+ , bindCommands+ -- , sendMessage ) where -- {{{ Imports-import Hbro.IPC.Signals-import Hbro.Logger-import Hbro.Prelude+import Hbro.Logger+import Hbro.Prelude -import Control.Lens hiding(Action, Context)+import Data.Function (fix)+import qualified Data.Map as Map -import System.ZMQ4.Monadic (ZMQ, Rep(..), Req(..), runZMQ)-import qualified System.ZMQ4.Monadic as ZMQ+import System.ZMQ4 (Receiver, Rep (..), Sender, Socket)+import qualified System.ZMQ4 as ZMQ -- }}} --- | Designed to be run in a distinct thread-routine :: Text -> Signals -> ZMQ z ()-routine uri signals = do- socket <- ZMQ.socket Rep- io . infoM "hbro.ipc" $ "Opening IPC socket at: " ++ uri- ZMQ.bind socket (unpack uri)+-- | Commands are mere 'Text's+type Command = Text - forever $ do- message <- receive socket- io . debugM "hbro.ipc" $ "Received command: " ++ message+-- | Arguments are 'Text's too+type Argument = Text - case words message of- [] -> send socket "ERROR Empty command"- command:arguments -> do- atomically $ putTMVar nextCommand (Command command, arguments)- response' <- atomically $ takeTMVar response- io . debugM "hbro.ipc" $ "Sending response: " ++ tshow response'- send socket $ either ("ERROR " ++) id response'- where- nextCommand = signals^.nextCommandL- response = signals^.responseL+-- | Responses may be OK or KO+type Response = Either Text Text +type CommandMap m = Map Command ([Argument] -> m Response)++withContext :: ControlIO m => (ZMQ.Context -> m a) -> m (StM m a)+withContext f = liftBaseWith $ \runInBase -> ZMQ.withContext (runInBase . f)++withSocket :: (ZMQ.SocketType s, ControlIO m) => ZMQ.Context -> s -> (Socket s -> m a) -> m (StM m a)+withSocket c s f = liftBaseWith $ \runInBase -> ZMQ.withSocket c s (runInBase . f)++bindCommands :: (ControlIO m, MonadLogger m) => Text -> CommandMap m -> m ()+bindCommands uri commandMap = void . withContext $ \c -> withSocket c Rep $ \socket -> do+ info $ "Opening IPC socket at: " ++ uri+ io $ ZMQ.bind socket (unpack uri)++ fix $ \recurse -> do+ message <- receive socket+ debug $ "Received command: " ++ message++ case words message of+ [] -> send socket "ERROR Empty command"+ command:arguments -> do+ response <- case Map.lookup command commandMap of+ Just f -> either ("ERROR " ++) id <$> f arguments+ _ -> return "ERROR Unknown command"+ debug $ "Sending response: " ++ tshow response+ send socket response+ recurse++ -- {{{ Utils -- | Send message to given socket-send :: (ZMQ.Sender a) => ZMQ.Socket z a -> Text -> ZMQ z ()-send socket payload = ZMQ.send socket [] (encodeUtf8 payload)+send :: (BaseIO m, Sender a) => Socket a -> Text -> m ()+send socket = io . ZMQ.send socket [] . encodeUtf8 -- | Send a single command to the given socket (which must be 'Rep'), and return the answer-sendMessage :: (BaseIO m)- => Text -- ^ Target socket URI- -> Text -- ^ Message- -> m Text-sendMessage socketURI message = runZMQ $ do- socket <- ZMQ.socket Req- ZMQ.bind socket (unpack socketURI)- io . debugM "hbro.ipc" $ "Sending message to IPC socket at: " ++ socketURI- send socket message- receive socket+-- sendMessage :: (BaseIO m)+-- => Context+-- -> Text -- ^ Target socket URI+-- -> Text -- ^ Message+-- -> m Text+-- sendMessage context socketURI message = do+-- socket <- io $ ZMQ.socket context Req+-- io . ZMQ.bind socket $ unpack socketURI+-- debug $ "Sending message to IPC socket at: " ++ socketURI+-- io . ZMQ.send socket [] $ encodeUtf8 message+-- decodeUtf8 <$> io (ZMQ.receive socket) -- | Wait for a message to be received from given socket-receive :: (ZMQ.Receiver a) => ZMQ.Socket z a -> ZMQ z Text-receive socket = decodeUtf8 <$> ZMQ.receive socket+receive :: (BaseIO m, Receiver a) => Socket a -> m Text+receive socket = decodeUtf8 <$> io (ZMQ.receive socket) -- | Same as 'sendMessage', but for all running instances of the browser. -- sendMessageToAll :: (MonadBase IO m, MonadReader t m, HasConfig t) => String -> m [String]
− library/Hbro/IPC/Hooks.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Hbro.IPC.Hooks where---- {{{ Imports-import Hbro.Error-import Hbro.IPC.Signals-import Hbro.Prelude--import Control.Lens hiding(Action)-import Control.Monad.Reader--import Data.Map as M--- }}}---- {{{ Types-type Action m = [Argument] -> (m Response) -- ^ Actions may depend on arguments-newtype Hooks m = Hooks (Map Command (Action m)) -- ^ Map commands to actions--- }}}---- | Bind a new command to an action-bind :: Command -> Action m -> Hooks m -> Hooks m-bind command f (Hooks hooks) = Hooks $ M.insert command f hooks---- |-dequeue :: (BaseIO m) => a -> Signals -> TVar (Hooks (ExceptT Text (ReaderT a m))) -> m ()-dequeue globalContext signals bindings = forever $ do- (Command c, arguments) <- atomically . takeTMVar $ nextCommand- (Hooks theBindings) <- atomically $ readTVar bindings-- -- result <- (`runReaderT` globalContext) . handleAll (return . Left . show) $ do- result <- (`runReaderT` globalContext) . runExceptT $ do- f <- return (M.lookup (Command c) theBindings) <!> ("Unknown command: " ++ c)- f arguments- atomically . putTMVar response $ join result- where- nextCommand = signals^.nextCommandL- response = signals^.responseL
− library/Hbro/IPC/Signals.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE TemplateHaskell, TupleSections #-}--- | Designed to be imported as @qualified@.-module Hbro.IPC.Signals- ( Argument- , Response- , Command(..)--- * Signals- , Signals- , nextCommandL- , responseL- , initSignals-) where---- {{{ Imports-import Hbro.Prelude--import Control.Lens hiding(Action, Context)--- }}}----- {{{ Types--- | Commands are mere 'Text's-newtype Command = Command Text deriving(Eq, Ord)---- | Arguments are 'Text's too-type Argument = Text---- | Responses may be OK or KO-type Response = Either Text Text--- type Queue = [(Command, [Argument])]--data Signals = Signals- { _nextCommand :: TMVar (Command, [Argument])- , _response :: TMVar Response- }--makeLensesWith ?? ''Signals $ lensRules- & lensField .~ (\name -> Just (tailSafe name ++ "L"))--- }}}--initSignals :: (BaseIO m) => m Signals-initSignals = io (Signals <$> newEmptyTMVarIO <*> newEmptyTMVarIO)
− library/Hbro/K.hs
@@ -1,165 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeFamilies #-}-module Hbro.K (- KData,- K,- init,- getHooks,- resetKeyBindings,-) where---- {{{-import Hbro.Clipboard as Clipboard-import Hbro.Config as Config-import Hbro.Core-import Hbro.Error-import Hbro.Gdk.KeyVal-import Hbro.Gui as Gui-import Hbro.Gui.NotificationBar-import Hbro.Gui.PromptBar as Prompt--- import Hbro.IPC as IPC (Command(..))-import Hbro.IPC.Hooks as IPC-import Hbro.IPC.Signals as IPC-import Hbro.Keys as Keys-import Hbro.Keys.Model ((.|))-import Hbro.Keys.Monadic as Keys-import Hbro.Hooks as Hooks-import Hbro.Signals as Signals-import Hbro.Gui.PromptBar.Hooks-import Hbro.Prelude-import Hbro.WebView.Hooks as WebView-import Hbro.WebView.Signals as WebView---- import Control.Lens.Getter-import Control.Lens.Lens-import Control.Lens.Setter-import Control.Lens.TH-import Control.Monad.Reader--import Data.Map as M hiding(foldl, map)--import Graphics.UI.Gtk.Gdk.EventM as Gdk-import Graphics.UI.Gtk.Windows.Window-import Graphics.UI.Gtk.WebKit.WebView--import Network.URI.Monadic--import qualified System.Glib.Attributes as G--- }}}--data KData = KData- { _config :: TVar Config- , _gui :: GUI- , _hooks :: Hooks.Hooks KE- , _signals :: Signals.Signals- }--type K = ReaderT KData IO-type KE = ExceptT Text K--makeLensesWith ?? ''KData $ lensRules- & lensField .~ (\name -> Just (tailSafe name ++ "L"))---instance HasConfig KData where _config = configL-instance HasGUI KData where _gui = guiL-instance Keys.HasHooks KE KData where _hooks = hooksL.keyHooksL-instance HasPromptHooks KE KData where _promptHooks = hooksL.promptHooksL-instance WebView.HasHooks KE KData where _hooks = hooksL.webViewHooksL-instance HasNotificationBar KData where _notificationbar = guiL.notificationBarL-instance HasPromptBar KData where _promptbar = guiL.promptBarL---init :: (BaseIO m) => GUI -> Hooks.Hooks KE -> Signals.Signals -> m KData-init ui hooks signals = io (KData <$> newTVarIO def <*> pure ui <*> pure hooks <*> pure signals)--getHooks :: (MonadReader KData m) => m (Hooks.Hooks KE)-getHooks = askL hooksL---- {{{ Default configuration--- instance Default (Signals.DownloadHook KE) where- -- def = Signals.DownloadHook . const . const . const $ return ()--instance Default (Hooks.LinkClickedHook KE) where- def = Hooks.LinkClickedHook f- where f (LinkClicked uri Gdk.MiddleButton) = spawn "hbro" ["-u", show uri]- f (LinkClicked uri _ ) = load uri--instance Default (Hooks.LoadRequestedHook KE) where- def = Hooks.LoadRequestedHook $ \(LoadRequested uri) -> load uri--instance Default (Hooks.NewWindowHook KE) where- def = Hooks.NewWindowHook $ \(NewWindow uri) -> spawn "hbro" ["-u", show uri]---- /!\ 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 (Hooks.ResourceOpenedHook KE) where- def = Hooks.ResourceOpenedHook $ \(ResourceOpened _uri mimetype) -> do- return Hooks.Load <<| canRender mimetype |>> return Hooks.Download'--instance Default (Hooks.TitleChangedHook KE) where- def = Hooks.TitleChangedHook (\(TitleChanged title) -> gAsync . (`G.set` [ windowTitle G.:= ("hbro | " ++ title)]) =<< Gui.get mainWindowL)----- | List of default supported requests.-instance Default (IPC.Hooks KE) where- def = IPC.Hooks . M.fromList . map (first IPC.Command) $ [- -- Get information- ("GET_URI", \_arguments -> Right . tshow <$> getCurrentURI),- ("GET_TITLE", \_arguments -> Right <$> getPageTitle),- ("GET_FAVICON_URI", \_arguments -> Right . tshow <$> getFaviconURI),- ("GET_LOAD_PROGRESS", \_arguments -> Right . tshow <$> getLoadProgress),- -- Trigger actions- ("LOAD_URI", \arguments -> case arguments of- uri:_ -> parseURIReference uri >>= load >> (return $ Right "OK")- _ -> return . Left $ "Argument needed."),- ("STOP_LOADING", \_arguments -> stopLoading >> (return $ Right "OK")),- ("RELOAD", \_arguments -> reload >> (return $ Right "OK")),- ("RELOAD_BYPASS_CACHE", \_arguments -> reloadBypassCache >> (return $ Right "OK")),- ("GO_BACK", \_arguments -> goBack >> (return $ Right "OK")),- ("GO_FORWARD", \_arguments -> goForward >> (return $ Right "OK")),- ("ZOOM_IN", \_arguments -> zoomIn >> (return $ Right "OK")),- ("ZOOM_OUT", \_arguments -> zoomOut >> (return $ Right "OK"))]---resetKeyBindings :: (BaseIO m, MonadReader t m, Keys.HasHooks (ExceptT Text K) t) => m ()-resetKeyBindings = do--- Browse- Keys.bind (_Alt .| _Left) $ goBack- Keys.bind (_Alt .| _Right) $ goForward- Keys.bind (_Control .| _Escape) $ stopLoading- Keys.bind _F5 $ reload- Keys.bind (_Control .| _r) $ reload- Keys.bind (_Control .| _F5) $ reloadBypassCache- Keys.bind (_Alt .| _r) $ reloadBypassCache- Keys.bind (_Control .| _dead_circumflex) $ scrollH (Absolute 0)- Keys.bind (_Control .| _dollar) $ scrollH (Absolute 100)- Keys.bind (_Control .| _Home) $ scrollV (Absolute 0)- Keys.bind (_Control .| _End) $ scrollV (Absolute 100)- Keys.bind (_Alt .| _Home) $ goHome--- Copy/paste- Keys.bind (_Control .| _c) $ getCurrentURI >>= Clipboard.write . tshow- Keys.bind (_Alt .| _c) $ getPageTitle >>= Clipboard.write- Keys.bind (_Control .| _v) $ Clipboard.read >>= parseURIReference >>= load- Keys.bind (_Alt .| _v) $ Clipboard.read >>= spawn "hbro" . ("-u":) . (:[]) . unpack--- Display- Keys.bind (_Control .| _plus) $ zoomIn- Keys.bind (_Control .| _minus) $ zoomOut- Keys.bind (_Control .| _b) $ Gui.toggle =<< Gui.get statusBarL- Keys.bind (_Alt .| _b) $ Gui.toggle =<< Gui.get notificationBarL- Keys.bind (_Control .| _u) $ toggleSourceMode >> reload--- Prompt- Keys.bind (_Control .| _o) $ promptURI "Open URI" "" >>= load- Keys.bind (_Alt .| _o) $ getCurrentURI >>= \uri -> promptURI "Open URI " (tshow uri) >>= load--- Search- Keys.bind _slash $ void $ prompt' "Search " "" $ searchText_ CaseInsensitive Forward Wrap- Keys.bind (_Control .| _f) $ prompt "Search " "" >>= searchText_ CaseInsensitive Forward Wrap- Keys.bind _question $ void $ prompt' "Search " "" $ searchText_ CaseInsensitive Backward Wrap- Keys.bind (_Control .| _n) $ searchText_ CaseInsensitive Forward Wrap =<< Prompt.getEntryValue- Keys.bind (_Control .| _p) $ searchText_ CaseInsensitive Backward Wrap =<< Prompt.getEntryValue- Keys.bind (_Control .| _h) $ gAsync . webViewUnMarkTextMatches =<< Gui.get webViewL--- Misc- -- Keys.bind (_Control .| _i) $ openInspector- Keys.bind (_Alt .| _Print) printPage- Keys.bind (_Control .| _t) $ spawn "hbro" []- Keys.bind (_Control .| _w) quit--- }}}
library/Hbro/Keys.hs view
@@ -1,4 +1,11 @@-{-# LANGUAGE TemplateHaskell, TupleSections, ViewPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} -- | Key bindings model. -- Designed to be imported as @qualified@. module Hbro.Keys (@@ -10,64 +17,74 @@ , modifier -- * Mode , Mode(..)--- * Bindings implementation+-- * KeyMap implementation , KeyStroke- , keyStroke- , Bindings- , Status- , Hooks- , statusL- , onKeyPressedL+ , keyStrokes+ , KeyMap -- * Interface- , HasHooks(..)- , initializeHooks- , Hbro.Keys.set+ , KeyPressed(..)+ , KeyMapPressed(..)+ , bindKeys ) where -- {{{ Imports-import Hbro.Gdk.KeyVal-import Hbro.Keys.Model ((.|), modifiersL, keyL)-import qualified Hbro.Keys.Model as Model-import Hbro.Prelude+import Hbro.Error+import Hbro.Event+import Hbro.Gdk.KeyVal+import Hbro.Keys.Model ((.|))+import qualified Hbro.Keys.Model as Model+import Hbro.Logger+import Hbro.Prelude hiding (isPrefixOf) -import Control.Lens.Getter-import Control.Lens.Lens-import Control.Lens.Setter-import Control.Lens.TH-import Control.Monad.Reader hiding(forM_, guard, mapM_)+import Control.Concurrent.Async.Lifted+import Control.Monad.Trans.Resource -import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.Set as Set+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as Map+import qualified Data.Set as Set -import qualified Graphics.UI.Gtk.Gdk.EventM as Gdk+import qualified Graphics.UI.Gtk.Gdk.EventM as Gdk -import Text.Parsec-import Text.Parsec.Text+import Text.Parsec hiding (many)+import Text.Parsec.Text -- }}} -- {{{ Modifiers-newtype Modifier = Modifier Gdk.Modifier deriving(Eq)+instance Describable Gdk.Modifier where+ describe Gdk.Control = "C-"+ describe Gdk.Shift = "S-"+ describe Gdk.Alt = "M-"+ describe _ = "" +deriving instance Ord Gdk.Modifier++instance Describable (Modifier, KeyVal) where+ describe (m, k) = describe m ++ describe k++newtype Modifier = Modifier (Set Gdk.Modifier) deriving(Eq)++instance Monoid Modifier where+ mempty = Modifier mempty+ (Modifier a) `mappend` (Modifier b) = Modifier (a `mappend` b)+ instance Describable Modifier where- describe (Modifier Gdk.Control) = "C-"- describe (Modifier Gdk.Shift) = "S-"- describe (Modifier Gdk.Alt) = "M-"- describe (Modifier _) = ""+ describe (Modifier x) = concatMap describe $ Set.toList x instance Ord Modifier where compare = comparing describe -instance ToSet Modifier Modifier where toSet = Set.singleton- _Alt, _Control, _Shift :: Modifier-_Alt = Modifier Gdk.Alt-_Control = Modifier Gdk.Control-_Shift = Modifier Gdk.Shift+_Alt = Modifier $ Set.singleton Gdk.Alt+_Control = Modifier $ Set.singleton Gdk.Control+_Shift = Modifier $ Set.singleton Gdk.Shift modifier :: Parser Modifier-modifier = spaces *> choice [ string "C-" >> return _Control- , string "M-" >> return _Alt- -- , string "S-" >> return _Shift- ]+modifier = spaces *> (mconcat <$> many elementModifier)++elementModifier :: Parser Modifier+elementModifier = choice [ string "C-" >> return _Control+ , string "M-" >> return _Alt+ -- , string "S-" >> return _Shift+ ] -- }}} -- {{{ Key mode (à la vi)@@ -76,48 +93,44 @@ instance Default Mode where def = Normal -- }}} --- {{{ Bindings implementation-type KeyStroke = Model.KeyStroke Modifier KeyVal+-- {{{ KeyMap implementation+type KeyStroke = Model.KeyStroke Modifier KeyVal instance Describable KeyStroke where- describe s = foldr (++) "" (map describe . Set.toList $ s^.modifiersL) ++ describe (s^.keyL)--instance ToNonEmpty KeyStroke KeyStroke where- toNonEmpty x = x :| []--instance ToNonEmpty KeyStroke KeyVal where- toNonEmpty x = ((Set.empty .| x) :| [])+ describe (Model.KeyStroke m k) = describe m ++ describe k -keyStroke :: Parser KeyStroke-keyStroke = do+keyStrokes :: Parser KeyStroke+keyStrokes = do spaces- m <- maybe Set.empty Set.singleton <$> optionMaybe modifier+ m <- fromMaybe (Modifier Set.empty) <$> optionMaybe modifier k <- keyVal- return $ Model.KeyStroke m k+ return $ m .| k -- type Binding m = Model.Binding Hbro.Keys.Stroke (m ())-type Bindings m = Model.Bindings KeyStroke (m ())-type Status m = Model.Status KeyStroke Mode (m ())-data Hooks m = Hooks- { _status :: TVar (Status m)- , _onKeyPressed :: TMVar ([KeyStroke] -> m ())- }+type KeyMap m = Model.KeyMap KeyStroke (m ())+-- }}} -makeLensesWith ?? ''Hooks $ lensRules- & lensField .~ (\name -> Just (tail name ++ "L"))+data KeyPressed = KeyPressed deriving(Show)+instance Event KeyPressed where+ type Input KeyPressed = KeyStroke+ describeInput _ stroke = Just $ "Key pressed: " ++ describe stroke -class HasHooks m t | t -> m where _hooks :: Lens' t (Hooks m)+data KeyMapPressed = KeyMapPressed deriving(Show)+instance Event KeyMapPressed where+ type Input KeyMapPressed = ([KeyStroke], Bool)+ describeInput _ (strokes, _bound) = Just . unwords $ "Key pressed: " : (describe <$> strokes) -instance HasHooks m (Hooks m) where _hooks = id -initializeHooks :: IO (Hooks m)-initializeHooks = Hooks <$> newTVarIO def <*> newEmptyTMVarIO--set :: (BaseIO m, MonadReader r m, HasHooks n r) => Lens' (Hooks n) (TMVar a) -> a -> m ()-set l v = atomically . (`writeTMVar` v) =<< askL (_hooks.l)--- }}}+bindKeys :: (ControlIO m, MonadLogger m, MonadError Text m, MonadResource m) => Signal KeyPressed -> Signal KeyMapPressed -> KeyMap m -> m ReleaseKey+bindKeys input output keyMap = addRecursiveHandler input empty $ \previousStrokes newStroke -> do+ let k = Map.keys keyMap+ strokes = previousStrokes |: newStroke+ strokesL = NonEmpty.toList strokes+ found = Map.lookup strokes keyMap+ reset = isJust found || all (not . NonEmpty.isPrefixOf strokesL) k + debug $ "Accumulated: " ++ unwords (map describe strokesL)+ emit output (strokesL, isJust found) -{-instance Monoid KeyMap where- mempty = KeyBindings M.empty- mappend (KeyBindings a) (KeyBindings b) = KeyBindings (mappend a b)-}+ async . logErrors $ fromMaybe doNothing found+ return $ empty <| reset |> strokesL
library/Hbro/Keys/Model.hs view
@@ -1,62 +1,39 @@-{-# LANGUAGE TemplateHaskell, TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} -- | Key bindings model. -- Designed to be imported as @qualified@. module Hbro.Keys.Model ( -- * Key strokes model KeyStroke(..),- modifiersL,- keyL, (.|),--- * Bindings model+ singleKey,+-- * KeyMap model Binding,- Bindings,- Tree(..),+ KeyMap, ModalBindings,- (-->),- insert,- merge,- Hbro.Keys.Model.lookup,--- * State machine- Status(Status),- modeL,- keyStrokesL,- bindingsL,- bind,- bind',- setMode,- press,- getBoundFunction,- resetStrokes, ) where -- {{{ Imports-import Hbro.Prelude hiding(lookup)--import Control.Lens ()-import Control.Lens.Getter-import Control.Lens.Lens-import Control.Lens.Setter-import Control.Lens.TH--import Data.List.NonEmpty (NonEmpty(..), nonEmpty)-import qualified Data.List.NonEmpty as NE (fromList, toList)-import qualified Data.Map as M+import Hbro.Prelude hiding (lookup) -import qualified Prelude (lookup)+import Data.List.NonEmpty (NonEmpty (..)) -- }}} -- {{{ Key strokes model--- | A single keystroke is a (possibly empty) set of (unorderered and unique) modifiers, and a single key.-data KeyStroke modifier key = KeyStroke- { _modifiers :: Set modifier- , _key :: key- } deriving (Eq, Ord)+-- | A single keystroke is a modifier, and a single key.+-- modifier is usually a 'Monoid'.+data KeyStroke modifier key = KeyStroke modifier key -makeLensesWith ?? ''KeyStroke $ lensRules- & lensField .~ (\name -> Just (tailSafe name ++ "L"))+deriving instance (Eq m, Eq k) => Eq (KeyStroke m k)+deriving instance (Ord m, Ord k) => Ord (KeyStroke m k) -(.|) :: (ToSet modifier m) => m -> key -> KeyStroke modifier key-(.|) m k = KeyStroke (toSet m) k+(.|) :: (Monoid modifier) => modifier -> key -> KeyStroke modifier key+(.|) = KeyStroke++singleKey :: (Monoid m) => k -> KeyStroke m k+singleKey = KeyStroke mempty -- }}} -- {{{ Binding model@@ -64,107 +41,105 @@ type Binding keystroke action = (NonEmpty keystroke, action) -- | A non-empty tree implementation that labels edges and leaves-type BranchedTree b l = [(b, Tree b l)]-data Tree b l = Leaf l | Branch (NonEmpty (b, Tree b l))+-- type BranchedTree b l = [(b, Tree b l)]+-- data Tree b l = Leaf l | Branch (NonEmpty (b, Tree b l)) --- | Bindings are stored together in a tree structure-type Bindings keystroke action = BranchedTree keystroke action+-- | KeyMap are stored together in a tree structure+-- type KeyMap keystroke action = BranchedTree keystroke action+type KeyMap keystroke action = Map (NonEmpty keystroke) action -- | Modal bindings (à la vi)-type ModalBindings mode keystroke action = Map mode (Bindings keystroke action)+type ModalBindings mode keystroke action = Map mode (KeyMap keystroke action) -(-->) :: (ToNonEmpty keystroke s) => s -> action -> Binding keystroke action-(-->) s a = (toNonEmpty s, a) --- | Make a branch out of a single binding-toBranch :: Ord a => (NonEmpty a, b) -> BranchedTree a b-toBranch ((h:|[]), a) = [ (h, Leaf a) ]-toBranch ((h:|h':t), a) = [ (h, Branch $ toBranch' ((h':|t), a)) ]+-- -- | Make a branch out of a single binding+-- toBranch :: Ord a => (NonEmpty a, b) -> BranchedTree a b+-- toBranch (h:|[], a) = [ (h, Leaf a) ]+-- toBranch (h:|h':t, a) = [ (h, Branch $ toBranch' (h':|t, a)) ] -toBranch' :: (NonEmpty b, l) -> NonEmpty (b, Tree b l)-toBranch' ((h:|[]), a) = (h, Leaf a) :| []-toBranch' ((h:|h':t), a) = (h, Branch $ toBranch' ((h':|t), a)) :| []+-- toBranch' :: (NonEmpty b, l) -> NonEmpty (b, Tree b l)+-- toBranch' (h:|[], a) = (h, Leaf a) :| []+-- toBranch' (h:|h':t, a) = (h, Branch $ toBranch' (h':|t, a)) :| [] --- | Merge 2 trees. In case of conflicts, prefer the rightmost operand.-merge :: Ord a => BranchedTree a b -> BranchedTree a b -> BranchedTree a b-merge [] [] = []-merge [] b = b-merge a [] = a-merge (h:t) (h':t') = NE.toList $ merge' (h:|t) (h':|t')+-- -- | Merge 2 trees. In case of conflicts, prefer the rightmost operand.+-- merge :: Ord a => BranchedTree a b -> BranchedTree a b -> BranchedTree a b+-- merge [] [] = []+-- merge [] b = b+-- merge a [] = a+-- merge (h:t) (h':t') = NE.toList $ merge' (h:|t) (h':|t') -merge' :: (Ord k, Ord a)- => NonEmpty (k, Tree a b) -> NonEmpty (k, Tree a b) -> NonEmpty (k, Tree a b)-merge' a b = NE.fromList . M.assocs $ M.unionWith merge'' (M.fromList $ NE.toList a) (M.fromList $ NE.toList b)+-- merge' :: (Ord k, Ord a)+-- => NonEmpty (k, Tree a b) -> NonEmpty (k, Tree a b) -> NonEmpty (k, Tree a b)+-- merge' a b = NE.fromList . M.assocs $ M.unionWith merge'' (M.fromList $ NE.toList a) (M.fromList $ NE.toList b) -merge'' :: Ord a => Tree a b -> Tree a b -> Tree a b-merge'' (Leaf _) (Leaf b) = Leaf b-merge'' (Leaf _) (Branch b) = Branch b-merge'' (Branch _) (Leaf b) = Leaf b-merge'' (Branch a) (Branch b) = Branch $ merge' a b+-- merge'' :: Ord a => Tree a b -> Tree a b -> Tree a b+-- merge'' (Leaf _) (Leaf b) = Leaf b+-- merge'' (Leaf _) (Branch b) = Branch b+-- merge'' (Branch _) (Leaf b) = Leaf b+-- merge'' (Branch a) (Branch b) = Branch $ merge' a b --- | Is there a leaf at the end of the given path ?-lookup :: Ord a => NonEmpty a -> BranchedTree a b -> Maybe b-lookup a b = case walk a b of- Just (Leaf x) -> Just x- _ -> Nothing+-- -- | Is there a leaf at the end of the given path ?+-- lookup :: Ord a => NonEmpty a -> BranchedTree a b -> Maybe b+-- lookup a b = case walk a b of+-- Just (Leaf x) -> Just x+-- _ -> Nothing --- | Return the subtree rooted at the end of the given path-walk :: Ord a => NonEmpty a -> BranchedTree a b -> Maybe (Tree a b)-walk _ [] = Nothing-walk (h:|t) tree = Prelude.lookup h tree >>= walk' t+-- -- | Return the subtree rooted at the end of the given path+-- walk :: Ord a => NonEmpty a -> BranchedTree a b -> Maybe (Tree a b)+-- walk _ [] = Nothing+-- walk (h:|t) tree = Prelude.lookup h tree >>= walk' t -walk' :: (Ord a) => [a] -> Tree a t -> Maybe (Tree a t)-walk' [] tree = Just tree-walk' (h:t) (Branch b) = walk (h:|t) (NE.toList b)-walk' _ _ = Nothing+-- walk' :: (Ord a) => [a] -> Tree a t -> Maybe (Tree a t)+-- walk' [] tree = Just tree+-- walk' (h:t) (Branch b) = walk (h:|t) (NE.toList b)+-- walk' _ _ = Nothing --- | Insert new binding into a tree-structured bindings list-insert :: (Ord m, Ord s) => Binding s a -> m -> ModalBindings m s a -> ModalBindings m s a-insert binding theMode = M.insertWith (flip merge) theMode (toBranch binding)+-- -- | Insert new binding into a tree-structured bindings list+-- insert :: (Ord m, Ord s) => Binding s a -> m -> ModalBindings m s a -> ModalBindings m s a+-- insert binding theMode = M.insertWith (flip merge) theMode (toBranch binding) -- }}} -- | Global state including any necessary information to handle key bindings-data Status keystroke mode action = Status- { _mode :: mode -- ^ Current mode- , _keyStrokes :: [keystroke] -- ^ Previous keystrokes- , _bindings :: ModalBindings mode keystroke action -- ^ Current bindings- }--makeLensesWith ?? ''Status $ lensRules- & lensField .~ (\name -> Just (tail name ++ "L"))+-- declareLenses [d|+-- data Status keystroke mode action = Status+-- { modeL :: mode -- ^ Current mode+-- , keyStrokesL :: [keystroke] -- ^ Previous keystrokes+-- , bindingsL :: ModalBindings mode keystroke action -- ^ Current bindings+-- }+-- |] -instance (Default mode) => Default (Status keystroke mode action) where- def = Status def [] M.empty+-- instance (Default mode) => Default (Status keystroke mode action) where+-- def = Status def [] M.empty -bind' :: (Ord mode, Ord keystroke, ToNonEmpty keystroke s)- => mode -> s -> action -> Status keystroke mode action -> Status keystroke mode action-bind' theMode theStrokes action (Status a b c) = Status a b $ insert (theStrokes --> action) theMode c+-- bind' :: (Ord mode, Ord keystroke, ToNonEmpty keystroke s)+-- => mode -> s -> action -> Status keystroke mode action -> Status keystroke mode action+-- bind' theMode theStrokes action (Status a b c) = Status a b $ insert (theStrokes >: action) theMode c --- | Same as 'bind' with default mode.-bind :: (Ord mode, Default mode, Ord keystroke, ToNonEmpty keystroke s)- => s -> action -> Status keystroke mode action -> Status keystroke mode action-bind s f = bind' def s f+-- -- | Same as 'bind' with default mode.+-- bind :: (Ord mode, Default mode, Ord keystroke, ToNonEmpty keystroke s)+-- => s -> action -> Status keystroke mode action -> Status keystroke mode action+-- bind = bind' def -setMode :: mode -> Status keystroke mode action -> Status keystroke mode action-setMode newMode = set modeL newMode . set keyStrokesL []+-- setMode :: mode -> Status keystroke mode action -> Status keystroke mode action+-- setMode newMode = set modeL newMode . set keyStrokesL [] -press :: (Ord mode, Ord keystroke) => keystroke -> Status keystroke mode action -> Status keystroke mode action-press keystroke status = set keyStrokesL newKeyStrokes status- where- oldKeyStrokes = status^.keyStrokesL- bindings = M.lookup (status^.modeL) (status^.bindingsL)- validKeyStrokes = isJust . join $ walk <$> nonEmpty oldKeyStrokes <*> bindings- boundKeyStroke = isJust . join $ lookup <$> nonEmpty oldKeyStrokes <*> bindings- newKeyStrokes = (oldKeyStrokes ++ [keystroke]) <| (validKeyStrokes && not boundKeyStroke) |> [keystroke]+-- press :: (Ord mode, Ord keystroke) => keystroke -> Status keystroke mode action -> Status keystroke mode action+-- press keystroke status = set keyStrokesL newKeyStrokes status+-- where+-- oldKeyStrokes = status^.keyStrokesL+-- bindings = M.lookup (status^.modeL) (status^.bindingsL)+-- validKeyStrokes = isJust . join $ walk <$> nonEmpty oldKeyStrokes <*> bindings+-- boundKeyStroke = isJust . join $ lookup <$> nonEmpty oldKeyStrokes <*> bindings+-- newKeyStrokes = (oldKeyStrokes ++ [keystroke]) <| (validKeyStrokes && not boundKeyStroke) |> [keystroke] -getBoundFunction :: (Ord mode, Ord keystroke) => Status keystroke mode action -> Maybe action-getBoundFunction status = do- theStrokes <- nonEmpty $ status^.keyStrokesL- theBindings <- M.lookup (status^.modeL) (status^.bindingsL)- lookup theStrokes theBindings+-- getBoundFunction :: (Ord mode, Ord keystroke) => Status keystroke mode action -> Maybe action+-- getBoundFunction status = do+-- theStrokes <- nonEmpty $ status^.keyStrokesL+-- theBindings <- M.lookup (status^.modeL) (status^.bindingsL)+-- lookup theStrokes theBindings -resetStrokes :: Status keystroke mode action -> Status keystroke mode action-resetStrokes = set keyStrokesL []+-- resetStrokes :: Status keystroke mode action -> Status keystroke mode action+-- resetStrokes = set keyStrokesL []
− library/Hbro/Keys/Monadic.hs
@@ -1,45 +0,0 @@-module Hbro.Keys.Monadic where---- {{{ Imports-import Hbro.Keys-import qualified Hbro.Keys.Model as Keys-import Hbro.Prelude--import Control.Lens.Type-import Control.Monad.Reader---- import Data.List.NonEmpty as NE--- import Data.Map as M--- import Data.Set (Set)--- }}}---modify :: (MonadReader r m, BaseIO m, HasHooks n r) => Lens' (Hooks n) (TVar a) -> (a -> a) -> m ()-modify l f = io . atomically . (`modifyTVar` f) =<< askL (_hooks.l)--bind' :: (HasHooks n r, ToNonEmpty KeyStroke s, BaseIO m, MonadReader r m)- => Mode -> s -> n () -> m ()-bind' mode strokes action = modify statusL $ Keys.bind' mode strokes action--bind :: (HasHooks n r, ToNonEmpty KeyStroke s, BaseIO m, MonadReader r m)- => s -> n () -> m ()-bind strokes action = modify statusL $ Keys.bind strokes action---- setMode :: mode -> Status stroke mode action -> Status stroke mode action--- setMode newMode = set _mode newMode . set _strokes []---- press :: (Ord mode, Ord stroke) => stroke -> Status stroke mode action -> Status stroke mode action--- press stroke status = set _strokes newStrokes status--- where--- newStrokes = maybe [stroke] (const chainedStrokes) $ walk (NE.fromList chainedStrokes) =<< bindings--- chainedStrokes = status^._strokes ++ [stroke]--- bindings = M.lookup (status^._mode) (status^._bindings)---- getBoundFunction :: (Ord mode, Ord stroke) => Status stroke mode action -> Maybe action--- getBoundFunction status = do--- theStrokes <- nonEmpty $ status^._strokes--- theBindings <- M.lookup (status^._mode) (status^._bindings)--- lookup theStrokes theBindings---- resetStrokes :: Status stroke mode action -> Status stroke mode action--- resetStrokes = set _strokes []
− library/Hbro/Keys/Signals.hs
@@ -1,39 +0,0 @@-module Hbro.Keys.Signals where---- {{{ Imports-import Hbro.Error--- import Hbro.Gdk.KeyVal-import Hbro.Keys as Keys-import Hbro.Keys.Model hiding(KeyStroke)-import Hbro.Logger-import Hbro.Prelude--import Control.Lens.Getter-import Control.Monad.Reader hiding(forM_)--- }}}--data KeyPressed = KeyPressed KeyStroke---dequeue :: (BaseIO m) => a -> TMVar KeyPressed -> Keys.Hooks (ExceptT Text (ReaderT a m)) -> m ()-dequeue globalContext signal hooks = forever $ do- -- debugM "hbro.hooks" "Listening for key-pressed signal..."- (KeyPressed stroke) <- atomically $ takeTMVar signal- theStatus <- atomically $ readTVar (hooks^.statusL)-- let newStatus = press stroke theStatus- newChain = newStatus^.keyStrokesL- f = getBoundFunction newStatus-- debugM "hbro.hooks" $ "Key pressed signal acknowledged: " ++ unwords (map describe newChain)-- g <- atomically . tryReadTMVar $ hooks^.onKeyPressedL- forM_ g $ \g' -> do- debugM "hbro.hooks" "Global callback defined, executing it."- (`runReaderT` globalContext) . logErrors_ $ g' newChain-- forM_ f $ \f' -> do- debugM "hbro.hooks" "Key is bound, executing callback..."- (`runReaderT` globalContext) . logErrors_ $ f'-- atomically . modifyTVar (hooks^.statusL) $ const newStatus
library/Hbro/Logger.hs view
@@ -1,64 +1,109 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} module Hbro.Logger ( module X- , initialize--- * Redefinitions- , debugM- , errorM- , infoM-) where+ , LogMessage(..)+ , MonadThreadedLogger(..)+ , ThreadedLoggingT+ , runThreadedLoggingT+ , logErrors+ , logErrors_+ ) where -- {{{ Imports-import Hbro.Prelude+import Hbro.Error+import Hbro.Event+import Hbro.Prelude hiding (runReaderT) -import Control.Concurrent (myThreadId)+import Control.Monad.Base+import Control.Monad.Logger.Extended as X+import Control.Monad.Reader+import Control.Monad.Trans.Resource -import Data.Text (justifyLeft, replace)+import Data.Text (justifyLeft)+import Data.Text.Encoding+import Data.Text.Encoding.Error -import System.Log as X (Priority(..))-import System.Log.Formatter-import System.Log.Handler.Simple-import System.Log.Logger (Logger, rootLoggerName, setLevel, setHandlers, updateGlobalLogger)-import qualified System.Log.Logger as L+import System.Log.FastLogger as X -- }}} -initialize :: (BaseIO m) => Priority -> m ()-initialize = io . updateGlobalLogger rootLoggerName . setup+-- | Log event+data LogMessage = LogMessage deriving(Show)+instance Event LogMessage where+ type Input LogMessage = (Loc, LogSource, LogLevel, Text)+ describeInput _ _ = Nothing -setup :: Priority -> Logger -> Logger-setup level = setLevel level . setHandlers [logHandler]+class (MonadLogger m) => MonadThreadedLogger m where+ addLogHandler :: (Input LogMessage -> IO ()) -> m () -logHandler :: GenericHandler ()-logHandler = GenericHandler- { priority = DEBUG- , formatter = logFormatter "$my_time $my_prio $my_tid $msg"- , privData = ()- , writeFunc = \_ t -> putStrLn $ pack t- , closeFunc = \_ -> return ()- }+instance (Monad m, MonadThreadedLogger m) => MonadThreadedLogger (ExceptT e m) where+ addLogHandler = lift . addLogHandler -logFormatter :: String -> LogFormatter a-logFormatter string handler (prio, message) loggername = varFormatter- [ ("my_prio", return $ formatPriority prio)- , ("my_time", formatTime defaultTimeLocale "%F %T" <$> getCurrentTime)- , ("my_tid", unpack . justifyLeft 5 ' ' . replace "ThreadId " "#" . tshow <$> myThreadId)- ]- string handler (prio, message) loggername+instance (Monad m, MonadThreadedLogger m) => MonadThreadedLogger (ResourceT m) where+ addLogHandler = lift . addLogHandler -formatPriority :: Priority -> String-formatPriority WARNING = "WARN "-formatPriority CRITICAL = "CRIT "-formatPriority INFO = "INFO "-formatPriority p = unpack . justifyLeft 5 ' ' . take 5 $ tshow p+newtype ThreadedLoggingT m a = ThreadedLoggingT { unThreadedLoggingT :: ReaderT (Signal LogMessage, LogLevel) m a }+deriving instance (Applicative m) => Applicative (ThreadedLoggingT m)+deriving instance (Functor m) => Functor (ThreadedLoggingT m)+deriving instance (Monad m) => Monad (ThreadedLoggingT m)+deriving instance (MonadIO m) => MonadIO (ThreadedLoggingT m)+deriving instance (MonadResource m) => MonadResource (ThreadedLoggingT m)+deriving instance (MonadThrow m) => MonadThrow (ThreadedLoggingT m)+deriving instance MonadTrans ThreadedLoggingT --- | Better version of 'debugM'-debugM :: (BaseIO m) => Text -> Text -> m ()-debugM a b = io $ L.debugM (unpack a) (unpack b)+instance MonadBase b m => MonadBase b (ThreadedLoggingT m) where+ liftBase = liftBaseDefault --- | Better version of 'errorM'-errorM :: (BaseIO m) => Text -> Text -> m ()-errorM a b = io $ L.errorM (unpack a) (unpack b)+instance MonadTransControl ThreadedLoggingT where+ type StT ThreadedLoggingT a = StT (ReaderT (Signal LogMessage, LogLevel)) a+ liftWith = defaultLiftWith ThreadedLoggingT unThreadedLoggingT+ restoreT = defaultRestoreT ThreadedLoggingT --- | Better version of 'infoM'-infoM :: (BaseIO m) => Text -> Text -> m ()-infoM a b = io $ L.infoM (unpack a) (unpack b)+instance MonadBaseControl b m => MonadBaseControl b (ThreadedLoggingT m) where+ type StM (ThreadedLoggingT m) a = ComposeSt ThreadedLoggingT m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++instance (MonadIO m, Functor m) => MonadLogger (ThreadedLoggingT m) where+ monadLoggerLog loc source level message = ThreadedLoggingT . void . runFailT $ do+ (loggerSignal, levelRef) <- Control.Monad.Reader.ask+ guard $ level >= levelRef+ emit' loggerSignal (loc, source, level, decodeUtf8With lenientDecode . fromLogStr $ toLogStr message)++instance (ControlIO m, MonadResource m) => MonadThreadedLogger (ThreadedLoggingT m) where+ addLogHandler f = ThreadedLoggingT $ do+ (loggerSignal, _) <- Control.Monad.Reader.ask+ void $ addHandler loggerSignal (io . f)++runThreadedLoggingT :: (ControlIO m, MonadResource m) => LogLevel -> ThreadedLoggingT m b -> m b+runThreadedLoggingT logLevel f = do+ loggerSignal <- newSignal LogMessage+ addHandler loggerSignal $ \(_loc, _source, level, message) -> io . putStrLn $ formatLevel level ++ " " ++ message++ result <- flip runReaderT (loggerSignal, logLevel) $ unThreadedLoggingT f+ closeSignal' loggerSignal+ return result++formatLevel :: LogLevel -> Text+formatLevel LevelDebug = "DEBUG"+formatLevel LevelInfo = "INFO "+formatLevel LevelWarn = "WARN "+formatLevel LevelError = "ERROR"+formatLevel (LevelOther a) = justifyLeft 5 ' ' . take 5 $ tshow a++-- | Like 'catchError', except that the error is automatically logged, then discarded.+logErrors :: (MonadLogger m, Functor m, MonadError Text m) => m a -> m (Maybe a)+logErrors f = catchError (Just <$> f) $ \e -> error e >> return Nothing++-- | Like 'logErrors', but discards the result.+logErrors_ :: (MonadLogger m, Functor m, MonadError Text m) => m a -> m ()+logErrors_ = void . logErrors
library/Hbro/Options.hs view
@@ -1,182 +1,126 @@-{-# LANGUAGE TemplateHaskell, ViewPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} -- | Commandline options tools. module Hbro.Options (--- * Types- CliOptions()+ Command(..)+ , CliOptions() , startURIL , socketPathL- , dyreModeL , uiFileL+ , dyreModeL , dyreDebugL--- * Util+ , logLevelL , parseOptions- , usage- , getSocketURI-) where+ ) where -- {{{ Imports-import qualified Hbro.Dyre as Dyre-import Hbro.Error-import Hbro.Logger as Logger-import Hbro.Prelude--import Control.Lens.Getter-import Control.Lens.Lens-import Control.Lens.Setter-import Control.Lens.TH--import Data.Version--import Filesystem--import Network.URI.Monadic+import qualified Hbro.Dyre as Dyre+import Hbro.Error+import Hbro.Prelude hiding ((<>)) -import Paths_hbro+import Control.Lens.Getter+import Control.Lens.TH+import Control.Monad.Logger -import System.Console.GetOpt-import System.Posix.Process-import qualified System.ZMQ4 as ZMQ (version)+import Network.URI -import Text.Read hiding(get, lift)+import Options.Applicative.Builder+import Options.Applicative.Extra+import Options.Applicative.Types -- }}} --- {{{ Types--- | Available commandline options (cf @hbro -h@).-data CliOptions = CliOptions- { _startURI :: Maybe URI- , _socketPath :: Maybe FilePath- , _uiFile :: Maybe FilePath- , _dyreMode :: Dyre.Mode- , _dyreDebug :: Bool- } deriving(Eq)+-- * Types+-- | Available commands+data Command = Rebuild | Version -makeLensesWith ?? ''CliOptions $ lensRules- & lensField .~ (\name -> Just (tail name ++ "L"))+-- | Available options+declareLenses [d|+ data CliOptions = CliOptions+ { startURIL :: Maybe URI+ , socketPathL :: Maybe FilePath+ , uiFileL :: Maybe FilePath+ , dyreModeL :: Dyre.Mode+ , dyreDebugL :: Bool+ , logLevelL :: LogLevel+ } deriving(Eq)+ |] instance Describable CliOptions where describe opts = unwords $ catMaybes [ ("URI=" ++) . tshow <$> (opts^.startURIL) , ("SOCKET=" ++) . fpToText <$> (opts^.socketPathL)- , ("UI_FILE=" ++) . fpToText <$> (opts^.uiFileL)+ , ("UI=" ++) . fpToText <$> (opts^.uiFileL) , Just . ("DYRE_MODE=" ++) . tshow $ opts^.dyreModeL , Just "DYRE_DEBUG" <| opts^.dyreDebugL |> Nothing+ , Just . ("LOG-LEVEL=" ++) . tshow $ opts^.logLevelL ] instance Default CliOptions where def = CliOptions- { _startURI = Nothing- , _socketPath = Nothing- , _uiFile = Nothing- , _dyreMode = def- , _dyreDebug = False- }--- }}}---- {{{ Util-action :: (BaseIO m, MonadPlus m) => m () -> ArgDescr (a -> m b)-action f = NoArg . const $ f >> abort--flag :: (Monad m) => Lens' CliOptions a -> a -> ArgDescr (CliOptions -> m CliOptions)-flag attribute value = NoArg $ return . set attribute value--optional :: (Monad m, IsString s) => Lens' CliOptions (Maybe s) -> String -> ArgDescr (CliOptions -> m CliOptions)-optional attribute name = ReqArg (\x -> return . set attribute (Just $ fromString x)) name--- }}}--description :: (BaseIO m, MonadPlus m) => [OptDescr (CliOptions -> m CliOptions)]-description =--- Action- [ Option ['h'] ["help"] (action help)- "Print this help."- , Option ['r'] ["recompile"] (action recompile)- "Recompile configuration file and exit."- , Option ['V'] ["version"] (action printVersion)- "Print version."--- Log level- , Option ['v'] ["verbose"] (setLogLevel DEBUG)- "Equivalent to -l DEBUG."- , Option ['q'] ["quiet"] (setLogLevel ERROR)- "Equivalent to -l ERROR."- , Option ['l'] ["log-level"] (ReqArg setCustomLogLevel "VALUE")- "Set log level. VALUE may be one of DEBUG|INFO|NOTICE|WARNING|ERROR|CRITICAL|ALERT|EMERGENCY."--- Paths- , Option ['u'] ["uri"] (ReqArg setStartURI "URI")- "URI to load at start-up."- , Option ['S'] ["socket"] (optional socketPathL "PATH")- "Where to open IPC socket"- , Option ['U'] ["ui"] (optional uiFileL "PATH")- "Path to UI descriptor (XML file)"--- Dynamic reconfiguration- , Option ['1'] ["vanilla"] (flag dyreModeL Dyre.Vanilla)- "Do not read custom configuration file"- , Option [] ["force-reconf"] (flag dyreModeL Dyre.ForceReconfiguration)- "Recompile configuration file before starting the program"- , Option [] ["dyre-master-binary"] (ReqArg (const return) "PATH")- "Internal flag used for dynamic reconfiguration."- , Option [] ["deny-reconf"] (flag dyreModeL Dyre.IgnoreReconfiguration)- "Do not recompile configuration file even if it has changed"- , Option [] ["dyre-debug"] (NoArg return)- "Use './cache/' as the cache directory and ./ as the configuration directory. Useful to debug the program."- ]+ {- startURI -} Nothing+ {- socketPath -} Nothing+ {- uiFile -} Nothing+ {- dyreMode -} def+ {- dyreDebug -} False+ {- logLevel -} LevelInfo +-- * High level+parseOptions :: (MonadIO m) => m (Either Command CliOptions)+parseOptions = io $ customExecParser (prefs noBacktrack) (info parser $ progDesc "Minimal extensible web-browser") -help, printVersion, recompile :: (BaseIO m, MonadPlus m) => m ()-help = putStrLn usage-recompile = Dyre.recompile >>= mapM_ putStrLn-printVersion = do- (a, b, c) <- io ZMQ.version- putStrLn $ "hbro: v" ++ pack (showVersion version)- putStrLn $ "0MQ library: v" ++ intercalate "." (map tshow [a, b, c])+-- * Low level+-- ** URI options+startURI :: Parser URI+startURI = option (eitherReader $ note "Invalid URI" . parseURIReference) $ long "uri" <> short 'u' <> metavar "START-URI" <> help "URI to load at start-up." -setLogLevel :: (BaseIO m, MonadPlus m) => Priority -> ArgDescr (a -> m a)-setLogLevel priority = NoArg $ \options -> do- Logger.initialize priority- return options+socketURI, uiURI :: Parser FilePath+socketURI = option (eitherReader $ Right . fromString) $ long "socket" <> short 'S' <> metavar "SOCKET-URI" <> help "URI to open IPC's listening socket."+uiURI = option (eitherReader $ Right . fromString) $ long "ui" <> short 'U' <> metavar "UI-FILE" <> help "Path to UI descriptor (XML file)" -setCustomLogLevel :: (BaseIO m) => String -> (a -> m a)-setCustomLogLevel level options = do- maybe (errorM "hbro.options" message) Logger.initialize $ readMaybe level- return options- where message = "Invalid log level '" ++ pack level ++ "'."+-- ** Dyre options+vanillaFlag, forceReconfFlag, denyReconfFlag :: Parser Dyre.Mode+vanillaFlag = flag def Dyre.Vanilla $ long "vanilla" <> short '1' <> help "Do not read custom configuration file"+forceReconfFlag = flag def Dyre.ForceReconfiguration $ long "force-reconf" <> help "Recompile configuration file before starting the program"+denyReconfFlag = flag def Dyre.IgnoreReconfiguration $ long "deny-reconf" <> help "Do not recompile configuration file even if it has changed" --- | Parse 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://")-setStartURI :: (BaseIO m, MonadPlus m) => String -> (CliOptions -> m CliOptions)-setStartURI (pack -> uri) options = do- fileURI <- io . isFile $ fpFromText uri- workingDir <- io getWorkingDirectory+dyreDebug :: Parser Bool+dyreDebug = switch $ long "dyre-debug" <> help "Use './cache/' as the cache directory and ./ as the configuration directory. Useful to debug the program." - let fileURI' = ("file://" ++ fpToText workingDir ++ "/" ++ uri) <| fileURI |> uri- parsedURI <- maybe abort return =<< logErrors (parseURIReference fileURI')+dyreMasterBinary :: Parser String+dyreMasterBinary = strOption $ long "dyre-master-binary" <> metavar "PATH" <> hidden <> internal <> help "Internal flag used for dynamic reconfiguration." - return $ set startURIL (Just parsedURI) options+-- ** Log level options+verboseFlag, quietFlag, logLevel :: Parser LogLevel+verboseFlag = flag LevelInfo LevelDebug $ long "verbose" <> short 'v' <> help "Set log level to DEBUG."+quietFlag = flag LevelInfo LevelError $ long "quiet" <> short 'q' <> help "Set log level to ERROR."+logLevel = option auto $ long "log-level" <> short 'l' <> metavar "LOG-LEVEL" <> value LevelInfo <> completeWith ["LevelDebug", "LevelInfo", "LevelWarn", "LevelError"] <> help "Set log level. Available values: LevelDebug, LevelInfo, LevelWarn, LevelError." --- | Usage text (cf @hbro -h@)-usage :: Text-usage = pack $ usageInfo "Usage: hbro [OPTIONS]" (description :: [OptDescr (CliOptions -> IO CliOptions)])+-- | --- | Get and parse commandline options-parseOptions :: (BaseIO m, MonadPlus m) => m CliOptions-parseOptions = do- Logger.initialize INFO+-- ** Commands+rebuildOptions, versionOptions :: Parser Command+rebuildOptions = pure Rebuild+versionOptions = pure Version - (opts, input', unknown', errors') <- io $ getOpt' Permute description . map unpack <$> getArgs- let (input, unknown, errors) = (tailSafe $ (pack <$> input'), pack <$> unknown', pack <$> errors')+rebuildCommand, versionCommand :: Mod CommandFields Command+rebuildCommand = command "rebuild" $ info rebuildOptions $ progDesc "Rebuild configuration file."+versionCommand = command "version" $ info versionOptions $ progDesc "Print version." - unless (null errors) $ errorM "hbro.options" (unlines errors) >> abort- unless (null unknown) . infoM "hbro.options" $ "Unrecognized options: " ++ unwords unknown- unless (null input) . infoM "hbro.options" $ "Ignored input: " ++ unlines input+commands :: Parser Command+commands = subparser $ rebuildCommand <> versionCommand - options <- foldl' (>>=) (return def) opts- debugM "hbro.options" $ "Used options: " ++ describe options- return options+-- ** Aggregated parsers+cliOptions :: Parser CliOptions+cliOptions = CliOptions+ <$> optional startURI+ <*> optional socketURI+ <*> optional uiURI+ <*> (vanillaFlag <|> forceReconfFlag <|> denyReconfFlag)+ <*> dyreDebug+ <*> (verboseFlag <|> quietFlag <|> logLevel) --- | Return socket URI used by this instance-getSocketURI :: (BaseIO m) => CliOptions -> m Text-getSocketURI options = maybe getDefaultSocketURI (return . normalize) $ options^.socketPathL- where- normalize = ("ipc://" ++) . fpToText- getDefaultSocketURI = do- dir <- fpToText <$> (io $ getAppCacheDirectory "hbro")- pid <- io getProcessID- return $ "ipc://" ++ dir ++ "/hbro." ++ tshow pid+parser :: Parser (Either Command CliOptions)+parser = helper <*> optional dyreMasterBinary *> ((Left <$> commands) <|> (Right <$> cliOptions))
library/Hbro/Prelude.hs view
@@ -1,110 +1,95 @@-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- | Replacement for the traditional @Prelude@ module. This module doesn't import any other Hbro.* module, so it can be safely imported from anywhere in the project. module Hbro.Prelude ( module X -- * Typeclass- , ToList(..)- , ToSet(..)- , ToNonEmpty(..) , Describable(..) , BaseIO , ControlIO -- * Generic aliases/shortcuts- , leftM+ , (|:)+ , (>:) , io , (>/>) , abort , doNothing+-- * File manipulation+ , readFileE+ , readFileE'+ , writeFileE+ , writeFileE' -- * Lens util , withM , withM_ , fwd- , askL--- * Concurrent util- , writeTMVar- , withAsyncList- , withAsyncList_--- * Gtk util- , gSync- , gAsync--- * Process control- , spawn--- * Pango util- , allItalic- , allBold- , black- , gray- , red- , green- , blue- , yellow ) where -- {{{ Imports-import ClassyPrelude as X hiding(Builder(..), log, toList)--import Control.Applicative as X (Alternative(..), WrappedMonad)-import Control.Arrow as X (Kleisli(..), left, right)-import Control.Concurrent.Async.Lifted-import Control.Conditional as X (ToBool(..), (<|), (|>), (<<|), (|>>))-import Control.Lens-import Control.Monad.Base as X (MonadBase(..))-import Control.Monad.Trans.Control as X-import Control.Monad.Reader+import ClassyPrelude as X hiding (Builder (..),+ MonadReader (..),+ ReaderT (..),+ defaultTimeLocale, error,+ log, toList) -import Data.Default as X-import Data.Foldable as X (asum)-import Data.Functor as X-import Data.List as X (tail)-import Data.List.NonEmpty (NonEmpty(..))-import Data.Maybe as X (fromJust)+import Control.Applicative as X (Alternative (..),+ WrappedMonad, optional)+import Control.Arrow as X (Kleisli (..), left, right)+import Control.Conditional as X (ToBool (..), (<<|), (<|),+ (|>), (|>>))+import Control.Lens+import Control.Monad.Base as X (MonadBase (..))+import Control.Monad.Except+import Control.Monad.Reader.Extended as X hiding (get)+import Control.Monad.Trans.Control as X -import Graphics.Rendering.Pango.Enums-import Graphics.UI.Gtk.General.General+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Lazy as Lazy+import Data.Default.Class as X+import Data.Foldable as X (asum)+import Data.List as X (tail)+import Data.List.NonEmpty hiding (reverse)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe as X (fromJust) -import Safe as X (initSafe, tailSafe)+import Safe as X (initSafe, tailSafe) -import System.Log.Logger -- import System.Posix.Process -- import System.Posix.Types-import System.Process -- }}} --- | We often want to use a single object where a list is expected.-class ToList m t | t -> m where toList :: t -> [m] -instance ToList m [m] where toList = id---- | We often want to use a single object where a set is expected.-class ToSet m t | t -> m where toSet :: t -> Set m--instance ToSet m (Set m) where toSet = id---- | We often want to use a single object where a non-empty list is expected.-class ToNonEmpty s t | t -> s where toNonEmpty :: t -> NonEmpty s--instance ToNonEmpty s (NonEmpty s) where toNonEmpty = id- -- | Like 'Show', for 'Text' class Describable a where describe :: a -> Text+instance Describable () where describe = const "()" --- | Mix of 'MonadBase IO' and 'MonadIO'+-- | Mix of @MonadBase IO@ and @MonadIO@ type BaseIO m = (MonadBase IO m, MonadIO m) --- | Mix of 'MonadBaseControl IO' and 'MonadIO'+-- | Mix of @MonadBaseControl IO@ and @MonadIO@ type ControlIO m = (MonadBaseControl IO m, MonadIO m) -- {{{ Generic aliases/shortcuts--- 'left' for 'Kleisli' arrows-leftM :: Monad m => (a -> m b) -> Either a c -> m (Either b c)-leftM f = runKleisli (left $ Kleisli f)+-- | Build a 'NonEmpty' from the right+(|:) :: [a] -> a -> NonEmpty a+list |: e = NonEmpty.reverse (e :| reverse list) +-- | Infix equivalent for @(,)@+(>:) :: a -> b -> (a, b)+(>:) = (,)+infix 0 >:+ -- | Alias for 'liftIO' io :: MonadIO m => IO a -> m a io = liftIO -- | Like '(\</\>)' with first argument in @IO@ to build platform-dependent paths.-(>/>) :: (BaseIO m) => IO FilePath -> FilePath -> m FilePath+(>/>) :: MonadIO m => IO FilePath -> FilePath -> m FilePath (>/>) a b = io $ (</> b) <$> a -- | Alias for 'mzero'@@ -116,6 +101,24 @@ doNothing = return () -- }}} +-- {{{ File manipulation+-- | Lifted version of 'readFile'+readFileE :: (ControlIO m, MonadError Text m) => FilePath -> m Lazy.ByteString+readFileE = handleIO (throwError . tshow) . readFile++-- | Strict version of 'readFileE'+readFileE' :: (ControlIO m, MonadError Text m) => FilePath -> m Strict.ByteString+readFileE' = handleIO (throwError . tshow) . readFile++-- | Lifted version of 'writeFile'+writeFileE :: (ControlIO m, MonadError Text m) => FilePath -> Lazy.ByteString -> m ()+writeFileE f x = handleIO (throwError . tshow) $ writeFile f x++-- | Strict version of 'writeFileE'+writeFileE' :: (ControlIO m, MonadError Text m) => FilePath -> Strict.ByteString -> m ()+writeFileE' f x = handleIO (throwError . tshow) $ writeFile f x+-- }}}+ -- {{{ Lens util -- | Alias for 'mapMOf' withM :: Profunctor p => Over p (WrappedMonad m) s t a b -> p a (m b) -> s -> m t@@ -126,50 +129,9 @@ fwd :: (Monad m) => (a -> m ()) -> a -> m a fwd f x = f x >> return x---- | Call 'asks' with the given lens getter.-askL ::(MonadReader t m) => Lens' t a -> m a-askL l = asks $ view l -- }}} --- {{{ Concurrent util--- | This is a combination of 'tryTakeTMVar' and 'putTMVar';--- ie. it empties the 'TMVar' if needed, and puts the new value instead.-writeTMVar :: TMVar a -> a -> STM ()-writeTMVar var val = do- tryTakeTMVar var- putTMVar var val---- | Recursive 'withAsync'-withAsyncList :: (ControlIO m) => [m a] -> ([Async (StM m a)] -> m b) -> m b-withAsyncList a f = withAsyncList' a [] f---- | Same as 'withAsyncList', but discards the result-withAsyncList_ :: (ControlIO m) => [m a] -> ([Async (StM m a)] -> m b) -> m ()-withAsyncList_ a f = void $ withAsyncList a f--withAsyncList' :: (ControlIO m) => [m a] -> [Async (StM m a)] -> ([Async (StM m a)] -> m b) -> m b-withAsyncList' [] x f = f x-withAsyncList' (a:b) x f = withAsync a $ \x' -> withAsyncList' b (x':x) f--- }}}---- {{{ Gtk util--- | Lifted alias for 'postGUISync'-gSync :: (BaseIO m) => IO a -> m a-gSync = io . postGUISync---- | Lifted alias for 'postGUIAsync'-gAsync :: (BaseIO m) => IO () -> m ()-gAsync = io . postGUIAsync--- }}}- -- {{{ Process management--- | Run external command and don't die when parent process exits.-spawn :: (BaseIO m) => String -> [String] -> m ()-spawn command options = io $ do- debugM "hbro.prelude" $ "Executing command: " ++ unwords (command:options)- 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 = do@@ -178,25 +140,4 @@ -- myPid <- io $ getProcessID -- return $ delete myPid . map (read :: String -> ProcessID) . nub . words $ pids ++ " " ++ pids'--- }}}---{-errorHandler :: (MonadIO m, MonadReader r m, HasOptions r) => FilePath -> IOError -> m ()-errorHandler file e = do- 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 ++ ">."-}---- {{{ Pango util-allItalic, allBold :: PangoAttribute-allItalic = AttrStyle {paStart = 0, paEnd = -1, paStyle = StyleItalic}-allBold = AttrWeight {paStart = 0, paEnd = -1, paWeight = WeightBold}--black, gray, red, green, blue, yellow :: Color-black = Color 0 0 0-gray = Color 32767 32767 32767-red = Color 65535 0 0-green = Color 0 65535 0-blue = Color 0 0 65535-yellow = Color 65535 65535 0 -- }}}
− library/Hbro/Signals.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Hbro.Signals (--- * Signals- Signals- , _ipcSignals- , _promptSignals- , _webViewSignals- , initialize- , attachGuiSignals-) where---- {{{ Imports--- import Hbro.Error-import Hbro.Gui hiding(initialize)-import Hbro.Gui.PromptBar (entryL)-import qualified Hbro.IPC.Signals as IPC-import qualified Hbro.Gui.PromptBar.Signals as Prompt-import Hbro.Prelude-import qualified Hbro.WebView.Signals as WebView--import Control.Lens hiding((??))--- }}}---- {{{ Signals-data Signals = Signals {- __ipcSignals :: IPC.Signals,- __promptSignals :: Prompt.Signals,- __webViewSignals :: WebView.Signals }--makeLenses ''Signals--initialize :: (BaseIO m) => m Signals-initialize = Signals <$> IPC.initSignals- <*> Prompt.initSignals- <*> WebView.initSignals--attachGuiSignals :: (BaseIO m) => GUI -> Signals -> m ()-attachGuiSignals gui signals = do- WebView.attach (gui^.webViewL) (signals^._webViewSignals)- Prompt.attach (gui^.promptBarL.entryL) (signals^._promptSignals)--- }}}
− library/Hbro/WebView/Hooks.hs
@@ -1,83 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Hbro.WebView.Hooks (--- * Types- DownloadHook(..)- , LinkClickedHook(..)- , LoadRequestedHook(..)- , NewWindowHook(..)- , ResourceOpenedHook(..)- , TitleChangedHook(..)- , Hooks- , onDownloadL- , onLinkClickedL- , onLinkHoveredL- , onLoadRequestedL- , onLoadStartedL- , onLoadFinishedL- , onNewWindowL- , onResourceOpenedL- , onTitleChangedL- , HasHooks(..)--- * Functions- , set- , initHooks-) where---- {{{ Imports-import Hbro.Prelude-import Hbro.WebView.Signals--import Control.Lens.Lens-import Control.Lens.Setter hiding(set)-import Control.Lens.TH-import Control.Monad.Reader--- }}}---newtype DownloadHook m = DownloadHook (Download -> m ())-newtype LinkClickedHook m = LinkClickedHook (LinkClicked -> m ())-newtype LoadRequestedHook m = LoadRequestedHook (LoadRequested -> m ())-newtype NewWindowHook m = NewWindowHook (NewWindow -> m ())-newtype ResourceOpenedHook m = ResourceOpenedHook (ResourceOpened -> m ResourceAction)-newtype TitleChangedHook m = TitleChangedHook (TitleChanged -> m ())---data Hooks m = Hooks- { _onDownload :: TMVar (Download -> m ())- , _onLinkClicked :: TMVar (LinkClicked -> m ())- , _onLinkHovered :: TMVar (LinkHovered -> m ())- , _onLoadRequested :: TMVar (LoadRequested -> m ())- , _onLoadStarted :: TMVar (LoadStarted -> m ())- , _onLoadFinished :: TMVar (LoadFinished -> m ())- , _onNewWindow :: TMVar (NewWindow -> m ())- , _onResourceOpened :: TMVar (ResourceOpened -> m ())- , _onTitleChanged :: TMVar (TitleChanged -> m ())- }--makeLensesWith ?? ''Hooks $ lensRules- & lensField .~ (\name -> Just (tail name ++ "L"))- -- & lensClass .~ (\name -> Just ("Has" ++ name, map toLower name))--class HasHooks n t | t -> n where _hooks :: Lens' t (Hooks n)--set :: (BaseIO m, MonadReader r m, HasHooks n r) => Lens' (Hooks n) (TMVar a) -> a -> m ()-set l v = atomically . (`writeTMVar` v) =<< askL (_hooks.l)---initHooks :: (Functor n, BaseIO m, Default (LinkClickedHook n), Default (LoadRequestedHook n), Default (NewWindowHook n), Default (ResourceOpenedHook n), Default (TitleChangedHook n))- => m (Hooks n)-initHooks = io (Hooks <$> newEmptyTMVarIO- <*> newTMVarIO lc- <*> newEmptyTMVarIO- <*> newTMVarIO lr- <*> newEmptyTMVarIO- <*> newEmptyTMVarIO- <*> newTMVarIO nw- <*> newTMVarIO (void . ro)- <*> newTMVarIO tc)- where- LinkClickedHook lc = def- LoadRequestedHook lr = def- NewWindowHook nw = def- ResourceOpenedHook ro = def- TitleChangedHook tc = def
library/Hbro/WebView/Signals.hs view
@@ -1,168 +1,155 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-} module Hbro.WebView.Signals where -- {{{ Imports-import Hbro.Error-import Hbro.Gdk.KeyVal-import Hbro.Keys as Keys hiding(Hooks)-import Hbro.Keys.Model ((.|))-import Hbro.Keys.Signals as Keys-import Hbro.Logger-import Hbro.Prelude hiding(on)--import Graphics.UI.Gtk.WebKit.Lifted as Lifted+import Hbro.Error+import Hbro.Event+import Hbro.Gdk.KeyVal+import Hbro.Keys as Keys+import Hbro.Keys.Model ((.|))+import Hbro.Logger+import Hbro.Prelude hiding (on) -import Control.Lens.Lens-import Control.Lens.Getter-import Control.Lens.Setter-import Control.Lens.TH+import Graphics.UI.Gtk.WebKit.Lifted as Lifted+import Graphics.UI.Gtk.WebKit.Lifted.WebView as W -import Data.Set as S hiding(map)+import Data.Set as S hiding (map) -import Graphics.UI.Gtk.Abstract.Widget hiding(KeyVal)-import Graphics.UI.Gtk.Gdk.EventM as Gdk-import Graphics.UI.Gtk.WebKit.Download as W hiding(Download, downloadGetUri, downloadGetSuggestedFilename)-import Graphics.UI.Gtk.WebKit.WebNavigationAction-import Graphics.UI.Gtk.WebKit.WebPolicyDecision-import Graphics.UI.Gtk.WebKit.WebView as W hiding(LoadFinished)+import Graphics.UI.Gtk.Abstract.Object+import Graphics.UI.Gtk.Abstract.Widget hiding (KeyVal)+import Graphics.UI.Gtk.Gdk.EventM as Gdk+import Graphics.UI.Gtk.General.General.Extended+import Graphics.UI.Gtk.WebKit.Download as W hiding+ (Download, downloadGetSuggestedFilename, downloadGetUri)+import Graphics.UI.Gtk.WebKit.WebNavigationAction+import Graphics.UI.Gtk.WebKit.WebPolicyDecision -import Network.URI+import Network.URI.Extended -import System.Glib.Signals hiding(Signal)+import qualified System.Glib.Attributes as Glib+import System.Glib.GError+import System.Glib.Signals hiding (Signal) -- }}} +data Download = Download deriving(Show)+instance Event Download where+ type Input Download = (URI, Text, Maybe Int)+ describeInput _ (uri, _, _) = Just $ "Requested download <" ++ tshow uri ++ ">" -data ResourceAction = Load | Download'+data LinkClicked = LinkClicked deriving(Show)+instance Event LinkClicked where+ type Input LinkClicked = (URI, MouseButton)+ describeInput _ (uri, _) = Just $ "Link clicked <" ++ tshow uri ++ ">" -data Download = Download URI Text (Maybe Int)-instance Describable Download where describe _ = "Download"+data LinkHovered = LinkHovered deriving(Show)+instance Event LinkHovered where+ type Input LinkHovered = (URI, Maybe Text)+ describeInput _ (uri, _) = Just $ "Link hovered <" ++ tshow uri ++ ">" -data LinkHovered = LinkHovered URI (Maybe Text)-instance Describable LinkHovered where describe _ = "LinkHovered"+data LinkUnhovered = LinkUnhovered deriving(Show)+instance Event LinkUnhovered where+ describeInput _ _ = Just "Link unhovered" -data LinkClicked = LinkClicked URI MouseButton-instance Describable LinkClicked where describe _ = "LinkClicked"+data LoadCommitted = LoadCommitted deriving(Show)+instance Event LoadCommitted where+ describeInput _ _ = Just "Load committed" -data LoadRequested = LoadRequested URI-instance Describable LoadRequested where describe _ = "LoadRequested"+data LoadFailed = LoadFailed deriving(Show)+instance Event LoadFailed where+ type Input LoadFailed = (URI, GError)+ describeInput _ (uri, e) = Just $ "Error loading <" ++ tshow uri ++ "> : " ++ tshow e -data LoadStarted = LoadStarted-instance Describable LoadStarted where describe _ = "LoadStarted"+data LoadFinished = LoadFinished deriving(Show)+instance Event LoadFinished where+ describeInput _ _ = Just "Load finished" -data LoadFinished = LoadFinished-instance Describable LoadFinished where describe _ = "LoadFinished"+data LoadRequested = LoadRequested deriving(Show)+instance Event LoadRequested where+ type Input LoadRequested = URI+ describeInput _ uri = Just $ "Load requested <" ++ tshow uri ++ ">" -data NewWindow = NewWindow URI-instance Describable NewWindow where describe _ = "NewWindow"+data LoadStarted = LoadStarted deriving(Show)+instance Event LoadStarted where+ describeInput _ _ = Just "Load started" -data ResourceOpened = ResourceOpened URI Text-instance Describable ResourceOpened where describe _ = "ResourceOpened"+data NewWindow = NewWindow deriving(Show)+instance Event NewWindow where+ type Input NewWindow = URI+ describeInput _ uri = Just $ "New window <" ++ tshow uri ++ ">" -data TitleChanged = TitleChanged Text-instance Describable TitleChanged where describe _ = "TitleChanged"+data ProgressChanged = ProgressChanged deriving(Show)+instance Event ProgressChanged where+ type Input ProgressChanged = Int+ describeInput _ percent = Just $ "Load progress: " ++ tshow percent ++ "%" +data ResourceOpened = ResourceOpened deriving(Show)+instance Event ResourceOpened where+ type Input ResourceOpened = (URI, Text)+ describeInput _ _ = Just "Resource opened" -data Signals = Signals- { _download :: TMVar Download- , _keyPressed :: TMVar KeyPressed- , _linkClicked :: TMVar LinkClicked- , _linkHovered :: TMVar LinkHovered- , _loadRequested :: TMVar LoadRequested- , _loadStarted :: TMVar LoadStarted- , _loadFinished :: TMVar LoadFinished- -- _newWebView :: TMVar URI,- , _newWindow :: TMVar NewWindow- , _resourceOpened :: TMVar ResourceOpened- , _titleChanged :: TMVar TitleChanged- }+data TitleChanged = TitleChanged deriving(Show)+instance Event TitleChanged where+ type Input TitleChanged = Text+ describeInput _ = Just . (++) "Title changed to: " +data URIChanged = URIChanged deriving(Show)+instance Event URIChanged where+ type Input URIChanged = URI+ describeInput _ = Just . (++) "URI changed to: " . tshow -makeLensesWith ?? ''Signals $ lensRules- & lensField .~ (\name -> Just (tailSafe name ++ "L"))+data ZoomLevelChanged = ZoomLevelChanged deriving(Show)+instance Event ZoomLevelChanged where+ type Input ZoomLevelChanged = Float+ describeInput _ value = Just $ "Zoom level changed to: " ++ tshow value -initSignals :: (BaseIO m) => m Signals-initSignals = io (Signals <$> newEmptyTMVarIO- <*> newEmptyTMVarIO- <*> newEmptyTMVarIO- <*> newEmptyTMVarIO- <*> newEmptyTMVarIO- <*> newEmptyTMVarIO- <*> newEmptyTMVarIO- <*> newEmptyTMVarIO- <*> newEmptyTMVarIO- <*> newEmptyTMVarIO)+data ResourceAction = Load | Download' deriving(Show)+instance Describable ResourceAction where describe = tshow --- | Sequentially bind all signals.-attach :: (BaseIO m) => WebView -> Signals -> m ()-attach webView signals = sequence_- [ attachDownload webView (signals^.downloadL)- , attachLinkHovered webView (signals^.linkHoveredL)- , attachLoadStarted webView (signals^.loadStartedL)- , attachLoadFinished webView (signals^.loadFinishedL)- , attachNavigationRequest webView (signals^.linkClickedL, signals^.loadRequestedL)- , attachNewWebView webView (signals^.newWindowL)- , attachNewWindow webView (signals^.newWindowL)- , attachResourceOpened webView (signals^.resourceOpenedL)- , attachTitleChanged webView (signals^.titleChangedL)- , attachKeyPressed webView (signals^.keyPressedL)- ] +attachDownload :: (ControlIO m, MonadLogger m) => WebView -> Signal Download -> m (ConnectId WebView)+attachDownload webView signal = liftBaseWith $ \runInIO -> gSync . on webView downloadRequested $ \d -> do+ runInIO . runExceptT . logErrors $ do+ amount <- io $ downloadGetTotalSize d+ uri <- downloadGetUri d+ name <- downloadGetSuggestedFilename d -attachDownload :: (BaseIO m) => WebView -> TMVar Download -> m (ConnectId WebView)-attachDownload webView signal = gSync . on webView downloadRequested $ \d -> do- logErrors $ do- amount <- io $ downloadGetTotalSize d- uri <- downloadGetUri d- name <- downloadGetSuggestedFilename d+ emit signal (uri, name, Just amount)+ return False - debugM "hbro.signals" $ "Requested download <" ++ tshow uri ++ ">" - atomically . tryPutTMVar signal $ Download uri name (Just amount)- return False+attachLinkHovered :: (ControlIO m, MonadLogger m) => WebView -> Signal LinkHovered -> Signal LinkUnhovered -> m (ConnectId WebView)+attachLinkHovered webView hoveredSignal unhoveredSignal = liftBaseWith $ \runInIO -> gSync $ on webView hoveringOverLink (\a b -> void . runInIO $ callback a b)+ where callback title (Just uri) = void . runExceptT . logErrors $ do+ u <- parseURIM $ pack uri+ emit hoveredSignal (u, pack <$> title)+ callback _ _ = emit unhoveredSignal () -attachLinkHovered :: (BaseIO m) => WebView -> TMVar LinkHovered -> m (ConnectId WebView)-attachLinkHovered webView signal = gSync . on webView hoveringOverLink $ \title uri -> void . runMaybeT $ do- debugM "hbro.signals" $ "Link hovered <" ++ tshow uri ++ ">"- u <- MaybeT . return $ parseURI . unpack =<< uri-- atomically . tryPutTMVar signal $ LinkHovered u title+attachLoadCommitted :: (ControlIO m, MonadLogger m) => WebView -> Signal LoadCommitted -> m (ConnectId WebView)+attachLoadCommitted webView signal = liftBaseWith $ \runInIO -> gSync . on webView loadCommitted $ \_frame -> void . runInIO $ emit signal () --- Triggered in 2 cases:--- 1/ Javascript window.open()--- 2/ Context menu "Open in new window"-attachNewWebView :: (BaseIO m) => WebView -> TMVar NewWindow -> m (ConnectId WebView)-attachNewWebView webView signal = gSync . on webView createWebView $ \_frame -> do- webView' <- webViewNew-- on webView' webViewReady $ return True- on webView' navigationPolicyDecisionRequested $ \_ request _ decision -> do- logErrors $ do- uri <- networkRequestGetUri request- debugM "hbro.signals" $ "New window <" ++ tshow uri ++ ">"- atomically . tryPutTMVar signal $ NewWindow uri-- webPolicyDecisionIgnore decision- return True-- return webView'+attachLoadFailed :: (ControlIO m, MonadLogger m) => WebView -> Signal LoadFailed -> m (ConnectId WebView)+attachLoadFailed webView signal = liftBaseWith $ \runInIO -> gSync . on webView loadError $ \_frame uri e -> do+ runInIO . runExceptT . logErrors $ do+ uri' <- parseURIReferenceM uri+ emit signal (uri', e)+ return False -attachLoadStarted :: (BaseIO m) => WebView -> TMVar LoadStarted -> m (ConnectId WebView)-attachLoadStarted webView signal = gSync . on webView loadStarted $ \_frame -> do- debugM "hbro.signals" "Load started"- void . atomically $ tryPutTMVar signal LoadStarted+attachLoadFinished :: (ControlIO m, MonadLogger m) => WebView -> Signal LoadFinished -> m (ConnectId WebView)+attachLoadFinished webView signal = liftBaseWith $ \runInIO -> gSync . on webView loadFinished $ \_frame -> void . runInIO $ emit signal () -attachLoadFinished :: (BaseIO m) => WebView -> TMVar LoadFinished -> m (ConnectId WebView)-attachLoadFinished webView signal = gSync . on webView loadFinished $ \_frame -> do- debugM "hbro.signals" "Load finished"- void . atomically $ tryPutTMVar signal LoadFinished-+attachLoadStarted :: (ControlIO m, MonadLogger m) => WebView -> Signal LoadStarted -> m (ConnectId WebView)+attachLoadStarted webView signal = liftBaseWith $ \runInIO -> gSync . on webView loadStarted $ \_frame -> void . runInIO $ emit signal () -attachNavigationRequest :: (BaseIO m) => WebView -> (TMVar LinkClicked, TMVar LoadRequested) -> m (ConnectId WebView)-attachNavigationRequest webView (signal1, signal2) = gSync . on webView navigationPolicyDecisionRequested $ \_frame request action decision -> do+attachNavigationRequest :: (ControlIO m, MonadLogger m) => WebView -> Signal LinkClicked -> Signal LoadRequested -> m (ConnectId WebView)+attachNavigationRequest webView signal1 signal2 = liftBaseWith $ \runInIO -> gSync . on webView navigationPolicyDecisionRequested $ \_frame request action decision -> do reason <- webNavigationActionGetReason action button <- toMouseButton <$> webNavigationActionGetButton action @@ -170,33 +157,30 @@ -- io . putStrLn . ("Request type: " ++) . describe =<< networkRequestGetContentType request -- io . putStrLn . ("Request type: " ++) . describe =<< networkRequestGetURI request - logErrors $ do+ runInIO . runExceptT $ do uri <- networkRequestGetUri request case (reason, button) of- (WebNavigationReasonLinkClicked, Just b) -> io $ do- debugM "hbro.signals" $ "Link clicked <" ++ tshow uri ++ ">"- atomically . tryPutTMVar signal1 $ LinkClicked uri b- webPolicyDecisionIgnore decision- (WebNavigationReasonOther, _) -> io $ do- debugM "hbro.signals" $ "Navigation request [" ++ tshow reason ++ "] to <" ++ tshow uri ++ ">"- webPolicyDecisionUse decision- (WebNavigationReasonBackForward, _) -> io $ do- debugM "hbro.signals" $ "Navigation request [" ++ tshow reason ++ "] to <" ++ tshow uri ++ ">"- webPolicyDecisionUse decision- (WebNavigationReasonReload, _) -> io $ do- debugM "hbro.signals" $ "Navigation request [" ++ tshow reason ++ "] to <" ++ tshow uri ++ ">"- webPolicyDecisionUse decision- (WebNavigationReasonFormSubmitted, _) -> io $ do- debugM "hbro.signals" $ "Form submitted to <" ++ tshow uri ++ ">"- webPolicyDecisionUse decision- _ -> io $ do- debugM "hbro.signals" $ "Navigation request [" ++ tshow reason ++ "] to <" ++ tshow uri ++ ">"- void . atomically . tryPutTMVar signal2 $ LoadRequested uri- webPolicyDecisionIgnore decision- `catchError` \e -> io $ do- errorM "hbro.signals" $ tshow e- webPolicyDecisionUse decision+ (WebNavigationReasonLinkClicked, Just b) -> do+ emit signal1 (uri, b)+ io $ webPolicyDecisionIgnore decision+ (WebNavigationReasonOther, _) -> do+ debug $ "Navigation request to <" ++ tshow uri ++ ">"+ io $ webPolicyDecisionUse decision+ (WebNavigationReasonBackForward, _) -> do+ io $ webPolicyDecisionUse decision+ (WebNavigationReasonReload, _) -> do+ io $ webPolicyDecisionUse decision+ (WebNavigationReasonFormSubmitted, _) -> do+ debug $ "Form submitted to <" ++ tshow uri ++ ">"+ io $ webPolicyDecisionUse decision+ _ -> do+ debug $ "Navigation request [" ++ tshow reason ++ "] to <" ++ tshow uri ++ ">"+ emit signal2 uri+ io $ webPolicyDecisionIgnore decision+ `catchError` \e -> do+ error e+ io $ webPolicyDecisionUse decision return True where@@ -206,45 +190,71 @@ toMouseButton _ = Nothing -attachNewWindow :: (BaseIO m) => WebView -> TMVar NewWindow -> m (ConnectId WebView)-attachNewWindow webView signal = gSync . on webView newWindowPolicyDecisionRequested $ \_frame request _action decision -> do- logErrors $ do- uri <- networkRequestGetUri request- debugM "hbro.signals" $ "New window request <" ++ tshow uri ++ ">"- atomically . tryPutTMVar signal $ NewWindow uri+-- Triggered in 2 cases:+-- 1/ Javascript window.open()+-- 2/ Context menu "Open in new window"+attachNewWebView :: (ControlIO m, MonadLogger m) => WebView -> Signal NewWindow -> m (ConnectId WebView)+attachNewWebView webView signal = liftBaseWith $ \runInIO -> gSync . on webView createWebView $ \_frame -> do+ webView' <- webViewNew + on webView' webViewReady $ return True+ on webView' navigationPolicyDecisionRequested $ \_ request _ decision -> do+ runInIO . runExceptT . logErrors $ networkRequestGetUri request >>= emit signal+ webPolicyDecisionIgnore decision+ return True++ return webView'+++attachNewWindow :: (ControlIO m, MonadLogger m) => WebView -> Signal NewWindow -> m (ConnectId WebView)+attachNewWindow webView signal = liftBaseWith $ \runInIO -> gSync . on webView newWindowPolicyDecisionRequested $ \_frame request _action decision -> do+ runInIO . runExceptT . logErrors $ networkRequestGetUri request >>= emit signal webPolicyDecisionIgnore decision return True -attachResourceOpened :: (BaseIO m) => WebView -> TMVar ResourceOpened -> m (ConnectId WebView)-attachResourceOpened webView signal = gSync . on webView mimeTypePolicyDecisionRequested $ \_frame request mimetype decision -> do- logErrors $ do- uri <- networkRequestGetUri request- debugM "hbro.signals" $ "Opening resource [MIME type=" ++ mimetype ++ "] at <" ++ tshow uri ++ ">"- atomically . tryPutTMVar signal $ ResourceOpened uri mimetype+attachProgressChanged :: (ControlIO m, MonadLogger m) => WebView -> Signal ProgressChanged -> m (ConnectId WebView)+attachProgressChanged webView signal = liftBaseWith $ \runInIO -> gSync . on webView progressChanged $ void . runInIO . emit signal - webPolicyDecisionUse decision- return True+-- attachResourceOpened :: (MonadIO m) => WebView -> Signal ResourceOpened -> m (ConnectId WebView)+-- attachResourceOpened webView signal = liftBaseWith $ \runInIO -> gSync . on webView mimeTypePolicyDecisionRequested $ \_frame request mimetype decision -> do+-- action <- logErrors $ do+-- uri <- networkRequestGetUri request+-- debug $ "Opening resource [MIME type=" ++ mimetype ++ "] at <" ++ tshow uri ++ ">"+-- -- io . waitForResult =<<+-- emit signal (uri, mimetype) +-- debug "debug" $ "decision made: " ++ tshow action+-- case action of+-- Just Load -> webPolicyDecisionUse decision+-- Just Download' -> webPolicyDecisionDownload decision+-- _ -> webPolicyDecisionIgnore decision+-- return True -attachTitleChanged :: (BaseIO m) => WebView -> TMVar TitleChanged -> m (ConnectId WebView)-attachTitleChanged webView signal = gSync . on webView W.titleChanged $ \_frame title -> do- debugM "hbro.signals" $ "Title changed to: " ++ title- void . atomically . tryPutTMVar signal $ TitleChanged title+-- waitForResult output = do+-- debug "hbro.debug" "iteration" >> mainIteration+-- maybe (waitForResult output) return =<< (atomically $ tryTakeTMVar output) -attachKeyPressed :: (BaseIO m) => WebView -> TMVar KeyPressed -> m (ConnectId WebView)-attachKeyPressed webView signal = gSync . on webView keyPressEvent $ do- modifiers <- S.delete _Shift . S.fromList . map Keys.Modifier <$> Gdk.eventModifier- key <- KeyVal <$> Gdk.eventKeyVal+attachTitleChanged :: (ControlIO m, MonadLogger m) => WebView -> Signal TitleChanged -> m (ConnectId WebView)+attachTitleChanged webView signal = liftBaseWith $ \runInIO -> gSync . on webView W.titleChanged $ \_frame title -> void . runInIO $ emit signal title - io . runMaybeT $ do- guard . not $ isModifier key || isModalKey key+attachUriChanged :: (ControlIO m, MonadLogger m) => WebView -> Signal URIChanged -> m (ConnectId WebView)+attachUriChanged webView signal = liftBaseWith $ \runInIO ->+ gSync . on webView (notifyProperty W.webViewUri) . void . runInIO . runExceptT . logErrors $+ io (Glib.get webView webViewUri) >>= maybe (throwError "Invalid URI") return >>= parseURIM >>= emit signal - let theStroke = modifiers .| key- debugM "hbro.signals" $ "Pressed: " ++ describe theStroke+attachZoomLevelChanged :: (ControlIO m, MonadLogger m) => WebView -> Signal ZoomLevelChanged -> m (ConnectId WebView)+attachZoomLevelChanged webView signal = liftBaseWith $ \runInIO -> gSync . on webView (notifyProperty webViewZoomLevel) . void . runInIO $ emit signal =<< io (Glib.get webView webViewZoomLevel) - atomically . tryPutTMVar signal $ KeyPressed theStroke++attachKeyPressed :: (ControlIO m, MonadLogger m) => WebView -> Signal KeyPressed -> m (ConnectId WebView)+attachKeyPressed webView signal = liftBaseWith $ \runInIO -> gSync . on webView keyPressEvent $ do+ modifiers <- Modifier . S.delete Gdk.Shift . S.fromList <$> Gdk.eventModifier+ key <- KeyVal <$> Gdk.eventKeyVal++ io . runInIO . runFailT $ do+ guard . not $ isModifier key || isModalKey key+ emit signal $ modifiers .| key return False
− library/Hbro/Webkit/WebSettings.hs
@@ -1,73 +0,0 @@--- | Designed to be imported as @qualified@.-module Hbro.Webkit.WebSettings where---- {{{ Imports-import qualified Hbro.Gui as Gui (get)-import Hbro.Gui hiding(get)-import Hbro.Logger-import Hbro.Prelude--import Control.Monad.Reader--import Graphics.UI.Gtk.WebKit.WebSettings-import Graphics.UI.Gtk.WebKit.WebView--import System.Glib.Attributes (Attr, AttrOp(..))-import qualified System.Glib.Attributes as G--- }}}---set :: (BaseIO m, MonadReader t m, HasGUI t, Show a) => Attr WebSettings a -> a -> m ()-set element newValue = modify_ element $ const newValue--modify :: (BaseIO m, MonadReader t m, HasGUI t, Show a) => Attr WebSettings a -> (a -> a) -> m a-modify element modifier = do- webView <- Gui.get webViewL- settings <- gSync $ webViewGetWebSettings webView- oldValue <- gSync $ G.get settings element-- gAsync $ G.set settings [element := modifier oldValue]- gAsync $ webViewSetWebSettings webView settings- infoM "hbro.settings" $ "Set " ++ tshow element ++ " = " ++ tshow (modifier oldValue)- return oldValue---- | Same as 'modify', but discards the result-modify_ :: (BaseIO m, MonadReader t m, HasGUI t, Show a) => Attr WebSettings a -> (a -> a) -> m ()-modify_ e m = void $ modify e m--toggle :: (BaseIO m, MonadReader t m, HasGUI t) => Attr WebSettings Bool -> m Bool-toggle = (`modify` not)---- | Same as 'toggle', but discards the result-toggle_ :: (BaseIO m, MonadReader t m, HasGUI t) => Attr WebSettings Bool -> m ()-toggle_ = (`modify_` not)---- | Reset default settings-resetAll :: (BaseIO m, MonadReader t m, HasGUI t) => m ()-resetAll = do- set webSettingsAutoLoadImages True- set webSettingsAutoShrinkImages True- set webSettingsEnableDefaultContextMenu True- set webSettingsDefaultEncoding (asText "utf8")- set webSettingsEnableDeveloperExtras False- set webSettingsEnableDomPaste False- set webSettingsEnableHtml5Database False- set webSettingsEnableHtml5LocalStorage False- set webSettingsEnableOfflineWebApplicationCache False- set webSettingsEnablePageCache True- set webSettingsEnablePlugins False- set webSettingsEnablePrivateBrowsing False- set webSettingsEnableScripts False- set webSettingsEnableSpellChecking False- set webSettingsEnableSpatialNavigation False- set webSettingsEnableUniversalAccessFromFileUris True- set webSettingsEnableSiteSpecificQuirks False- set webSettingsEnableXssAuditor False- set webSettingsJSCanOpenWindowAuto False- set webSettingsMonospaceFontFamily (asText "inconsolata")- set webSettingsPrintBackgrounds True- set webSettingsResizableTextAreas True- set webSettingsSpellCheckingLang (Nothing :: Maybe Text)- set webSettingsTabKeyCyclesThroughElements True- set webSettingsUserStylesheetUri (Nothing :: Maybe Text)- set webSettingsZoomStep 0.1
+ library/Network/URI/Extended.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Monadic version of 'Network.URI'.+module Network.URI.Extended+ ( module X+ , parseURIReferenceM+ , parseURIM+ ) where++-- {{{ Imports+import Hbro.Error+import Hbro.Prelude++import Data.Aeson++import Network.URI as X+-- }}}++instance FromJSON URI where+ parseJSON (String t) = maybe mzero return . parseURIReference $ unpack t+ parseJSON _ = mzero++instance ToJSON URI where+ toJSON = String . tshow++-- | Error message+invalidURI :: Text -> Text+invalidURI uri = "Invalid URI: " ++ uri++-- | Monadic version of 'parseURIReference'+parseURIReferenceM :: (MonadError Text m) => Text -> m URI+parseURIReferenceM uri = parseURIReference (unpack uri) `failWith` invalidURI uri++-- | Monadic version of 'parseURI'+parseURIM :: (MonadError Text m) => Text -> m URI+parseURIM uri = parseURI (unpack uri) `failWith` invalidURI uri
− library/Network/URI/Monadic.hs
@@ -1,26 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--- | Functions from 'Network.URI' rewritten with 'MonadError' instead of 'Maybe'.-module Network.URI.Monadic- ( module X- , parseURIReference- , parseURI- ) where---- {{{ Imports-import Hbro.Prelude--import Control.Monad.Except (MonadError(..), throwError)--import Network.URI as X hiding(parseURIReference, parseURI)-import qualified Network.URI as N--- }}}---- | Error message-invalidURI :: Text -> Text-invalidURI uri = "Invalid URI: " ++ uri--parseURIReference :: (MonadError Text m) => Text -> m URI-parseURIReference uri = maybe (throwError $ invalidURI uri) return . N.parseURIReference $ unpack uri--parseURI :: (MonadError Text m) => Text -> m URI-parseURI uri = maybe (throwError $ invalidURI uri) return . N.parseURI $ unpack uri
+ library/System/Glib/Attributes/Extended.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Extension of @System.Glib.Attributes@ module.+-- All functions call `postGUISync' or `postGUIAsync` as they are not meant to be used in the same thread as the Gtk loop.+module System.Glib.Attributes.Extended where++-- {{{ Imports+import Hbro.Logger+import Hbro.Prelude++import Graphics.UI.Gtk.General.General.Extended++import System.Glib.Attributes (Attr, AttrOp (..),+ ReadWriteAttr)+import qualified System.Glib.Attributes as Glib+-- }}}++-- * Wrappers+get :: (MonadIO m) => o -> ReadWriteAttr o a b -> m a+get o a = gSync $ Glib.get o a++set :: (MonadIO m, MonadLogger m, Show a) => o -> Attr o a -> a -> m o+set object attribute newValue = do+ info $ "Set " ++ tshow attribute ++ " = " ++ tshow newValue+ gAsync $ Glib.set object [attribute := newValue]+ return object++set_ :: (MonadIO m, MonadLogger m, Functor m, Show a) => o -> Attr o a -> a -> m ()+set_ o a v = void $ set o a v++-- * Utils+modify :: (MonadIO m, MonadLogger m, Show a) => o -> Attr o a -> (a -> a) -> m a+modify object attribute f = do+ oldValue <- get object attribute+ set object attribute $ f oldValue+ return oldValue++-- | Same as 'modify', but discards the result.+modify_ :: (MonadIO m, MonadLogger m, Functor m, Show a) => o -> Attr o a -> (a -> a) -> m ()+modify_ object e = void . modify object e++toggle :: (MonadIO m, MonadLogger m) => o -> Attr o Bool -> m Bool+toggle object x = modify object x not++-- | Same as 'toggle', but discards the result.+toggle_ :: (MonadIO m, MonadLogger m, Functor m) => o -> Attr o Bool -> m ()+toggle_ object x = modify_ object x not
+ library/System/Process/Extended.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+module System.Process.Extended where++-- {{{ Imports+import Hbro.Logger++import ClassyPrelude++import System.Process+-- }}}++-- | Run external command and don't die when parent process exits.+spawn :: (MonadLogger m, MonadIO m) => Text -> [Text] -> m ()+spawn (unpack -> command) (map unpack -> options) = do+ debug $ "Executing command: " ++ pack (showCommandForUser command options)+ liftIO . void $ createProcess (proc command options) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, close_fds = True }