EWMHStrut.hs

{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}

module Graphics.UI.EWMHStrut where

import Control.Monad.IO.Class
import Data.Int
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
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
    }

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