gtk-strut (empty) → 0.1.0.0

raw patch · 7 files changed

+337/−0 lines, 7 filesdep +basedep +gi-gdkdep +gi-gtksetup-changed

Dependencies added: base, gi-gdk, gi-gtk, text, transformers

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• gtk-strut.cabal +43/−0
• src/Graphics/UI/EWMHStrut.hs +106/−0
• src/Graphics/UI/GIGtkStrut.hs +152/−0

@@ -0,0 +1,3 @@+# Changelog for gtk-strut++## Unreleased changes

@@ -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.

@@ -0,0 +1,1 @@+# gtk-strut

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <https://github.com/IvanMalison/gtk-strut#readme>+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

@@ -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

@@ -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+  ]