1 files changed, 108 insertions, 0 deletions
diff --git a/thunk.hs b/thunk.hs
new file mode 100644
index 0000000..9b63116
--- /dev/null
+++ b/thunk.hs
@@ -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