From 3dc06f20fd102531a005818e28552284786091a7 Mon Sep 17 00:00:00 2001 From: Don Stewart Date: Wed, 7 Mar 2007 03:23:32 +0100 Subject: Flatten module hierarchy darcs-hash:20070307022332-9c5c1-4b24108ce990c0b74183fedf99e6de26d2e7a15c --- Thunk/Wm.hs | 48 ---------- Thunk/XlibExtras.hsc | 253 --------------------------------------------------- Wm.hs | 48 ++++++++++ XlibExtras.hsc | 253 +++++++++++++++++++++++++++++++++++++++++++++++++++ thunk.cabal | 2 +- thunk.hs | 5 +- 6 files changed, 305 insertions(+), 304 deletions(-) delete mode 100644 Thunk/Wm.hs delete mode 100644 Thunk/XlibExtras.hsc create mode 100644 Wm.hs create mode 100644 XlibExtras.hsc diff --git a/Thunk/Wm.hs b/Thunk/Wm.hs deleted file mode 100644 index 69b1de1..0000000 --- a/Thunk/Wm.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# 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 deleted file mode 100644 index 4be16b3..0000000 --- a/Thunk/XlibExtras.hsc +++ /dev/null @@ -1,253 +0,0 @@ -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 () diff --git a/Wm.hs b/Wm.hs new file mode 100644 index 0000000..542f66f --- /dev/null +++ b/Wm.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +module 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/XlibExtras.hsc b/XlibExtras.hsc new file mode 100644 index 0000000..103a149 --- /dev/null +++ b/XlibExtras.hsc @@ -0,0 +1,253 @@ +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/thunk.cabal b/thunk.cabal index 42e3d4e..8d9b3b3 100644 --- a/thunk.cabal +++ b/thunk.cabal @@ -12,7 +12,7 @@ build-depends: base >= 2.0, X11, unix, mtl executable: thunk main-is: thunk.hs extensions: ForeignFunctionInterface -other-modules: Thunk.XlibExtras +other-modules: XlibExtras ghc-options: -O include-dirs: include -- OpenBSD: diff --git a/thunk.hs b/thunk.hs index 9b63116..3a8f92b 100644 --- a/thunk.hs +++ b/thunk.hs @@ -10,8 +10,9 @@ import System.IO import Graphics.X11.Xlib import System.Process (runCommand) import System.Exit -import Thunk.Wm -import Thunk.XlibExtras + +import Wm +import XlibExtras handler :: Event -> Wm () handler (MapRequestEvent {window = w}) = manage w -- cgit v1.2.3