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 @@
1
+#!/usr/bin/env runhaskell
2
+> import Distribution.Simple
3
+> main = defaultMain

+ 48
- 0
Thunk/Wm.hs View File

@@ -0,0 +1,48 @@
1
+{-# OPTIONS_GHC -fglasgow-exts #-}
2
+
3
+module Thunk.Wm where
4
+
5
+import Data.Sequence
6
+import Control.Monad.State
7
+import System.IO (hFlush, hPutStrLn, stderr)
8
+import Graphics.X11.Xlib
9
+
10
+data WmState = WmState 
11
+                { display :: Display
12
+                , screenWidth :: Int
13
+                , screenHeight :: Int
14
+                , windows :: Seq Window
15
+                }
16
+
17
+newtype Wm a = Wm (StateT WmState IO a)
18
+    deriving (Monad, MonadIO{-, MonadState WmState-})
19
+
20
+runWm :: Wm a -> WmState -> IO (a, WmState)
21
+runWm (Wm m) = runStateT m
22
+
23
+l :: IO a -> Wm a
24
+l = liftIO
25
+
26
+trace msg = l $ do
27
+    hPutStrLn stderr msg
28
+    hFlush stderr
29
+
30
+withIO :: (forall b. (a -> IO b) -> IO b) -> (a -> Wm c) -> Wm c
31
+withIO f g = do
32
+    s <- Wm get
33
+    (y, s') <- l $ f $ \x -> runWm (g x) s
34
+    Wm (put s')
35
+    return y
36
+
37
+getDisplay = Wm (gets display)
38
+
39
+getWindows = Wm (gets windows)
40
+
41
+getScreenWidth = Wm (gets screenWidth)
42
+
43
+getScreenHeight = Wm (gets screenHeight)
44
+
45
+setWindows x = Wm (modify (\s -> s {windows = x}))
46
+
47
+modifyWindows :: (Seq Window -> Seq Window) -> Wm ()
48
+modifyWindows f = Wm (modify (\s -> s {windows = f (windows s)}))

+ 253
- 0
Thunk/XlibExtras.hsc View File

@@ -0,0 +1,253 @@
1
+module Thunk.XlibExtras where
2
+
3
+import Graphics.X11.Xlib
4
+import Graphics.X11.Xlib.Types
5
+import Foreign
6
+import Foreign.C.Types
7
+import Control.Monad (ap)
8
+
9
+#include "XlibExtras.h"
10
+
11
+data Event 
12
+    = AnyEvent
13
+        { event_type            :: EventType
14
+        , serial                :: CULong
15
+        , send_event            :: Bool
16
+        , event_display         :: Display
17
+        , window                :: Window
18
+        }
19
+    | ConfigureRequestEvent
20
+        { event_type            :: EventType
21
+        , serial                :: CULong
22
+        , send_event            :: Bool
23
+        , event_display         :: Display
24
+        , parent                :: Window
25
+        , window                :: Window
26
+        , x                     :: Int
27
+        , y                     :: Int
28
+        , width                 :: Int
29
+        , height                :: Int
30
+        , border_width          :: Int
31
+        , above                 :: Window
32
+        , detail                :: Int
33
+        , value_mask            :: CULong
34
+        }
35
+    | MapRequestEvent
36
+        { event_type            :: EventType
37
+        , serial                :: CULong
38
+        , send_event            :: Bool
39
+        , event_display         :: Display
40
+        , parent                :: Window
41
+        , window                :: Window
42
+        }
43
+    | KeyEvent
44
+        { event_type            :: EventType
45
+        , serial                :: CULong
46
+        , send_event            :: Bool
47
+        , event_display         :: Display
48
+        , window                :: Window
49
+        , root                  :: Window
50
+        , subwindow             :: Window
51
+        , time                  :: Time
52
+        , x                     :: Int
53
+        , y                     :: Int
54
+        , x_root                :: Int
55
+        , y_root                :: Int
56
+        , state                 :: KeyMask
57
+        , keycode               :: KeyCode
58
+        , same_screen           :: Bool
59
+        }
60
+    | DestroyWindowEvent
61
+        { event_type            :: EventType
62
+        , serial                :: CULong
63
+        , send_event            :: Bool
64
+        , event_display         :: Display
65
+        , event                 :: Window
66
+        , window                :: Window
67
+        }
68
+    | UnmapEvent
69
+        { event_type            :: EventType
70
+        , serial                :: CULong
71
+        , send_event            :: Bool
72
+        , event_display         :: Display
73
+        , event                 :: Window
74
+        , window                :: Window
75
+        , fromConfigure         :: Bool
76
+        }
77
+    deriving Show
78
+
79
+getEvent :: XEventPtr -> IO Event
80
+getEvent p = do
81
+    -- All events share this layout and naming convention, there is also a
82
+    -- common Window field, but the names for this field vary.
83
+    type_ <- #{peek XAnyEvent, type} p
84
+    serial_ <- #{peek XAnyEvent, serial} p
85
+    send_event_ <- #{peek XAnyEvent, send_event} p
86
+    display_ <- fmap Display (#{peek XAnyEvent, display} p)
87
+    case () of
88
+
89
+        -------------------------
90
+        -- ConfigureRequestEvent:
91
+        -------------------------
92
+        _ | type_ == configureRequest -> do
93
+            parent_       <- #{peek XConfigureRequestEvent, parent      } p
94
+            window_       <- #{peek XConfigureRequestEvent, window      } p
95
+            x_            <- #{peek XConfigureRequestEvent, x           } p
96
+            y_            <- #{peek XConfigureRequestEvent, y           } p
97
+            width_        <- #{peek XConfigureRequestEvent, width       } p
98
+            height_       <- #{peek XConfigureRequestEvent, height      } p
99
+            border_width_ <- #{peek XConfigureRequestEvent, border_width} p
100
+            above_        <- #{peek XConfigureRequestEvent, above       } p
101
+            detail_       <- #{peek XConfigureRequestEvent, detail      } p
102
+            value_mask_   <- #{peek XConfigureRequestEvent, value_mask  } p
103
+            return $ ConfigureRequestEvent
104
+                        { event_type    = type_
105
+                        , serial        = serial_
106
+                        , send_event    = send_event_
107
+                        , event_display = display_
108
+                        , parent        = parent_
109
+                        , window        = window_
110
+                        , x             = x_
111
+                        , y             = y_
112
+                        , width         = width_
113
+                        , height        = height_
114
+                        , border_width  = border_width_
115
+                        , above         = above_
116
+                        , detail        = detail_
117
+                        , value_mask    = value_mask_
118
+                        }
119
+
120
+          -------------------
121
+          -- MapRequestEvent:
122
+          -------------------
123
+          | type_ == mapRequest -> do
124
+            parent_ <- #{peek XMapRequestEvent, parent} p
125
+            window_ <- #{peek XMapRequestEvent, window} p
126
+            return $ MapRequestEvent
127
+                        { event_type    = type_
128
+                        , serial        = serial_
129
+                        , send_event    = send_event_
130
+                        , event_display = display_
131
+                        , parent        = parent_
132
+                        , window        = window_
133
+                        }
134
+
135
+          ------------
136
+          -- KeyEvent:
137
+          ------------
138
+          | type_ == keyPress || type_ == keyRelease -> do
139
+            window_      <- #{peek XKeyEvent, window     } p
140
+            root_        <- #{peek XKeyEvent, root       } p
141
+            subwindow_   <- #{peek XKeyEvent, subwindow  } p
142
+            time_        <- #{peek XKeyEvent, time       } p
143
+            x_           <- #{peek XKeyEvent, x          } p
144
+            y_           <- #{peek XKeyEvent, y          } p
145
+            x_root_      <- #{peek XKeyEvent, x_root     } p
146
+            y_root_      <- #{peek XKeyEvent, y_root     } p
147
+            state_       <- #{peek XKeyEvent, state      } p
148
+            keycode_     <- #{peek XKeyEvent, keycode    } p
149
+            same_screen_ <- #{peek XKeyEvent, same_screen} p
150
+            return $ KeyEvent
151
+                        { event_type    = type_
152
+                        , serial        = serial_
153
+                        , send_event    = send_event_
154
+                        , event_display = display_
155
+                        , window        = window_
156
+                        , root          = root_
157
+                        , subwindow     = subwindow_
158
+                        , time          = time_
159
+                        , x             = x_
160
+                        , y             = y_
161
+                        , x_root        = x_root_
162
+                        , y_root        = y_root_
163
+                        , state         = state_
164
+                        , keycode       = keycode_
165
+                        , same_screen   = same_screen_
166
+                        }
167
+
168
+          ----------------------
169
+          -- DestroyWindowEvent:
170
+          ----------------------
171
+          | type_ == destroyNotify -> do
172
+            event_  <- #{peek XDestroyWindowEvent, event } p
173
+            window_ <- #{peek XDestroyWindowEvent, window} p
174
+            return $ DestroyWindowEvent
175
+                        { event_type    = type_
176
+                        , serial        = serial_
177
+                        , send_event    = send_event_
178
+                        , event_display = display_
179
+                        , event         = event_
180
+                        , window        = window_
181
+                        }
182
+
183
+
184
+          --------------------
185
+          -- UnmapNotifyEvent:
186
+          --------------------
187
+          | type_ == unmapNotify -> do
188
+            event_         <- #{peek XUnmapEvent, event         } p
189
+            window_        <- #{peek XUnmapEvent, window        } p
190
+            fromConfigure_ <- #{peek XUnmapEvent, from_configure} p
191
+            return $ UnmapEvent
192
+                        { event_type    = type_
193
+                        , serial        = serial_
194
+                        , send_event    = send_event_
195
+                        , event_display = display_
196
+                        , event         = event_
197
+                        , window        = window_
198
+                        , fromConfigure = fromConfigure_
199
+                        }
200
+
201
+          -- We don't handle this event specifically, so return the generic
202
+          -- AnyEvent.
203
+          | otherwise -> do
204
+            window_ <- #{peek XAnyEvent, window} p
205
+            return $ AnyEvent
206
+                        { event_type    = type_
207
+                        , serial        = serial_
208
+                        , send_event    = send_event_
209
+                        , event_display = display_
210
+                        , window        = window_
211
+                        }
212
+
213
+data WindowChanges = WindowChanges
214
+                        { wcX :: Int
215
+                        , wcY :: Int
216
+                        , wcWidth :: Int
217
+                        , wcHeight:: Int
218
+                        , wcBorderWidth :: Int
219
+                        , wcSibling :: Window
220
+                        , wcStackMode :: Int
221
+                        }
222
+
223
+instance Storable WindowChanges where
224
+    sizeOf _ = #{size XWindowChanges}
225
+
226
+    -- I really hope this is right:
227
+    alignment _ = alignment (undefined :: Int)
228
+
229
+    poke p wc = do
230
+        #{poke XWindowChanges, x           } p $ wcX wc
231
+        #{poke XWindowChanges, y           } p $ wcY wc
232
+        #{poke XWindowChanges, width       } p $ wcWidth wc
233
+        #{poke XWindowChanges, height      } p $ wcHeight wc
234
+        #{poke XWindowChanges, border_width} p $ wcBorderWidth wc
235
+        #{poke XWindowChanges, sibling     } p $ wcSibling wc
236
+        #{poke XWindowChanges, stack_mode  } p $ wcStackMode wc
237
+        
238
+    peek p = return WindowChanges
239
+                `ap` (#{peek XWindowChanges, x} p)
240
+                `ap` (#{peek XWindowChanges, y} p)
241
+                `ap` (#{peek XWindowChanges, width} p)
242
+                `ap` (#{peek XWindowChanges, height} p)
243
+                `ap` (#{peek XWindowChanges, border_width} p)
244
+                `ap` (#{peek XWindowChanges, sibling} p)
245
+                `ap` (#{peek XWindowChanges, stack_mode} p)
246
+
247
+foreign import ccall unsafe "XlibExtras.h XConfigureWindow"
248
+    xConfigureWindow :: Display -> Window -> CULong -> Ptr WindowChanges -> IO Int
249
+
250
+configureWindow :: Display -> Window -> CULong -> WindowChanges -> IO ()
251
+configureWindow d w m c = do
252
+    with c (xConfigureWindow d w m)
253
+    return ()

+ 33
- 0
include/XlibExtras.h View File

@@ -0,0 +1,33 @@
1
+/* This file copied from the X11 package */
2
+
3
+/* -----------------------------------------------------------------------------
4
+ * Definitions for package `X11' which are visible in Haskell land.
5
+ * ---------------------------------------------------------------------------*
6
+ */
7
+
8
+#ifndef XLIBEXTRAS_H
9
+#define XLIBEXTRAS_H
10
+#include <stdlib.h>
11
+/* This doesn't always work, so we play safe below... */
12
+#define XUTIL_DEFINE_FUNCTIONS
13
+#include <X11/X.h>
14
+#include <X11/X.h>
15
+#include <X11/Xlib.h>
16
+#include <X11/Xatom.h>
17
+#include <X11/Xutil.h>
18
+/* Xutil.h overrides some functions with macros.
19
+ * In recent versions of X this can be turned off with
20
+ *      #define XUTIL_DEFINE_FUNCTIONS
21
+ * before the #include, but this doesn't work with older versions.
22
+ * As a workaround, we undef the macros here.  Note that this is only
23
+ * safe for functions with return type int.
24
+ */
25
+#undef XDestroyImage
26
+#undef XGetPixel
27
+#undef XPutPixel
28
+#undef XSubImage
29
+#undef XAddPixel
30
+#define XK_MISCELLANY
31
+#define XK_LATIN1
32
+#include <X11/keysymdef.h>
33
+#endif

+ 12
- 0
thunk.cabal View File

@@ -0,0 +1,12 @@
1
+Name:           thunk
2
+Version:        0.0
3
+Description:    A lightweight X11 window manager.
4
+Author:         Spencer Janssen
5
+Maintainer:     sjanssen@cse.unl.edu
6
+Build-Depends:  base >= 2.0, X11, unix, mtl
7
+
8
+Executable:     thunk
9
+Main-Is:        thunk.hs
10
+Extensions:     ForeignFunctionInterface
11
+Other-Modules:  Thunk.XlibExtras
12
+Include-Dirs:   include

+ 108
- 0
thunk.hs View File

@@ -0,0 +1,108 @@
1
+{-# OPTIONS_GHC -fglasgow-exts #-}
2
+
3
+import qualified Data.Map as Map
4
+import Data.Map (Map)
5
+import Data.Sequence as Seq
6
+import qualified Data.Foldable as Fold
7
+import Data.Bits
8
+import Control.Monad.State
9
+import System.IO
10
+import Graphics.X11.Xlib
11
+import System.Process (runCommand)
12
+import System.Exit
13
+import Thunk.Wm
14
+import Thunk.XlibExtras
15
+
16
+handler :: Event -> Wm ()
17
+handler (MapRequestEvent {window = w}) = manage w
18
+handler (DestroyWindowEvent {window = w}) = do
19
+    modifyWindows (Seq.fromList . filter (/= w) . Fold.toList)
20
+    refresh
21
+handler (KeyEvent {event_type = t, state = mod, keycode = code}) 
22
+ | t == keyPress = do
23
+    dpy <- getDisplay
24
+    sym <- l $ keycodeToKeysym dpy code 0
25
+    case filter (\(mod', sym', _) -> mod == mod' && sym == sym') keys of
26
+        []              -> return ()
27
+        ((_, _, act):_) -> act
28
+handler _ = return ()
29
+
30
+switch :: Wm ()
31
+switch = do
32
+    ws' <- getWindows
33
+    case viewl ws' of
34
+        EmptyL -> return ()
35
+        (w :< ws) -> do
36
+            setWindows (ws |> w)
37
+            refresh
38
+
39
+spawn :: String -> Wm ()
40
+spawn c = do
41
+    l $ runCommand c
42
+    return ()
43
+
44
+keys :: [(KeyMask, KeySym, Wm ())]
45
+keys = 
46
+    [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm")
47
+    , (controlMask, xK_space, spawn "gmrun")
48
+    , (mod1Mask, xK_Tab, switch)
49
+    , (mod1Mask .|. shiftMask, xK_q, l $ exitWith ExitSuccess)
50
+    ]
51
+
52
+grabkeys = do
53
+    dpy <- getDisplay
54
+    root <- l $ rootWindow dpy (defaultScreen dpy)
55
+    forM_ keys $ \(mod, sym, _) -> do
56
+        code <- l $ keysymToKeycode dpy sym
57
+        l $ grabKey dpy code mod root True grabModeAsync grabModeAsync
58
+
59
+manage :: Window -> Wm ()
60
+manage w = do
61
+    trace "manage"
62
+    d <- getDisplay
63
+    ws <- getWindows
64
+    when (Fold.notElem w ws) $ do
65
+        trace "modifying"
66
+        modifyWindows (w <|)
67
+        l $ mapWindow d w
68
+        refresh
69
+
70
+refresh :: Wm ()
71
+refresh = do
72
+    v  <- getWindows
73
+    case viewl v of
74
+        EmptyL   -> return ()
75
+        (w :< _) -> do
76
+            d  <- getDisplay
77
+            sw <- getScreenWidth
78
+            sh <- getScreenHeight
79
+            l $ moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh)
80
+            l $ raiseWindow d w
81
+
82
+main = do
83
+    dpy <- openDisplay ""
84
+    runWm main' (WmState 
85
+                    { display = dpy 
86
+                    , screenWidth  = displayWidth dpy (defaultScreen dpy)
87
+                    , screenHeight = displayHeight dpy (defaultScreen dpy)
88
+                    , windows = Seq.empty
89
+                    })
90
+    return ()
91
+
92
+main' = do
93
+    dpy <- getDisplay
94
+    let screen = defaultScreen dpy
95
+    root <- l $ rootWindow dpy screen
96
+    l $ selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask)
97
+    l $ sync dpy False
98
+    grabkeys
99
+    loop
100
+
101
+loop :: Wm ()
102
+loop = do
103
+    dpy <- getDisplay
104
+    e <- l $ allocaXEvent $ \ev -> do
105
+        nextEvent dpy ev
106
+        getEvent ev
107
+    handler e
108
+    loop

Loading…
Cancel
Save