summaryrefslogtreecommitdiffstats
path: root/Main.hs
blob: 0c455f84598ee903085b0cb3d0f79b59c6ad734f (plain)
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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
-----------------------------------------------------------------------------
-- |
-- Module      :  Main.hs
-- Copyright   :  (c) Spencer Janssen 2007
-- License     :  BSD3-style (see LICENSE)
-- 
-- Maintainer  :  sjanssen@cse.unl.edu
-- Stability   :  unstable
-- Portability :  not portable, uses mtl, X11, posix
--
-----------------------------------------------------------------------------
--
-- thunk, a minimal window manager for X11
--

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 Graphics.X11.Xlib.Extras
import System.Process (runCommand)
import System.Exit

import Wm

------------------------------------------------------------------------

--
-- let's get underway
-- 
main :: IO ()
main = do
    dpy <- openDisplay ""
    runWm realMain $ WmState
            { display = dpy
            , screenWidth  = displayWidth  dpy (defaultScreen dpy)
            , screenHeight = displayHeight dpy (defaultScreen dpy)
            , windows = Seq.empty
            }
    return ()

--
-- Grab the display and input, and jump into the input loop
--
realMain :: Wm ()
realMain = do
    dpy <- getDisplay
    let screen = defaultScreen dpy
    io $ do root <- rootWindow dpy screen
            selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask)
            sync dpy False
    grabkeys
    loop

--
-- The main event handling loop
--
loop :: Wm ()
loop = do
    dpy <- getDisplay
    forever $ do
        e <- io $ allocaXEvent $ \ev -> nextEvent dpy ev >> getEvent ev
        handler e
  where
    forever a = a >> forever a

--
-- The event handler
-- 
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 <- io $ keycodeToKeysym dpy code 0
    case filter (\(mod', sym', _) -> mod == mod' && sym == sym') keys of
        []              -> return ()
        ((_, _, act):_) -> act
handler _ = return ()

--
-- switch focus (?)
--
switch :: Wm ()
switch = do
    ws' <- getWindows
    case viewl ws' of
        EmptyL -> return ()
        (w :< ws) -> do
            setWindows (ws |> w)
            refresh

--
-- | spawn. Launch an external application
--
spawn :: String -> Wm ()
spawn = io_ . runCommand

--
-- | Keys we understand.
--
keys :: [(KeyMask, KeySym, Wm ())]
keys =
    [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm")
    , (controlMask,            xK_space,  spawn "gmrun")
    , (mod1Mask,               xK_Tab,    switch)
    , (mod1Mask .|. shiftMask, xK_q,      io $ exitWith ExitSuccess)
    ]

--
-- | grabkeys. Register key commands
--
grabkeys :: Wm ()
grabkeys = do
    dpy <- getDisplay
    root <- io $ rootWindow dpy (defaultScreen dpy)
    forM_ keys $ \(mod, sym, _) -> do
        code <- io $ keysymToKeycode dpy sym
        io $ 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 <|)
        io $ mapWindow d w
        refresh

--
-- refresh the windows
--
refresh :: Wm ()
refresh = do
    v  <- getWindows
    case viewl v of
        EmptyL   -> return ()
        (w :< _) -> do
            d  <- getDisplay
            sw <- getScreenWidth
            sh <- getScreenHeight
            io $ do moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh)
                    raiseWindow d w