mirror of
https://github.com/xmonad/xmonad.git
synced 2025-05-19 00:20:22 -07:00
Initial import.
This commit is contained in:
Spencer Janssen
commit
b2c14305a2
3
Setup.lhs
Normal file
3
Setup.lhs
Normal file
@ -0,0 +1,3 @@
|
||||
#!/usr/bin/env runhaskell
|
||||
> import Distribution.Simple
|
||||
> main = defaultMain
|
||||
48
Thunk/Wm.hs
Normal file
48
Thunk/Wm.hs
Normal 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
Thunk/XlibExtras.hsc
Normal file
253
Thunk/XlibExtras.hsc
Normal 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
include/XlibExtras.h
Normal file
33
include/XlibExtras.h
Normal 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
thunk.cabal
Normal file
12
thunk.cabal
Normal 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
thunk.hs
Normal file
108
thunk.hs
Normal 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…
x
Reference in New Issue
Block a user