summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorSpencer Janssen <sjanssen@cse.unl.edu>2007-03-07 02:35:27 +0100
committerSpencer Janssen <sjanssen@cse.unl.edu>2007-03-07 02:35:27 +0100
commit50b87487a2a859fb1958bca605f66b47ea381c30 (patch)
treed58dcf904e299b1238841a631f832ee38c0491b3
downloadmetatile-50b87487a2a859fb1958bca605f66b47ea381c30.tar
metatile-50b87487a2a859fb1958bca605f66b47ea381c30.zip
Initial import.
darcs-hash:20070307013527-a5988-dc8444fae65e473dba691c38e2487cd2a3efe326
-rwxr-xr-xSetup.lhs3
-rw-r--r--Thunk/Wm.hs48
-rw-r--r--Thunk/XlibExtras.hsc253
-rw-r--r--include/XlibExtras.h33
-rw-r--r--thunk.cabal12
-rw-r--r--thunk.hs108
6 files changed, 457 insertions, 0 deletions
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100755
index 0000000..5bde0de
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
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 ()
diff --git a/include/XlibExtras.h b/include/XlibExtras.h
new file mode 100644
index 0000000..52fbeaa
--- /dev/null
+++ b/include/XlibExtras.h
@@ -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
diff --git a/thunk.cabal b/thunk.cabal
new file mode 100644
index 0000000..1b8b4ef
--- /dev/null
+++ b/thunk.cabal
@@ -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
diff --git a/thunk.hs b/thunk.hs
new file mode 100644
index 0000000..9b63116
--- /dev/null
+++ b/thunk.hs
@@ -0,0 +1,108 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.Sequence as Seq
+import qualified Data.Foldable as Fold
+import Data.Bits
+import Control.Monad.State
+import System.IO
+import Graphics.X11.Xlib
+import System.Process (runCommand)
+import System.Exit
+import Thunk.Wm
+import Thunk.XlibExtras
+
+handler :: Event -> Wm ()
+handler (MapRequestEvent {window = w}) = manage w
+handler (DestroyWindowEvent {window = w}) = do
+ modifyWindows (Seq.fromList . filter (/= w) . Fold.toList)
+ refresh
+handler (KeyEvent {event_type = t, state = mod, keycode = code})
+ | t == keyPress = do
+ dpy <- getDisplay
+ sym <- l $ keycodeToKeysym dpy code 0
+ case filter (\(mod', sym', _) -> mod == mod' && sym == sym') keys of
+ [] -> return ()
+ ((_, _, act):_) -> act
+handler _ = return ()
+
+switch :: Wm ()
+switch = do
+ ws' <- getWindows
+ case viewl ws' of
+ EmptyL -> return ()
+ (w :< ws) -> do
+ setWindows (ws |> w)
+ refresh
+
+spawn :: String -> Wm ()
+spawn c = do
+ l $ runCommand c
+ return ()
+
+keys :: [(KeyMask, KeySym, Wm ())]
+keys =
+ [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm")
+ , (controlMask, xK_space, spawn "gmrun")
+ , (mod1Mask, xK_Tab, switch)
+ , (mod1Mask .|. shiftMask, xK_q, l $ exitWith ExitSuccess)
+ ]
+
+grabkeys = do
+ dpy <- getDisplay
+ root <- l $ rootWindow dpy (defaultScreen dpy)
+ forM_ keys $ \(mod, sym, _) -> do
+ code <- l $ keysymToKeycode dpy sym
+ l $ grabKey dpy code mod root True grabModeAsync grabModeAsync
+
+manage :: Window -> Wm ()
+manage w = do
+ trace "manage"
+ d <- getDisplay
+ ws <- getWindows
+ when (Fold.notElem w ws) $ do
+ trace "modifying"
+ modifyWindows (w <|)
+ l $ mapWindow d w
+ refresh
+
+refresh :: Wm ()
+refresh = do
+ v <- getWindows
+ case viewl v of
+ EmptyL -> return ()
+ (w :< _) -> do
+ d <- getDisplay
+ sw <- getScreenWidth
+ sh <- getScreenHeight
+ l $ moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh)
+ l $ raiseWindow d w
+
+main = do
+ dpy <- openDisplay ""
+ runWm main' (WmState
+ { display = dpy
+ , screenWidth = displayWidth dpy (defaultScreen dpy)
+ , screenHeight = displayHeight dpy (defaultScreen dpy)
+ , windows = Seq.empty
+ })
+ return ()
+
+main' = do
+ dpy <- getDisplay
+ let screen = defaultScreen dpy
+ root <- l $ rootWindow dpy screen
+ l $ selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask)
+ l $ sync dpy False
+ grabkeys
+ loop
+
+loop :: Wm ()
+loop = do
+ dpy <- getDisplay
+ e <- l $ allocaXEvent $ \ev -> do
+ nextEvent dpy ev
+ getEvent ev
+ handler e
+ loop