{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MonoLocalBinds #-}
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
  { EWMHStrutSettings -> Int32
_left :: Int32
  , EWMHStrutSettings -> Int32
_right :: Int32
  , EWMHStrutSettings -> Int32
_top :: Int32
  , EWMHStrutSettings -> Int32
_bottom :: Int32
  , EWMHStrutSettings -> Int32
_left_start_y :: Int32
  , EWMHStrutSettings -> Int32
_left_end_y :: Int32
  , EWMHStrutSettings -> Int32
_right_start_y :: Int32
  , EWMHStrutSettings -> Int32
_right_end_y :: Int32
  , EWMHStrutSettings -> Int32
_top_start_x :: Int32
  , EWMHStrutSettings -> Int32
_top_end_x :: Int32
  , EWMHStrutSettings -> Int32
_bottom_start_x :: Int32
  , EWMHStrutSettings -> Int32
_bottom_end_x :: Int32
  } deriving (Int -> EWMHStrutSettings -> ShowS
[EWMHStrutSettings] -> ShowS
EWMHStrutSettings -> String
(Int -> EWMHStrutSettings -> ShowS)
-> (EWMHStrutSettings -> String)
-> ([EWMHStrutSettings] -> ShowS)
-> Show EWMHStrutSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EWMHStrutSettings -> ShowS
showsPrec :: Int -> EWMHStrutSettings -> ShowS
$cshow :: EWMHStrutSettings -> String
show :: EWMHStrutSettings -> String
$cshowList :: [EWMHStrutSettings] -> ShowS
showList :: [EWMHStrutSettings] -> ShowS
Show, EWMHStrutSettings -> EWMHStrutSettings -> Bool
(EWMHStrutSettings -> EWMHStrutSettings -> Bool)
-> (EWMHStrutSettings -> EWMHStrutSettings -> Bool)
-> Eq EWMHStrutSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EWMHStrutSettings -> EWMHStrutSettings -> Bool
== :: EWMHStrutSettings -> EWMHStrutSettings -> Bool
$c/= :: EWMHStrutSettings -> EWMHStrutSettings -> Bool
/= :: EWMHStrutSettings -> EWMHStrutSettings -> Bool
Eq)

zeroStrutSettings :: EWMHStrutSettings
zeroStrutSettings = EWMHStrutSettings
  { _left :: Int32
_left = Int32
0
  , _right :: Int32
_right = Int32
0
  , _top :: Int32
_top = Int32
0
  , _bottom :: Int32
_bottom = Int32
0
  , _left_start_y :: Int32
_left_start_y = Int32
0
  , _left_end_y :: Int32
_left_end_y = Int32
0
  , _right_start_y :: Int32
_right_start_y = Int32
0
  , _right_end_y :: Int32
_right_end_y = Int32
0
  , _top_start_x :: Int32
_top_start_x = Int32
0
  , _top_end_x :: Int32
_top_end_x = Int32
0
  , _bottom_start_x :: Int32
_bottom_start_x = Int32
0
  , _bottom_end_x :: Int32
_bottom_end_x = Int32
0
  }

scaleStrutSettings :: Int32 -> EWMHStrutSettings -> EWMHStrutSettings
scaleStrutSettings :: Int32 -> EWMHStrutSettings -> EWMHStrutSettings
scaleStrutSettings Int32
scaleFactor EWMHStrutSettings
st = EWMHStrutSettings
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 :: forall (m :: * -> *).
MonadIO m =>
EWMHStrutSettings -> m (Ptr CULong)
strutSettingsToPtr EWMHStrutSettings
                     { _left :: EWMHStrutSettings -> Int32
_left = Int32
left
                     , _right :: EWMHStrutSettings -> Int32
_right = Int32
right
                     , _top :: EWMHStrutSettings -> Int32
_top = Int32
top
                     , _bottom :: EWMHStrutSettings -> Int32
_bottom = Int32
bottom
                     , _left_start_y :: EWMHStrutSettings -> Int32
_left_start_y = Int32
left_start_y
                     , _left_end_y :: EWMHStrutSettings -> Int32
_left_end_y = Int32
left_end_y
                     , _right_start_y :: EWMHStrutSettings -> Int32
_right_start_y = Int32
right_start_y
                     , _right_end_y :: EWMHStrutSettings -> Int32
_right_end_y = Int32
right_end_y
                     , _top_start_x :: EWMHStrutSettings -> Int32
_top_start_x = Int32
top_start_x
                     , _top_end_x :: EWMHStrutSettings -> Int32
_top_end_x = Int32
top_end_x
                     , _bottom_start_x :: EWMHStrutSettings -> Int32
_bottom_start_x = Int32
bottom_start_x
                     , _bottom_end_x :: EWMHStrutSettings -> Int32
_bottom_end_x = Int32
bottom_end_x
                     } = IO (Ptr CULong) -> m (Ptr CULong)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr CULong) -> m (Ptr CULong))
-> IO (Ptr CULong) -> m (Ptr CULong)
forall a b. (a -> b) -> a -> b
$ do
  arr <- Int -> IO (Ptr CULong)
forall a. Storable a => Int -> IO (Ptr a)
mallocArray Int
12
  let doPoke Int
off Int32
v = Ptr CULong -> Int -> CULong -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr CULong
arr Int
off (CULong -> IO ()) -> CULong -> IO ()
forall a b. (a -> b) -> a -> b
$ Int32 -> CULong
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
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 :: forall a (m :: * -> *).
(IsWindow a, MonadIO m) =>
a
-> Atom -> Atom -> Int32 -> PropMode -> Ptr CUChar -> Int32 -> m ()
propertyChange a
window Atom
property Atom
type_ Int32
format PropMode
mode Ptr CUChar
data_ Int32
nelements = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    window' <- a -> IO (Ptr Window)
forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
Gdk.unsafeManagedPtrCastPtr a
window
    property' <- Gdk.unsafeManagedPtrGetPtr property
    type_' <- Gdk.unsafeManagedPtrGetPtr type_
    let mode' = (Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CUInt) -> (PropMode -> Int) -> PropMode -> CUInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropMode -> Int
forall a. Enum a => a -> Int
fromEnum) PropMode
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 :: forall (m :: * -> *) w.
(MonadIO m, IsWindow w) =>
w -> EWMHStrutSettings -> m ()
setStrut w
w EWMHStrutSettings
settings = do
  strutAtom <- Text -> Bool -> m Atom
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Bool -> m Atom
Gdk.atomIntern Text
"_NET_WM_STRUT_PARTIAL" Bool
False
  cardinalAtom <- Gdk.atomIntern "CARDINAL" False
  settingsArray <- castPtr <$> strutSettingsToPtr settings
  propertyChange w strutAtom cardinalAtom 32 Gdk.PropModeReplace settingsArray 12