diff options
Diffstat (limited to 'Thunk')
| -rw-r--r-- | Thunk/Wm.hs | 48 | ||||
| -rw-r--r-- | Thunk/XlibExtras.hsc | 253 |
2 files changed, 301 insertions, 0 deletions
diff --git a/Thunk/Wm.hs b/Thunk/Wm.hs new file mode 100644 index 0000000..69b1de1 --- /dev/null +++ b/Thunk/Wm.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +module Thunk.Wm where + +import Data.Sequence +import Control.Monad.State +import System.IO (hFlush, hPutStrLn, stderr) +import Graphics.X11.Xlib + +data WmState = WmState + { display :: Display + , screenWidth :: Int + , screenHeight :: Int + , windows :: Seq Window + } + +newtype Wm a = Wm (StateT WmState IO a) + deriving (Monad, MonadIO{-, MonadState WmState-}) + +runWm :: Wm a -> WmState -> IO (a, WmState) +runWm (Wm m) = runStateT m + +l :: IO a -> Wm a +l = liftIO + +trace msg = l $ do + hPutStrLn stderr msg + hFlush stderr + +withIO :: (forall b. (a -> IO b) -> IO b) -> (a -> Wm c) -> Wm c +withIO f g = do + s <- Wm get + (y, s') <- l $ f $ \x -> runWm (g x) s + Wm (put s') + return y + +getDisplay = Wm (gets display) + +getWindows = Wm (gets windows) + +getScreenWidth = Wm (gets screenWidth) + +getScreenHeight = Wm (gets screenHeight) + +setWindows x = Wm (modify (\s -> s {windows = x})) + +modifyWindows :: (Seq Window -> Seq Window) -> Wm () +modifyWindows f = Wm (modify (\s -> s {windows = f (windows s)})) diff --git a/Thunk/XlibExtras.hsc b/Thunk/XlibExtras.hsc new file mode 100644 index 0000000..4be16b3 --- /dev/null +++ b/Thunk/XlibExtras.hsc @@ -0,0 +1,253 @@ +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 () |