hbro 1.5.0.0 → 1.6.0.0
raw patch · 26 files changed
+213/−193 lines, 26 filesdep +chunked-datadep +monadIOdep +mono-traversabledep −classy-preludedep −exceptions
Dependencies added: chunked-data, monadIO, mono-traversable, safe-exceptions
Dependencies removed: classy-prelude, exceptions
Files
- hbro.cabal +5/−3
- library/Graphics/UI/Gtk/WebKit/Extended.hs +11/−12
- library/Hbro.hs +1/−1
- library/Hbro/Boot.hs +14/−12
- library/Hbro/Clipboard.hs +6/−6
- library/Hbro/Config.hs +5/−4
- library/Hbro/Core.hs +15/−11
- library/Hbro/Defaults.hs +11/−9
- library/Hbro/Dyre.hs +10/−9
- library/Hbro/Error.hs +2/−2
- library/Hbro/Event.hs +9/−17
- library/Hbro/Gdk/KeyVal.hsc +2/−2
- library/Hbro/Gui.hs +3/−2
- library/Hbro/Gui/MainView.hs +12/−13
- library/Hbro/Gui/NotificationBar.hs +3/−3
- library/Hbro/Gui/PromptBar.hs +13/−15
- library/Hbro/IPC.hs +5/−5
- library/Hbro/Keys.hs +8/−6
- library/Hbro/Keys/Model.hs +1/−1
- library/Hbro/Logger.hs +5/−5
- library/Hbro/Options.hs +9/−9
- library/Hbro/Prelude.hs +31/−13
- library/Hbro/WebView/Signals.hs +23/−21
- library/Network/URI/Extended.hs +3/−5
- library/System/Glib/Attributes/Extended.hs +4/−4
- library/System/Process/Extended.hs +2/−3
hbro.cabal view
@@ -1,5 +1,5 @@ Name: hbro-Version: 1.5.0.0+Version: 1.6.0.0 Synopsis: Minimal extensible web-browser Description: Cf README Homepage: https://github.com/k0ral/hbro@@ -24,14 +24,14 @@ Build-depends: base == 4.*, bytestring,- classy-prelude >= 0.12,+ chunked-data, cond, containers, data-default-class, directory, dyre >= 0.8.8, errors,- exceptions,+ safe-exceptions, fast-logger, filepath, glib,@@ -45,6 +45,8 @@ mtl >= 2.2, monad-control >= 1.0, monad-logger >= 0.3.6.2,+ monadIO,+ mono-traversable, network-uri, optparse-applicative >= 0.11, pango,
library/Graphics/UI/Gtk/WebKit/Extended.hs view
@@ -39,7 +39,8 @@ import Graphics.UI.Gtk.WebKit.WebDataSource as W import Graphics.UI.Gtk.WebKit.WebView as X hiding (webViewGetIconUri, webViewGetTitle,- webViewGetUri, webViewTryGetFaviconPixbuf,+ webViewGetUri,+ webViewTryGetFaviconPixbuf, webViewUri) import qualified Graphics.UI.Gtk.WebKit.WebView as W @@ -78,10 +79,10 @@ webViewGetTitle = gSync . W.webViewGetTitle >=> maybe (throwM UnavailableTitle) return loadHtmlString :: (MonadIO m) => Text -> URI -> WebView -> m ()-loadHtmlString html uri webView = gAsync $ W.webViewLoadHtmlString webView html (tshow uri)+loadHtmlString html uri webView = gAsync $ W.webViewLoadHtmlString webView html (show uri) loadString :: (MonadIO m) => Text -> URI -> WebView -> m ()-loadString html uri webView = gAsync $ W.webViewLoadString webView html Nothing (tshow uri)+loadString html uri webView = gAsync $ W.webViewLoadString webView html Nothing (show uri) data WebKitException = UnavailableData@@ -89,13 +90,11 @@ | UnavailableFileName | UnavailableTitle | UnavailableUri- deriving(Eq)--instance Exception WebKitException+ deriving(Eq, Show) -instance Show WebKitException where- show UnavailableData = "No data available in the web frame."- show UnavailableFavicon = "No available favicon."- show UnavailableFileName = "No file name available."- show UnavailableTitle = "No available title."- show UnavailableUri = "No URI available."+instance Exception WebKitException where+ displayException UnavailableData = "No data available in the web frame."+ displayException UnavailableFavicon = "No available favicon."+ displayException UnavailableFileName = "No file name available."+ displayException UnavailableTitle = "No available title."+ displayException UnavailableUri = "No URI available."
library/Hbro.hs view
@@ -1,4 +1,4 @@-module Hbro ( module X) where+module Hbro (module X) where import Hbro.Boot as X -- import Hbro.Clipboard
library/Hbro/Boot.hs view
@@ -11,6 +11,7 @@ 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@@ -22,6 +23,7 @@ import Hbro.Prelude import Control.Concurrent.Async.Lifted+import Control.Concurrent.STM.MonadIO import Control.Lens hiding ((<|), (??), (|>)) import Control.Monad.Trans.Resource @@ -58,7 +60,7 @@ } -getDataFileName :: (MonadIO m, Functor m) => Text -> m FilePath+getDataFileName :: (MonadIO m) => Text -> m FilePath getDataFileName file = io (Package.getDataFileName $ unpack file) -- | Main function to call in the configuration file. Cf @Hbro/Main.hs@ as an example.@@ -67,7 +69,7 @@ options <- parseOptions case options of- Left Rebuild -> Dyre.recompile >>= mapM_ putStrLn+ Left Rebuild -> Dyre.recompile >>= mapM_ (putStrLn . unpack) Left Version -> printVersions Right runOptions -> runResourceT . runThreadedLoggingT (runOptions^.logLevel_) $ Dyre.wrap (runOptions^.dyreMode_) (withAsyncBound guiThread . mainThread)@@ -93,7 +95,7 @@ socketURI <- getSocketURI options keySignal <- newSignal KeyMapPressed- config <- io . newTVarIO $ configuration settings+ config <- newTVar $ configuration settings flip runReaderT (config, ()) . withReaderT (mainView, )@@ -112,7 +114,7 @@ startUp settings - debug . ("Start-up configuration: \n" ++) . describe =<< Config.get id+ debug . ("Start-up configuration: \n" <>) . describe =<< Config.get id maybe goHome (load <=< getStartURI) (options^.startURI_) io $ wait uiThread@@ -121,21 +123,21 @@ -- | Return the list of available UI files (from configuration and package)-getUIFiles :: (MonadIO m, Functor m) => CliOptions -> m [FilePath]+getUIFiles :: (MonadIO m) => CliOptions -> m [FilePath] getUIFiles options = do fileFromConfig <- getAppUserDataDirectory "hbro" >/> "ui.xml" fileFromPackage <- getDataFileName "examples/ui.xml" return $ catMaybes [options^.uiFile_, Just fileFromConfig, Just fileFromPackage] -- | Return socket URI used by this instance-getSocketURI :: (MonadIO m, Functor m) => CliOptions -> m Text+getSocketURI :: (MonadIO m) => CliOptions -> m Text getSocketURI options = maybe getDefaultSocketURI (return . normalize) $ options^.socketPath_ where- normalize = ("ipc://" ++) . pack+ normalize = ("ipc://" <>) . pack getDefaultSocketURI = do dir <- pack <$> io getTemporaryDirectory uuid <- io (randomIO :: IO UUID)- return $ "ipc://" ++ dir ++ "/hbro-" ++ tshow uuid+ return $ "ipc://" <> dir <> "/hbro-" <> show uuid -- | 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://")@@ -144,12 +146,12 @@ fileURI <- io . doesFileExist $ show uri workingDir <- pack <$> io getCurrentDirectory - if fileURI then parseURIReference ("file://" ++ workingDir ++ "/" ++ tshow uri) else return uri+ if fileURI then parseURIReference ("file://" <> workingDir <> "/" <> show uri) else return uri -- maybe abort return =<< logErrors (parseURIReference fileURI') printVersions :: IO () printVersions = do (a, b, c) <- ZMQ.version- putStrLn $ "hbro-" ++ pack (showVersion Package.version)- putStrLn $ "compiled by " ++ pack compilerName ++ "-" ++ pack (showVersion compilerVersion)- putStrLn $ "using zeromq-" ++ intercalate "." (map tshow [a, b, c])+ putStrLn $ "hbro-" <> pack (showVersion Package.version)+ putStrLn $ "compiled by " <> pack compilerName <> "-" <> pack (showVersion compilerVersion)+ putStrLn $ "using zeromq-" <> ointercalate "." (map show [a, b, c])
library/Hbro/Clipboard.hs view
@@ -10,18 +10,18 @@ import Hbro.Logger import Hbro.Prelude +import Control.Concurrent.MVar.Lifted+ import Graphics.UI.Gtk.General.Clipboard import Graphics.UI.Gtk.General.General.Extended import Graphics.UI.Gtk.General.Selection -- }}} -data ClipboardException = EmptyClipboard SelectionTag deriving(Eq)--instance Exception ClipboardException+data ClipboardException = EmptyClipboard SelectionTag deriving(Eq, Show) -instance Show ClipboardException where- show (EmptyClipboard tag) = "Empty clipboard [" ++ show tag ++ "]"+instance Exception ClipboardException where+ displayException (EmptyClipboard tag) = "Empty clipboard [" <> show tag <> "]" -- | Write given 'Text' to the selection-primary clipboard@@ -31,7 +31,7 @@ -- | Write given text to the given clipboard write' :: (BaseIO m, MonadLogger m) => SelectionTag -> Text -> m () write' tag text = do- debug $ "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).
library/Hbro/Config.hs view
@@ -22,6 +22,7 @@ -- {{{ Imports import Hbro.Prelude +import Control.Concurrent.STM.MonadIO import Control.Lens hiding (set) import qualified Control.Lens as L (set) @@ -37,13 +38,13 @@ |] instance Describable Config where- describe c = "Home page = " ++ tshow (c^.homePage_)+ describe c = "Home page = " <> show (c^.homePage_) instance Default Config where- def = Config $ fromJust . N.parseURI $ "https://duckduckgo.com/"+ def = Config $ fromJust . N.parseURI $ "https://duckduckgo.com/" get :: (MonadIO m, MonadReader r m, Has (TVar Config) r) => Lens' Config a -> m a-get l = return . view l =<< atomically . readTVar =<< ask+get l = fmap (view l) (readTVar =<< ask) 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+set l v = void . (`modifyTVar` L.set l v) =<< ask
library/Hbro/Core.hs view
@@ -41,11 +41,15 @@ import Hbro.Config as Config import Hbro.Dyre--- import Hbro.Gui as Gui+import Hbro.Error import Hbro.Gui.MainView import Hbro.Logger import Hbro.Prelude as H +import Control.Concurrent.STM.MonadIO++import Data.IOData+ import Graphics.UI.Gtk.Gdk.Pixbuf (Pixbuf) import Graphics.UI.Gtk.General.General.Extended import Graphics.UI.Gtk.WebKit.WebDataSource@@ -105,7 +109,7 @@ load :: (MonadIO m, MonadLogger m, MonadReader r m, Has MainView r, MonadThrow m) => URI -> m () load uri = do- debug $ "Loading URI: " ++ tshow uri+ debug $ "Loading URI: " <> show uri -- void . logErrors $ do -- currentURI <- getURI -- guard (currentURI /= uri')@@ -113,7 +117,7 @@ -- load' uri' webview <- getWebView- gSync . webViewLoadUri webview $ show uri'+ gSync . webViewLoadUri webview $ (show uri' :: Text) where uri' = case uriScheme uri of@@ -137,10 +141,10 @@ -- goForward = load' =<< Browser.stepForward =<< getURI reload = gAsync . webViewReload =<< getWebView goBack = do- unlessM (gSync . webViewCanGoBack =<< getWebView) $ warning "Unable to go back."+ (gSync . webViewCanGoBack =<< getWebView) >>= (`unless` warning "Unable to go back.") gAsync . webViewGoBack =<< getWebView goForward = do- unlessM (gSync . webViewCanGoForward =<< getWebView) $ warning "Unable to go forward."+ (gSync . webViewCanGoForward =<< getWebView) >>= (`unless` warning "Unable to go forward.") gAsync . webViewGoForward =<< getWebView reloadBypassCache, stopLoading :: (MonadIO m, MonadLogger m, MonadReader r m, Has MainView r) => m ()@@ -152,11 +156,11 @@ -- {{{ searchText :: (MonadIO m, MonadLogger m, MonadReader r m, Has MainView r) => CaseSensitivity -> Direction -> Wrap -> Text -> m Bool searchText s d w text = do- debug $ "Searching text: " ++ text+ debug $ "Searching text: " <> text v <- getWebView gSync $ webViewSearchText v text (toBool s) (toBool d) (toBool w) -searchText_ :: (MonadIO m, Functor m, MonadLogger m, MonadReader r m, Has MainView r) => CaseSensitivity -> Direction -> Wrap -> Text -> m ()+searchText_ :: (MonadIO 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 :: (MonadIO m, MonadReader r m, Has MainView r) => m ()@@ -173,7 +177,7 @@ spawnHbro' :: (MonadIO m, MonadLogger m) => URI -> m () spawnHbro' uri = do executable <- getHbroExecutable- spawn (pack executable) ["-u", tshow uri]+ spawn (pack executable) ["-u", show uri] -- | Terminate the program. quit :: (MonadIO m) => m ()@@ -187,11 +191,11 @@ -- | Execute a javascript file on current webpage. executeJSFile :: (MonadIO m, MonadLogger m) => FilePath -> WebView -> m () executeJSFile filePath webView' = do- debug $ "Executing Javascript file: " ++ pack filePath+ debug $ "Executing Javascript file: " <> pack filePath script <- readFile filePath- let script' = asText . unwords . map (++ "\n") . lines $ script+ let script' = unwords . map (<> "\n") . lines $ script - gAsync $ webViewExecuteScript webView' script'+ gAsync $ webViewExecuteScript webView' (script' :: Text) -- }}} -- | Save current web page to a file,
library/Hbro/Defaults.hs view
@@ -11,6 +11,7 @@ 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@@ -25,6 +26,7 @@ import Hbro.Prelude import Hbro.WebView.Signals +import Control.Concurrent.STM.MonadIO import Control.Monad.Trans.Resource import Data.Map as Map hiding (foldl,@@ -57,9 +59,9 @@ defaultNewWindowHandler :: (MonadIO m, MonadLogger m) => URI -> m () defaultNewWindowHandler = spawnHbro' -defaultTitleChangedHandler :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader r m, Has Gtk.Builder r)+defaultTitleChangedHandler :: (MonadIO m, MonadLogger m, MonadReader r m, Has Gtk.Builder r) => Text -> m ()-defaultTitleChangedHandler title = getMainWindow >>= \w -> set w windowTitle ("hbro | " ++ title) >> return ()+defaultTitleChangedHandler title = getMainWindow >>= \w -> void (set w windowTitle $ "hbro | " <> title) -- /!\ 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.@@ -69,13 +71,13 @@ -- | List of default supported requests.-defaultCommandMap :: (God r m, MonadCatch m) => CommandMap m+defaultCommandMap :: (God r m) => CommandMap m defaultCommandMap = Map.fromList -- Get information- [ "GET_URI" >: \_arguments -> Right . tshow <$> getCurrentURI+ [ "GET_URI" >: \_arguments -> Right . show <$> getCurrentURI , "GET_TITLE" >: \_arguments -> Right <$> getPageTitle- , "GET_FAVICON_URI" >: \_arguments -> Right . tshow <$> getFaviconURI- , "GET_LOAD_PROGRESS" >: \_arguments -> Right . tshow <$> getLoadProgress+ , "GET_FAVICON_URI" >: \_arguments -> Right . show <$> getFaviconURI+ , "GET_LOAD_PROGRESS" >: \_arguments -> Right . show <$> getLoadProgress -- Trigger actions , "LOAD_URI" >: \arguments -> case arguments of uri:_ -> parseURIReference uri >>= load >> return (Right "OK")@@ -90,7 +92,7 @@ ] -defaultKeyMap :: (God r m, MonadCatch m) => KeyMap m+defaultKeyMap :: (God r m) => KeyMap m defaultKeyMap = Map.fromList -- Browse [ [_Alt .| _Left] >: goBack@@ -106,7 +108,7 @@ , [_Control .| _End] >: scrollV (Absolute 100) , [_Alt .| _Home] >: goHome -- Copy/paste- , [_Control .| _c] >: getCurrentURI >>= Clipboard.write . tshow+ , [_Control .| _c] >: getCurrentURI >>= Clipboard.write . show , [_Alt .| _c] >: getPageTitle >>= Clipboard.write , [_Control .| _v] >: Clipboard.read >>= parseURIReference >>= load , [_Alt .| _v] >: Clipboard.read >>= parseURIReference >>= spawnHbro'@@ -118,7 +120,7 @@ , [_Control .| _u] >: getWebView >>= \v -> toggle_ v webViewViewSourceMode -- Prompt , [_Control .| _o] >: uriPromptM "Open URI" "" >>= load- , [_Alt .| _o] >: getCurrentURI >>= \uri -> uriPromptM "Open URI " (tshow uri) >>= load+ , [_Alt .| _o] >: getCurrentURI >>= \uri -> uriPromptM "Open URI " (show uri) >>= load -- Search , [singleKey _slash] >: ipromptM "Search " "" (searchText_ CaseInsensitive Forward Wrap) , [_Control .| _f] >: ipromptM "Search " "" (searchText_ CaseInsensitive Forward Wrap)
library/Hbro/Dyre.hs view
@@ -21,6 +21,7 @@ import Config.Dyre.Paths import System.Directory+import System.IO -- }}} -- | How dynamic reconfiguration process should behave.@@ -35,11 +36,11 @@ describePaths = io $ do (a, b, c, d, e) <- getPaths baseParameters return . unlines $ map pack- [ "Current binary: " ++ a- , "Custom binary: " ++ b- , "Config file: " ++ c- , "Cache directory: " ++ d- , "Lib directory: " ++ e+ [ "Current binary: " <> a+ , "Custom binary: " <> b+ , "Config file: " <> c+ , "Cache directory: " <> d+ , "Lib directory: " <> e ] getHbroExecutable :: (MonadIO m) => m FilePath@@ -48,7 +49,7 @@ return a -- Dynamic reconfiguration settings-parameters :: (Functor m, MonadIO m, MonadLogger m, StM m () ~ ())+parameters :: (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@@ -56,7 +57,7 @@ } where main' (Left e) = error e main' (Right x) = do- debug . ("Dynamic reconfiguration paths:\n" ++) =<< describePaths+ debug . ("Dynamic reconfiguration paths:\n" <>) =<< describePaths void $ main x baseParameters :: Params (Either Text a)@@ -76,5 +77,5 @@ -- | Launch a recompilation of the configuration file recompile :: (MonadIO m) => m (Maybe Text) recompile = io $ do- customCompile baseParameters- map pack <$> getErrorString baseParameters+ customCompile baseParameters+ fmap pack <$> getErrorString baseParameters
library/Hbro/Error.hs view
@@ -6,8 +6,8 @@ -- {{{ Imports import Hbro.Prelude -import Control.Error.Util as X (hush, note)-import Control.Monad.Catch ()+import Control.Error.Util as X (hush, note)+import Control.Exception.Safe as X hiding (Handler) -- }}} failWith :: (MonadThrow m, Exception e) => Maybe a -> e -> m a
library/Hbro/Event.hs view
@@ -26,6 +26,7 @@ import Hbro.Prelude import Control.Concurrent.Async.Lifted+import Control.Concurrent.STM.MonadIO import Control.Concurrent.STM.TMChan import Control.Monad.Logger.Extended import Control.Monad.Trans.Resource@@ -47,11 +48,11 @@ type Handler m a = Input a -> m () instance (Event e) => Describable (Signal e) where- describe (Signal e _ _) = tshow e+ describe (Signal e _ _) = show 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 [])+newSignal e = Signal e <$> io newBroadcastTMChanIO <*> newTVar [] -- | Blocks until signal is received. waitFor :: (MonadIO m) => TMChan a -> m (Maybe a)@@ -60,9 +61,9 @@ -- | 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: "+ forM_ (describeInput e input) $ debug . ("Event triggered: " <>)+ handlers <- readTVar h+ when (null handlers) . forM_ (describeInput e input) $ debug . (<>) "No handler for event: " emit' signal input -- | Like 'emit', but doesn't log anything.@@ -83,16 +84,7 @@ -- | 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+addHandler signal f = addRecursiveHandler signal () $ const f -- | 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@@ -103,10 +95,10 @@ 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:)+ 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 . mapM release =<< atomically (readTVar handlers)+deleteHandlers (Signal _ _ handlers) = mapM_ release =<< readTVar handlers
library/Hbro/Gdk/KeyVal.hsc view
@@ -9,6 +9,7 @@ import Hbro.Prelude import Data.Char+import Data.Word import qualified Graphics.UI.Gtk.Gdk.Keys as Gtk @@ -23,8 +24,7 @@ -- | Single characters are returned as is. For other keys, the corresponding keyName wrapped into @\<\>@ is returned. instance Describable KeyVal where- describe (KeyVal key) = if length name < 2 then name else "<" ++ name ++ ">"- where name = Gtk.keyName key+ describe (KeyVal key) = if olength name < 2 then name else "<" <> name <> ">" where name = Gtk.keyName key keyVal, shortKeyVal, longKeyVal :: Parser KeyVal keyVal = spaces *> (shortKeyVal <|> longKeyVal)
library/Hbro/Gui.hs view
@@ -15,6 +15,7 @@ -- {{{ Imports import Graphics.UI.Gtk.WebKit.Extended () +import Hbro.Error import Hbro.Event import Hbro.Gui.Builder import Hbro.Gui.MainView hiding (initialize)@@ -25,7 +26,7 @@ import qualified Hbro.Gui.PromptBar as Prompt import Hbro.Gui.StatusBar import Hbro.Logger-import Hbro.Prelude hiding (on)+import Hbro.Prelude import Control.Lens.Getter import Control.Monad.Trans.Resource@@ -42,7 +43,7 @@ initialize :: (ControlIO m, Alternative m, MonadCatch m, MonadThreadedLogger m, MonadResource m) => FilePath -> m (Gtk.Builder, MainView, PromptBar, StatusBar, NotificationBar) initialize (pack -> file) = do- debug $ "Building GUI from " ++ file+ debug $ "Building GUI from " <> file builder <- gSync Gtk.builderNew gSync . Gtk.builderAddFromFile builder $ unpack file
library/Hbro/Gui/MainView.hs view
@@ -42,17 +42,16 @@ ) where -- {{{ Imports+import Hbro.Error import Hbro.Event import Hbro.Gui.Builder import Hbro.Keys as Keys import Hbro.Logger-import Hbro.Prelude hiding (on)+import Hbro.Prelude 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@@ -157,13 +156,13 @@ 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]+ putStrLn $ unlines [a, b, show 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)+ renderable <- webViewCanShowMimeType webView (mimetype :: Text) case (uri, renderable) of (Just _, True) -> webPolicyDecisionUse decision (Just _, _) -> webPolicyDecisionDownload decision@@ -209,7 +208,7 @@ render :: (MonadReader r m, Has MainView r, MonadIO m, MonadLogger m) => Text -> URI -> m () render page uri = do- debug $ "Rendering <" ++ tshow uri ++ ">"+ debug $ "Rendering <" <> show uri <> ">" -- loadString page uri =<< get' webView_ -- debug $ "Base URI: " ++ show (baseOf uri)@@ -217,19 +216,19 @@ loadString page (baseOf uri) =<< asks (view webView_) where baseOf uri' = uri' {- uriPath = unpack . (`snoc` '/') . intercalate "/" . initSafe . splitOn "/" . pack $ uriPath uri'+ uriPath = (`snoc` '/') . ointercalate "/" . initSafe . splitElem '/' $ uriPath uri' } -- | Set default settings-initSettings :: (MonadIO m, MonadLogger m, Functor m) => WebView -> m WebView+initSettings :: (MonadIO m, MonadLogger 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 webSettingsDefaultEncoding ("utf8" :: Text) set s webSettingsEnableDeveloperExtras False set s webSettingsEnableDomPaste False set s webSettingsEnableHtml5Database False@@ -245,7 +244,7 @@ set s webSettingsEnableSiteSpecificQuirks False set s webSettingsEnableXssAuditor False set s webSettingsJSCanOpenWindowAuto False- set s webSettingsMonospaceFontFamily (asText "inconsolata")+ set s webSettingsMonospaceFontFamily ("inconsolata" :: Text) set s webSettingsPrintBackgrounds True set s webSettingsResizableTextAreas True set s webSettingsSpellCheckingLang (Nothing :: Maybe Text)@@ -256,19 +255,19 @@ return webView -zoomIn, zoomOut :: (MonadIO m, Functor m, MonadReader r m, Has MainView r) => m ()+zoomIn, zoomOut :: (MonadIO 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, scrollV :: (MonadIO 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+ debug $ "Set scroll " <> show axis <> " = " <> show percentage adj <- getAdjustment axis $ mainView^.scrollWindow_ page <- get adj Gtk.adjustmentPageSize
library/Hbro/Gui/NotificationBar.hs view
@@ -38,7 +38,7 @@ asNotificationBar = id -- | A 'NotificationBar' can be built from an XML file.-buildFrom :: (MonadIO m, Functor m) => Gtk.Builder -> m NotificationBar+buildFrom :: (MonadIO m) => Gtk.Builder -> m NotificationBar buildFrom builder = NotificationBar <$> getWidget builder "notificationLabel" instance GObjectClass NotificationBar where@@ -59,8 +59,8 @@ logColor :: LogLevel -> Color logColor LevelError = red-logColor LevelWarn = yellow-logColor _ = gray+logColor LevelWarn = yellow+logColor _ = gray write :: (MonadIO m) => Text -> NotificationBar -> m NotificationBar write message = write' message gray
library/Hbro/Gui/PromptBar.hs view
@@ -40,13 +40,13 @@ import Hbro.Gdk.KeyVal import Hbro.Gui.Builder import Hbro.Logger-import Hbro.Prelude hiding (on)+import Hbro.Prelude import Control.Concurrent.Async.Lifted import Control.Lens.Getter import Control.Lens.TH import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Resource+import Control.Monad.Trans.Resource hiding(throwM) import Graphics.Rendering.Pango.Extended import Graphics.UI.Gtk.Abstract.Widget@@ -72,12 +72,12 @@ data Changed = Changed deriving(Show) instance Event Changed where type Input Changed = Text- describeInput _ = Just . (++) "Prompt value changed to: "+ 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: "+ describeInput _ = Just . (<>) "Prompt validated with value: " -- | No exported constructor, please use 'buildFrom' declareLenses [d|@@ -91,16 +91,14 @@ } |] -data PromptException = PromptInterrupted deriving(Eq)--instance Exception PromptException+data PromptException = PromptInterrupted deriving(Eq, Show) -instance Show PromptException where- show PromptInterrupted = "Prompt interrupted."+instance Exception PromptException where+ displayException PromptInterrupted = "Prompt interrupted." -- }}} -- | A 'PromptBar' can be built from an XML file.-buildFrom :: (ControlIO m, MonadLogger m, Applicative m) => Gtk.Builder -> m PromptBar+buildFrom :: (ControlIO m, MonadLogger m) => Gtk.Builder -> m PromptBar buildFrom builder = do entry <- getWidget builder entryName closedSignal <- newSignal Closed@@ -181,7 +179,7 @@ promptM a b = prompt a b =<< ask -iprompt :: (ControlIO m, MonadLogger m, MonadThrow m, MonadResource m)+iprompt :: (ControlIO m, MonadLogger m, MonadResource m) => Text -> Text -> (Text -> m ())@@ -197,13 +195,13 @@ close promptBar release update -ipromptM :: (ControlIO m, MonadResource m, MonadReader r m, Has PromptBar r, MonadLogger m, MonadThrow m)+ipromptM :: (ControlIO m, MonadResource m, MonadReader r m, Has PromptBar r, MonadLogger m) => Text -> Text -> (Text -> m ()) -> m () ipromptM a b c = iprompt a b c =<< ask -- | Same as 'prompt' for URI values-uriPrompt :: (ControlIO m, MonadLogger m, MonadThrow m, MonadResource m)+uriPrompt :: (ControlIO m, MonadLogger m, MonadResource m) => Text -> Text -> PromptBar@@ -223,14 +221,14 @@ parseURIReference =<< maybe (throwM PromptInterrupted) return (join $ hush result) -uriPromptM :: (ControlIO m, MonadReader r m, Has PromptBar r, MonadLogger m, MonadThrow m, MonadResource m)+uriPromptM :: (ControlIO m, MonadReader r m, Has PromptBar r, MonadLogger 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)+ debug $ "Is URI ? " <> show (isURIReference $ unpack v) gAsync $ widgetModifyText (promptBar^.entry_) StateNormal (if isURIReference (unpack v) then green else red)
library/Hbro/IPC.hs view
@@ -41,20 +41,20 @@ 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+ info $ "Opening IPC socket at: " <> uri io $ ZMQ.bind socket (unpack uri) fix $ \recurse -> do message <- receive socket- debug $ "Received command: " ++ message+ 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+ Just f -> either ("ERROR " <>) id <$> f arguments+ _ -> return "ERROR Unknown command"+ debug $ "Sending response: " <> show response send socket response recurse
library/Hbro/Keys.hs view
@@ -28,6 +28,7 @@ ) where -- {{{ Imports+import Hbro.Error import Hbro.Event import Hbro.Gdk.KeyVal import Hbro.Keys.Model ((.|))@@ -40,6 +41,7 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map+import Data.Set (Set) import qualified Data.Set as Set import qualified Graphics.UI.Gtk.Gdk.EventM as Gdk@@ -58,7 +60,7 @@ deriving instance Ord Gdk.Modifier instance Describable (Modifier, KeyVal) where- describe (m, k) = describe m ++ describe k+ describe (m, k) = describe m <> describe k newtype Modifier = Modifier (Set Gdk.Modifier) deriving(Eq) @@ -67,7 +69,7 @@ (Modifier a) `mappend` (Modifier b) = Modifier (a `mappend` b) instance Describable Modifier where- describe (Modifier x) = concatMap describe $ Set.toList x+ describe (Modifier x) = mconcat $ map describe $ Set.toList x instance Ord Modifier where compare = comparing describe @@ -96,7 +98,7 @@ type KeyStroke = Model.KeyStroke Modifier KeyVal instance Describable KeyStroke where- describe (Model.KeyStroke m k) = describe m ++ describe k+ describe (Model.KeyStroke m k) = describe m <> describe k keyStrokes :: Parser KeyStroke keyStrokes = do@@ -112,12 +114,12 @@ data KeyPressed = KeyPressed deriving(Show) instance Event KeyPressed where type Input KeyPressed = KeyStroke- describeInput _ stroke = Just $ "Key pressed: " ++ describe stroke+ describeInput _ stroke = Just $ "Key pressed: " <> describe stroke data KeyMapPressed = KeyMapPressed deriving(Show) instance Event KeyMapPressed where type Input KeyMapPressed = ([KeyStroke], Bool)- describeInput _ (strokes, _bound) = Just . unwords $ "Key pressed: " : (describe <$> strokes)+ describeInput _ (strokes, _bound) = Just $ "Key pressed: " <> unwords (describe <$> strokes) bindKeys :: (ControlIO m, MonadLogger m, MonadCatch m, MonadResource m)@@ -129,7 +131,7 @@ found = Map.lookup strokes keyMap reset = isJust found || all (not . NonEmpty.isPrefixOf strokesL) k - debug $ "Accumulated: " ++ unwords (map describe strokesL)+ debug $ "Accumulated: " <> unwords (map describe strokesL) emit output (strokesL, isJust found) async . logErrors $ fromMaybe doNothing found
library/Hbro/Keys/Model.hs view
@@ -29,7 +29,7 @@ deriving instance (Eq m, Eq k) => Eq (KeyStroke m k) deriving instance (Ord m, Ord k) => Ord (KeyStroke m k) -(.|) :: (Monoid modifier) => modifier -> key -> KeyStroke modifier key+(.|) :: modifier -> key -> KeyStroke modifier key (.|) = KeyStroke singleKey :: (Monoid m) => k -> KeyStroke m k
library/Hbro/Logger.hs view
@@ -23,14 +23,14 @@ import Hbro.Event import Hbro.Prelude hiding (runReaderT) +import Control.Exception.Safe import Control.Monad.Base-import Control.Monad.Catch import Control.Monad.Logger.Extended as X import Control.Monad.Reader import Control.Monad.Trans.Maybe import Control.Monad.Trans.Resource -import Data.Text (justifyLeft)+import qualified Data.Text as Text (justifyLeft) import Data.Text.Encoding import Data.Text.Encoding.Error @@ -87,7 +87,7 @@ 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+ addHandler loggerSignal $ \(_loc, _source, level, message) -> io . putStrLn . unpack $ formatLevel level <> " " <> message result <- flip runReaderT (loggerSignal, logLevel) $ unThreadedLoggingT f closeSignal' loggerSignal@@ -98,11 +98,11 @@ formatLevel LevelInfo = "INFO " formatLevel LevelWarn = "WARN " formatLevel LevelError = "ERROR"-formatLevel (LevelOther a) = justifyLeft 5 ' ' . take 5 $ tshow a+formatLevel (LevelOther a) = Text.justifyLeft 5 ' ' . take 5 $ show a -- | Like 'catchError', except that the error is automatically logged, then discarded. logErrors :: (ControlIO m, MonadLogger m, MonadCatch m) => m a -> m (Maybe a)-logErrors f = catchAll (Just <$> f) $ \e -> error (tshow e) >> return Nothing+logErrors f = catchAny (Just <$> f) $ \e -> error (show e) >> return Nothing -- | Like 'logErrors', but discards the result. logErrors_ :: (MonadLogger m, ControlIO m, MonadCatch m) => m a -> m ()
library/Hbro/Options.hs view
@@ -19,7 +19,7 @@ -- {{{ Imports import qualified Hbro.Dyre as Dyre import Hbro.Error-import Hbro.Prelude hiding ((<>))+import Hbro.Prelude import Control.Lens.Getter import Control.Lens.TH@@ -49,14 +49,14 @@ |] instance Describable CliOptions where- describe opts = unwords $ catMaybes- [ ("URI=" ++) . tshow <$> (opts^.startURI_)- , ("SOCKET=" ++) . pack <$> (opts^.socketPath_)- , ("UI=" ++) . pack <$> (opts^.uiFile_)- , Just . ("DYRE_MODE=" ++) . tshow $ opts^.dyreMode_- , if opts^.dyreDebug_ then Just "DYRE_DEBUG" else Nothing- , Just . ("LOG-LEVEL=" ++) . tshow $ opts^.logLevel_- ]+ describe opts = unwords $ catMaybes+ [ ("URI=" <>) . show <$> (opts^.startURI_)+ , ("SOCKET=" <>) . pack <$> (opts^.socketPath_)+ , ("UI=" <>) . pack <$> (opts^.uiFile_)+ , Just . ("DYRE_MODE=" <>) . show $ opts^.dyreMode_+ , if opts^.dyreDebug_ then Just "DYRE_DEBUG" else Nothing+ , Just . ("LOG-LEVEL=" <>) . show $ opts^.logLevel_+ ] instance Default CliOptions where def = CliOptions
library/Hbro/Prelude.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -13,6 +12,7 @@ , BaseIO , ControlIO -- * Generic aliases/shortcuts+ , show , (|:) , (>:) , io@@ -26,34 +26,48 @@ ) where -- {{{ Imports-import ClassyPrelude as X hiding (Builder (..),- MonadReader (..),- ReaderT (..),- defaultTimeLocale, error,- log, toList)- 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 as X (MonadPlus (..), forM_,+ forM_, guard, join, unless,+ void, when, (<=<), (>=>)) import Control.Monad.Base as X (MonadBase (..))+import Control.Monad.IO.Class as X (MonadIO (..)) import Control.Monad.Reader.Extended as X hiding (get) import Control.Monad.Trans.Control as X +import Data.ByteString as X (ByteString) 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 Data.Map as X (Map)+import Data.Maybe as X (fromJust, fromMaybe,+ isJust)+import Data.Monoid as X+import Data.MonoTraversable as X+import Data.Ord as X (comparing)+import Data.Sequences as X+import Data.String as X (IsString (..))+import Data.Text as X (Text) -import Safe as X (initSafe, tailSafe)+import qualified GHC.Show as Show --- import System.Posix.Process--- import System.Posix.Types--- }}}+import Prelude as X hiding (break, drop,+ dropWhile, error, filter,+ lines, readFile, replicate,+ reverse, show, span,+ splitAt, take, takeWhile,+ unlines, unwords, words,+ writeFile) +import Safe as X (initSafe, tailSafe)+import System.FilePath+-- }}} -- | Like 'Show', for 'Text' class Describable a where describe :: a -> Text@@ -66,6 +80,10 @@ type ControlIO m = (MonadBaseControl IO m, MonadIO m) -- {{{ Generic aliases/shortcuts+-- | Generic 'Show.show'+show :: (Show a, IsString b) => a -> b+show = fromString . Show.show+ -- | Build a 'NonEmpty' from the right (|:) :: [a] -> a -> NonEmpty a list |: e = NonEmpty.reverse (e :| reverse list)@@ -94,7 +112,7 @@ -- {{{ Lens util -- | Alias for 'mapMOf'-withM :: Profunctor p => Over p (WrappedMonad m) s t a b -> p a (m b) -> s -> m t+withM :: LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t withM = mapMOf withM_ :: Monad m => Over (->) (WrappedMonad m) s t a a -> (a -> m ()) -> s -> m t
library/Hbro/WebView/Signals.hs view
@@ -6,14 +6,14 @@ module Hbro.WebView.Signals where -- {{{ Imports+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 Hbro.Prelude -import Control.Monad.Catch import Control.Monad.Trans.Maybe import Data.Set as S hiding (map)@@ -23,7 +23,9 @@ 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)+ (Download,+ downloadGetSuggestedFilename,+ downloadGetUri) import Graphics.UI.Gtk.WebKit.Extended as W import Graphics.UI.Gtk.WebKit.WebNavigationAction import Graphics.UI.Gtk.WebKit.WebPolicyDecision@@ -38,17 +40,17 @@ data Download = Download deriving(Show) instance Event Download where type Input Download = (URI, Text, Maybe Int)- describeInput _ (uri, _, _) = Just $ "Requested download <" ++ tshow uri ++ ">"+ describeInput _ (uri, _, _) = Just $ "Requested download <" <> show uri <> ">" data LinkClicked = LinkClicked deriving(Show) instance Event LinkClicked where type Input LinkClicked = (URI, MouseButton)- describeInput _ (uri, _) = Just $ "Link clicked <" ++ tshow uri ++ ">"+ describeInput _ (uri, _) = Just $ "Link clicked <" <> show uri <> ">" data LinkHovered = LinkHovered deriving(Show) instance Event LinkHovered where type Input LinkHovered = (URI, Maybe Text)- describeInput _ (uri, _) = Just $ "Link hovered <" ++ tshow uri ++ ">"+ describeInput _ (uri, _) = Just $ "Link hovered <" <> show uri <> ">" data LinkUnhovered = LinkUnhovered deriving(Show) instance Event LinkUnhovered where@@ -61,7 +63,7 @@ data LoadFailed = LoadFailed deriving(Show) instance Event LoadFailed where type Input LoadFailed = (URI, GError)- describeInput _ (uri, e) = Just $ "Error loading <" ++ tshow uri ++ "> : " ++ tshow e+ describeInput _ (uri, e) = Just $ "Error loading <" <> show uri <> "> : " <> show e data LoadFinished = LoadFinished deriving(Show) instance Event LoadFinished where@@ -70,7 +72,7 @@ data LoadRequested = LoadRequested deriving(Show) instance Event LoadRequested where type Input LoadRequested = URI- describeInput _ uri = Just $ "Load requested <" ++ tshow uri ++ ">"+ describeInput _ uri = Just $ "Load requested <" <> show uri <> ">" data LoadStarted = LoadStarted deriving(Show) instance Event LoadStarted where@@ -79,12 +81,12 @@ data NewWindow = NewWindow deriving(Show) instance Event NewWindow where type Input NewWindow = URI- describeInput _ uri = Just $ "New window <" ++ tshow uri ++ ">"+ describeInput _ uri = Just $ "New window <" <> show uri <> ">" data ProgressChanged = ProgressChanged deriving(Show) instance Event ProgressChanged where type Input ProgressChanged = Int- describeInput _ percent = Just $ "Load progress: " ++ tshow percent ++ "%"+ describeInput _ percent = Just $ "Load progress: " <> show percent <> "%" data ResourceOpened = ResourceOpened deriving(Show) instance Event ResourceOpened where@@ -94,20 +96,20 @@ data TitleChanged = TitleChanged deriving(Show) instance Event TitleChanged where type Input TitleChanged = Text- describeInput _ = Just . (++) "Title changed to: "+ describeInput _ = Just . (<>) "Title changed to: " data URIChanged = URIChanged deriving(Show) instance Event URIChanged where type Input URIChanged = URI- describeInput _ = Just . (++) "URI changed to: " . tshow+ describeInput _ = Just . (<>) "URI changed to: " . show data ZoomLevelChanged = ZoomLevelChanged deriving(Show) instance Event ZoomLevelChanged where type Input ZoomLevelChanged = Float- describeInput _ value = Just $ "Zoom level changed to: " ++ tshow value+ describeInput _ value = Just $ "Zoom level changed to: " <> show value data ResourceAction = Load | Download' deriving(Show)-instance Describable ResourceAction where describe = tshow+instance Describable ResourceAction where describe = show attachDownload :: (ControlIO m, MonadCatch m, MonadLogger m)@@ -168,19 +170,19 @@ emit signal1 (uri, b) io $ webPolicyDecisionIgnore decision (WebNavigationReasonOther, _) -> do- debug $ "Navigation request to <" ++ tshow uri ++ ">"+ debug $ "Navigation request to <" <> show uri <> ">" io $ webPolicyDecisionUse decision (WebNavigationReasonBackForward, _) -> io $ webPolicyDecisionUse decision (WebNavigationReasonReload, _) -> io $ webPolicyDecisionUse decision (WebNavigationReasonFormSubmitted, _) -> do- debug $ "Form submitted to <" ++ tshow uri ++ ">"+ debug $ "Form submitted to <" <> show uri <> ">" io $ webPolicyDecisionUse decision _ -> do- debug $ "Navigation request [" ++ tshow reason ++ "] to <" ++ tshow uri ++ ">"+ debug $ "Navigation request [" <> show reason <> "] to <" <> show uri <> ">" emit signal2 uri io $ webPolicyDecisionIgnore decision- `catchAll` \e -> do- error (tshow e)+ `catchAny` \e -> do+ error (show e) io $ webPolicyDecisionUse decision return True@@ -221,11 +223,11 @@ -- 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 ++ ">"+-- debug $ "Opening resource [MIME type=" ++ mimetype ++ "] at <" <> show uri <> ">" -- -- io . waitForResult =<< -- emit signal (uri, mimetype) --- debug "debug" $ "decision made: " ++ tshow action+-- debug "debug" $ "decision made: " ++ show action -- case action of -- Just Load -> webPolicyDecisionUse decision -- Just Download' -> webPolicyDecisionDownload decision
library/Network/URI/Extended.hs view
@@ -26,8 +26,6 @@ parseURI uri = N.parseURI (unpack uri) `failWith` InvalidUri uri -data UriException = InvalidUri Text deriving(Eq)-instance Exception UriException--instance Show UriException where- show (InvalidUri t) = "Invalid URI: " ++ unpack t+data UriException = InvalidUri Text deriving(Eq, Show)+instance Exception UriException where+ displayException (InvalidUri t) = "Invalid URI: " ++ unpack t
library/System/Glib/Attributes/Extended.hs view
@@ -23,11 +23,11 @@ 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+ info $ "Set " <> show attribute <> " = " <> show 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_ :: (MonadIO m, MonadLogger m, Show a) => o -> Attr o a -> a -> m () set_ o a v = void $ set o a v -- * Utils@@ -38,12 +38,12 @@ 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_ :: (MonadIO m, MonadLogger 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_ :: (MonadIO m, MonadLogger m) => o -> Attr o Bool -> m () toggle_ object x = modify_ object x not
library/System/Process/Extended.hs view
@@ -6,8 +6,7 @@ -- {{{ Imports import Hbro.Logger--import ClassyPrelude+import Hbro.Prelude import System.Process -- }}}@@ -15,5 +14,5 @@ -- | 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)+ 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 }