diff --git a/hbro.cabal b/hbro.cabal --- a/hbro.cabal +++ b/hbro.cabal @@ -1,5 +1,5 @@ Name: hbro -Version: 1.6.0.0 +Version: 1.7.0.0 Synopsis: Minimal extensible web-browser Description: Cf README Homepage: https://github.com/k0ral/hbro @@ -39,7 +39,7 @@ -- http-conduit, -- http-conduit-browser, -- http-types, - lens >= 4.4, + microlens-platform, lifted-async >= 0.6, lifted-base >= 0.2.3.3, mtl >= 2.2, @@ -57,6 +57,7 @@ safe, semigroups, stm-chans, + template-haskell, text, -- text-icu, time >= 1.5, @@ -118,7 +119,7 @@ Executable hbro Build-depends: - hbro >= 1.5, + hbro >= 1.7, base == 4.* Main-is: Main.hs Hs-Source-Dirs: executable diff --git a/library/Hbro/Boot.hs b/library/Hbro/Boot.hs --- a/library/Hbro/Boot.hs +++ b/library/Hbro/Boot.hs @@ -24,13 +24,14 @@ import Control.Concurrent.Async.Lifted import Control.Concurrent.STM.MonadIO -import Control.Lens hiding ((<|), (??), (|>)) import Control.Monad.Trans.Resource import Data.UUID import Data.Version hiding (Version) import Graphics.UI.Gtk.General.General as Gtk + +import Lens.Micro.Platform import Network.URI.Extended diff --git a/library/Hbro/Config.hs b/library/Hbro/Config.hs --- a/library/Hbro/Config.hs +++ b/library/Hbro/Config.hs @@ -3,7 +3,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -- | General configuration parameters. -- The recommended way to import this module is: -- @ @@ -15,28 +14,27 @@ Config , homePage_ -- * Getter/setter - , get - , set + , Hbro.Config.get + , Hbro.Config.set ) where -- {{{ Imports import Hbro.Prelude -import Control.Concurrent.STM.MonadIO -import Control.Lens hiding (set) -import qualified Control.Lens as L (set) +import Control.Concurrent.STM.MonadIO +import Lens.Micro.Platform as Lens + import Network.URI (URI) import qualified Network.URI as N -- }}} -- | Custom settings provided by the user -declareLenses [d| - data Config = Config - { homePage_ :: URI - } - |] +data Config = Config URI +homePage_ :: Lens' Config URI +homePage_ f (Config a) = (\b -> Config b) <$> f a + instance Describable Config where describe c = "Home page = " <> show (c^.homePage_) @@ -47,4 +45,4 @@ 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 = void . (`modifyTVar` L.set l v) =<< ask +set l v = void . (`modifyTVar` Lens.set l v) =<< ask diff --git a/library/Hbro/Gui.hs b/library/Hbro/Gui.hs --- a/library/Hbro/Gui.hs +++ b/library/Hbro/Gui.hs @@ -28,7 +28,6 @@ import Hbro.Logger import Hbro.Prelude -import Control.Lens.Getter import Control.Monad.Trans.Resource import Graphics.Rendering.Pango.Enums @@ -37,6 +36,9 @@ 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 Lens.Micro.Platform + import System.Glib.Signals hiding (Signal) -- }}} diff --git a/library/Hbro/Gui/MainView.hs b/library/Hbro/Gui/MainView.hs --- a/library/Hbro/Gui/MainView.hs +++ b/library/Hbro/Gui/MainView.hs @@ -50,8 +50,6 @@ import Hbro.Prelude import Hbro.WebView.Signals -import Control.Lens hiding (set, snoc) - import qualified Graphics.UI.Gtk.Abstract.Container as Gtk import Graphics.UI.Gtk.Abstract.Widget import qualified Graphics.UI.Gtk.Builder as Gtk @@ -67,6 +65,8 @@ import Graphics.UI.Gtk.WebKit.WebPolicyDecision import Graphics.UI.Gtk.WebKit.WebSettings +import Lens.Micro.Platform hiding(set) + import Network.URI import System.Glib.Attributes.Extended @@ -78,29 +78,30 @@ instance Event Scrolled where describeInput _ _ = Just "Scrolled" -declareLenses [d| - data MainView = MainView - { scrollWindow_ :: ScrolledWindow -- ^ 'ScrolledWindow' containing the webview - , webView_ :: WebView - , downloadHandler_ :: Signal Download - , keyPressedHandler_ :: Signal KeyPressed - , linkClickedHandler_ :: Signal LinkClicked - , linkHoveredHandler_ :: Signal LinkHovered - , linkUnhoveredHandler_ :: Signal LinkUnhovered - , loadCommittedHandler_ :: Signal LoadCommitted - , loadFailedHandler_ :: Signal LoadFailed - , loadFinishedHandler_ :: Signal LoadFinished - , loadRequestedHandler_ :: Signal LoadRequested - , loadStartedHandler_ :: Signal LoadStarted - , newWindowHandler_ :: Signal NewWindow - , progressChangedHandler_ :: Signal ProgressChanged - -- , resourceOpenedHandlerL :: Signal ResourceOpened - , scrolledHandler_ :: Signal Scrolled - , titleChangedHandler_ :: Signal TitleChanged - , uriChangedHandler_ :: Signal URIChanged - , zoomLevelChangedHandler_ :: Signal ZoomLevelChanged - } - |] +data MainView = MainView + { _scrollWindow :: ScrolledWindow -- ^ 'ScrolledWindow' containing the webview + , _webView :: WebView + , _downloadHandler :: Signal Download + , _keyPressedHandler :: Signal KeyPressed + , _linkClickedHandler :: Signal LinkClicked + , _linkHoveredHandler :: Signal LinkHovered + , _linkUnhoveredHandler :: Signal LinkUnhovered + , _loadCommittedHandler :: Signal LoadCommitted + , _loadFailedHandler :: Signal LoadFailed + , _loadFinishedHandler :: Signal LoadFinished + , _loadRequestedHandler :: Signal LoadRequested + , _loadStartedHandler :: Signal LoadStarted + , _newWindowHandler :: Signal NewWindow + , _progressChangedHandler :: Signal ProgressChanged + -- , resourceOpenedHandler :: Signal ResourceOpened + , _scrolledHandler :: Signal Scrolled + , _titleChangedHandler :: Signal TitleChanged + , _uriChangedHandler :: Signal URIChanged + , _zoomLevelChangedHandler :: Signal ZoomLevelChanged + } + + +makeLensesWith (lensRules & lensField .~ lensGen) ''MainView -- * Commonly used getters diff --git a/library/Hbro/Gui/PromptBar.hs b/library/Hbro/Gui/PromptBar.hs --- a/library/Hbro/Gui/PromptBar.hs +++ b/library/Hbro/Gui/PromptBar.hs @@ -43,8 +43,6 @@ 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 hiding(throwM) @@ -58,6 +56,8 @@ import Graphics.UI.Gtk.General.General.Extended import Graphics.UI.Gtk.Layout.HBox +import Lens.Micro.Platform + import Network.URI.Extended import System.Glib.Attributes.Extended @@ -80,17 +80,17 @@ describeInput _ = Just . (<>) "Prompt validated with value: " -- | No exported constructor, please use 'buildFrom' -declareLenses [d| - data PromptBar = PromptBar - { box_ :: HBox - , description_ :: Label - , entry_ :: Entry - , changed_ :: Signal Changed - , closed_ :: Signal Closed - , validated_ :: Signal Validated - } - |] +data PromptBar = PromptBar + { _box :: HBox + , _description :: Label + , _entry :: Entry + , _changed :: Signal Changed + , _closed :: Signal Closed + , _validated :: Signal Validated + } +makeLensesWith (lensRules & lensField .~ lensGen) ''PromptBar + data PromptException = PromptInterrupted deriving(Eq, Show) instance Exception PromptException where @@ -125,20 +125,26 @@ boxName = "promptBox" initialize :: (MonadIO m) => PromptBar -> m PromptBar -initialize = - withM_ description_ (gAsync . (`labelSetAttributes` [allItalic, allBold])) - >=> withM_ description_ (gAsync . (`labelSetAttributes` [AttrForeground {paStart = 0, paEnd = -1, paColor = gray}])) - >=> withM_ entry_ (gAsync . (\e -> widgetModifyBase e StateNormal black)) - >=> withM_ entry_ (gAsync . (\e -> widgetModifyText e StateNormal gray)) +initialize promptBar = do + mapM gAsync + [ labelSetAttributes (promptBar ^. description_) [allItalic, allBold] + , labelSetAttributes (promptBar ^. description_) [AttrForeground {paStart = 0, paEnd = -1, paColor = gray}] + , widgetModifyBase (promptBar ^. entry_) StateNormal black + , widgetModifyText (promptBar ^. entry_) StateNormal gray + ] + return promptBar open :: (MonadIO m) => Text -> Text -> PromptBar -> m PromptBar -open description defaultText = - withM_ description_ (gAsync . (`labelSetText` description)) - >=> withM_ entry_ (gAsync . (`entrySetText` defaultText)) - >=> withM_ box_ (gAsync . widgetShow) - >=> withM_ entry_ (gAsync . widgetGrabFocus) - >=> withM_ entry_ (gAsync . (`editableSetPosition` (-1))) +open description defaultText promptBar = do + mapM gAsync + [ labelSetText (promptBar ^. description_) description + , entrySetText (promptBar ^. entry_) defaultText + , widgetShow $ promptBar ^. box_ + , widgetGrabFocus $ promptBar ^. entry_ + , editableSetPosition (promptBar ^. entry_) (-1) + ] + return promptBar close :: (ControlIO m, MonadLogger m) => PromptBar -> m PromptBar close promptBar = do @@ -151,8 +157,13 @@ -- | Close prompt, that is: clean its content, signals and callbacks clean :: (ControlIO m) => PromptBar -> m PromptBar -clean = withM_ entry_ (gAsync . (`widgetRestoreText` StateNormal)) - >=> withM_ entry_ (gAsync . (\e -> widgetModifyText e StateNormal gray)) +clean promptBar = do + mapM gAsync + [ widgetRestoreText (promptBar ^. entry_) StateNormal + , widgetModifyText (promptBar ^. entry_) StateNormal gray + ] + return promptBar + -- {{{ Prompts diff --git a/library/Hbro/Options.hs b/library/Hbro/Options.hs --- a/library/Hbro/Options.hs +++ b/library/Hbro/Options.hs @@ -21,10 +21,10 @@ import Hbro.Error import Hbro.Prelude -import Control.Lens.Getter -import Control.Lens.TH import Control.Monad.Logger +import Lens.Micro.Platform + import Network.URI import Options.Applicative.Builder @@ -37,16 +37,16 @@ data Command = Rebuild | Version -- | Available options -declareLenses [d| - data CliOptions = CliOptions - { startURI_ :: Maybe URI - , socketPath_ :: Maybe FilePath - , uiFile_ :: Maybe FilePath - , dyreMode_ :: Dyre.Mode - , dyreDebug_ :: Bool - , logLevel_ :: LogLevel - } deriving(Eq) - |] +data CliOptions = CliOptions + { _startURI :: Maybe URI + , _socketPath :: Maybe FilePath + , _uiFile :: Maybe FilePath + , _dyreMode :: Dyre.Mode + , _dyreDebug :: Bool + , _logLevel :: LogLevel + } deriving(Eq) + +makeLensesWith (lensRules & lensField .~ lensGen) ''CliOptions instance Describable CliOptions where describe opts = unwords $ catMaybes diff --git a/library/Hbro/Prelude.hs b/library/Hbro/Prelude.hs --- a/library/Hbro/Prelude.hs +++ b/library/Hbro/Prelude.hs @@ -20,8 +20,7 @@ , abort , doNothing -- * Lens util - , withM - , withM_ + , lensGen , fwd ) where @@ -30,7 +29,6 @@ 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, (<=<), (>=>)) @@ -57,6 +55,10 @@ import qualified GHC.Show as Show +import Language.Haskell.TH.Syntax + +import Lens.Micro.Platform + import Prelude as X hiding (break, drop, dropWhile, error, filter, lines, readFile, replicate, @@ -111,12 +113,10 @@ -- }}} -- {{{ Lens util --- | Alias for 'mapMOf' -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 -withM_ l f = mapMOf l (fwd f) +-- | Lens field generator +lensGen _ _ n = case nameBase n of + '_':x -> [TopName (mkName $ x ++ "_")] + _ -> [] fwd :: (Monad m) => (a -> m ()) -> a -> m a fwd f x = f x >> return x