summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Main.hs45
-rw-r--r--Wm.hs35
-rw-r--r--thunk.cabal1
3 files changed, 54 insertions, 27 deletions
diff --git a/Main.hs b/Main.hs
index bae8b76..9f2d8cd 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,4 +1,17 @@
-{-# OPTIONS_GHC -fglasgow-exts #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Main.hs
+-- Copyright : (c) Spencer Janssen 2007
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : sjanssen@cse.unl.edu
+-- Stability : unstable
+-- Portability : not portable, uses cunning newtype deriving
+--
+-----------------------------------------------------------------------------
+--
+-- thunk, a minimal window manager for X11
+--
import qualified Data.Map as Map
import Data.Map (Map)
@@ -22,7 +35,7 @@ handler (DestroyWindowEvent {window = w}) = do
handler (KeyEvent {event_type = t, state = mod, keycode = code})
| t == keyPress = do
dpy <- getDisplay
- sym <- l $ keycodeToKeysym dpy code 0
+ sym <- io $ keycodeToKeysym dpy code 0
case filter (\(mod', sym', _) -> mod == mod' && sym == sym') keys of
[] -> return ()
((_, _, act):_) -> act
@@ -39,7 +52,7 @@ switch = do
spawn :: String -> Wm ()
spawn c = do
- l $ runCommand c
+ io $ runCommand c
return ()
keys :: [(KeyMask, KeySym, Wm ())]
@@ -47,15 +60,15 @@ keys =
[ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm")
, (controlMask, xK_space, spawn "gmrun")
, (mod1Mask, xK_Tab, switch)
- , (mod1Mask .|. shiftMask, xK_q, l $ exitWith ExitSuccess)
+ , (mod1Mask .|. shiftMask, xK_q, io $ exitWith ExitSuccess)
]
grabkeys = do
dpy <- getDisplay
- root <- l $ rootWindow dpy (defaultScreen dpy)
+ root <- io $ rootWindow dpy (defaultScreen dpy)
forM_ keys $ \(mod, sym, _) -> do
- code <- l $ keysymToKeycode dpy sym
- l $ grabKey dpy code mod root True grabModeAsync grabModeAsync
+ code <- io $ keysymToKeycode dpy sym
+ io $ grabKey dpy code mod root True grabModeAsync grabModeAsync
manage :: Window -> Wm ()
manage w = do
@@ -65,7 +78,7 @@ manage w = do
when (Fold.notElem w ws) $ do
trace "modifying"
modifyWindows (w <|)
- l $ mapWindow d w
+ io $ mapWindow d w
refresh
refresh :: Wm ()
@@ -77,8 +90,8 @@ refresh = do
d <- getDisplay
sw <- getScreenWidth
sh <- getScreenHeight
- l $ moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh)
- l $ raiseWindow d w
+ io $ moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh)
+ io $ raiseWindow d w
main = do
dpy <- openDisplay ""
@@ -93,17 +106,17 @@ main = do
main' = do
dpy <- getDisplay
let screen = defaultScreen dpy
- root <- l $ rootWindow dpy screen
- l $ selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask)
- l $ sync dpy False
+ io $ do root <- rootWindow dpy screen
+ selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask)
+ sync dpy False
grabkeys
loop
loop :: Wm ()
loop = do
dpy <- getDisplay
- e <- l $ allocaXEvent $ \ev -> do
- nextEvent dpy ev
- getEvent ev
+ e <- io $ allocaXEvent $ \ev -> do
+ nextEvent dpy ev
+ getEvent ev
handler e
loop
diff --git a/Wm.hs b/Wm.hs
index 542f66f..c95648d 100644
--- a/Wm.hs
+++ b/Wm.hs
@@ -1,4 +1,17 @@
-{-# OPTIONS_GHC -fglasgow-exts #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Wm.hs
+-- Copyright : (c) Spencer Janssen 2007
+-- License : BSD3-style (see LICENSE)
+--
+-- Maintainer : sjanssen@cse.unl.edu
+-- Stability : unstable
+-- Portability : not portable, uses cunning newtype deriving
+--
+-----------------------------------------------------------------------------
+--
+-- The Wm monad, a state monad transformer over IO, for the window manager state.
+--
module Wm where
@@ -7,12 +20,12 @@ 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
- }
+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-})
@@ -20,17 +33,17 @@ newtype Wm a = Wm (StateT WmState IO a)
runWm :: Wm a -> WmState -> IO (a, WmState)
runWm (Wm m) = runStateT m
-l :: IO a -> Wm a
-l = liftIO
+io :: IO a -> Wm a
+io = liftIO
-trace msg = l $ do
+trace msg = io $ 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
+ (y, s') <- io $ f $ \x -> runWm (g x) s
Wm (put s')
return y
diff --git a/thunk.cabal b/thunk.cabal
index 90bc2c1..e4df966 100644
--- a/thunk.cabal
+++ b/thunk.cabal
@@ -12,3 +12,4 @@ build-depends: base==2.0, X11==1.1, X11-extras==0.0, unix==1.0, mtl==1.0
executable: thunk
main-is: Main.hs
ghc-options: -O
+extensions: GeneralizedNewtypeDeriving