gtk-strut 0.1.3.0 → 0.1.3.1
raw patch · 3 files changed
+119/−29 lines, 3 filesdep +data-defaultdep +hslogger
Dependencies added: data-default, hslogger
Files
- gtk-strut.cabal +4/−4
- src/Graphics/UI/EWMHStrut.hs +17/−0
- src/Graphics/UI/GIGtkStrut.hs +98/−25
gtk-strut.cabal view
@@ -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 <https://github.com/IvanMalison/gtk-strut#readme> 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
src/Graphics/UI/EWMHStrut.hs view
@@ -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)
src/Graphics/UI/GIGtkStrut.hs view
@@ -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