path: root/Thunk/XlibExtras.hsc

module Thunk.XlibExtras where

import Graphics.X11.Xlib
import Graphics.X11.Xlib.Types
import Foreign
import Foreign.C.Types
import Control.Monad (ap)

#include "XlibExtras.h"

data Event 
    = AnyEvent
        { event_type            :: EventType
        , serial                :: CULong
        , send_event            :: Bool
        , event_display         :: Display
        , window                :: Window
        }
    | ConfigureRequestEvent
        { event_type            :: EventType
        , serial                :: CULong
        , send_event            :: Bool
        , event_display         :: Display
        , parent                :: Window
        , window                :: Window
        , x                     :: Int
        , y                     :: Int
        , width                 :: Int
        , height                :: Int
        , border_width          :: Int
        , above                 :: Window
        , detail                :: Int
        , value_mask            :: CULong
        }
    | MapRequestEvent
        { event_type            :: EventType
        , serial                :: CULong
        , send_event            :: Bool
        , event_display         :: Display
        , parent                :: Window
        , window                :: Window
        }
    | KeyEvent
        { event_type            :: EventType
        , serial                :: CULong
        , send_event            :: Bool
        , event_display         :: Display
        , window                :: Window
        , root                  :: Window
        , subwindow             :: Window
        , time                  :: Time
        , x                     :: Int
        , y                     :: Int
        , x_root                :: Int
        , y_root                :: Int
        , state                 :: KeyMask
        , keycode               :: KeyCode
        , same_screen           :: Bool
        }
    | DestroyWindowEvent
        { event_type            :: EventType
        , serial                :: CULong
        , send_event            :: Bool
        , event_display         :: Display
        , event                 :: Window
        , window                :: Window
        }
    | UnmapEvent
        { event_type            :: EventType
        , serial                :: CULong
        , send_event            :: Bool
        , event_display         :: Display
        , event                 :: Window
        , window                :: Window
        , fromConfigure         :: Bool
        }
    deriving Show

getEvent :: XEventPtr -> IO Event
getEvent p = do
    -- All events share this layout and naming convention, there is also a
    -- common Window field, but the names for this field vary.
    type_ <- #{peek XAnyEvent, type} p
    serial_ <- #{peek XAnyEvent, serial} p
    send_event_ <- #{peek XAnyEvent, send_event} p
    display_ <- fmap Display (#{peek XAnyEvent, display} p)
    case () of

        -------------------------
        -- ConfigureRequestEvent:
        -------------------------
        _ | type_ == configureRequest -> do
            parent_       <- #{peek XConfigureRequestEvent, parent      } p
            window_       <- #{peek XConfigureRequestEvent, window      } p
            x_            <- #{peek XConfigureRequestEvent, x           } p
            y_            <- #{peek XConfigureRequestEvent, y           } p
            width_        <- #{peek XConfigureRequestEvent, width       } p
            height_       <- #{peek XConfigureRequestEvent, height      } p
            border_width_ <- #{peek XConfigureRequestEvent, border_width} p
            above_        <- #{peek XConfigureRequestEvent, above       } p
            detail_       <- #{peek XConfigureRequestEvent, detail      } p
            value_mask_   <- #{peek XConfigureRequestEvent, value_mask  } p
            return $ ConfigureRequestEvent
                        { event_type    = type_
                        , serial        = serial_
                        , send_event    = send_event_
                        , event_display = display_
                        , parent        = parent_
                        , window        = window_
                        , x             = x_
                        , y             = y_
                        , width         = width_
                        , height        = height_
                        , border_width  = border_width_
                        , above         = above_
                        , detail        = detail_
                        , value_mask    = value_mask_
                        }

          -------------------
          -- MapRequestEvent:
          -------------------
          | type_ == mapRequest -> do
            parent_ <- #{peek XMapRequestEvent, parent} p
            window_ <- #{peek XMapRequestEvent, window} p
            return $ MapRequestEvent
                        { event_type    = type_
                        , serial        = serial_
                        , send_event    = send_event_
                        , event_display = display_
                        , parent        = parent_
                        , window        = window_
                        }

          ------------
          -- KeyEvent:
          ------------
          | type_ == keyPress || type_ == keyRelease -> do
            window_      <- #{peek XKeyEvent, window     } p
            root_        <- #{peek XKeyEvent, root       } p
            subwindow_   <- #{peek XKeyEvent, subwindow  } p
            time_        <- #{peek XKeyEvent, time       } p
            x_           <- #{peek XKeyEvent, x          } p
            y_           <- #{peek XKeyEvent, y          } p
            x_root_      <- #{peek XKeyEvent, x_root     } p
            y_root_      <- #{peek XKeyEvent, y_root     } p
            state_       <- #{peek XKeyEvent, state      } p
            keycode_     <- #{peek XKeyEvent, keycode    } p
            same_screen_ <- #{peek XKeyEvent, same_screen} p
            return $ KeyEvent
                        { event_type    = type_
                        , serial        = serial_
                        , send_event    = send_event_
                        , event_display = display_
                        , window        = window_
                        , root          = root_
                        , subwindow     = subwindow_
                        , time          = time_
                        , x             = x_
                        , y             = y_
                        , x_root        = x_root_
                        , y_root        = y_root_
                        , state         = state_
                        , keycode       = keycode_
                        , same_screen   = same_screen_
                        }

          ----------------------
          -- DestroyWindowEvent:
          ----------------------
          | type_ == destroyNotify -> do
            event_  <- #{peek XDestroyWindowEvent, event } p
            window_ <- #{peek XDestroyWindowEvent, window} p
            return $ DestroyWindowEvent
                        { event_type    = type_
                        , serial        = serial_
                        , send_event    = send_event_
                        , event_display = display_
                        , event         = event_
                        , window        = window_
                        }


          --------------------
          -- UnmapNotifyEvent:
          --------------------
          | type_ == unmapNotify -> do
            event_         <- #{peek XUnmapEvent, event         } p
            window_        <- #{peek XUnmapEvent, window        } p
            fromConfigure_ <- #{peek XUnmapEvent, from_configure} p
            return $ UnmapEvent
                        { event_type    = type_
                        , serial        = serial_
                        , send_event    = send_event_
                        , event_display = display_
                        , event         = event_
                        , window        = window_
                        , fromConfigure = fromConfigure_
                        }

          -- We don't handle this event specifically, so return the generic
          -- AnyEvent.
          | otherwise -> do
            window_ <- #{peek XAnyEvent, window} p
            return $ AnyEvent
                        { event_type    = type_
                        , serial        = serial_
                        , send_event    = send_event_
                        , event_display = display_
                        , window        = window_
                        }

data WindowChanges = WindowChanges
                        { wcX :: Int
                        , wcY :: Int
                        , wcWidth :: Int
                        , wcHeight:: Int
                        , wcBorderWidth :: Int
                        , wcSibling :: Window
                        , wcStackMode :: Int
                        }

instance Storable WindowChanges where
    sizeOf _ = #{size XWindowChanges}

    -- I really hope this is right:
    alignment _ = alignment (undefined :: Int)

    poke p wc = do
        #{poke XWindowChanges, x           } p $ wcX wc
        #{poke XWindowChanges, y           } p $ wcY wc
        #{poke XWindowChanges, width       } p $ wcWidth wc
        #{poke XWindowChanges, height      } p $ wcHeight wc
        #{poke XWindowChanges, border_width} p $ wcBorderWidth wc
        #{poke XWindowChanges, sibling     } p $ wcSibling wc
        #{poke XWindowChanges, stack_mode  } p $ wcStackMode wc
        
    peek p = return WindowChanges
                `ap` (#{peek XWindowChanges, x} p)
                `ap` (#{peek XWindowChanges, y} p)
                `ap` (#{peek XWindowChanges, width} p)
                `ap` (#{peek XWindowChanges, height} p)
                `ap` (#{peek XWindowChanges, border_width} p)
                `ap` (#{peek XWindowChanges, sibling} p)
                `ap` (#{peek XWindowChanges, stack_mode} p)

foreign import ccall unsafe "XlibExtras.h XConfigureWindow"
    xConfigureWindow :: Display -> Window -> CULong -> Ptr WindowChanges -> IO Int

configureWindow :: Display -> Window -> CULong -> WindowChanges -> IO ()
configureWindow d w m c = do
    with c (xConfigureWindow d w m)
    return ()