comments, rename 'l' to 'io', and state explicitly that we use GeneralizedNewtypeDeriving

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
+        code <- io $ keysymToKeycode dpy sym
-        l $ grabKey dpy code mod root True grabModeAsync grabModeAsync
+        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)
+            io $ moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh)
-            l $ raiseWindow d w
+            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
+    io $ do root <- rootWindow dpy screen
-    l $ selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask)
+            selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask)
-    l $ sync dpy False
+            sync dpy False
     grabkeys
     loop
 
 loop :: Wm ()
 loop = do
     dpy <- getDisplay
-    e <- l $ allocaXEvent $ \ev -> do
+    e <- io $ allocaXEvent $ \ev -> do
-        nextEvent dpy ev
+                    nextEvent dpy ev
-        getEvent ev
+                    getEvent ev
     handler e
     loop

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
 
@@ -8,11 +21,11 @@ import System.IO (hFlush, hPutStrLn, stderr)
 import Graphics.X11.Xlib
 
 data WmState = WmState
-                { display :: Display
+    { display       :: Display
-                , screenWidth :: Int
+    , screenWidth   :: !Int
-                , screenHeight :: Int
+    , screenHeight  :: !Int
-                , windows :: Seq Window
+    , 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
+io :: IO a -> Wm a
-l = liftIO
+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
 

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