{-# 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 :: Int32
_left = EWMHStrutSettings -> Int32
_left EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
scaleFactor
  , _right :: Int32
_right = EWMHStrutSettings -> Int32
_right EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
scaleFactor
  , _top :: Int32
_top = EWMHStrutSettings -> Int32
_top EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
scaleFactor
  , _bottom :: Int32
_bottom = EWMHStrutSettings -> Int32
_bottom EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
scaleFactor
  , _left_start_y :: Int32
_left_start_y = EWMHStrutSettings -> Int32
_left_start_y EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
scaleFactor
  , _left_end_y :: Int32
_left_end_y = EWMHStrutSettings -> Int32
_left_end_y EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
scaleFactor
  , _right_start_y :: Int32
_right_start_y = EWMHStrutSettings -> Int32
_right_start_y EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
scaleFactor
  , _right_end_y :: Int32
_right_end_y = EWMHStrutSettings -> Int32
_right_end_y EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
scaleFactor
  , _top_start_x :: Int32
_top_start_x = EWMHStrutSettings -> Int32
_top_start_x EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
scaleFactor
  , _top_end_x :: Int32
_top_end_x = EWMHStrutSettings -> Int32
_top_end_x EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
scaleFactor
  , _bottom_start_x :: Int32
_bottom_start_x = EWMHStrutSettings -> Int32
_bottom_start_x EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
scaleFactor
  , _bottom_end_x :: Int32
_bottom_end_x = EWMHStrutSettings -> Int32
_bottom_end_x EWMHStrutSettings
st Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
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
  Ptr CULong
arr <- Int -> IO (Ptr CULong)
forall a. Storable a => Int -> IO (Ptr a)
mallocArray Int
12
  let doPoke :: Int -> Int32 -> IO ()
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
  Int -> Int32 -> IO ()
doPoke Int
0 Int32
left
  Int -> Int32 -> IO ()
doPoke Int
1 Int32
right
  Int -> Int32 -> IO ()
doPoke Int
2 Int32
top
  Int -> Int32 -> IO ()
doPoke Int
3 Int32
bottom
  Int -> Int32 -> IO ()
doPoke Int
4 Int32
left_start_y
  Int -> Int32 -> IO ()
doPoke Int
5 Int32
left_end_y
  Int -> Int32 -> IO ()
doPoke Int
6 Int32
right_start_y
  Int -> Int32 -> IO ()
doPoke Int
7 Int32
right_end_y
  Int -> Int32 -> IO ()
doPoke Int
8 Int32
top_start_x
  Int -> Int32 -> IO ()
doPoke Int
9 Int32
top_end_x
  Int -> Int32 -> IO ()
doPoke Int
10 Int32
bottom_start_x
  Int -> Int32 -> IO ()
doPoke Int
11 Int32
bottom_end_x
  Ptr CULong -> IO (Ptr CULong)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr CULong
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
    Ptr Window
window' <- a -> IO (Ptr Window)
forall a b. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr b)
Gdk.unsafeManagedPtrCastPtr a
window
    Ptr Atom
property' <- Atom -> IO (Ptr Atom)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
Gdk.unsafeManagedPtrGetPtr Atom
property
    Ptr Atom
type_' <- Atom -> IO (Ptr Atom)
forall a. (HasCallStack, ManagedPtrNewtype a) => a -> IO (Ptr a)
Gdk.unsafeManagedPtrGetPtr Atom
type_
    let mode' :: CUInt
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
    Ptr Window
-> Ptr Atom
-> Ptr Atom
-> Int32
-> CUInt
-> Ptr CUChar
-> Int32
-> IO ()
gdk_property_change Ptr Window
window' Ptr Atom
property' Ptr Atom
type_' Int32
format CUInt
mode' Ptr CUChar
data_ Int32
nelements
    a -> IO ()
forall a. ManagedPtrNewtype a => a -> IO ()
Gdk.touchManagedPtr a
window
    Atom -> IO ()
forall a. ManagedPtrNewtype a => a -> IO ()
Gdk.touchManagedPtr Atom
property
    Atom -> IO ()
forall a. ManagedPtrNewtype a => a -> IO ()
Gdk.touchManagedPtr Atom
type_
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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
  Atom
strutAtom <- Text -> Bool -> m Atom
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Bool -> m Atom
Gdk.atomIntern Text
"_NET_WM_STRUT_PARTIAL" Bool
False
  Atom
cardinalAtom <- Text -> Bool -> m Atom
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Bool -> m Atom
Gdk.atomIntern Text
"CARDINAL" Bool
False
  Ptr CUChar
settingsArray <- Ptr CULong -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr (Ptr CULong -> Ptr CUChar) -> m (Ptr CULong) -> m (Ptr CUChar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EWMHStrutSettings -> m (Ptr CULong)
forall (m :: * -> *).
MonadIO m =>
EWMHStrutSettings -> m (Ptr CULong)
strutSettingsToPtr EWMHStrutSettings
settings
  w
-> Atom -> Atom -> Int32 -> PropMode -> Ptr CUChar -> Int32 -> m ()
forall a (m :: * -> *).
(IsWindow a, MonadIO m) =>
a
-> Atom -> Atom -> Int32 -> PropMode -> Ptr CUChar -> Int32 -> m ()
propertyChange w
w Atom
strutAtom Atom
cardinalAtom Int32
32 PropMode
Gdk.PropModeReplace Ptr CUChar
settingsArray Int32
12