Permalink
Browse files

Initial import.

  • Loading branch information...
spencerjanssen committed Mar 7, 2007
0 parents commit b2c14305a25ef954f26edfdc29c63a4875f58165
Showing with 457 additions and 0 deletions.
  1. +3 −0 Setup.lhs
  2. +48 −0 Thunk/Wm.hs
  3. +253 −0 Thunk/XlibExtras.hsc
  4. +33 −0 include/XlibExtras.h
  5. +12 −0 thunk.cabal
  6. +108 −0 thunk.hs
@@ -0,0 +1,3 @@
#!/usr/bin/env runhaskell
> import Distribution.Simple
> main = defaultMain
@@ -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)}))
@@ -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 ()
@@ -0,0 +1,33 @@
/* 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
@@ -0,0 +1,12 @@
Name: thunk
Version: 0.0
Description: A lightweight X11 window manager.
Author: Spencer Janssen
Maintainer: sjanssen@cse.unl.edu
Build-Depends: base >= 2.0, X11, unix, mtl
Executable: thunk
Main-Is: thunk.hs
Extensions: ForeignFunctionInterface
Other-Modules: Thunk.XlibExtras
Include-Dirs: include
Oops, something went wrong.

0 comments on commit b2c1430

Please sign in to comment.