diff --git a/gtk-strut.cabal b/gtk-strut.cabal --- a/gtk-strut.cabal +++ b/gtk-strut.cabal @@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack --- --- hash: 59b81efe446840a83cfa0445adb590537b8ca5f8fad1b907a117b4e6e7daaba9 name: gtk-strut -version: 0.1.3.0 +version: 0.1.3.1 synopsis: Libary for creating strut windows with gi-gtk description: Please see the README on Github at category: System @@ -36,8 +34,10 @@ src build-depends: base >=4.7 && <5 + , data-default , gi-gdk , gi-gtk + , hslogger , text , transformers default-language: Haskell2010 diff --git a/src/Graphics/UI/EWMHStrut.hs b/src/Graphics/UI/EWMHStrut.hs --- a/src/Graphics/UI/EWMHStrut.hs +++ b/src/Graphics/UI/EWMHStrut.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MonoLocalBinds #-} module Graphics.UI.EWMHStrut where import Control.Monad.IO.Class @@ -40,6 +41,22 @@ , _top_end_x = 0 , _bottom_start_x = 0 , _bottom_end_x = 0 + } + +scaleStrutSettings :: Int32 -> EWMHStrutSettings -> EWMHStrutSettings +scaleStrutSettings scaleFactor st = st + { _left = _left st * scaleFactor + , _right = _right st * scaleFactor + , _top = _top st * scaleFactor + , _bottom = _bottom st * scaleFactor + , _left_start_y = _left_start_y st * scaleFactor + , _left_end_y = _left_end_y st * scaleFactor + , _right_start_y = _right_start_y st * scaleFactor + , _right_end_y = _right_end_y st * scaleFactor + , _top_start_x = _top_start_x st * scaleFactor + , _top_end_x = _top_end_x st * scaleFactor + , _bottom_start_x = _bottom_start_x st * scaleFactor + , _bottom_end_x = _bottom_end_x st * scaleFactor } strutSettingsToPtr :: MonadIO m => EWMHStrutSettings -> m (Ptr CULong) diff --git a/src/Graphics/UI/GIGtkStrut.hs b/src/Graphics/UI/GIGtkStrut.hs --- a/src/Graphics/UI/GIGtkStrut.hs +++ b/src/Graphics/UI/GIGtkStrut.hs @@ -1,21 +1,43 @@ -module Graphics.UI.GIGtkStrut where +module Graphics.UI.GIGtkStrut + ( defaultStrutConfig + , StrutPosition(..) + , StrutSize(..) + , StrutAlignment(..) + , StrutConfig(..) + , buildStrutWindow + , setupStrutWindow + ) where import Control.Monad -import Control.Monad.IO.Class import Control.Monad.Fail (MonadFail) +import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe +import Data.Default import Data.Int import Data.Maybe import qualified Data.Text as T import qualified GI.Gdk as Gdk import qualified GI.Gtk as Gtk import Graphics.UI.EWMHStrut +import System.Log.Logger +import Text.Printf -data StrutPosition = TopPos | BottomPos | LeftPos | RightPos deriving (Show, Read, Eq) -data StrutAlignment = Beginning | Center | End deriving (Show, Read, Eq) -data StrutSize = ExactSize Int32 | ScreenRatio Rational deriving (Show, Read, Eq) +strutLog :: MonadIO m => Priority -> String -> m () +strutLog p s = liftIO $ logM "Graphics.UI.GIGtkStrut" p s +data StrutPosition + = TopPos | BottomPos | LeftPos | RightPos + deriving (Show, Read, Eq) + +data StrutAlignment + = Beginning | Center | End + deriving (Show, Read, Eq) + +data StrutSize + = ExactSize Int32 | ScreenRatio Rational + deriving (Show, Read, Eq) + data StrutConfig = StrutConfig { strutWidth :: StrutSize , strutHeight :: StrutSize @@ -38,51 +60,83 @@ , strutDisplayName = Nothing } +instance Default StrutConfig where + def = + StrutConfig + { strutWidth = ScreenRatio 1 + , strutHeight = ScreenRatio 1 + , strutXPadding = 0 + , strutYPadding = 0 + , strutMonitor = Nothing + , strutPosition = TopPos + , strutAlignment = Beginning + , strutDisplayName = Nothing + } + + +-- | Build a strut window to the specifications provided by the 'StrutConfig' +-- argument. buildStrutWindow :: (MonadFail m, MonadIO m) => StrutConfig -> m Gtk.Window buildStrutWindow config = do window <- Gtk.windowNew Gtk.WindowTypeToplevel setupStrutWindow config window return window +-- | Configure the provided 'Gtk.Window' so that it has the properties specified +-- by the 'StrutConfig' argument. setupStrutWindow :: (MonadFail m, MonadIO m) => StrutConfig -> Gtk.Window -> m () setupStrutWindow StrutConfig - { strutWidth = widthSize - , strutHeight = heightSize - , strutXPadding = xpadding - , strutYPadding = ypadding - , strutMonitor = monitorNumber - , strutPosition = position - , strutAlignment = alignment - , strutDisplayName = displayName - } window = do + { strutWidth = widthSize + , strutHeight = heightSize + , strutXPadding = xpadding + , strutYPadding = ypadding + , strutMonitor = monitorNumber + , strutPosition = position + , strutAlignment = alignment + , strutDisplayName = displayName + } window = do + strutLog DEBUG "Starting strut window setup" Just display <- maybe Gdk.displayGetDefault Gdk.displayOpen displayName Just monitor <- maybe (Gdk.displayGetPrimaryMonitor display) (Gdk.displayGetMonitor display) monitorNumber + screen <- Gdk.displayGetDefaultScreen display monitorCount <- Gdk.displayGetNMonitors display - allMonitors <- catMaybes <$> mapM (Gdk.displayGetMonitor display) [0..(monitorCount-1)] + allMonitors <- catMaybes <$> mapM (Gdk.displayGetMonitor display) + [0..(monitorCount-1)] allGeometries <- mapM Gdk.monitorGetGeometry allMonitors - let getFullY geometry = (+) <$> Gdk.getRectangleY geometry <*> Gdk.getRectangleHeight geometry - getFullX geometry = (+) <$> Gdk.getRectangleX geometry <*> Gdk.getRectangleWidth geometry + + let getFullY geometry = (+) <$> Gdk.getRectangleY geometry + <*> Gdk.getRectangleHeight geometry + getFullX geometry = (+) <$> Gdk.getRectangleX geometry + <*> Gdk.getRectangleWidth geometry + + -- The screen concept actually encapsulates things displayed across multiple + -- monitors, which is why we take the maximum here -- what we really want to + -- know is what is the farthest we can go in each direction on any monitor. screenWidth <- maximum <$> mapM getFullX allGeometries screenHeight <- maximum <$> mapM getFullY allGeometries - Gtk.windowSetTypeHint window Gdk.WindowTypeHintDock geometry <- Gdk.newZeroGeometry monitorGeometry <- Gdk.monitorGetGeometry monitor + monitorScaleFactor <- Gdk.monitorGetScaleFactor monitor monitorWidth <- Gdk.getRectangleWidth monitorGeometry monitorHeight <- Gdk.getRectangleHeight monitorGeometry monitorX <- Gdk.getRectangleX monitorGeometry monitorY <- Gdk.getRectangleY monitorGeometry - let width = case widthSize of - ExactSize w -> w - ScreenRatio p -> floor $ p * fromIntegral (monitorWidth - (2 * xpadding)) - height = case heightSize of - ExactSize h -> h - ScreenRatio p -> floor $ p * fromIntegral (monitorHeight - (2 * ypadding)) + let width = + case widthSize of + ExactSize w -> w + ScreenRatio p -> + floor $ p * fromIntegral (monitorWidth - (2 * xpadding)) + height = + case heightSize of + ExactSize h -> h + ScreenRatio p -> + floor $ p * fromIntegral (monitorHeight - (2 * ypadding)) Gdk.setGeometryBaseWidth geometry width Gdk.setGeometryBaseHeight geometry height @@ -110,6 +164,7 @@ LeftPos -> (monitorX + xpadding, yAligned) RightPos -> (monitorX + monitorWidth - width - xpadding, yAligned) + Gtk.windowSetTypeHint window Gdk.WindowTypeHintDock Gtk.windowSetScreen window screen Gtk.windowMove window xPos yPos Gtk.windowSetKeepBelow window True @@ -140,10 +195,28 @@ , _right_start_y = yPos - ypadding , _right_end_y = yPos + height + ypadding - 1 } + scaledStrutSettings = scaleStrutSettings monitorScaleFactor ewmhSettings setStrutProperties = void $ runMaybeT $ do gdkWindow <- MaybeT $ Gtk.widgetGetWindow window - lift $ setStrut gdkWindow ewmhSettings + lift $ setStrut gdkWindow scaledStrutSettings + logPairs = + [ ("width", show width) + , ("height", show height) + , ("xPos", show xPos) + , ("yPos", show yPos) + , ("paddedWidth", show paddedWidth) + , ("paddedHeight", show paddedHeight) + , ("monitorWidth", show monitorWidth) + , ("monitorHeight", show monitorHeight) + , ("monitorX", show monitorX) + , ("monitorY", show monitorY) + , ("strutSettings", show ewmhSettings) + , ("scaledStrutSettings", show scaledStrutSettings) + ] + + strutLog DEBUG "Properties:" + mapM_ (\(name, value) -> strutLog WARNING $ printf "%s: %s" name value) logPairs void $ Gtk.onWidgetRealize window setStrutProperties