diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for gtk-strut + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ivan Malison (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ivan Malison nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# gtk-strut diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gtk-strut.cabal b/gtk-strut.cabal new file mode 100644 --- /dev/null +++ b/gtk-strut.cabal @@ -0,0 +1,43 @@ +-- This file has been generated from package.yaml by hpack version 0.27.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: fe4485dfb03709a5eca48ff263f4c8d94171ddf58082c04fd8f0aad138ca6048 + +name: gtk-strut +version: 0.1.0.0 +synopsis: Libary for creating strut windows with gi-gtk +description: Please see the README on Github at +category: System +homepage: https://github.com/IvanMalison/gtk-strut#readme +bug-reports: https://github.com/IvanMalison/gtk-strut/issues +author: Ivan Malison +maintainer: IvanMalison@gmail.com +copyright: Ivan Malison +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/IvanMalison/gtk-strut + +library + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , gi-gdk + , gi-gtk + , text + , transformers + exposed-modules: + Graphics.UI.GIGtkStrut + other-modules: + Graphics.UI.EWMHStrut + default-language: Haskell2010 diff --git a/src/Graphics/UI/EWMHStrut.hs b/src/Graphics/UI/EWMHStrut.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/EWMHStrut.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedStrings #-} +module Graphics.UI.EWMHStrut where + +import Control.Monad.IO.Class +import Data.Int +import Data.Text +import Data.Word +import Foreign.C.Types +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable + +import qualified GI.Gdk as Gdk + +data EWMHStrutSettings = EWMHStrutSettings + { _left :: Int32 + , _right :: Int32 + , _top :: Int32 + , _bottom :: Int32 + , _left_start_y :: Int32 + , _left_end_y :: Int32 + , _right_start_y :: Int32 + , _right_end_y :: Int32 + , _top_start_x :: Int32 + , _top_end_x :: Int32 + , _bottom_start_x :: Int32 + , _bottom_end_x :: Int32 + } deriving (Show, Eq) + +zeroStrutSettings = EWMHStrutSettings + { _left = 0 + , _right = 0 + , _top = 0 + , _bottom = 0 + , _left_start_y = 0 + , _left_end_y = 0 + , _right_start_y = 0 + , _right_end_y = 0 + , _top_start_x = 0 + , _top_end_x = 0 + , _bottom_start_x = 0 + , _bottom_end_x = 0 + } + +strutSettingsToPtr :: MonadIO m => EWMHStrutSettings -> m (Ptr CULong) +strutSettingsToPtr EWMHStrutSettings + { _left = left + , _right = right + , _top = top + , _bottom = bottom + , _left_start_y = left_start_y + , _left_end_y = left_end_y + , _right_start_y = right_start_y + , _right_end_y = right_end_y + , _top_start_x = top_start_x + , _top_end_x = top_end_x + , _bottom_start_x = bottom_start_x + , _bottom_end_x = bottom_end_x + } = liftIO $ do + arr <- mallocArray 12 + let doPoke off v = pokeElemOff arr off $ fromIntegral v + doPoke 0 left + doPoke 1 right + doPoke 2 top + doPoke 3 bottom + doPoke 4 left_start_y + doPoke 5 left_end_y + doPoke 6 right_start_y + doPoke 7 right_end_y + doPoke 8 top_start_x + doPoke 9 top_end_x + doPoke 10 bottom_start_x + doPoke 11 bottom_end_x + return arr + +foreign import ccall "gdk_property_change" gdk_property_change :: + Ptr Gdk.Window -> + Ptr Gdk.Atom -> Ptr Gdk.Atom -> Int32 -> CUInt -> Ptr CUChar -> Int32 -> IO () + +propertyChange + :: (Gdk.IsWindow a, MonadIO m) + => a + -> Gdk.Atom + -> Gdk.Atom + -> Int32 + -> Gdk.PropMode + -> Ptr CUChar + -> Int32 + -> m () +propertyChange window property type_ format mode data_ nelements = liftIO $ do + window' <- Gdk.unsafeManagedPtrCastPtr window + property' <- Gdk.unsafeManagedPtrGetPtr property + type_' <- Gdk.unsafeManagedPtrGetPtr type_ + let mode' = (fromIntegral . fromEnum) mode + gdk_property_change window' property' type_' format mode' data_ nelements + Gdk.touchManagedPtr window + Gdk.touchManagedPtr property + Gdk.touchManagedPtr type_ + return () + +setStrut :: MonadIO m => Gdk.IsWindow w => w -> EWMHStrutSettings -> m () +setStrut w settings = do + strutAtom <- Gdk.atomIntern "_NET_WM_STRUT_PARTIAL" False + cardinalAtom <- Gdk.atomIntern "CARDINAL" False + settingsArray <- castPtr <$> strutSettingsToPtr settings + propertyChange w strutAtom cardinalAtom 32 Gdk.PropModeReplace settingsArray 12 diff --git a/src/Graphics/UI/GIGtkStrut.hs b/src/Graphics/UI/GIGtkStrut.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GIGtkStrut.hs @@ -0,0 +1,152 @@ +module Graphics.UI.GIGtkStrut where + + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Data.Int +import Data.Maybe +import Data.Ratio +import qualified Data.Text as T +import qualified GI.Gdk as Gdk +import qualified GI.Gtk as Gtk +import Graphics.UI.EWMHStrut + +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 + , strutXPadding :: Int32 + , strutYPadding :: Int32 + , strutMonitor :: Maybe Int32 + , strutPosition :: StrutPosition + , strutAlignment :: StrutAlignment + , strutDisplayName :: Maybe T.Text + } deriving (Show, Eq) + +defaultStrutConfig = StrutConfig + { strutWidth = ScreenRatio 1 + , strutHeight = ScreenRatio 1 + , strutXPadding = 0 + , strutYPadding = 0 + , strutMonitor = Nothing + , strutPosition = TopPos + , strutAlignment = Beginning + , strutDisplayName = Nothing + } + +buildStrutWindow :: MonadIO m => StrutConfig -> m Gtk.Window +buildStrutWindow StrutConfig + { strutWidth = widthSize + , strutHeight = heightSize + , strutXPadding = xpadding + , strutYPadding = ypadding + , strutMonitor = monitorNumber + , strutPosition = position + , strutAlignment = alignment + , strutDisplayName = displayName + } = do + Just display <- maybe Gdk.displayGetDefault Gdk.displayOpen displayName + Just monitor <- maybe (Gdk.displayGetPrimaryMonitor display) + (Gdk.displayGetMonitor display) monitorNumber + monitorCount <- Gdk.displayGetNMonitors display + 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 + screenWidth <- maximum <$> mapM getFullX allGeometries + screenHeight <- maximum <$> mapM getFullY allGeometries + screen <- Gdk.displayGetDefaultScreen display + + window <- Gtk.windowNew Gtk.WindowTypeToplevel + Gtk.windowSetTypeHint window Gdk.WindowTypeHintDock + geometry <- Gdk.newZeroGeometry + + monitorGeometry <- Gdk.monitorGetGeometry 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))) + + Gdk.setGeometryBaseWidth geometry width + Gdk.setGeometryBaseHeight geometry height + Gdk.setGeometryMinWidth geometry width + Gdk.setGeometryMinHeight geometry height + Gdk.setGeometryMaxWidth geometry width + Gdk.setGeometryMaxHeight geometry height + Gtk.windowSetGeometryHints window (Nothing :: Maybe Gtk.Window) + (Just geometry) allHints + + let paddedHeight = (height + 2 * ypadding) + paddedWidth = (width + 2 * xpadding) + getAlignedPos dimensionPos dpadding monitorSize barSize = + dimensionPos + + case alignment of + Beginning -> dpadding + Center -> (monitorSize - barSize) `div` 2 + End -> monitorSize - barSize - dpadding + xAligned = getAlignedPos monitorX xpadding monitorWidth width + yAligned = getAlignedPos monitorY ypadding monitorHeight height + (xPos, yPos) = + case position of + TopPos -> (xAligned, monitorY + ypadding) + BottomPos -> (xAligned, monitorY + monitorHeight - height - ypadding) + LeftPos -> (monitorX + xpadding, yAligned) + RightPos -> (monitorX + monitorWidth - width - xpadding, yAligned) + + Gtk.windowSetScreen window screen + Gtk.windowMove window xPos yPos + + let ewmhSettings = + case position of + TopPos -> + zeroStrutSettings + { _top = monitorY + paddedHeight + , _top_start_x = xPos - xpadding + , _top_end_x = xPos + width + xpadding + } + BottomPos -> + zeroStrutSettings + { _bottom = screenHeight - monitorY - monitorHeight + paddedHeight + , _bottom_start_x = xPos - xpadding + , _bottom_end_x = xPos + width + xpadding + } + LeftPos -> + zeroStrutSettings + { _left = monitorX + paddedWidth + , _left_start_y = yPos - ypadding + , _left_end_y = yPos + height + ypadding + } + RightPos -> + zeroStrutSettings + { _right = screenWidth - monitorX - monitorWidth + paddedWidth + , _right_start_y = yPos - ypadding + , _right_end_y = yPos + height + ypadding + } + setStrutProperties = + void $ runMaybeT $ do + gdkWindow <- MaybeT $ Gtk.widgetGetWindow window + lift $ setStrut gdkWindow ewmhSettings + + Gtk.onWidgetRealize window setStrutProperties + + return window + +allHints = + [ Gdk.WindowHintsMinSize + , Gdk.WindowHintsMaxSize + , Gdk.WindowHintsBaseSize + , Gdk.WindowHintsUserPos + , Gdk.WindowHintsUserSize + ]