Initial import.

Setup.lhs

@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain

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)}))

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 ()

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

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

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