diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +# 3.0.0 + +## Breaking Changes + + * Taffybar has replaced gtk2hs with gi-gtk everywhere. All widgets must now be + created with gi-gtk. + # 2.0.0 ## Breaking Changes diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,8 +2,7 @@ ![https://github.com/taffybar/taffybar/blob/master/doc/screenshot.png](https://raw.githubusercontent.com/taffybar/taffybar/master/doc/screenshot.png) -Taffybar is a gtk+3 [(through gtk2hs and -gi-gtk)](https://github.com/taffybar/taffybar/issues/256) based desktop +Taffybar is a gtk+3 [(through gi-gtk)](https://github.com/taffybar/taffybar/issues/256) based desktop information bar, intended primarily for use with XMonad, though it can also function alongside other EWMH compliant window managers. It is similar in spirit to xmobar, but it differs in that it gives up some simplicity for a reasonable @@ -72,17 +71,6 @@ documentation](https://hackage.haskell.org/package/taffybar). You can find a list of available widgets [here](http://hackage.haskell.org/package/taffybar-2.0.0/docs/System-Taffybar-Widget.html) - -Development Status ------------------- - -Taffybar has recently undergone a lot changes recently with the release of -[2.0.0](https://github.com/taffybar/taffybar/releases/tag/v2.0.0), but it's API -should be pretty stable moving forward, with the exception of the ongoing gi-gtk -migration (see [#256](https://github.com/taffybar/taffybar/issues/256). Though -it does/will involve significant code changes, this migration should be pretty -transparent, especially for users who don't do any advanced widget customization -(i.e. that involves actually directly importing gtk2hs). Contributing ------------ diff --git a/src/System/Taffybar.hs b/src/System/Taffybar.hs --- a/src/System/Taffybar.hs +++ b/src/System/Taffybar.hs @@ -36,10 +36,13 @@ -- -- Below is a fairly typical example: -- + -- > {-# LANGUAGE OverloadedStrings #-} -- > import System.Taffybar + -- > import System.Taffybar.Information.CPU -- > import System.Taffybar.SimpleConfig -- > import System.Taffybar.Widget - -- > import System.Taffybar.Information.CPU + -- > import System.Taffybar.Widget.Generic.Graph + -- > import System.Taffybar.Widget.Generic.PollingGraph -- > -- > cpuCallback = do -- > (_, systemLoad, totalLoad) <- cpuLoad @@ -105,9 +108,9 @@ import qualified Config.Dyre.Params as Dyre import Control.Monad import qualified Data.GI.Gtk.Threading as GIThreading -import qualified Graphics.UI.Gtk as Gtk -import Graphics.UI.Gtk.General.CssProvider -import qualified Graphics.UI.Gtk.General.StyleContext as Gtk +import qualified Data.Text as T +import qualified GI.Gdk as Gdk +import qualified GI.Gtk as Gtk import Graphics.X11.Xlib.Misc import System.Directory import System.Environment.XDG.BaseDir ( getUserConfigFile ) @@ -151,19 +154,19 @@ dataDir <- getDataDir return (dataDir name) -startCSS :: IO CssProvider +startCSS :: IO Gtk.CssProvider startCSS = do -- Override the default GTK theme path settings. This causes the -- bar (by design) to ignore the real GTK theme and just use the -- provided minimal theme to set the background and text colors. -- Users can override this default. - taffybarProvider <- cssProviderNew + taffybarProvider <- Gtk.cssProviderNew let loadIfExists filePath = doesFileExist filePath >>= - flip when (cssProviderLoadFromPath taffybarProvider filePath) + flip when (Gtk.cssProviderLoadFromPath taffybarProvider (T.pack filePath)) loadIfExists =<< getDefaultConfigFile "taffybar.css" loadIfExists =<< getUserConfigFile "taffybar" "taffybar.css" - Just scr <- Gtk.screenGetDefault + Just scr <- Gdk.screenGetDefault Gtk.styleContextAddProviderForScreen scr taffybarProvider 800 return taffybarProvider @@ -176,10 +179,10 @@ startTaffybar :: TaffybarConfig -> IO () startTaffybar config = do _ <- initThreads - _ <- Gtk.initGUI - Gtk.postGUIAsync GIThreading.setCurrentThreadAsGUIThread + _ <- Gtk.init Nothing + GIThreading.setCurrentThreadAsGUIThread _ <- startCSS _ <- buildContext config - Gtk.mainGUI + Gtk.main return () diff --git a/src/System/Taffybar/Compat/GtkLibs.hs b/src/System/Taffybar/Compat/GtkLibs.hs deleted file mode 100644 --- a/src/System/Taffybar/Compat/GtkLibs.hs +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : System.Taffybar.Compat.GtkLibs --- Copyright : (c) Ivan A. Malison --- License : BSD3-style (see LICENSE) --- --- Maintainer : Ivan A. Malison --- Stability : unstable --- Portability : unportable ------------------------------------------------------------------------------ -module System.Taffybar.Compat.GtkLibs where - -import Control.Monad.IO.Class -import Data.GI.Base.ManagedPtr -import Foreign.ForeignPtr -import Foreign.Ptr -import qualified GI.GdkPixbuf.Objects.Pixbuf as PB -import qualified GI.Gtk -import qualified Graphics.UI.Gtk as Gtk -import qualified Graphics.UI.Gtk.Types as Gtk -import System.Glib.GObject - -fromGIPixBuf :: MonadIO m => PB.Pixbuf -> m Gtk.Pixbuf -fromGIPixBuf (PB.Pixbuf pbManagedPtr) = liftIO $ - wrapNewGObject Gtk.mkPixbuf (castPtr <$> disownManagedPtr pbManagedPtr) - -fromGIWidget' - :: (MonadIO m, GObjectClass a) - => (ForeignPtr a -> a, FinalizerPtr a) - -> GI.Gtk.ManagedPtr b - -> m a -fromGIWidget' mk2hs giWidget = liftIO $ - wrapNewGObject mk2hs (castPtr <$> disownManagedPtr giWidget) - -toGIWidget' - :: MonadIO m - => (GI.Gtk.ManagedPtr a1 -> b) -> (t -> ForeignPtr a2) -> t -> m b -toGIWidget' mkGI un2hs gtk2hsWidget = liftIO $ do - fPtr <- withForeignPtr (un2hs gtk2hsWidget) $ - flip GI.Gtk.newManagedPtr (return ()) . castPtr - return $! mkGI fPtr - -fromGIWidget :: MonadIO m => GI.Gtk.Widget -> m Gtk.Widget -fromGIWidget (GI.Gtk.Widget wManagedPtr) = fromGIWidget' Gtk.mkWidget wManagedPtr - -toGIWidget :: MonadIO m => Gtk.Widget -> m GI.Gtk.Widget -toGIWidget = toGIWidget' GI.Gtk.Widget Gtk.unWidget - -toGIWindow :: MonadIO m => Gtk.Window -> m GI.Gtk.Window -toGIWindow = toGIWidget' GI.Gtk.Window Gtk.unWindow - -fromGIImage :: MonadIO m => GI.Gtk.Image -> m Gtk.Image -fromGIImage (GI.Gtk.Image wManagedPtr) = fromGIWidget' Gtk.mkImage wManagedPtr - -toGIImage :: MonadIO m => Gtk.Image -> m GI.Gtk.Image -toGIImage = toGIWidget' GI.Gtk.Image Gtk.unImage diff --git a/src/System/Taffybar/Context.hs b/src/System/Taffybar/Context.hs --- a/src/System/Taffybar/Context.hs +++ b/src/System/Taffybar/Context.hs @@ -36,12 +36,10 @@ import Data.Unique import qualified GI.Gdk import qualified GI.GdkX11 as GdkX11 -import qualified GI.Gtk +import qualified GI.Gtk as Gtk import Graphics.UI.GIGtkStrut -import Graphics.UI.Gtk as Gtk import StatusNotifier.TransparentWindow import System.Log.Logger -import System.Taffybar.Compat.GtkLibs import System.Taffybar.Information.SafeX11 import System.Taffybar.Information.X11DesktopInfo import System.Taffybar.Util @@ -166,24 +164,22 @@ printf "Building bar window with StrutConfig: %s" $ show $ strutConfig barConfig - window <- Gtk.windowNew + window <- Gtk.windowNew Gtk.WindowTypeToplevel box <- Gtk.hBoxNew False $ fromIntegral $ widgetSpacing barConfig - _ <- widgetSetClass box "taffy-box" + _ <- widgetSetClassGI box "taffy-box" centerBox <- Gtk.hBoxNew False $ fromIntegral $ widgetSpacing barConfig - Gtk.boxSetCenterWidget box centerBox + Gtk.boxSetCenterWidget box (Just centerBox) - -- XXX: This conversion could leak memory - giWindow <- toGIWindow window - setupStrutWindow (strutConfig barConfig) giWindow + setupStrutWindow (strutConfig barConfig) window Gtk.containerAdd window box - _ <- widgetSetClass window "taffy-window" + _ <- widgetSetClassGI window "taffy-window" let addWidgetWith widgetAdd buildWidget = runReaderT buildWidget thisContext >>= widgetAdd - addToStart widget = Gtk.boxPackStart box widget Gtk.PackNatural 0 - addToEnd widget = Gtk.boxPackEnd box widget Gtk.PackNatural 0 - addToCenter widget = Gtk.boxPackStart centerBox widget Gtk.PackNatural 0 + addToStart widget = Gtk.boxPackStart box widget False False 0 + addToEnd widget = Gtk.boxPackEnd box widget False False 0 + addToCenter widget = Gtk.boxPackStart centerBox widget False False 0 logIO DEBUG "Building start widgets" mapM_ (addWidgetWith addToStart) (startWidgets barConfig) @@ -192,22 +188,22 @@ logIO DEBUG "Building end widgets" mapM_ (addWidgetWith addToEnd) (endWidgets barConfig) - makeWindowTransparent giWindow + makeWindowTransparent window logIO DEBUG "Showing window" - widgetShow window - widgetShow box - widgetShow centerBox + Gtk.widgetShow window + Gtk.widgetShow box + Gtk.widgetShow centerBox runX11Context context () $ void $ runMaybeT $ do - gdkWindow <- MaybeT $ GI.Gtk.widgetGetWindow giWindow + gdkWindow <- MaybeT $ Gtk.widgetGetWindow window xid <- GdkX11.x11WindowGetXid gdkWindow lift $ doLowerWindow (fromIntegral xid) return window refreshTaffyWindows :: TaffyIO () -refreshTaffyWindows = liftReader Gtk.postGUIAsync $ do +refreshTaffyWindows = liftReader postGUIASync $ do logT DEBUG "Refreshing windows" ctx <- ask windowsVar <- asks existingWindows @@ -217,12 +213,10 @@ barConfigs <- join $ asks getBarConfigs let currentConfigs = map sel1 currentWindows - (_, newConfs) = partition (`elem` currentConfigs) barConfigs + newConfs = filter (`notElem` currentConfigs) barConfigs (remainingWindows, removedWindows) = partition ((`elem` barConfigs) . sel1) currentWindows - setPropertiesFromPair (barConf, window) = - toGIWindow window >>= - setupStrutWindow (strutConfig barConf) + setPropertiesFromPair (barConf, window) = setupStrutWindow (strutConfig barConf) window newWindowPairs <- lift $ do logIO DEBUG $ printf "removedWindows: %s" $ diff --git a/src/System/Taffybar/Information/DiskIO.hs b/src/System/Taffybar/Information/DiskIO.hs --- a/src/System/Taffybar/Information/DiskIO.hs +++ b/src/System/Taffybar/Information/DiskIO.hs @@ -31,7 +31,7 @@ getDiskInfo = getParsedInfo "/proc/diskstats" parse parse :: String -> [(String, [Int])] -parse = mapMaybe (tuplize . (drop 2 . words)) . lines +parse = mapMaybe (tuplize . drop 2 . words) . lines tuplize :: [String] -> Maybe (String, [Int]) tuplize s = do diff --git a/src/System/Taffybar/Information/EWMHDesktopInfo.hs b/src/System/Taffybar/Information/EWMHDesktopInfo.hs --- a/src/System/Taffybar/Information/EWMHDesktopInfo.hs +++ b/src/System/Taffybar/Information/EWMHDesktopInfo.hs @@ -26,11 +26,10 @@ , X11Window -- re-exported from X11DesktopInfo , X11WindowHandle , focusWindow - , getActiveWindowTitle + , getActiveWindow , getCurrentWorkspace , getVisibleWorkspaces , getWindowClass - , getWindowHandles , getWindowIconsData , getWindowTitle , getWindows @@ -86,8 +85,6 @@ , ewmhPixelsARGB :: Ptr PixelsWordType } deriving (Show, Eq) -noFocus :: String -noFocus = "..." -- | Retrieve the index of the current workspace in the desktop, -- starting from 0. @@ -193,32 +190,17 @@ | otherwise = (thisIcon :) <$> parseIcons newSize newArr -- Keep going getRes $ totalSize - fromIntegral (thisSize + 2) -withActiveWindow :: (X11Window -> X11Property String) -> X11Property String -withActiveWindow getProp = do - awt <- readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW" - let w = listToMaybe $ filter (>0) awt - maybe (return noFocus) getProp w - --- | Get the title of the currently focused window. -getActiveWindowTitle :: X11Property String -getActiveWindowTitle = withActiveWindow getWindowTitle +-- Get the window that currently has focus if such a window exists +getActiveWindow :: X11Property (Maybe X11Window) +getActiveWindow = + listToMaybe . filter (> 0) <$> readAsListOfWindow Nothing "_NET_ACTIVE_WINDOW" -- | Return a list of all windows getWindows :: X11Property [X11Window] getWindows = readAsListOfWindow Nothing "_NET_CLIENT_LIST" --- | Return a list of X11 window handles, one for each window open. Refer to the --- documentation of 'X11WindowHandle' for details on the structure returned. -getWindowHandles :: X11Property [X11WindowHandle] -getWindowHandles = do - windows <- getWindows - workspaces <- mapM getWorkspace windows - wtitles <- mapM getWindowTitle windows - wclasses <- mapM getWindowClass windows - return $ zip (zip3 workspaces wtitles wclasses) windows - --- | Return the index (starting from 0) of the workspace on which the --- given window is being displayed. +-- | Return the index (starting from 0) of the workspace on which the given +-- window is being displayed. getWorkspace :: X11Window -> X11Property WorkspaceIdx getWorkspace window = WSIdx <$> readAsInt (Just window) "_NET_WM_DESKTOP" diff --git a/src/System/Taffybar/SimpleConfig.hs b/src/System/Taffybar/SimpleConfig.hs --- a/src/System/Taffybar/SimpleConfig.hs +++ b/src/System/Taffybar/SimpleConfig.hs @@ -19,12 +19,14 @@ ) where import qualified Control.Concurrent.MVar as MV +import Control.Monad import Control.Monad.Trans.Class import Data.List import Data.Maybe import Data.Unique +import qualified GI.Gtk as Gtk +import GI.Gdk import Graphics.UI.GIGtkStrut -import Graphics.UI.Gtk as Gtk import System.Taffybar.Information.X11DesktopInfo import System.Taffybar import qualified System.Taffybar.Context as BC (BarConfig(..)) @@ -135,7 +137,8 @@ simpleTaffybar conf = dyreTaffybar $ toTaffyConfig conf getMonitorCount :: IO Int -getMonitorCount = screenGetDefault >>= maybe (return 0) screenGetNMonitors +getMonitorCount = + fromIntegral <$> (screenGetDefault >>= maybe (return 0) (screenGetDisplay >=> displayGetNMonitors)) -- | Display a taffybar window on all monitors. useAllMonitors :: TaffyIO [Int] diff --git a/src/System/Taffybar/Util.hs b/src/System/Taffybar/Util.hs --- a/src/System/Taffybar/Util.hs +++ b/src/System/Taffybar/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Util @@ -22,7 +23,11 @@ import Control.Monad.Trans.Reader import Data.Either.Combinators import Data.GI.Base.GError +import qualified Data.GI.Gtk.Threading as Gtk +import qualified Data.Text as T import Data.Tuple.Sequence +import GI.GLib.Constants +import GI.Gdk (threadsAddIdle) import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk import System.Exit (ExitCode (..)) import System.Log.Logger @@ -59,10 +64,15 @@ maybeToEither = flip maybe Right . Left truncateString :: Int -> String -> String -truncateString n xs - | length xs <= n = xs - | otherwise = take n xs ++ "…" +truncateString n incoming + | length incoming <= n = incoming + | otherwise = take n incoming ++ "…" +truncateText :: Int -> T.Text -> T.Text +truncateText n incoming + | T.length incoming <= n = incoming + | otherwise = T.append (T.take n incoming) "…" + runCommandFromPath :: MonadIO m => [String] -> m (Either String String) runCommandFromPath = runCommand "/usr/bin/env" @@ -94,8 +104,9 @@ maybeTCombine a b = runMaybeT $ MaybeT a <|> MaybeT b infixl 3 <||> -(<||>) :: Monad m => - (t -> m (Maybe a)) -> (t -> m (Maybe a)) -> t -> m (Maybe a) +(<||>) :: + Monad m => + (t -> m (Maybe a)) -> (t -> m (Maybe a)) -> t -> m (Maybe a) a <||> b = combineOptions where combineOptions v = maybeTCombine (a v) (b v) @@ -125,3 +136,13 @@ logM "System.Taffybar.WindowIcon" WARNING $ printf "Failed to load icon from filepath %s" filepath return $ rightToMaybe result + +postGUIASync action = + threadsAddIdle PRIORITY_DEFAULT_IDLE (action >> return False) >> return () + +-- XXX: This has serious problems becuase it will cause a hang if it is used +-- when already on the UI Thread +postGUISync action = do + ans <- newEmptyMVar + threadsAddIdle PRIORITY_DEFAULT_IDLE $ action >>= putMVar ans >> return False + takeMVar ans diff --git a/src/System/Taffybar/Widget/Battery.hs b/src/System/Taffybar/Widget/Battery.hs --- a/src/System/Taffybar/Widget/Battery.hs +++ b/src/System/Taffybar/Widget/Battery.hs @@ -24,16 +24,14 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Reader -import Data.GI.Gtk.Threading import Data.Int (Int64) import qualified Data.Text as T import GI.Gtk -import qualified Graphics.UI.Gtk as Gtk2hs import Prelude import StatusNotifier.Tray (scalePixbufToSize) -import System.Taffybar.Compat.GtkLibs import System.Taffybar.Context import System.Taffybar.Information.Battery +import System.Taffybar.Util import System.Taffybar.Widget.Generic.AutoSizeImage import System.Taffybar.Widget.Generic.ChannelWidget import Text.Printf @@ -74,7 +72,7 @@ in BWI {seconds = battTime, percent = battPctNum, status = battStatus} -- | Given (maybe summarized) battery info and format: provides the string to display -formatBattInfo :: BatteryWidgetInfo -> String -> String +formatBattInfo :: BatteryWidgetInfo -> String -> T.Text formatBattInfo info fmt = let tpl = newSTMP fmt tpl' = setManyAttrib [ ("percentage", (show . percent) info) @@ -89,12 +87,11 @@ -- charged/discharged. textBatteryNew :: String -- ^ Display format - -> TaffyIO Gtk2hs.Widget -textBatteryNew format = fromGIWidget =<< do + -> TaffyIO Widget +textBatteryNew format = do chan <- getDisplayBatteryChan ctx <- ask - let getLabelText info = - T.pack $ formatBattInfo (getBatteryWidgetInfo info) format + let getLabelText info = formatBattInfo (getBatteryWidgetInfo info) format getBatteryInfoIO = runReaderT getDisplayBatteryInfo ctx liftIO $ do label <- getLabelText <$> getBatteryInfoIO >>= labelNew . Just @@ -106,8 +103,8 @@ themeLoadFlags :: [IconLookupFlags] themeLoadFlags = [IconLookupFlagsGenericFallback, IconLookupFlagsUseBuiltin] -batteryIconNew :: TaffyIO Gtk2hs.Widget -batteryIconNew = fromGIWidget =<< do +batteryIconNew :: TaffyIO Widget +batteryIconNew = do chan <- getDisplayBatteryChan ctx <- ask liftIO $ do diff --git a/src/System/Taffybar/Widget/CPUMonitor.hs b/src/System/Taffybar/Widget/CPUMonitor.hs --- a/src/System/Taffybar/Widget/CPUMonitor.hs +++ b/src/System/Taffybar/Widget/CPUMonitor.hs @@ -16,7 +16,7 @@ import Control.Monad.IO.Class import Data.IORef -import Graphics.UI.Gtk +import qualified GI.Gtk import System.Taffybar.Information.CPU2 (getCPUInfo) import System.Taffybar.Information.StreamInfo (getAccLoad) import System.Taffybar.Widget.Generic.PollingGraph @@ -29,7 +29,7 @@ => GraphConfig -- ^ Configuration data for the Graph. -> Double -- ^ Polling period (in seconds). -> String -- ^ Name of the core to watch (e.g. \"cpu\", \"cpu0\"). - -> m Widget + -> m GI.Gtk.Widget cpuMonitorNew cfg interval cpu = liftIO $ do info <- getCPUInfo cpu sample <- newIORef info diff --git a/src/System/Taffybar/Widget/CommandRunner.hs b/src/System/Taffybar/Widget/CommandRunner.hs --- a/src/System/Taffybar/Widget/CommandRunner.hs +++ b/src/System/Taffybar/Widget/CommandRunner.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.CommandRunner @@ -15,11 +16,12 @@ module System.Taffybar.Widget.CommandRunner ( commandRunnerNew ) where import Control.Monad.IO.Class -import qualified Graphics.UI.Gtk as Gtk +import qualified GI.Gtk import System.Log.Logger import System.Taffybar.Util import System.Taffybar.Widget.Generic.PollingLabel import Text.Printf +import qualified Data.Text as T -- | Creates a new command runner widget. This is a 'PollingLabel' fed by -- regular calls to command given by argument. The results of calling this @@ -29,15 +31,15 @@ => Double -- ^ Polling period (in seconds). -> String -- ^ Command to execute. Should be in $PATH or an absolute path -> [String] -- ^ Command argument. May be @[]@ - -> String -- ^ If command fails this will be displayed. - -> m Gtk.Widget + -> T.Text -- ^ If command fails this will be displayed. + -> m GI.Gtk.Widget commandRunnerNew interval cmd args defaultOutput = pollingLabelNew "" interval $ runCommandWithDefault cmd args defaultOutput -runCommandWithDefault :: FilePath -> [String] -> String -> IO String +runCommandWithDefault :: FilePath -> [String] -> T.Text -> IO T.Text runCommandWithDefault cmd args def = - filter (/= '\n') <$> (runCommand cmd args >>= either logError return) + T.filter (/= '\n') <$> (runCommand cmd args >>= either logError (return . T.pack)) where logError err = logM "System.Taffybar.Widget.CommandRunner" ERROR (printf "Got error in CommandRunner %s" err) >> return def diff --git a/src/System/Taffybar/Widget/Decorators.hs b/src/System/Taffybar/Widget/Decorators.hs --- a/src/System/Taffybar/Widget/Decorators.hs +++ b/src/System/Taffybar/Widget/Decorators.hs @@ -1,29 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} module System.Taffybar.Widget.Decorators where import Control.Monad.IO.Class -import qualified Graphics.UI.Gtk as Gtk +import qualified GI.Gtk as Gtk import System.Taffybar.Widget.Util -- | Wrap a widget with two container boxes. The inner box will have the class -- "InnerPad", and the outer box will have the class "OuterPad". These boxes can -- be used to add padding between the outline of the widget and its contents, or -- for the purpose of displaying a different background behind the widget. -buildPadBox :: (Gtk.WidgetClass widget, MonadIO m) => widget -> m Gtk.Widget +buildPadBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget buildPadBox contents = liftIO $ do innerBox <- Gtk.hBoxNew False 0 outerBox <- Gtk.eventBoxNew Gtk.containerAdd innerBox contents Gtk.containerAdd outerBox innerBox - _ <- widgetSetClass innerBox "inner-pad" - _ <- widgetSetClass outerBox "outer-pad" + _ <- widgetSetClassGI innerBox "inner-pad" + _ <- widgetSetClassGI outerBox "outer-pad" Gtk.widgetShow outerBox Gtk.widgetShow innerBox - return $ Gtk.toWidget outerBox + Gtk.toWidget outerBox -buildContentsBox :: (Gtk.WidgetClass widget, MonadIO m) => widget -> m Gtk.Widget +buildContentsBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget buildContentsBox widget = liftIO $ do contents <- Gtk.hBoxNew False 0 Gtk.containerAdd contents widget - _ <- widgetSetClass contents "contents" + _ <- widgetSetClassGI contents "contents" Gtk.widgetShowAll contents - buildPadBox contents + Gtk.toWidget contents >>= buildPadBox diff --git a/src/System/Taffybar/Widget/DiskIOMonitor.hs b/src/System/Taffybar/Widget/DiskIOMonitor.hs --- a/src/System/Taffybar/Widget/DiskIOMonitor.hs +++ b/src/System/Taffybar/Widget/DiskIOMonitor.hs @@ -16,7 +16,7 @@ module System.Taffybar.Widget.DiskIOMonitor ( dioMonitorNew ) where import Control.Monad.IO.Class -import qualified Graphics.UI.Gtk as Gtk +import qualified GI.Gtk import System.Taffybar.Information.DiskIO ( getDiskTransfer ) import System.Taffybar.Widget.Generic.PollingGraph ( GraphConfig, pollingGraphNew ) @@ -29,7 +29,7 @@ => GraphConfig -- ^ Configuration data for the Graph. -> Double -- ^ Polling period (in seconds). -> String -- ^ Name of the disk or partition to watch (e.g. \"sda\", \"sdb1\"). - -> m Gtk.Widget + -> m GI.Gtk.Widget dioMonitorNew cfg pollSeconds = pollingGraphNew cfg pollSeconds . probeDisk diff --git a/src/System/Taffybar/Widget/FSMonitor.hs b/src/System/Taffybar/Widget/FSMonitor.hs --- a/src/System/Taffybar/Widget/FSMonitor.hs +++ b/src/System/Taffybar/Widget/FSMonitor.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.FSMonitor @@ -17,9 +18,10 @@ module System.Taffybar.Widget.FSMonitor ( fsMonitorNew ) where import Control.Monad.IO.Class -import qualified Graphics.UI.Gtk as Gtk +import qualified GI.Gtk import System.Process ( readProcess ) import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew ) +import qualified Data.Text as T -- | Creates a new filesystem monitor widget. It contains one 'PollingLabel' -- that displays the data returned by the df command. The usage level of all @@ -28,14 +30,14 @@ :: MonadIO m => Double -- ^ Polling interval (in seconds, e.g. 500) -> [String] -- ^ Names of the partitions to monitor (e.g. [\"\/\", \"\/home\"]) - -> m Gtk.Widget + -> m GI.Gtk.Widget fsMonitorNew interval fsList = liftIO $ do label <- pollingLabelNew "" interval $ showFSInfo fsList - Gtk.widgetShowAll label - return $ Gtk.toWidget label + GI.Gtk.widgetShowAll label + GI.Gtk.toWidget label -showFSInfo :: [String] -> IO String +showFSInfo :: [String] -> IO T.Text showFSInfo fsList = do fsOut <- readProcess "df" ("-kP":fsList) "" let fss = map (take 2 . reverse . words) $ drop 1 $ lines fsOut - return $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss + return $ T.pack $ unwords $ map ((\s -> "[" ++ s ++ "]") . unwords) fss diff --git a/src/System/Taffybar/Widget/FreedesktopNotifications.hs b/src/System/Taffybar/Widget/FreedesktopNotifications.hs --- a/src/System/Taffybar/Widget/FreedesktopNotifications.hs +++ b/src/System/Taffybar/Widget/FreedesktopNotifications.hs @@ -43,7 +43,10 @@ import Data.Text ( Text ) import qualified Data.Text as T import Data.Word ( Word32 ) -import Graphics.UI.Gtk hiding ( Variant ) +import GI.GLib (markupEscapeText) +import GI.Gtk +import qualified GI.Pango as Pango +import System.Taffybar.Util -- | A simple structure representing a Freedesktop notification data Notification = Notification @@ -111,17 +114,19 @@ -> IO Word32 notify s appName replaceId _ summary body _ _ timeout = do realId <- if replaceId == 0 then noteFreshId s else return replaceId - let escapeText = T.pack . escapeMarkup . T.unpack - configTimeout = notificationMaxTimeout (noteConfig s) + let configTimeout = notificationMaxTimeout (noteConfig s) realTimeout = if timeout <= 0 -- Gracefully handle out of spec negative values then configTimeout else case configTimeout of Nothing -> Just timeout Just maxTimeout -> Just (min maxTimeout timeout) - n = Notification { noteAppName = appName + + escapedSummary <- markupEscapeText summary (fromIntegral $ T.length summary) + escapedBody <- markupEscapeText body (fromIntegral $ T.length body) + let n = Notification { noteAppName = appName , noteReplaceId = replaceId - , noteSummary = escapeText summary - , noteBody = escapeText body + , noteSummary = escapedSummary + , noteBody = escapedBody , noteExpireTimeout = realTimeout , noteId = realId } @@ -174,7 +179,7 @@ displayThread s = forever $ do () <- readChan (noteChan s) ns <- readTVarIO (noteQueue s) - postGUIAsync $ + postGUIASync $ if S.length ns == 0 then widgetHide (noteContainer s) else do @@ -182,7 +187,7 @@ widgetShowAll (noteContainer s) where formatMessage NotificationConfig {..} ns = - take notificationMaxLength $ notificationFormatter ns + T.take notificationMaxLength $ notificationFormatter ns -------------------------------------------------------------------------------- startTimeoutThread :: NotifyState -> Notification -> IO () @@ -197,19 +202,19 @@ data NotificationConfig = NotificationConfig { notificationMaxTimeout :: Maybe Int32 -- ^ Maximum time that a notification will be displayed (in seconds). Default: None , notificationMaxLength :: Int -- ^ Maximum length displayed, in characters. Default: 100 - , notificationFormatter :: [Notification] -> String -- ^ Function used to format notifications, takes the notifications from first to last + , notificationFormatter :: [Notification] -> T.Text -- ^ Function used to format notifications, takes the notifications from first to last } -defaultFormatter :: [Notification] -> String +defaultFormatter :: [Notification] -> T.Text defaultFormatter ns = let count = length ns n = head ns prefix = if count == 1 then "" - else "(" <> show count <> ") " - msg = T.unpack $ if T.null (noteBody n) - then noteSummary n - else noteSummary n <> ": " <> noteBody n + else "(" <> T.pack (show count) <> ") " + msg = if T.null (noteBody n) + then noteSummary n + else noteSummary n <> ": " <> noteBody n in "" <> prefix <> "" <> msg -- | The default formatter is one of @@ -228,48 +233,50 @@ -- | Create a new notification area with the given configuration. notifyAreaNew :: MonadIO m => NotificationConfig -> m Widget notifyAreaNew cfg = liftIO $ do - frame <- frameNew + frame <- frameNew Nothing box <- hBoxNew False 3 - textArea <- labelNew (Nothing :: Maybe String) + textArea <- labelNew (Nothing :: Maybe Text) button <- eventBoxNew - sep <- vSeparatorNew + sep <- separatorNew OrientationHorizontal - bLabel <- labelNew (Nothing :: Maybe String) - widgetSetName bLabel ("NotificationCloseButton" :: String) - labelSetMarkup bLabel ("×" :: String) + bLabel <- labelNew (Nothing :: Maybe Text) + widgetSetName bLabel "NotificationCloseButton" + labelSetMarkup bLabel "×" - labelSetMaxWidthChars textArea (notificationMaxLength cfg) - labelSetEllipsize textArea EllipsizeEnd + labelSetMaxWidthChars textArea (fromIntegral $ notificationMaxLength cfg) + labelSetEllipsize textArea Pango.EllipsizeModeEnd containerAdd button bLabel - boxPackStart box textArea PackGrow 0 - boxPackStart box sep PackNatural 0 - boxPackStart box button PackNatural 0 + boxPackStart box textArea True True 0 + boxPackStart box sep False False 0 + boxPackStart box button False False 0 containerAdd frame box widgetHide frame + w <- toWidget frame - s <- initialNoteState (toWidget frame) textArea cfg - _ <- on button buttonReleaseEvent (userCancel s) + s <- initialNoteState w textArea cfg + _ <- onWidgetButtonReleaseEvent button (userCancel s) realizableWrapper <- hBoxNew False 0 - boxPackStart realizableWrapper frame PackNatural 0 + boxPackStart realizableWrapper frame False False 0 widgetShow realizableWrapper -- We can't start the dbus listener thread until we are in the GTK -- main loop, otherwise things are prone to lock up and block -- infinitely on an mvar. Bad stuff - only start the dbus thread -- after the fake invisible wrapper widget is realized. - void $ on realizableWrapper realize $ do + void $ onWidgetRealize realizableWrapper $ do void $ forkIO (displayThread s) notificationDaemon (notify s) (closeNotification s) -- Don't show the widget by default - it will appear when needed - return (toWidget realizableWrapper) + toWidget realizableWrapper + where -- | Close the current note and pull up the next, if any - userCancel s = liftIO $ do + userCancel s _ = do noteNext s wakeupDisplayThread s return True diff --git a/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs b/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs --- a/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs +++ b/src/System/Taffybar/Widget/Generic/AutoSizeImage.hs @@ -4,7 +4,6 @@ import qualified Control.Concurrent.MVar as MV import Control.Monad import Control.Monad.IO.Class -import qualified Data.GI.Gtk.Threading as Gtk import Data.Int import Data.Maybe import qualified GI.Gdk as Gdk @@ -12,6 +11,7 @@ import qualified GI.Gtk as Gtk import StatusNotifier.Tray (scalePixbufToSize) import System.Log.Logger +import System.Taffybar.Util import System.Taffybar.Widget.Util import Text.Printf @@ -131,7 +131,7 @@ pixbuf <- getPixbuf size pbWidth <- fromMaybe 0 <$> traverse Gdk.getPixbufWidth pixbuf - pbHeight <- fromMaybe 0 <$> traverse Gdk.getPixbufWidth pixbuf + pbHeight <- fromMaybe 0 <$> traverse Gdk.getPixbufHeight pixbuf let pbSize = case orientation of Gtk.OrientationHorizontal -> pbHeight _ -> pbWidth @@ -149,7 +149,7 @@ (show pbHeight) Gtk.imageSetFromPixbuf image pixbuf - Gtk.postGUIASync $ Gtk.widgetQueueResize image + postGUIASync $ Gtk.widgetQueueResize image _ <- Gtk.onWidgetSizeAllocate image $ setPixbuf False return $ Gtk.widgetGetAllocation image >>= setPixbuf True diff --git a/src/System/Taffybar/Widget/Generic/ChannelGraph.hs b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs --- a/src/System/Taffybar/Widget/Generic/ChannelGraph.hs +++ b/src/System/Taffybar/Widget/Generic/ChannelGraph.hs @@ -3,18 +3,18 @@ import Control.Concurrent import Control.Monad import Control.Monad.IO.Class -import Graphics.UI.Gtk +import GI.Gtk import System.Taffybar.Widget.Generic.Graph channelGraphNew :: MonadIO m - => GraphConfig -> Chan a -> (a -> IO [Double]) -> m Widget -channelGraphNew config chan sampleBuilder = liftIO $ do + => GraphConfig -> Chan a -> (a -> IO [Double]) -> m GI.Gtk.Widget +channelGraphNew config chan sampleBuilder = do (graphWidget, graphHandle) <- graphNew config - _ <- on graphWidget realize $ do + _ <- onWidgetRealize graphWidget $ do ourChan <- dupChan chan sampleThread <- forkIO $ forever $ do value <- readChan ourChan sampleBuilder value >>= graphAddSample graphHandle - void $ on graphWidget unrealize $ killThread sampleThread + void $ onWidgetUnrealize graphWidget $ killThread sampleThread return graphWidget diff --git a/src/System/Taffybar/Widget/Generic/Graph.hs b/src/System/Taffybar/Widget/Generic/Graph.hs --- a/src/System/Taffybar/Widget/Generic/Graph.hs +++ b/src/System/Taffybar/Widget/Generic/Graph.hs @@ -28,10 +28,12 @@ import Data.Foldable ( mapM_ ) import Data.Sequence ( Seq, (<|), viewl, ViewL(..) ) import qualified Data.Sequence as S +import qualified Data.Text as T +import qualified GI.Gtk as Gtk import qualified Graphics.Rendering.Cairo as C import qualified Graphics.Rendering.Cairo.Matrix as M -import qualified Graphics.UI.Gtk as Gtk import Prelude hiding ( mapM_ ) +import System.Taffybar.Util import System.Taffybar.Widget.Util newtype GraphHandle = GH (MVar GraphState) @@ -70,7 +72,7 @@ -- | The number of data points to retain for each data set (default 20) , graphHistorySize :: Int -- | May contain Pango markup (default @Nothing@) - , graphLabel :: Maybe String + , graphLabel :: Maybe T.Text -- | The width (in pixels) of the graph widget (default 50) , graphWidth :: Int -- | The direction in which the graph will move as time passes (default LEFT_TO_RIGHT) @@ -105,7 +107,7 @@ _ -> map (\(p,h) -> S.take histSize $ p <| h) histsAndNewVals when (graphIsBootstrapped s) $ do modifyMVar_ mv (\s' -> return s' { graphHistory = newHists }) - Gtk.postGUIAsync $ Gtk.widgetQueueDraw drawArea + postGUIASync $ Gtk.widgetQueueDraw drawArea where pcts = map (clamp 0 1) rawData @@ -223,19 +225,20 @@ , graphConfig = cfg } - Gtk.widgetSetSizeRequest drawArea (graphWidth cfg) (-1) - _ <- Gtk.on drawArea Gtk.draw $ drawGraph mv drawArea + Gtk.widgetSetSizeRequest drawArea (fromIntegral $ graphWidth cfg) (-1) + _ <- Gtk.onWidgetDraw drawArea (\ctx -> renderWithContext ctx (drawGraph mv drawArea) >> return True) box <- Gtk.hBoxNew False 1 case graphLabel cfg of Nothing -> return () Just lbl -> do - l <- Gtk.labelNew (Nothing :: Maybe String) + l <- Gtk.labelNew (Nothing :: Maybe T.Text) Gtk.labelSetMarkup l lbl - Gtk.boxPackStart box l Gtk.PackNatural 0 + Gtk.boxPackStart box l False False 0 - Gtk.set drawArea [Gtk.widgetVExpand Gtk.:= True] - Gtk.set box [Gtk.widgetVExpand Gtk.:= True] - Gtk.boxPackStart box drawArea Gtk.PackGrow 0 + Gtk.widgetSetVexpand drawArea True + Gtk.widgetSetVexpand box True + Gtk.boxPackStart box drawArea True True 0 Gtk.widgetShowAll box - return (Gtk.toWidget box, GH mv) + giBox <- Gtk.toWidget box + return (giBox, GH mv) diff --git a/src/System/Taffybar/Widget/Generic/Icon.hs b/src/System/Taffybar/Widget/Generic/Icon.hs --- a/src/System/Taffybar/Widget/Generic/Icon.hs +++ b/src/System/Taffybar/Widget/Generic/Icon.hs @@ -8,15 +8,17 @@ import Control.Concurrent ( forkIO, threadDelay ) import Control.Exception as E import Control.Monad ( forever ) -import Graphics.UI.Gtk +import Control.Monad.IO.Class +import GI.Gtk +import System.Taffybar.Util -- | Create a new widget that displays a static image -- -- > iconImageWidgetNew path -- -- returns a widget with icon at @path@. -iconImageWidgetNew :: FilePath -> IO Widget -iconImageWidgetNew path = imageNewFromFile path >>= putInBox +iconImageWidgetNew :: MonadIO m => FilePath -> m Widget +iconImageWidgetNew path = liftIO $ imageNewFromFile path >>= putInBox -- | Create a new widget that updates itself at regular intervals. The -- function @@ -30,28 +32,29 @@ -- If the IO action throws an exception, it will be swallowed and the -- label will not update until the update interval expires. pollingIconImageWidgetNew - :: FilePath -- ^ Initial file path of the icon + :: MonadIO m + => FilePath -- ^ Initial file path of the icon -> Double -- ^ Update interval (in seconds) -> IO FilePath -- ^ Command to run to get the input filepath - -> IO Widget -pollingIconImageWidgetNew path interval cmd = do + -> m Widget +pollingIconImageWidgetNew path interval cmd = liftIO $ do icon <- imageNewFromFile path - _ <- on icon realize $ do + _ <- onWidgetRealize icon $ do _ <- forkIO $ forever $ do let tryUpdate = do str <- cmd - postGUIAsync $ imageSetFromFile icon str + postGUIASync $ imageSetFromFile icon (Just str) E.catch tryUpdate ignoreIOException threadDelay $ floor (interval * 1000000) return () putInBox icon -putInBox :: WidgetClass child => child -> IO Widget +putInBox :: IsWidget child => child -> IO Widget putInBox icon = do box <- hBoxNew False 0 - boxPackStart box icon PackNatural 0 + boxPackStart box icon False False 0 widgetShowAll box - return $ toWidget box + toWidget box ignoreIOException :: IOException -> IO () ignoreIOException _ = return () diff --git a/src/System/Taffybar/Widget/Generic/PollingBar.hs b/src/System/Taffybar/Widget/Generic/PollingBar.hs --- a/src/System/Taffybar/Widget/Generic/PollingBar.hs +++ b/src/System/Taffybar/Widget/Generic/PollingBar.hs @@ -13,20 +13,24 @@ import Control.Concurrent import Control.Exception.Enclosed ( tryAny ) -import Graphics.UI.Gtk -import System.Taffybar.Widget.Util ( backgroundLoop, drawOn ) +import qualified GI.Gtk +import System.Taffybar.Widget.Util ( backgroundLoop ) +import Control.Monad.IO.Class import System.Taffybar.Widget.Generic.VerticalBar -verticalBarFromCallback :: BarConfig -> IO Double -> IO Widget -verticalBarFromCallback cfg action = do +verticalBarFromCallback :: MonadIO m + => BarConfig -> IO Double -> m GI.Gtk.Widget +verticalBarFromCallback cfg action = liftIO $ do (drawArea, h) <- verticalBarNew cfg - drawOn drawArea $ - backgroundLoop $ do + _ <- GI.Gtk.onWidgetRealize drawArea $ backgroundLoop $ do esample <- tryAny action traverse (verticalBarSetPercent h) esample + return drawArea -pollingBarNew :: BarConfig -> Double -> IO Double -> IO Widget +pollingBarNew :: MonadIO m + => BarConfig -> Double -> IO Double -> m GI.Gtk.Widget pollingBarNew cfg pollSeconds action = + liftIO $ verticalBarFromCallback cfg $ action <* delay where delay = threadDelay $ floor (pollSeconds * 1000000) diff --git a/src/System/Taffybar/Widget/Generic/PollingGraph.hs b/src/System/Taffybar/Widget/Generic/PollingGraph.hs --- a/src/System/Taffybar/Widget/Generic/PollingGraph.hs +++ b/src/System/Taffybar/Widget/Generic/PollingGraph.hs @@ -15,22 +15,22 @@ import qualified Control.Exception.Enclosed as E import Control.Monad import Control.Monad.IO.Class -import Graphics.UI.Gtk +import GI.Gtk import System.Taffybar.Util import System.Taffybar.Widget.Generic.Graph pollingGraphNew :: MonadIO m - => GraphConfig -> Double -> IO [Double] -> m Widget + => GraphConfig -> Double -> IO [Double] -> m GI.Gtk.Widget pollingGraphNew cfg pollSeconds action = liftIO $ do (graphWidget, graphHandle) <- graphNew cfg - _ <- on graphWidget realize $ do + _ <- onWidgetRealize graphWidget $ do sampleThread <- foreverWithDelay pollSeconds $ do esample <- E.tryAny action case esample of Left _ -> return () Right sample -> graphAddSample graphHandle sample - void $ on graphWidget unrealize $ killThread sampleThread + void $ onWidgetUnrealize graphWidget $ killThread sampleThread return graphWidget diff --git a/src/System/Taffybar/Widget/Generic/PollingLabel.hs b/src/System/Taffybar/Widget/Generic/PollingLabel.hs --- a/src/System/Taffybar/Widget/Generic/PollingLabel.hs +++ b/src/System/Taffybar/Widget/Generic/PollingLabel.hs @@ -5,14 +5,13 @@ , pollingLabelNewWithTooltip ) where +import Control.Concurrent import Control.Exception.Enclosed as E import Control.Monad import Control.Monad.IO.Class -import Data.GI.Gtk.Threading +import System.Taffybar.Util import qualified Data.Text as T import GI.Gtk -import qualified Graphics.UI.Gtk as Gtk2hs -import System.Taffybar.Compat.GtkLibs import System.Taffybar.Util import System.Taffybar.Widget.Util @@ -31,31 +30,32 @@ -- not update until the update interval expires. pollingLabelNew :: MonadIO m - => String -- ^ Initial value for the label + => T.Text -- ^ Initial value for the label -> Double -- ^ Update interval (in seconds) - -> IO String -- ^ Command to run to get the input string - -> m Gtk2hs.Widget + -> IO T.Text -- ^ Command to run to get the input string + -> m GI.Gtk.Widget pollingLabelNew initialString interval cmd = pollingLabelNewWithTooltip initialString interval $ (, Nothing) <$> cmd pollingLabelNewWithTooltip :: MonadIO m - => String -- ^ Initial value for the label + => T.Text -- ^ Initial value for the label -> Double -- ^ Update interval (in seconds) - -> IO (String, Maybe String) -- ^ Command to run to get the input string - -> m Gtk2hs.Widget + -> IO (T.Text, Maybe T.Text) -- ^ Command to run to get the input string + -> m GI.Gtk.Widget pollingLabelNewWithTooltip initialString interval cmd = - liftIO $ fromGIWidget =<< do + liftIO $ do grid <- gridNew - label <- labelNew $ Just $ T.pack initialString + label <- labelNew $ Just initialString let updateLabel (labelStr, tooltipStr) = postGUIASync $ do - labelSetMarkup label $ T.pack labelStr - widgetSetTooltipMarkup label $ T.pack <$> tooltipStr + labelSetMarkup label labelStr + widgetSetTooltipMarkup label tooltipStr - _ <- onWidgetRealize label $ void $ foreverWithDelay interval $ - E.tryAny cmd >>= either (const $ return ()) updateLabel + _ <- onWidgetRealize label $ do + sampleThread <- foreverWithDelay interval $ E.tryAny cmd >>= either (const $ return ()) updateLabel + void $ onWidgetUnrealize label $ killThread sampleThread vFillCenter label vFillCenter grid diff --git a/src/System/Taffybar/Widget/Generic/VerticalBar.hs b/src/System/Taffybar/Widget/Generic/VerticalBar.hs --- a/src/System/Taffybar/Widget/Generic/VerticalBar.hs +++ b/src/System/Taffybar/Widget/Generic/VerticalBar.hs @@ -15,8 +15,9 @@ import Control.Concurrent import Control.Monad import Control.Monad.IO.Class +import GI.Gtk hiding (widgetGetAllocatedSize) import qualified Graphics.Rendering.Cairo as C -import Graphics.UI.Gtk +import System.Taffybar.Util import System.Taffybar.Widget.Util newtype VerticalBarHandle = VBH (MVar VerticalBarState) @@ -78,7 +79,7 @@ let drawArea = barCanvas s when (barIsBootstrapped s) $ do modifyMVar_ mv (\s' -> return s' { barPercent = clamp 0 1 pct }) - postGUIAsync $ widgetQueueDraw drawArea + postGUIASync $ widgetQueueDraw drawArea clamp :: Double -> Double -> Double -> Double clamp lo hi d = max lo $ min hi d @@ -101,8 +102,8 @@ BarConfig { barColor = c } -> return (c pct) BarConfigIO { barColorIO = c } -> c pct -renderFrame :: Double -> BarConfig -> Int -> Int -> C.Render () -renderFrame pct cfg width height = do +renderFrame_ :: Double -> BarConfig -> Int -> Int -> C.Render () +renderFrame_ pct cfg width height = do let fwidth = fromIntegral width fheight = fromIntegral height @@ -135,7 +136,7 @@ HORIZONTAL -> 0 pad = barPadding cfg - renderFrame pct cfg width height + renderFrame_ pct cfg width height -- After we draw the frame, transform the coordinate space so that -- we only draw within the frame. @@ -159,8 +160,8 @@ return s renderBar (barPercent s) (barConfig s) w h -verticalBarNew :: BarConfig -> IO (Widget, VerticalBarHandle) -verticalBarNew cfg = do +verticalBarNew :: MonadIO m => BarConfig -> m (GI.Gtk.Widget, VerticalBarHandle) +verticalBarNew cfg = liftIO $ do drawArea <- drawingAreaNew mv <- newMVar @@ -170,9 +171,10 @@ , barCanvas = drawArea , barConfig = cfg } - widgetSetSizeRequest drawArea (barWidth cfg) (-1) - _ <- on drawArea draw $ drawBar mv drawArea + widgetSetSizeRequest drawArea (fromIntegral $ barWidth cfg) (-1) + _ <- onWidgetDraw drawArea $ \ctx -> renderWithContext ctx (drawBar mv drawArea) >> return True box <- hBoxNew False 1 - boxPackStart box drawArea PackGrow 0 + boxPackStart box drawArea True True 0 widgetShowAll box - return (toWidget box, VBH mv) + giBox <- toWidget box + return (giBox, VBH mv) diff --git a/src/System/Taffybar/Widget/Layout.hs b/src/System/Taffybar/Widget/Layout.hs --- a/src/System/Taffybar/Widget/Layout.hs +++ b/src/System/Taffybar/Widget/Layout.hs @@ -25,12 +25,12 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader -import qualified Graphics.UI.Gtk as Gtk -import qualified Graphics.UI.Gtk.Abstract.Widget as W +import qualified Data.Text as T +import qualified GI.Gtk as Gtk +import GI.Gdk import System.Taffybar.Context import System.Taffybar.Information.X11DesktopInfo import System.Taffybar.Util -import System.Taffybar.Widget.Util -- $usage -- @@ -52,7 +52,7 @@ -- now you can use @los@ as any other Taffybar widget. newtype LayoutConfig = LayoutConfig - { formatLayout :: String -> TaffyIO String + { formatLayout :: T.Text -> TaffyIO T.Text } defaultLayoutConfig :: LayoutConfig @@ -68,37 +68,38 @@ layoutNew :: LayoutConfig -> TaffyIO Gtk.Widget layoutNew config = do ctx <- ask - label <- lift $ Gtk.labelNew (Nothing :: Maybe String) + label <- lift $ Gtk.labelNew (Nothing :: Maybe T.Text) -- This callback is run in a separate thread and needs to use - -- postGUIAsync - let callback _ = liftReader Gtk.postGUIAsync $ do + -- postGUIASync + let callback _ = liftReader postGUIASync $ do layout <- runX11Def "" $ readAsString Nothing xLayoutProp - markup <- formatLayout config layout + markup <- formatLayout config (T.pack layout) lift $ Gtk.labelSetMarkup label markup subscription <- subscribeToEvents [xLayoutProp] callback - lift $ do + do ebox <- Gtk.eventBoxNew Gtk.containerAdd ebox label - _ <- Gtk.on ebox Gtk.buttonPressEvent $ dispatchButtonEvent ctx + _ <- Gtk.onWidgetButtonPressEvent ebox $ dispatchButtonEvent ctx Gtk.widgetShowAll ebox - _ <- Gtk.on ebox W.unrealize $ flip runReaderT ctx $ unsubscribe subscription - return $ Gtk.toWidget ebox + _ <- Gtk.onWidgetUnrealize ebox $ flip runReaderT ctx $ unsubscribe subscription + Gtk.toWidget ebox -- | Call 'switch' with the appropriate argument (1 for left click, -1 for -- right click), depending on the click event received. -dispatchButtonEvent :: Context -> Gtk.EventM Gtk.EButton Bool -dispatchButtonEvent context = do - btn <- Gtk.eventButton - let trigger prop = - onClick [Gtk.SingleClick] $ - runReaderT (runX11Def () prop) context >> return True - case btn of - Gtk.LeftButton -> trigger $ switch 1 - Gtk.RightButton -> trigger $ switch (-1) - _ -> return False +dispatchButtonEvent :: Context -> EventButton -> IO Bool +dispatchButtonEvent context btn = do + pressType <- getEventButtonType btn + buttonNumber <- getEventButtonButton btn + case pressType of + EventTypeButtonPress -> + case buttonNumber of + 1 -> runReaderT (runX11Def () (switch 1)) context >> return True + 2 -> runReaderT (runX11Def () (switch (-1))) context >> return True + _ -> return False + _ -> return False -- | Emit a new custom event of type _XMONAD_CURRENT_LAYOUT, that can be -- intercepted by the PagerHints hook, which in turn can instruct XMonad to diff --git a/src/System/Taffybar/Widget/MPRIS2.hs b/src/System/Taffybar/Widget/MPRIS2.hs --- a/src/System/Taffybar/Widget/MPRIS2.hs +++ b/src/System/Taffybar/Widget/MPRIS2.hs @@ -27,13 +27,11 @@ import DBus.Internal.Types import qualified DBus.TH as DBus import Data.Coerce -import qualified Data.GI.Gtk.Threading as Gtk import Data.List import qualified Data.Text as T import qualified GI.Gtk as Gtk -import qualified Graphics.UI.Gtk as Gtk2hs +import qualified GI.GLib as G import System.Log.Logger -import System.Taffybar.Compat.GtkLibs import System.Taffybar.Context import System.Taffybar.DBus.Client.MPRIS2 import System.Taffybar.Information.MPRIS2 @@ -51,8 +49,8 @@ , playerGrid :: Gtk.Grid } -mpris2New :: TaffyIO Gtk2hs.Widget -mpris2New = asks sessionDBusClient >>= \client -> lift $ fromGIWidget =<< do +mpris2New :: TaffyIO Gtk.Widget +mpris2New = asks sessionDBusClient >>= \client -> lift $ do grid <- Gtk.gridNew vFillCenter grid playerWidgetsVar <- MV.newMVar [] @@ -109,7 +107,7 @@ } = do logPrintF "System.Taffybar.Widget.MPRIS2" DEBUG "Setting state %s" nowPlaying - Gtk.labelSetMarkup label $ playingText 20 30 nowPlaying + Gtk.labelSetMarkup label =<< playingText 20 30 nowPlaying if status == "Playing" then Gtk.widgetShowAll playerBox else Gtk.widgetHide playerBox @@ -122,9 +120,8 @@ mapM_ (Gtk.widgetHide . playerGrid . snd) noInfoPlayerWidgets return newWidgets - updatePlayerWidgetsVar nowPlayings = - MV.modifyMVar_ playerWidgetsVar $ - Gtk.postGUISync . updatePlayerWidgets nowPlayings + updatePlayerWidgetsVar nowPlayings = postGUIASync $ + MV.modifyMVar_ playerWidgetsVar $ updatePlayerWidgets nowPlayings doUpdate = getNowPlayingInfo client >>= updatePlayerWidgetsVar signalCallback _ _ _ _ = doUpdate @@ -145,11 +142,10 @@ Gtk.widgetShow grid Gtk.toWidget grid -playingText :: Int -> Int -> NowPlaying -> T.Text +playingText :: MonadIO m => Int -> Int -> NowPlaying -> m T.Text playingText artistMax songMax NowPlaying {npArtists = artists, npTitle = title} = - T.pack $ - Gtk2hs.escapeMarkup $ - printf - "%s - %s" - (truncateString artistMax $ intercalate "," artists) - (truncateString songMax title) + G.markupEscapeText formattedText (fromIntegral $ T.length formattedText) + where formattedText = T.pack $ printf + "%s - %s" + (truncateString artistMax $ intercalate "," artists) + (truncateString songMax title) diff --git a/src/System/Taffybar/Widget/NetworkGraph.hs b/src/System/Taffybar/Widget/NetworkGraph.hs --- a/src/System/Taffybar/Widget/NetworkGraph.hs +++ b/src/System/Taffybar/Widget/NetworkGraph.hs @@ -1,6 +1,6 @@ module System.Taffybar.Widget.NetworkGraph where -import Graphics.UI.Gtk +import qualified GI.Gtk import System.Taffybar.Context import System.Taffybar.Hooks import System.Taffybar.Information.Network @@ -12,7 +12,7 @@ logBase base (min value maxValue) / actualMax where actualMax = logBase base maxValue -networkGraphNew :: GraphConfig -> Maybe [String] -> TaffyIO Widget +networkGraphNew :: GraphConfig -> Maybe [String] -> TaffyIO GI.Gtk.Widget networkGraphNew config interfaces = do NetworkInfoChan chan <- getNetworkChan let filterFn = maybe (const True) (flip elem) interfaces diff --git a/src/System/Taffybar/Widget/SNITray.hs b/src/System/Taffybar/Widget/SNITray.hs --- a/src/System/Taffybar/Widget/SNITray.hs +++ b/src/System/Taffybar/Widget/SNITray.hs @@ -15,11 +15,9 @@ import Control.Monad.Trans.Reader import qualified GI.Gtk import Graphics.UI.GIGtkStrut -import qualified Graphics.UI.Gtk as Gtk import qualified StatusNotifier.Host.Service as H import StatusNotifier.Tray import System.Posix.Process -import System.Taffybar.Compat.GtkLibs import System.Taffybar.Context import System.Taffybar.Widget.Util import Text.Printf @@ -37,7 +35,7 @@ -- | Build a new StatusNotifierItem tray that will share a host with any other -- trays that are constructed automatically -sniTrayNewFromHost :: H.Host -> TaffyIO Gtk.Widget +sniTrayNewFromHost :: H.Host -> TaffyIO GI.Gtk.Widget sniTrayNewFromHost host = do client <- asks sessionDBusClient lift $ do @@ -53,11 +51,11 @@ } _ <- widgetSetClassGI tray "sni-tray" GI.Gtk.widgetShowAll tray - GI.Gtk.toWidget tray >>= fromGIWidget + GI.Gtk.toWidget tray -sniTrayNew :: TaffyIO Gtk.Widget +sniTrayNew :: TaffyIO GI.Gtk.Widget sniTrayNew = getHost False >>= sniTrayNewFromHost -sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt :: TaffyIO Gtk.Widget +sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt :: TaffyIO GI.Gtk.Widget sniTrayThatStartsWatcherEvenThoughThisIsABadWayToDoIt = getHost True >>= sniTrayNewFromHost diff --git a/src/System/Taffybar/Widget/SimpleClock.hs b/src/System/Taffybar/Widget/SimpleClock.hs --- a/src/System/Taffybar/Widget/SimpleClock.hs +++ b/src/System/Taffybar/Widget/SimpleClock.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} + -- | This module implements a very simple text-based clock widget. -- The widget also toggles a calendar widget when clicked. This -- calendar is not fancy at all and has no data backend. @@ -16,22 +18,21 @@ import Data.Time.Format import Data.Time.LocalTime import qualified Data.Time.Locale.Compat as L -import Graphics.UI.Gtk - +import GI.Gtk +import qualified GI.Gdk as D import System.Taffybar.Widget.Generic.PollingLabel import System.Taffybar.Widget.Util +import qualified Data.Text as T makeCalendar :: IO TimeZone -> IO Window makeCalendar tzfn = do - container <- windowNew + container <- windowNew WindowTypeToplevel cal <- calendarNew containerAdd container cal -- update the date on show - _ <- on container showSignal $ resetCalendarDate cal tzfn + _ <- onWidgetShow container $ resetCalendarDate cal tzfn -- prevent calendar from being destroyed, it can be only hidden: - _ <- on container deleteEvent $ do - liftIO (widgetHide container) - return True + _ <- onWidgetDeleteEvent container $ \_ -> widgetHide container >> return True return container resetCalendarDate :: Calendar -> IO TimeZone -> IO () @@ -42,9 +43,9 @@ calendarSelectMonth cal (fromIntegral m - 1) (fromIntegral y) calendarSelectDay cal (fromIntegral d) -toggleCalendar :: WidgetClass w => w -> Window -> IO Bool +toggleCalendar :: IsWidget w => w -> Window -> IO Bool toggleCalendar w c = do - isVis <- get c widgetVisible + isVis <- widgetGetVisible c if isVis then widgetHide c else do @@ -55,7 +56,7 @@ -- | Create the widget. I recommend passing @Nothing@ for the TimeLocale -- parameter. The format string can include Pango markup -- (http://developer.gnome.org/pango/stable/PangoMarkupFormat.html). -textClockNew :: MonadIO m => Maybe L.TimeLocale -> String -> Double -> m Widget +textClockNew :: MonadIO m => Maybe L.TimeLocale -> String -> Double -> m GI.Gtk.Widget textClockNew userLocale = textClockNewWith cfg where @@ -103,17 +104,17 @@ containerAdd ebox l eventBoxSetVisibleWindow ebox False cal <- makeCalendar $ getTZ ti - _ <- on ebox buttonPressEvent $ onClick [SingleClick] (toggleCalendar l cal) + _ <- onWidgetButtonPressEvent ebox $ onClick [D.EventTypeButtonPress] (toggleCalendar l cal) widgetShowAll ebox - return (toWidget ebox) + toWidget ebox where userZone = clockTimeZone cfg userLocale = clockTimeLocale cfg -- alternate getCurrentTime that takes a specific TZ - getCurrentTime' :: TimeInfo -> String -> IO String + getCurrentTime' :: TimeInfo -> String -> IO T.Text getCurrentTime' ti f = do l <- getLocale ti z <- getTZ ti t <- Clock.getCurrentTime - return $ formatTime l f $ utcToZonedTime z t + return $ T.pack $ formatTime l f $ utcToZonedTime z t diff --git a/src/System/Taffybar/Widget/Systray.hs b/src/System/Taffybar/Widget/Systray.hs deleted file mode 100644 --- a/src/System/Taffybar/Widget/Systray.hs +++ /dev/null @@ -1,22 +0,0 @@ --- | This is a very basic system tray widget. That said, it works --- very well since it is based on eggtraymanager. -module System.Taffybar.Widget.Systray {-# DEPRECATED "Use SNITray instead" #-} ( systrayNew ) where - -import Control.Monad.IO.Class -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Misc.TrayManager - -systrayNew :: MonadIO m => m Widget -systrayNew = liftIO $ do - box <- hBoxNew False 5 - - trayManager <- trayManagerNew - Just screen <- screenGetDefault - _ <- trayManagerManageScreen trayManager screen - - _ <- on trayManager trayIconAdded $ \w -> do - widgetShowAll w - boxPackStart box w PackNatural 0 - - widgetShowAll box - return (toWidget box) diff --git a/src/System/Taffybar/Widget/Text/CPUMonitor.hs b/src/System/Taffybar/Widget/Text/CPUMonitor.hs --- a/src/System/Taffybar/Widget/Text/CPUMonitor.hs +++ b/src/System/Taffybar/Widget/Text/CPUMonitor.hs @@ -4,16 +4,17 @@ import qualified Text.StringTemplate as ST import System.Taffybar.Information.CPU import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew ) -import qualified Graphics.UI.Gtk as Gtk +import qualified GI.Gtk +import qualified Data.Text as T -- | Creates a simple textual CPU monitor. It updates once every polling -- period (in seconds). textCpuMonitorNew :: String -- ^ Format. You can use variables: $total$, $user$, $system$ -> Double -- ^ Polling period (in seconds) - -> IO Gtk.Widget + -> IO GI.Gtk.Widget textCpuMonitorNew fmt period = do - label <- pollingLabelNew fmt period callback - Gtk.widgetShowAll label + label <- pollingLabelNew (T.pack fmt) period callback + GI.Gtk.widgetShowAll label return label where callback = do diff --git a/src/System/Taffybar/Widget/Text/MemoryMonitor.hs b/src/System/Taffybar/Widget/Text/MemoryMonitor.hs --- a/src/System/Taffybar/Widget/Text/MemoryMonitor.hs +++ b/src/System/Taffybar/Widget/Text/MemoryMonitor.hs @@ -3,16 +3,17 @@ import qualified Text.StringTemplate as ST import System.Taffybar.Information.Memory import System.Taffybar.Widget.Generic.PollingLabel ( pollingLabelNew ) -import qualified Graphics.UI.Gtk as Gtk +import qualified GI.Gtk +import qualified Data.Text as T -- | Creates a simple textual memory monitor. It updates once every polling -- period (in seconds). textMemoryMonitorNew :: String -- ^ Format. You can use variables: "used", "total", "free", "buffer", "cache", "rest", "used". -> Double -- ^ Polling period in seconds. - -> IO Gtk.Widget + -> IO GI.Gtk.Widget textMemoryMonitorNew fmt period = do - label <- pollingLabelNew fmt period callback - Gtk.widgetShowAll label + label <- pollingLabelNew (T.pack fmt) period callback + GI.Gtk.widgetShowAll label return label where callback = do diff --git a/src/System/Taffybar/Widget/Text/NetworkMonitor.hs b/src/System/Taffybar/Widget/Text/NetworkMonitor.hs --- a/src/System/Taffybar/Widget/Text/NetworkMonitor.hs +++ b/src/System/Taffybar/Widget/Text/NetworkMonitor.hs @@ -2,14 +2,12 @@ import Control.Monad import Control.Monad.Trans.Class -import Data.GI.Gtk.Threading import qualified Data.Text as T import GI.Gtk -import qualified Graphics.UI.Gtk as Gtk2hs -import System.Taffybar.Compat.GtkLibs import System.Taffybar.Context import System.Taffybar.Hooks import System.Taffybar.Information.Network +import System.Taffybar.Util import System.Taffybar.Widget.Generic.ChannelWidget import Text.Printf import Text.StringTemplate @@ -17,7 +15,7 @@ defaultNetFormat :: String defaultNetFormat = "▼ $inAuto$ ▲ $outAuto$" -showInfo :: String -> Int -> (Double, Double) -> String +showInfo :: String -> Int -> (Double, Double) -> T.Text showInfo template prec (incomingb, outgoingb) = let attribs = [ ("inB", show incomingb) @@ -58,14 +56,13 @@ p :: Int p = max 0 $ floor $ fromIntegral prec - logBase 10 v -networkMonitorNew :: String -> Maybe [String] -> TaffyIO Gtk2hs.Widget -networkMonitorNew template interfaces = fromGIWidget =<< do +networkMonitorNew :: String -> Maybe [String] -> TaffyIO GI.Gtk.Widget +networkMonitorNew template interfaces = do NetworkInfoChan chan <- getNetworkChan let filterFn = maybe (const True) (flip elem) interfaces label <- lift $ labelNew Nothing void $ channelWidgetNew label chan $ \speedInfo -> let (up, down) = sumSpeeds $ map snd $ filter (filterFn . fst) speedInfo - labelString = - T.pack $ showInfo template 3 (fromRational down, fromRational up) + labelString = showInfo template 3 (fromRational down, fromRational up) in postGUIASync $ labelSetMarkup label labelString toWidget label diff --git a/src/System/Taffybar/Widget/Util.hs b/src/System/Taffybar/Widget/Util.hs --- a/src/System/Taffybar/Widget/Util.hs +++ b/src/System/Taffybar/Widget/Util.hs @@ -15,65 +15,77 @@ module System.Taffybar.Widget.Util where import Control.Concurrent ( forkIO ) -import Control.Monad ( when, forever, void ) +import Control.Monad ( forever, void ) import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Data.Functor ( ($>) ) import Data.Int import qualified Data.Text as T -import Data.Tuple.Sequence import qualified GI.GdkPixbuf.Objects.Pixbuf as GI import qualified GI.GdkPixbuf.Objects.Pixbuf as PB -import qualified GI.Gtk -import Graphics.UI.Gtk as Gtk -import Graphics.UI.Gtk.General.StyleContext +import GI.Gtk as Gtk +import qualified GI.Gdk as D import System.Directory import System.FilePath.Posix import System.Taffybar.Information.XDG.DesktopEntry import System.Taffybar.Util import Text.Printf +import qualified Graphics.Rendering.Cairo as C +import qualified GI.Cairo +import Control.Monad.Trans.Reader (runReaderT) +import Graphics.Rendering.Cairo.Internal (Render(runRender)) +import Foreign.Ptr (castPtr) +import Graphics.Rendering.Cairo.Types (Cairo(Cairo)) + import Paths_taffybar ( getDataDir ) -- | Execute the given action as a response to any of the given types -- of mouse button clicks. -onClick :: [Click] -- ^ Types of button clicks to listen to. +onClick :: [D.EventType] -- ^ Types of button clicks to listen to. -> IO a -- ^ Action to execute. - -> EventM EButton Bool -onClick triggers action = tryEvent $ do - click <- eventClick - when (click `elem` triggers) $ void $ liftIO action + -> D.EventButton + -> IO Bool +onClick triggers action btn = do + click <- D.getEventButtonType btn + if click `elem` triggers + then action >> return True + else return False -- | Attach the given widget as a popup with the given title to the -- given window. The newly attached popup is not shown initially. Use -- the 'displayPopup' function to display it. -attachPopup :: (WidgetClass w, WindowClass wnd) => +attachPopup :: (Gtk.IsWidget w, Gtk.IsWindow wnd) => w -- ^ The widget to set as popup. - -> String -- ^ The title of the popup. + -> T.Text -- ^ The title of the popup. -> wnd -- ^ The window to attach the popup to. -> IO () attachPopup widget title window = do - set window [ windowTitle := title - , windowTypeHint := WindowTypeHintTooltip - , windowSkipTaskbarHint := True - , windowSkipPagerHint := True - , windowTransientFor :=> getWindow - ] + + windowSetTitle window title + windowSetTypeHint window D.WindowTypeHintTooltip + windowSetSkipTaskbarHint window True + windowSetSkipPagerHint window True + transient <- getWindow + windowSetTransientFor window transient windowSetKeepAbove window True windowStick window - where getWindow = do - Just topLevelWindow <- fmap castToWindow <$> widgetGetAncestor widget gTypeWindow - return topLevelWindow + where + getWindow :: IO (Maybe Window) + getWindow = do + windowGType <- gobjectType (undefined :: Window) + Just ancestor <- Gtk.widgetGetAncestor widget windowGType + castTo Window ancestor -- | Display the given popup widget (previously prepared using the -- 'attachPopup' function) immediately beneath (or above) the given -- window. -displayPopup :: (WidgetClass w, WindowClass wnd) => +displayPopup :: (Gtk.IsWidget w, Gtk.IsWidget wnd, Gtk.IsWindow wnd) => w -- ^ The popup widget. -> wnd -- ^ The window the widget was attached to. -> IO () displayPopup widget window = do - windowSetPosition window WinPosMouse + windowSetPosition window WindowPositionMouse (x, y ) <- windowGetPosition window (_, y') <- widgetGetSizeRequest widget widgetShowAll window @@ -82,11 +94,12 @@ else windowMove window x y' widgetGetAllocatedSize - :: (WidgetClass self, MonadIO m) + :: (Gtk.IsWidget self, MonadIO m) => self -> m (Int, Int) -widgetGetAllocatedSize widget = - liftIO $ - sequenceT (widgetGetAllocatedWidth widget, widgetGetAllocatedHeight widget) +widgetGetAllocatedSize widget = do + w <- Gtk.widgetGetAllocatedWidth widget + h <- Gtk.widgetGetAllocatedHeight widget + return (fromIntegral w, fromIntegral h) -- | Creates markup with the given foreground and background colors and the -- given contents. @@ -102,26 +115,18 @@ backgroundLoop :: IO a -> IO () backgroundLoop = void . forkIO . forever -drawOn :: WidgetClass object => object -> IO () -> IO object -drawOn drawArea action = on drawArea realize action $> drawArea - -widgetSetClass - :: (Gtk.WidgetClass widget, MonadIO m) - => widget -> String -> m widget -widgetSetClass widget klass = liftIO $ do - context <- Gtk.widgetGetStyleContext widget - styleContextAddClass context klass - return widget +drawOn :: Gtk.IsWidget object => object -> IO () -> IO object +drawOn drawArea action = Gtk.onWidgetRealize drawArea action $> drawArea -widgetSetClassGI :: (GI.Gtk.IsWidget b, MonadIO m) => b -> T.Text -> m b +widgetSetClassGI :: (Gtk.IsWidget b, MonadIO m) => b -> T.Text -> m b widgetSetClassGI widget klass = - GI.Gtk.widgetGetStyleContext widget >>= - flip GI.Gtk.styleContextAddClass klass >> return widget + Gtk.widgetGetStyleContext widget >>= + flip Gtk.styleContextAddClass klass >> return widget -themeLoadFlags :: [GI.Gtk.IconLookupFlags] +themeLoadFlags :: [Gtk.IconLookupFlags] themeLoadFlags = - [ GI.Gtk.IconLookupFlagsGenericFallback - , GI.Gtk.IconLookupFlagsUseBuiltin + [ Gtk.IconLookupFlagsGenericFallback + , Gtk.IconLookupFlagsUseBuiltin ] getImageForDesktopEntry :: Int32 -> DesktopEntry -> IO (Maybe GI.Pixbuf) @@ -129,13 +134,13 @@ iconName <- MaybeT $ return $ deIcon entry let iconNameText = T.pack iconName MaybeT $ do - iconTheme <- GI.Gtk.iconThemeGetDefault - hasIcon <- GI.Gtk.iconThemeHasIcon iconTheme iconNameText + iconTheme <- Gtk.iconThemeGetDefault + hasIcon <- Gtk.iconThemeHasIcon iconTheme iconNameText logPrintFDebug "System.Taffybar.Widget.Util" "Entry: %s" entry logPrintFDebug "System.Taffybar.Widget.Util" "Icon present: %s" hasIcon if hasIcon then - GI.Gtk.iconThemeLoadIcon iconTheme iconNameText size themeLoadFlags + Gtk.iconThemeLoadIcon iconTheme iconNameText size themeLoadFlags else do exists <- doesFileExist iconName if isAbsolute iconName && exists @@ -144,22 +149,22 @@ loadPixbufByName :: Int32 -> T.Text -> IO (Maybe GI.Pixbuf) loadPixbufByName size name = do - iconTheme <- GI.Gtk.iconThemeGetDefault - hasIcon <- GI.Gtk.iconThemeHasIcon iconTheme name + iconTheme <- Gtk.iconThemeGetDefault + hasIcon <- Gtk.iconThemeHasIcon iconTheme name if hasIcon - then GI.Gtk.iconThemeLoadIcon iconTheme name size themeLoadFlags + then Gtk.iconThemeLoadIcon iconTheme name size themeLoadFlags else return Nothing -alignCenter :: (GI.Gtk.IsWidget o, MonadIO m) => o -> m () +alignCenter :: (Gtk.IsWidget o, MonadIO m) => o -> m () alignCenter widget = - GI.Gtk.setWidgetValign widget GI.Gtk.AlignCenter >> - GI.Gtk.setWidgetHalign widget GI.Gtk.AlignCenter + Gtk.setWidgetValign widget Gtk.AlignCenter >> + Gtk.setWidgetHalign widget Gtk.AlignCenter -vFillCenter :: (GI.Gtk.IsWidget o, MonadIO m) => o -> m () +vFillCenter :: (Gtk.IsWidget o, MonadIO m) => o -> m () vFillCenter widget = - GI.Gtk.widgetSetVexpand widget True >> - GI.Gtk.setWidgetValign widget GI.Gtk.AlignFill >> - GI.Gtk.setWidgetHalign widget GI.Gtk.AlignCenter + Gtk.widgetSetVexpand widget True >> + Gtk.setWidgetValign widget Gtk.AlignFill >> + Gtk.setWidgetHalign widget Gtk.AlignCenter pixbufNewFromFileAtScaleByHeight :: Int32 -> String -> IO PB.Pixbuf pixbufNewFromFileAtScaleByHeight height name = @@ -170,7 +175,12 @@ (( "icons" name) <$> getDataDir) >>= pixbufNewFromFileAtScaleByHeight height -setMinWidth :: (Gtk.WidgetClass w, MonadIO m) => Int -> w -> m w +setMinWidth :: (Gtk.IsWidget w, MonadIO m) => Int -> w -> m w setMinWidth width widget = liftIO $ do - Gtk.widgetSetSizeRequest widget width (-1) + Gtk.widgetSetSizeRequest widget (fromIntegral width) (-1) return widget + +renderWithContext :: GI.Cairo.Context -> C.Render () -> IO () +renderWithContext ct r = GI.Cairo.withManagedPtr ct $ \p -> + runReaderT (runRender r) (Cairo (castPtr p)) + diff --git a/src/System/Taffybar/Widget/Weather.hs b/src/System/Taffybar/Widget/Weather.hs --- a/src/System/Taffybar/Widget/Weather.hs +++ b/src/System/Taffybar/Widget/Weather.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- | This module defines a simple textual weather widget that polls -- NOAA for weather data. To find your weather station, you can use -- @@ -58,6 +59,7 @@ -- Implementation Note: the weather data parsing code is taken from xmobar. This -- version of the code makes direct HTTP requests instead of invoking a separate -- cURL process. + module System.Taffybar.Widget.Weather ( WeatherConfig(..) , WeatherInfo(..) @@ -68,13 +70,15 @@ ) where import Control.Monad.IO.Class -import Graphics.UI.Gtk +import GI.Gtk +import GI.GLib(markupEscapeText) import qualified Network.Browser as Browser import Network.HTTP import Network.URI import Text.Parsec import Text.Printf import Text.StringTemplate +import qualified Data.Text as T import System.Taffybar.Widget.Generic.PollingLabel @@ -95,7 +99,6 @@ , pressure :: Int } deriving (Show) - -- Parsers stolen from xmobar type Parser = Parsec String () @@ -171,7 +174,6 @@ getNumbersAsString :: Parser String getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n - skipRestOfLine :: Parser Char skipRestOfLine = do _ <- many $ noneOf "\n\r" @@ -230,17 +232,22 @@ -> StringTemplate String -> StringTemplate String -> WeatherFormatter - -> IO (String, Maybe String) + -> IO (T.Text, Maybe T.Text) getCurrentWeather getter labelTpl tooltipTpl formatter = do dat <- getter case dat of Right wi -> - return $ case formatter of - DefaultWeatherFormatter -> - ( escapeMarkup $ defaultFormatter labelTpl wi - , Just $ escapeMarkup $ defaultFormatter tooltipTpl wi) - WeatherFormatter f -> (f wi, Just $ f wi) + DefaultWeatherFormatter -> do + let rawLabel = T.pack $ defaultFormatter labelTpl wi + let rawTooltip = T.pack $ defaultFormatter tooltipTpl wi + lbl <- markupEscapeText rawLabel (fromIntegral $ T.length rawLabel) + tooltip <- markupEscapeText rawTooltip (fromIntegral $ T.length rawTooltip) + return (lbl, Just tooltip) + WeatherFormatter f -> do + let rawLabel = T.pack $ f wi + lbl <- markupEscapeText rawLabel (fromIntegral $ T.length rawLabel) + return (lbl, Just lbl) Left err -> do putStrLn err return ("N/A", Nothing) @@ -292,10 +299,11 @@ } -- | Create a periodically-updating weather widget that polls NOAA. -weatherNew :: WeatherConfig -- ^ Configuration to render +weatherNew :: MonadIO m + => WeatherConfig -- ^ Configuration to render -> Double -- ^ Polling period in _minutes_ - -> IO Widget -weatherNew cfg delayMinutes = do + -> m GI.Gtk.Widget +weatherNew cfg delayMinutes = liftIO $ do let url = printf "%s/%s.TXT" baseUrl (weatherStation cfg) getter = getWeather (weatherProxy cfg) url weatherCustomNew getter (weatherTemplate cfg) (weatherTemplateTooltip cfg) @@ -309,7 +317,7 @@ -> String -- ^ Weather template -> WeatherFormatter -- ^ Weather formatter -> Double -- ^ Polling period in _minutes_ - -> m Widget + -> m GI.Gtk.Widget weatherCustomNew getter labelTpl tooltipTpl formatter delayMinutes = liftIO $ do let labelTpl' = newSTMP labelTpl tooltipTpl' = newSTMP tooltipTpl @@ -317,5 +325,5 @@ l <- pollingLabelNewWithTooltip "N/A" (delayMinutes * 60) (getCurrentWeather getter labelTpl' tooltipTpl' formatter) - widgetShowAll l + GI.Gtk.widgetShowAll l return l diff --git a/src/System/Taffybar/Widget/Windows.hs b/src/System/Taffybar/Widget/Windows.hs --- a/src/System/Taffybar/Widget/Windows.hs +++ b/src/System/Taffybar/Widget/Windows.hs @@ -27,11 +27,10 @@ import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Reader -import Data.GI.Gtk.Threading +import Data.Maybe import qualified Data.Text as T +import GI.GLib (markupEscapeText) import qualified GI.Gtk as Gtk -import qualified Graphics.UI.Gtk as Gtk2hs -import System.Taffybar.Compat.GtkLibs import System.Taffybar.Context import System.Taffybar.Information.EWMHDesktopInfo import System.Taffybar.Util @@ -49,37 +48,44 @@ -- > ... data WindowsConfig = WindowsConfig - { getMenuLabel :: X11Window -> TaffyIO String + { getMenuLabel :: X11Window -> TaffyIO T.Text -- ^ A monadic function that will be used to make a label for the window in -- the window menu. - , getActiveLabel :: TaffyIO String + , getActiveLabel :: TaffyIO T.Text -- ^ Action to build the label text for the active window. } -truncatedGetMenuLabel :: Int -> X11Window -> TaffyIO String -truncatedGetMenuLabel maxLength = - fmap (Gtk2hs.escapeMarkup . truncateString maxLength) . - runX11Def "(nameless window)" . getWindowTitle +defaultGetMenuLabel :: X11Window -> TaffyIO T.Text +defaultGetMenuLabel window = do + windowString <- runX11Def "(nameless window)" (getWindowTitle window) + markupEscapeText (T.pack windowString) $ fromIntegral $ length windowString -truncatedGetActiveLabel :: Int -> TaffyIO String +defaultGetActiveLabel :: TaffyIO T.Text +defaultGetActiveLabel = fromMaybe "" <$> + (runX11Def Nothing getActiveWindow >>= traverse defaultGetMenuLabel) + +truncatedGetActiveLabel :: Int -> TaffyIO T.Text truncatedGetActiveLabel maxLength = - Gtk2hs.escapeMarkup . truncateString maxLength <$> - runX11Def "(nameless window)" getActiveWindowTitle + truncateText maxLength <$> defaultGetActiveLabel +truncatedGetMenuLabel :: Int -> X11Window -> TaffyIO T.Text +truncatedGetMenuLabel maxLength = + fmap (truncateText maxLength) . defaultGetMenuLabel + defaultWindowsConfig :: WindowsConfig defaultWindowsConfig = WindowsConfig - { getMenuLabel = truncatedGetMenuLabel 35 - , getActiveLabel = truncatedGetActiveLabel 35 + { getMenuLabel = defaultGetMenuLabel + , getActiveLabel = defaultGetActiveLabel } -- | Create a new Windows widget that will use the given Pager as -- its source of events. -windowsNew :: WindowsConfig -> TaffyIO Gtk2hs.Widget -windowsNew config = (`widgetSetClass` "windows") =<< fromGIWidget =<< do +windowsNew :: WindowsConfig -> TaffyIO Gtk.Widget +windowsNew config = do label <- lift $ Gtk.labelNew Nothing - let setLabelTitle title = lift $ postGUIASync $ Gtk.labelSetMarkup label (T.pack title) + let setLabelTitle title = lift $ postGUIASync $ Gtk.labelSetMarkup label title activeWindowUpdatedCallback _ = getActiveLabel config >>= setLabelTitle subscription <- subscribeToEvents ["_NET_ACTIVE_WINDOW"] activeWindowUpdatedCallback @@ -88,11 +94,13 @@ context <- ask labelWidget <- Gtk.toWidget label - dynamicMenuNew + menu <- dynamicMenuNew DynamicMenuConfig { dmClickWidget = labelWidget , dmPopulateMenu = flip runReaderT context . fillMenu config } + widgetSetClassGI menu "windows" + -- | Populate the given menu widget with the list of all currently open windows. fillMenu :: Gtk.IsMenuShell a => WindowsConfig -> a -> ReaderT Context IO () fillMenu config menu = ask >>= \context -> @@ -102,7 +110,7 @@ lift $ do labelText <- runReaderT (getMenuLabel config windowId) context let focusCallback = runReaderT (runX11 $ focusWindow windowId) context >> return True - item <- Gtk.menuItemNewWithLabel $ T.pack labelText + item <- Gtk.menuItemNewWithLabel labelText _ <- Gtk.onWidgetButtonPressEvent item $ const focusCallback Gtk.menuShellAppend menu item Gtk.widgetShow item diff --git a/src/System/Taffybar/Widget/Workspaces.hs b/src/System/Taffybar/Widget/Workspaces.hs --- a/src/System/Taffybar/Widget/Workspaces.hs +++ b/src/System/Taffybar/Widget/Workspaces.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-} -{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : System.Taffybar.Widget.Workspaces @@ -32,19 +32,17 @@ import qualified Data.MultiMap as MM import Data.Ord import qualified Data.Set as Set +import qualified Data.Text as T import Data.Time.Units import Data.Tuple.Select import Data.Tuple.Sequence +import qualified GI.Gdk.Enums as Gdk +import qualified GI.Gdk.Structs.EventScroll as Gdk import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk -import qualified GI.Gtk -import qualified Graphics.UI.Gtk as Gtk -import qualified Graphics.UI.Gtk.Abstract.Widget as W -import Graphics.UI.Gtk.General.StyleContext -import qualified Graphics.UI.Gtk.Layout.Table as T +import qualified GI.Gtk as Gtk import Prelude import StatusNotifier.Tray (scalePixbufToSize) import System.Log.Logger -import System.Taffybar.Compat.GtkLibs import System.Taffybar.Context import System.Taffybar.Information.EWMHDesktopInfo import System.Taffybar.Information.SafeX11 @@ -64,10 +62,10 @@ | Urgent deriving (Show, Eq) -getCSSClass :: (Show s) => s -> String -getCSSClass = map Char.toLower . show +getCSSClass :: (Show s) => s -> T.Text +getCSSClass = T.toLower . T.pack . show -cssWorkspaceStates :: [String] +cssWorkspaceStates :: [T.Text] cssWorkspaceStates = map getCSSClass [Active, Visible, Hidden, Empty, Urgent] data WindowData = WindowData @@ -104,30 +102,32 @@ liftX11Def :: a -> X11Property a -> WorkspacesIO a liftX11Def def prop = liftContext $ runX11Def def prop -setWorkspaceWidgetStatusClass - :: W.WidgetClass widget - => Workspace -> widget -> IO () +setWorkspaceWidgetStatusClass :: + (MonadIO m, Gtk.IsWidget a) => Workspace -> a -> m () setWorkspaceWidgetStatusClass workspace widget = updateWidgetClasses widget - [map Char.toLower $ show $ workspaceState workspace] + [getCSSClass $ workspaceState workspace] cssWorkspaceStates -updateWidgetClasses - :: W.WidgetClass widget - => widget -> [String] -> [String] -> IO () +updateWidgetClasses :: + (Foldable t1, Foldable t, Gtk.IsWidget a, MonadIO m) + => a + -> t1 T.Text + -> t T.Text + -> m () updateWidgetClasses widget toAdd toRemove = do context <- Gtk.widgetGetStyleContext widget - let hasClass = styleContextHasClass context + let hasClass = Gtk.styleContextHasClass context addIfMissing klass = - hasClass klass >>= (`when` styleContextAddClass context klass) . not + hasClass klass >>= (`when` Gtk.styleContextAddClass context klass) . not removeIfPresent klass = unless (klass `elem` toAdd) $ - hasClass klass >>= (`when` styleContextRemoveClass context klass) + hasClass klass >>= (`when` Gtk.styleContextRemoveClass context klass) mapM_ removeIfPresent toRemove mapM_ addIfMissing toAdd class WorkspaceWidgetController wc where - getWidget :: wc -> Gtk.Widget + getWidget :: wc -> WorkspacesIO Gtk.Widget updateWidget :: wc -> WidgetUpdate -> WorkspacesIO wc updateWidgetX11 :: wc -> WidgetUpdate -> WorkspacesIO wc updateWidgetX11 cont _ = return cont @@ -151,7 +151,6 @@ { widgetBuilder :: ControllerConstructor , widgetGap :: Int , underlineHeight :: Int - , minWSWidgetSize :: Maybe Int , underlinePadding :: Int , maxIcons :: Maybe Int , minIcons :: Int @@ -171,7 +170,6 @@ { widgetBuilder = buildButtonController defaultBuildContentsController , widgetGap = 0 , underlineHeight = 4 - , minWSWidgetSize = Just 30 , underlinePadding = 1 , maxIcons = Nothing , minIcons = 0 @@ -283,7 +281,7 @@ addWidget :: WWC -> WorkspacesIO () addWidget controller = do cont <- asks workspacesWidget - let workspaceWidget = getWidget controller + workspaceWidget <- getWidget controller lift $ do -- XXX: This hbox exists to (hopefully) prevent the issue where workspace -- widgets appear out of order, in the switcher, by acting as an empty @@ -291,13 +289,13 @@ hbox <- Gtk.hBoxNew False 0 parent <- Gtk.widgetGetParent workspaceWidget if isJust parent - then Gtk.widgetReparent (getWidget controller) hbox + then Gtk.widgetReparent workspaceWidget hbox else Gtk.containerAdd hbox workspaceWidget Gtk.containerAdd cont hbox workspacesNew :: WorkspacesConfig -> TaffyIO Gtk.Widget workspacesNew cfg = ask >>= \tContext -> lift $ do - cont <- Gtk.hBoxNew False (widgetGap cfg) + cont <- Gtk.hBoxNew False $ fromIntegral (widgetGap cfg) controllersRef <- MV.newMVar M.empty workspacesRef <- MV.newMVar M.empty let context = @@ -319,9 +317,9 @@ ) let doUnsubscribe = flip runReaderT tContext $ mapM_ unsubscribe [iconSubscription, workspaceSubscription] - _ <- Gtk.on cont W.unrealize doUnsubscribe - _ <- widgetSetClass cont "workspaces" - return $ Gtk.toWidget cont + _ <- Gtk.onWidgetUnrealize cont doUnsubscribe + _ <- widgetSetClassGI cont "workspaces" + Gtk.toWidget cont updateAllWorkspaceWidgets :: WorkspacesIO () updateAllWorkspaceWidgets = do @@ -351,21 +349,22 @@ setControllerWidgetVisibility :: WorkspacesIO () setControllerWidgetVisibility = do - WorkspacesContext { workspacesVar = workspacesRef - , controllersVar = controllersRef - , workspacesConfig = cfg - } <- ask + ctx@WorkspacesContext + { workspacesVar = workspacesRef + , controllersVar = controllersRef + , workspacesConfig = cfg + } <- ask lift $ do workspacesMap <- MV.readMVar workspacesRef controllersMap <- MV.readMVar controllersRef forM_ (M.elems workspacesMap) $ \ws -> - let c = M.lookup (workspaceIdx ws) controllersMap - mWidget = getWidget <$> c - action = if showWorkspaceFn cfg ws + let action = if showWorkspaceFn cfg ws then Gtk.widgetShow else Gtk.widgetHide in - maybe (return ()) action mWidget + traverse (flip runReaderT ctx . getWidget) + (M.lookup (workspaceIdx ws) controllersMap) >>= + maybe (return ()) action doWidgetUpdate :: (WorkspaceIdx -> WWC -> WorkspacesIO WWC) -> WorkspacesIO () doWidgetUpdate updateController = do @@ -433,7 +432,7 @@ return withLog where combineRequests _ b = Just (b, const ((), ())) - doUpdate _ = Gtk.postGUIAsync $ runReaderT updateAllWorkspaceWidgets context + doUpdate _ = postGUIASync $ runReaderT updateAllWorkspaceWidgets context onIconChanged :: (Set.Set X11Window -> IO ()) -> Event -> IO () onIconChanged handler event = @@ -444,14 +443,13 @@ _ -> return () onIconsChanged :: WorkspacesContext -> IO (Set.Set X11Window -> IO ()) -onIconsChanged context = - (.) (void . forkIO) <$> rateLimitFn context onIconsChanged' combineRequests +onIconsChanged context = rateLimitFn context onIconsChanged' combineRequests where combineRequests windows1 windows2 = Just (Set.union windows1 windows2, const ((), ())) onIconsChanged' wids = do wLog DEBUG $ printf "Icon update execute %s" $ show wids - flip runReaderT context $ + postGUIASync $ flip runReaderT context $ doWidgetUpdate (\idx c -> wLog DEBUG (printf "Updating %s icons." $ show idx) >> @@ -465,14 +463,16 @@ buildContentsController :: [ControllerConstructor] -> ControllerConstructor buildContentsController constructors ws = do controllers <- mapM ($ ws) constructors + ctx <- ask tempController <- lift $ do cons <- Gtk.hBoxNew False 0 - mapM_ (Gtk.containerAdd cons . getWidget) controllers - outerBox <- buildPadBox cons - _ <- widgetSetClass cons "contents" + mapM_ (flip runReaderT ctx . getWidget >=> Gtk.containerAdd cons) controllers + outerBox <- Gtk.toWidget cons >>= buildPadBox + _ <- widgetSetClassGI cons "contents" + widget <- Gtk.toWidget outerBox return WorkspaceContentsController - { containerWidget = Gtk.toWidget outerBox + { containerWidget = widget , contentsControllers = controllers } WWC <$> updateWidget tempController (WorkspaceUpdate ws) @@ -482,12 +482,9 @@ buildContentsController [buildLabelController, buildIconController] instance WorkspaceWidgetController WorkspaceContentsController where - getWidget = containerWidget + getWidget = return . containerWidget updateWidget cc update = do - WorkspacesContext {workspacesConfig = cfg} <- ask - lift $ - maybe (return ()) (updateMinSize $ Gtk.toWidget $ containerWidget cc) $ - minWSWidgetSize cfg + WorkspacesContext {} <- ask case update of WorkspaceUpdate newWorkspace -> lift $ setWorkspaceWidgetStatusClass newWorkspace $ containerWidget cc @@ -503,18 +500,18 @@ buildLabelController :: ControllerConstructor buildLabelController ws = do tempController <- lift $ do - lbl <- Gtk.labelNew (Nothing :: Maybe String) - _ <- widgetSetClass lbl "workspace-label" + lbl <- Gtk.labelNew Nothing + _ <- widgetSetClassGI lbl "workspace-label" return LabelController { label = lbl } WWC <$> updateWidget tempController (WorkspaceUpdate ws) instance WorkspaceWidgetController LabelController where - getWidget = Gtk.toWidget . label + getWidget = lift . Gtk.toWidget . label updateWidget lc (WorkspaceUpdate newWorkspace) = do WorkspacesContext { workspacesConfig = cfg } <- ask labelText <- labelSetter cfg newWorkspace lift $ do - Gtk.labelSetMarkup (label lc) labelText + Gtk.labelSetMarkup (label lc) $ T.pack labelText setWorkspaceWidgetStatusClass newWorkspace $ label lc return lc updateWidget lc _ = return lc @@ -547,18 +544,17 @@ lift $ do windowVar <- MV.newMVar Nothing img <- Gtk.imageNew - giImg <- toGIImage img refreshImage <- - autoSizeImage giImg + autoSizeImage img (flip runReaderT ctx . getPixbufForIconWidget transparentOnNone windowVar) - GI.Gtk.OrientationHorizontal + Gtk.OrientationHorizontal ebox <- Gtk.eventBoxNew - _ <- widgetSetClass img "window-icon" - _ <- widgetSetClass ebox "window-icon-container" + _ <- widgetSetClassGI img "window-icon" + _ <- widgetSetClassGI ebox "window-icon-container" Gtk.containerAdd ebox img _ <- - Gtk.on ebox Gtk.buttonPressEvent $ - liftIO $ do + Gtk.onWidgetButtonPressEvent ebox $ + const $ liftIO $ do info <- MV.readMVar windowVar case info of Just updatedInfo -> @@ -591,7 +587,7 @@ WWC <$> updateWidget tempController (WorkspaceUpdate ws) instance WorkspaceWidgetController IconController where - getWidget = Gtk.toWidget . iconsContainer + getWidget = lift . Gtk.toWidget . iconsContainer updateWidget ic (WorkspaceUpdate newWorkspace) = do newImages <- updateImages ic newWorkspace return ic { iconImages = newImages, iconWorkspace = newWorkspace } @@ -610,16 +606,10 @@ when (maybe False (flip elem windowIds . windowId) info) $ updateIconWidget ic widget info -updateMinSize :: Gtk.Widget -> Int -> IO () -updateMinSize widget minWidth = do - W.widgetSetSizeRequest widget (-1) (-1) - W.Requisition w _ <- W.widgetSizeRequest widget - when (w < minWidth) $ W.widgetSetSizeRequest widget minWidth $ -1 - scaledWindowIconPixbufGetter :: WindowIconPixbufGetter -> WindowIconPixbufGetter scaledWindowIconPixbufGetter getter size = getter size >=> - lift . traverse (scalePixbufToSize size GI.Gtk.OrientationHorizontal) + lift . traverse (scalePixbufToSize size Gtk.OrientationHorizontal) constantScaleWindowIconPixbufGetter :: Int32 -> WindowIconPixbufGetter @@ -728,18 +718,18 @@ when newImagesNeeded $ lift $ Gtk.widgetShowAll $ iconsContainer ic return newImgs -getWindowStatusString :: WindowData -> String -getWindowStatusString windowData = map Char.toLower $ +getWindowStatusString :: WindowData -> T.Text +getWindowStatusString windowData = T.toLower $ T.pack $ case windowData of WindowData { windowMinimized = True } -> "minimized" WindowData { windowActive = True } -> show Active WindowData { windowUrgent = True } -> show Urgent _ -> "normal" -possibleStatusStrings :: [String] +possibleStatusStrings :: [T.Text] possibleStatusStrings = map - (map Char.toLower) + (T.toLower . T.pack) [show Active, show Urgent, "minimized", "normal", "inactive"] updateIconWidget @@ -752,7 +742,7 @@ , iconWindow = windowRef , iconForceUpdate = updateIcon } windowData = do - let statusString = maybe "inactive" getWindowStatusString windowData + let statusString = maybe "inactive" getWindowStatusString windowData :: T.Text setIconWidgetProperties = updateWidgetClasses iconButton [statusString] possibleStatusStrings void $ updateVar windowRef $ const $ return windowData @@ -769,12 +759,14 @@ cc <- contentsBuilder workspace workspacesRef <- asks workspacesVar ctx <- ask + widget <- getWidget cc lift $ do ebox <- Gtk.eventBoxNew - Gtk.containerAdd ebox $ getWidget cc + Gtk.containerAdd ebox widget Gtk.eventBoxSetVisibleWindow ebox False _ <- - Gtk.on ebox Gtk.scrollEvent $ do + Gtk.onWidgetScrollEvent ebox $ \scrollEvent -> do + dir <- Gdk.getEventScrollDirection scrollEvent workspaces <- liftIO $ MV.readMVar workspacesRef let switchOne a = liftIO $ @@ -783,14 +775,13 @@ () (switchOneWorkspace a (length (M.toList workspaces) - 1)) >> return True - dir <- Gtk.eventScrollDirection case dir of - Gtk.ScrollUp -> switchOne True - Gtk.ScrollLeft -> switchOne True - Gtk.ScrollDown -> switchOne False - Gtk.ScrollRight -> switchOne False - Gtk.ScrollSmooth -> return False - _ <- Gtk.on ebox Gtk.buttonPressEvent $ switch ctx $ workspaceIdx workspace + Gdk.ScrollDirectionUp -> switchOne True + Gdk.ScrollDirectionLeft -> switchOne True + Gdk.ScrollDirectionDown -> switchOne False + Gdk.ScrollDirectionRight -> switchOne False + _ -> return False + _ <- Gtk.onWidgetButtonPressEvent ebox $ const $ switch ctx $ workspaceIdx workspace return $ WWC WorkspaceButtonController @@ -803,94 +794,7 @@ instance WorkspaceWidgetController WorkspaceButtonController where - getWidget wbc = Gtk.toWidget $ button wbc + getWidget wbc = lift $ Gtk.toWidget $ button wbc updateWidget wbc update = do newContents <- updateWidget (contentsController wbc) update return wbc { contentsController = newContents } - -data WorkspaceUnderlineController = WorkspaceUnderlineController - { table :: T.Table - -- XXX: An event box is used here because we need to change the background - , underline :: Gtk.EventBox - , overlineController :: WWC - } - -buildUnderlineController :: ParentControllerConstructor -buildUnderlineController contentsBuilder workspace = do - cfg <- asks workspacesConfig - cc <- contentsBuilder workspace - - lift $ do - t <- T.tableNew 2 1 False - u <- Gtk.eventBoxNew - W.widgetSetSizeRequest u (-1) $ underlineHeight cfg - - T.tableAttach t (getWidget cc) 0 1 0 1 - [T.Expand, T.Fill] [T.Expand, T.Fill] 0 0 - T.tableAttach t u 0 1 1 2 - [T.Fill] [T.Shrink] (underlinePadding cfg) 0 - - _ <- widgetSetClass u "underline" - return $ WWC WorkspaceUnderlineController - {table = t, underline = u, overlineController = cc} - -instance WorkspaceWidgetController WorkspaceUnderlineController where - getWidget uc = Gtk.toWidget $ table uc - updateWidget uc wu@(WorkspaceUpdate workspace) = - lift (setWorkspaceWidgetStatusClass workspace (underline uc)) >> - updateUnderline uc wu - updateWidget a b = updateUnderline a b - -updateUnderline :: WorkspaceUnderlineController - -> WidgetUpdate - -> WorkspacesIO WorkspaceUnderlineController -updateUnderline uc u = do - newContents <- updateWidget (overlineController uc) u - return uc { overlineController = newContents } - -data WorkspaceBorderController = WorkspaceBorderController - { border :: Gtk.EventBox - , borderContents :: Gtk.EventBox - , insideController :: WWC - } - -buildBorderController :: ParentControllerConstructor -buildBorderController contentsBuilder workspace = do - cc <- contentsBuilder workspace - cfg <- asks workspacesConfig - lift $ do - brd <- Gtk.eventBoxNew - cnt <- Gtk.eventBoxNew - Gtk.eventBoxSetVisibleWindow brd True - Gtk.containerSetBorderWidth cnt $ borderWidth cfg - Gtk.containerAdd brd cnt - Gtk.containerAdd cnt $ getWidget cc - _ <- widgetSetClass brd "border" - _ <- widgetSetClass cnt "container" - return $ - WWC - WorkspaceBorderController - {border = brd, borderContents = cnt, insideController = cc} - -instance WorkspaceWidgetController WorkspaceBorderController where - getWidget bc = Gtk.toWidget $ border bc - updateWidget bc wu@(WorkspaceUpdate workspace) = - let setClasses = setWorkspaceWidgetStatusClass workspace - in lift (setClasses (border bc) >> setClasses (borderContents bc)) >> - updateBorder bc wu - updateWidget a b = updateBorder a b - -updateBorder :: WorkspaceBorderController - -> WidgetUpdate - -> WorkspacesIO WorkspaceBorderController -updateBorder bc update = do - newContents <- updateWidget (insideController bc) update - return bc { insideController = newContents } - -buildUnderlineButtonController :: ControllerConstructor -buildUnderlineButtonController = - buildButtonController (buildUnderlineController defaultBuildContentsController) - -buildBorderButtonController :: ControllerConstructor -buildBorderButtonController = - buildButtonController (buildBorderController defaultBuildContentsController) diff --git a/src/System/Taffybar/Widget/XDGMenu/Menu.hs b/src/System/Taffybar/Widget/XDGMenu/Menu.hs --- a/src/System/Taffybar/Widget/XDGMenu/Menu.hs +++ b/src/System/Taffybar/Widget/XDGMenu/Menu.hs @@ -25,6 +25,7 @@ import Data.Char (toLower) import Data.List import Data.Maybe +import qualified Data.Text as T import System.Taffybar.Information.XDG.DesktopEntry import System.Taffybar.Information.XDG.Protocol @@ -40,10 +41,10 @@ -- | Displayable menu entry data MenuEntry = MenuEntry - { feName :: String - , feComment :: String + { feName :: T.Text + , feComment :: T.Text , feCommand :: String - , feIcon :: Maybe String + , feIcon :: Maybe T.Text } deriving (Eq, Show) -- | Fetch menus and desktop entries and assemble the menu. @@ -114,13 +115,14 @@ Nothing -> Nothing Just c -> Just $ "(" ++ c ++ ")" comment = + T.pack $ fromMaybe "??" $ case deComment langs de of Nothing -> mc Just tt -> Just $ tt ++ maybe "" ("\n" ++) mc cmd = fromMaybe "FIXME" $ deCommand de - name = deName langs de - mIcon = deIcon de + name = T.pack $ deName langs de + mIcon = T.pack <$> deIcon de -- | postprocess unallocated entries fixOnlyUnallocated :: [MenuEntry] -> Menu -> Menu diff --git a/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs b/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs --- a/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs +++ b/src/System/Taffybar/Widget/XDGMenu/MenuWidget.hs @@ -25,7 +25,9 @@ import Control.Monad import Control.Monad.IO.Class -import Graphics.UI.Gtk hiding (Menu) +import qualified Data.Text as T +import GI.Gtk hiding (Menu) +import GI.GdkPixbuf import System.Directory import System.FilePath.Posix import System.Process @@ -58,16 +60,16 @@ -- | Add a desktop entry to a gtk menu by appending a gtk menu item. -addItem :: (MenuShellClass msc) => +addItem :: (IsMenuShell msc) => msc -- ^ GTK menu -> MenuEntry -- ^ Desktop entry -> IO () addItem ms de = do item <- imageMenuItemNewWithLabel (feName de) - set item [ widgetTooltipText := Just (feComment de)] - setIcon item (feIcon de) + setWidgetTooltipText item (feComment de) + setIcon item (T.unpack <$> feIcon de) menuShellAppend ms item - _ <- on item menuItemActivated $ do + _ <- onMenuItemActivate item $ do let cmd = feCommand de putStrLn $ "Launching '" ++ cmd ++ "'" _ <- spawnCommand cmd @@ -76,7 +78,7 @@ -- | Add an xdg menu to a gtk menu by appending gtk menu items and -- submenus. -addMenu :: (MenuShellClass msc) => +addMenu :: (IsMenuShell msc) => msc -- ^ GTK menu -> Menu -- ^ menu -> IO () @@ -84,11 +86,11 @@ let subMenus = fmSubmenus fm items = fmEntries fm when (not (null items) || not (null subMenus)) $ do - item <- imageMenuItemNewWithLabel (fmName fm) + item <- imageMenuItemNewWithLabel (T.pack $ fmName fm) setIcon item (fmIcon fm) menuShellAppend ms item subMenu <- menuNew - menuItemSetSubmenu item subMenu + menuItemSetSubmenu item (Just subMenu) mapM_ (addMenu subMenu) subMenus mapM_ (addItem subMenu) items @@ -96,9 +98,9 @@ setIcon _ Nothing = return () setIcon item (Just iconName) = do iconTheme <- iconThemeGetDefault - hasIcon <- iconThemeHasIcon iconTheme iconName + hasIcon <- iconThemeHasIcon iconTheme (T.pack iconName) mImg <- if hasIcon - then Just <$> imageNewFromIconName iconName IconSizeMenu + then Just <$> imageNewFromIconName (Just $ T.pack iconName) (fromIntegral $ fromEnum IconSizeMenu) else if isAbsolute iconName then do @@ -107,23 +109,23 @@ then do let defaultSize = 24 -- FIXME should auto-adjust to font size pb <- pixbufNewFromFileAtScale iconName defaultSize defaultSize True - Just <$> imageNewFromPixbuf pb + Just <$> imageNewFromPixbuf (Just pb) else return Nothing else return Nothing case mImg of - Just img -> imageMenuItemSetImage item img + Just img -> imageMenuItemSetImage item (Just img) Nothing -> putStrLn $ "Icon not found: " ++ iconName -- | Create a new XDG Menu Widget. menuWidgetNew :: MonadIO m => Maybe String -- ^ menu name, must end with a dash, -- e.g. "mate-" or "gnome-" - -> m Widget + -> m GI.Gtk.Widget menuWidgetNew mMenuPrefix = liftIO $ do mb <- menuBarNew m <- buildMenu mMenuPrefix addMenu mb m widgetShowAll mb - return (toWidget mb) + toWidget mb -- -- | Show XDG Menu Widget in a standalone frame. -- testMenuWidget :: IO () diff --git a/taffybar.cabal b/taffybar.cabal --- a/taffybar.cabal +++ b/taffybar.cabal @@ -1,5 +1,5 @@ name: taffybar -version: 2.1.2 +version: 3.0.0 synopsis: A desktop bar similar to xmobar, but with more GUI license: BSD3 license-file: LICENSE @@ -59,11 +59,10 @@ , gi-glib , gi-gtk , gi-gtk-hs + , gi-pango , glib - , gtk-sni-tray >= 0.1.3.1 + , gtk-sni-tray >= 0.1.4.0 , gtk-strut >= 0.1.2.1 - , gtk-traymanager >= 1.0.1 && < 2.0.0 - , gtk3 >= 0.14.9 , haskell-gi >= 0.21.2 , haskell-gi-base >= 0.21.1 , hslogger @@ -75,11 +74,11 @@ , regex-compat , safe >= 0.3 && < 1 , split >= 0.1.4.2 - , status-notifier-item >= 0.2.2.0 + , status-notifier-item >= 0.3.0.0 , stm , template-haskell , text - , time >= 1.4 && < 2.0 + , time >= 1.8 && < 2.0 , time-locale-compat >= 0.1 && < 0.2 , time-units >= 1.0.0 , transformers >= 0.3.0.0 @@ -101,7 +100,6 @@ pkgconfig-depends: gtk+-3.0 exposed-modules: System.Taffybar , System.Taffybar.Auth - , System.Taffybar.Compat.GtkLibs , System.Taffybar.Context , System.Taffybar.DBus , System.Taffybar.DBus.Toggle @@ -145,7 +143,6 @@ , System.Taffybar.Widget.NetworkGraph , System.Taffybar.Widget.SNITray , System.Taffybar.Widget.SimpleClock - , System.Taffybar.Widget.Systray , System.Taffybar.Widget.Text.CPUMonitor , System.Taffybar.Widget.Text.MemoryMonitor , System.Taffybar.Widget.Text.NetworkMonitor diff --git a/taffybar.css b/taffybar.css --- a/taffybar.css +++ b/taffybar.css @@ -12,6 +12,12 @@ /* Top level styling */ .taffy-window * { + /* + This removes any existing styling from UI elements. Taffybar will not cohere + with your gtk theme. + */ + all: unset; + font-family: "Noto Sans", sans-serif; font-size: 10pt; color: @font-color;