diff options
| -rwxr-xr-x | Setup.lhs | 3 | ||||
| -rw-r--r-- | Thunk/Wm.hs | 48 | ||||
| -rw-r--r-- | Thunk/XlibExtras.hsc | 253 | ||||
| -rw-r--r-- | include/XlibExtras.h | 33 | ||||
| -rw-r--r-- | thunk.cabal | 12 | ||||
| -rw-r--r-- | thunk.hs | 108 |
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 |