Browse Source

Initial import.

master
Spencer Janssen 12 years ago
commit
b2c14305a2
6 changed files 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

+ 3
- 0
Setup.lhs View File

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

+ 48
- 0
Thunk/Wm.hs View File

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

+ 253
- 0
Thunk/XlibExtras.hsc View File

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

+ 33
- 0
include/XlibExtras.h View File

@@ -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

+ 12
- 0
thunk.cabal View File

@@ -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

+ 108
- 0
thunk.hs View File

@@ -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

Loading…
Cancel
Save