diff options
| -rw-r--r-- | Main.hs | 22 | ||||
| -rw-r--r-- | W.hs | 98 | ||||
| -rw-r--r-- | Wm.hs | 70 |
3 files changed, 109 insertions, 81 deletions
@@ -25,7 +25,7 @@ import Graphics.X11.Xlib.Extras import System.Process (runCommand) import System.Exit -import Wm +import W ------------------------------------------------------------------------ @@ -35,7 +35,7 @@ import Wm main :: IO () main = do dpy <- openDisplay "" - runWm realMain $ WmState + runW realMain $ WState { display = dpy , screenWidth = displayWidth dpy (defaultScreen dpy) , screenHeight = displayHeight dpy (defaultScreen dpy) @@ -46,7 +46,7 @@ main = do -- -- Grab the display and input, and jump into the input loop -- -realMain :: Wm () +realMain :: W () realMain = do dpy <- getDisplay let screen = defaultScreen dpy @@ -59,7 +59,7 @@ realMain = do -- -- The main event handling loop -- -loop :: Wm () +loop :: W () loop = do dpy <- getDisplay forever $ do @@ -71,7 +71,7 @@ loop = do -- -- The event handler -- -handler :: Event -> Wm () +handler :: Event -> W () handler (MapRequestEvent {window = w}) = manage w handler (DestroyWindowEvent {window = w}) = do @@ -90,7 +90,7 @@ handler _ = return () -- -- switch focus (?) -- -switch :: Wm () +switch :: W () switch = do ws' <- getWindows case viewl ws' of @@ -102,13 +102,13 @@ switch = do -- -- | spawn. Launch an external application -- -spawn :: String -> Wm () +spawn :: String -> W () spawn = io_ . runCommand -- -- | Keys we understand. -- -keys :: [(KeyMask, KeySym, Wm ())] +keys :: [(KeyMask, KeySym, W ())] keys = [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm") , (controlMask, xK_space, spawn "gmrun") @@ -119,7 +119,7 @@ keys = -- -- | grabkeys. Register key commands -- -grabkeys :: Wm () +grabkeys :: W () grabkeys = do dpy <- getDisplay root <- io $ rootWindow dpy (defaultScreen dpy) @@ -130,7 +130,7 @@ grabkeys = do -- -- -- -manage :: Window -> Wm () +manage :: Window -> W () manage w = do trace "manage" d <- getDisplay @@ -144,7 +144,7 @@ manage w = do -- -- refresh the windows -- -refresh :: Wm () +refresh :: W () refresh = do v <- getWindows case viewl v of @@ -0,0 +1,98 @@ +----------------------------------------------------------------------------- +-- | +-- Module : W.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 W monad, a state monad transformer over IO, for the window manager state. +-- + +module W where + +import Data.Sequence +import Control.Monad.State +import System.IO (hFlush, hPutStrLn, stderr) +import Graphics.X11.Xlib + +-- +-- | WState, the window manager state. +-- Just the display, width, height and a window list +-- +data WState = WState + { display :: Display + , screenWidth :: !Int + , screenHeight :: !Int + , windows :: Seq Window + } + +-- | The W monad, a StateT transformer over IO encapuslating the window +-- manager state +-- +newtype W a = W (StateT WState IO a) + deriving (Functor, Monad, MonadIO) + +-- | Run the W monad, given a chunk of W monad code, and an initial state +-- Return the result, and final state +-- +runW :: W a -> WState -> IO (a, WState) +runW (W m) = runStateT m + +withIO :: (forall b. (a -> IO b) -> IO b) -> (a -> W c) -> W c +withIO f g = do + s <- W get + (y, t) <- io (f (flip runW s . g)) + W (put t) + return y + +-- +-- | Lift an IO action into the W monad +-- +io :: IO a -> W a +io = liftIO + +-- +-- | Lift an IO action into the W monad, discarding any result +-- +io_ :: IO a -> W () +io_ f = liftIO f >> return () + +-- +-- | A 'trace' for the W monad +-- +trace :: String -> W () +trace msg = io $ do + hPutStrLn stderr msg + hFlush stderr + +-- --------------------------------------------------------------------- +-- Getting at the window manager state + +-- | Return the current dispaly +getDisplay :: W Display +getDisplay = W (gets display) + +-- | Return the current windows +getWindows :: W (Seq Window) +getWindows = W (gets windows) + +-- | Return the screen width +getScreenWidth :: W Int +getScreenWidth = W (gets screenWidth) + +-- | Return the screen height +getScreenHeight :: W Int +getScreenHeight = W (gets screenHeight) + +-- | Set the current window list +setWindows :: Seq Window -> W () +setWindows x = W (modify (\s -> s {windows = x})) + +-- | Modify the current window list +modifyWindows :: (Seq Window -> Seq Window) -> W () +modifyWindows f = W (modify (\s -> s {windows = f (windows s)})) @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 - -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 - --- --- | Lift an IO action into the Wm monad --- -io :: IO a -> Wm a -io = liftIO - --- --- | Lift an IO action into the Wm monad, discarding any result --- -io_ :: IO a -> Wm () -io_ f = liftIO f >> return () - -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') <- io $ 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)})) |