diff options
| -rw-r--r-- | XlibExtras.hsc | 253 | ||||
| -rw-r--r-- | include/XlibExtras.h | 33 | ||||
| -rw-r--r-- | thunk.cabal | 7 | ||||
| -rw-r--r-- | thunk.hs | 2 |
4 files changed, 2 insertions, 293 deletions
diff --git a/XlibExtras.hsc b/XlibExtras.hsc deleted file mode 100644 index 103a149..0000000 --- a/XlibExtras.hsc +++ /dev/null @@ -1,253 +0,0 @@ -module 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 () diff --git a/include/XlibExtras.h b/include/XlibExtras.h deleted file mode 100644 index 52fbeaa..0000000 --- a/include/XlibExtras.h +++ /dev/null @@ -1,33 +0,0 @@ -/* This file copied from the X11 package */ - -/* ----------------------------------------------------------------------------- - * Definitions for package `X11' which are visible in Haskell land. - * ---------------------------------------------------------------------------* - */ - -#ifndef XLIBEXTRAS_H -#define XLIBEXTRAS_H -#include <stdlib.h> -/* This doesn't always work, so we play safe below... */ -#define XUTIL_DEFINE_FUNCTIONS -#include <X11/X.h> -#include <X11/X.h> -#include <X11/Xlib.h> -#include <X11/Xatom.h> -#include <X11/Xutil.h> -/* Xutil.h overrides some functions with macros. - * In recent versions of X this can be turned off with - * #define XUTIL_DEFINE_FUNCTIONS - * before the #include, but this doesn't work with older versions. - * As a workaround, we undef the macros here. Note that this is only - * safe for functions with return type int. - */ -#undef XDestroyImage -#undef XGetPixel -#undef XPutPixel -#undef XSubImage -#undef XAddPixel -#define XK_MISCELLANY -#define XK_LATIN1 -#include <X11/keysymdef.h> -#endif diff --git a/thunk.cabal b/thunk.cabal index 8d9b3b3..cee19bf 100644 --- a/thunk.cabal +++ b/thunk.cabal @@ -7,13 +7,8 @@ license: BSD3 license-file: LICENSE author: Spencer Janssen maintainer: sjanssen@cse.unl.edu -build-depends: base >= 2.0, X11, unix, mtl +build-depends: base >= 2.0, X11, X11-extras, unix, mtl executable: thunk main-is: thunk.hs -extensions: ForeignFunctionInterface -other-modules: XlibExtras ghc-options: -O -include-dirs: include --- OpenBSD: --- include-dirs: include /usr/X11R6/include @@ -8,11 +8,11 @@ import Data.Bits import Control.Monad.State import System.IO import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras import System.Process (runCommand) import System.Exit import Wm -import XlibExtras handler :: Event -> Wm () handler (MapRequestEvent {window = w}) = manage w |