diff options
| -rw-r--r-- | Main.hs | 167 | ||||
| -rw-r--r-- | W.hs | 49 |
2 files changed, 97 insertions, 119 deletions
@@ -13,10 +13,7 @@ -- thunk, a minimal window manager for X11 -- -import qualified Data.Map as Map -import Data.Map (Map) - -import Data.Bits +import Data.Bits hiding (rotate) import System.IO import System.Process (runCommand) @@ -29,56 +26,62 @@ import Control.Monad.State import W ------------------------------------------------------------------------- - -- -- let's get underway -- main :: IO () main = do dpy <- openDisplay "" - runW realMain $ WState - { display = dpy - , screenWidth = displayWidth dpy (defaultScreen dpy) - , screenHeight = displayHeight dpy (defaultScreen dpy) - , windows = [] - } + let dflt = defaultScreen dpy + initState = WState + { display = dpy + , screenWidth = displayWidth dpy dflt + , screenHeight = displayHeight dpy dflt + , windows = [] } + + runW initState $ do + root <- io $ rootWindow dpy dflt + io $ do selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) + sync dpy False + registerKeys dpy root + go dpy + return () + where + -- The main loop + go dpy = forever $ do + e <- io $ allocaXEvent $ \ev -> nextEvent dpy ev >> getEvent ev + handle e -- --- Grab the display and input, and jump into the input loop +-- | grabkeys. Register key commands -- -realMain :: W () -realMain = do - dpy <- getDisplay - let screen = defaultScreen dpy - io $ do root <- rootWindow dpy screen - selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) - sync dpy False - grabkeys - loop +registerKeys :: Display -> Window -> W () +registerKeys dpy root = + forM_ keys $ \(mod, sym, _) -> do + kc <- io (keysymToKeycode dpy sym) + io $ grabKey dpy kc mod root True grabModeAsync grabModeAsync --- --- The main event handling loop --- -loop :: W () -loop = do - dpy <- getDisplay - forever $ do - e <- io $ allocaXEvent $ \ev -> nextEvent dpy ev >> getEvent ev - handler e +keys :: [(KeyMask, KeySym, W ())] +keys = + [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm") + , (mod1Mask, xK_p, spawn "exe=`dmenu_path | dmenu` && exec $exe") + , (controlMask, xK_space, spawn "gmrun") + , (mod1Mask, xK_Tab, switch) + , (mod1Mask .|. shiftMask, xK_q, io $ exitWith ExitSuccess) + ] -- -- The event handler -- -handler :: Event -> W () -handler (MapRequestEvent {window = w}) = manage w +handle :: Event -> W () +handle (MapRequestEvent {window = w}) = manage w -handler (DestroyWindowEvent {window = w}) = do +handle (DestroyWindowEvent {window = w}) = do modifyWindows (filter (/= w)) refresh -handler (KeyEvent {event_type = t, state = mod, keycode = code}) +handle (KeyEvent {event_type = t, state = mod, keycode = code}) | t == keyPress = do dpy <- getDisplay sym <- io $ keycodeToKeysym dpy code 0 @@ -86,75 +89,57 @@ handler (KeyEvent {event_type = t, state = mod, keycode = code}) [] -> return () ((_, _, act):_) -> act -handler _ = return () +handle _ = return () --- --- switch focus to next window in list. --- -switch :: W () -switch = do - ws <- getWindows - case ws of - [] -> return () - (x:xs) -> do - setWindows (xs++[x]) -- snoc. polish this. - refresh +-- --------------------------------------------------------------------- +-- Managing windows --- --- | spawn. Launch an external application --- -spawn :: String -> W () -spawn = io_ . runCommand +-- | Modify the current window list with a pure funtion, and refresh +withWindows :: (Windows -> Windows) -> W () +withWindows f = do + modifyWindows f + refresh --- --- | Keys we understand. --- -keys :: [(KeyMask, KeySym, W ())] -keys = - [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm") - , (mod1Mask, xK_p, spawn "exe=`dmenu_path | dmenu` && exec $exe") - , (controlMask, xK_space, spawn "gmrun") - , (mod1Mask, xK_Tab, switch) - , (mod1Mask .|. shiftMask, xK_q, io $ exitWith ExitSuccess) - ] +-- | Run an action on the currently focused window +withCurrent :: (Window -> W ()) -> W () +withCurrent f = do + ws <- getWindows + case ws of + [] -> return () + (w:_) -> f w -- --- | grabkeys. Register key commands +-- | refresh. Refresh the currently focused window. Resizes to full +-- screen and raises the window. -- -grabkeys :: W () -grabkeys = do - dpy <- getDisplay - root <- io $ rootWindow dpy (defaultScreen dpy) - forM_ keys $ \(mod, sym, _) -> do - code <- io $ keysymToKeycode dpy sym - io $ grabKey dpy code mod root True grabModeAsync grabModeAsync +refresh :: W () +refresh = withCurrent $ \w -> do + d <- getDisplay + sw <- getScreenWidth + sh <- getScreenHeight + io $ do moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) + raiseWindow d w -- --- +-- | manage. Add a new window to be managed -- manage :: Window -> W () manage w = do trace "manage" - d <- getDisplay - ws <- getWindows - when (w `notElem` ws) $ do - trace "modifying" - modifyWindows (w :) - io $ mapWindow d w - refresh + d <- getDisplay + withWindows $ \ws -> if w `elem` ws then ws else w:ws -- a set + io $ mapWindow d w + -- --- refresh the windows +-- | switch. switch focus to next window in list. +-- The currently focused window is always the head of the list -- -refresh :: W () -refresh = do - ws <- getWindows - case ws of - [] -> return () - (w:_) -> do - d <- getDisplay - sw <- getScreenWidth - sh <- getScreenHeight - io $ do moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) - raiseWindow d w +switch :: W () +switch = withWindows rotate +-- +-- | spawn. Launch an external application +-- +spawn :: String -> W () +spawn = io_ . runCommand @@ -20,64 +20,42 @@ import System.IO import Graphics.X11.Xlib import Control.Monad.State --- -- | WState, the window manager state. -- Just the display, width, height and a window list --- data WState = WState { display :: Display , screenWidth :: !Int , screenHeight :: !Int - , windows :: Windows + , windows :: !Windows } type Windows = [Window] -- | The W monad, a StateT transformer over IO encapuslating the window -- manager state --- -newtype W a = W (StateT WState IO a) +newtype W a = W { unW :: 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 +runW :: WState -> W a -> IO (a, WState) +runW st a = runStateT (unW a) st -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 --- +-- | A 'trace' for the W monad. Logs a string to stderr. The result may +-- be found in your .xsession-errors file trace :: String -> W () trace msg = io $ do hPutStrLn stderr msg hFlush stderr --- --- | Run an action forever --- -forever :: (Monad m) => m a -> m b -forever a = a >> forever a - -- --------------------------------------------------------------------- -- Getting at the window manager state @@ -104,3 +82,18 @@ setWindows x = W (modify (\s -> s {windows = x})) -- | Modify the current window list modifyWindows :: (Windows -> Windows) -> W () modifyWindows f = W (modify (\s -> s {windows = f (windows s)})) + +-- --------------------------------------------------------------------- +-- Generic utilities + +-- | Run an action forever +forever :: (Monad m) => m a -> m b +forever a = a >> forever a + +-- | Add an element onto the end of a list +snoc :: [a] -> a -> [a] +snoc xs x = xs ++ [x] + +-- | Rotate a list one element +rotate [] = [] +rotate (x:xs) = xs `snoc` x |