1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
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
|
