diff options
| -rw-r--r-- | Main.hs | 45 | ||||
| -rw-r--r-- | Wm.hs | 35 | ||||
| -rw-r--r-- | thunk.cabal | 1 |
3 files changed, 54 insertions, 27 deletions
@@ -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 @@ -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 |