diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/NOTES b/NOTES new file mode 100644 --- /dev/null +++ b/NOTES @@ -0,0 +1,1 @@ +grabButton should take a keyMask, not a buttonMask. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks defaultUserHooks diff --git a/Whim.hs b/Whim.hs new file mode 100644 --- /dev/null +++ b/Whim.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE ForeignFunctionInterface, ExistentialQuantification #-} +-- whim: a window manager +-- Copyright (C) 2006 Evan Martin + +module Main (main) where + +import Prelude hiding (log, lookup) +import Control.Monad.State hiding (State) +import Data.Bits ((.|.)) +import qualified Data.Map +import Data.Map ((!), lookup) +import System.Cmd (system) +import System.Random + +import Graphics.X11.Xlib + +import Whim.Util +import qualified Whim.Xlib + +magicMod :: KeyMask +magicMod = controlMask .|. mod1Mask + +{- +data Config = Config { + cMagicKey :: + } +-} + +-- | Data we track about each window. +data Client = Client { + clWindow :: Window, + clPos :: Coord, + clSize :: Coord, + clName :: String + } deriving Show + +-- | A map from Window -> Client. +type ClientMap = Data.Map.Map Window Client +-- | The reason we're grabbing the mouse. +data MouseGrab = Drag | Resize + +-- | Key bindings. +type KeyBindingKey = (KeyMask, KeyCode) +type KeyBindingTarget = StateM () +type KeyBindings = Data.Map.Map KeyBindingKey KeyBindingTarget +keyConfig = [ + (xK_x, cmd "xeyes"), + (xK_t, cmd "xvt") + ] where cmd c = liftIO (system (c ++ " &")) >> return () + +-- | Global state. +data State = State { + sClients :: ClientMap, + sMouseGrab :: Maybe (MouseGrab, Window, Coord), + sKeyBindings :: KeyBindings + } +sClient :: Window -> State -> Client +sClient win state = sClients state ! win + +-- | A state monad that allows IO and modifying the state. +type StateM a = StateT State IO a + +-- | Wrap a Window into a Client, adding the appropriate grabs. +wrapWindow :: Display -> Window -> IO Client +wrapWindow dpy win = do + log $ ["wrapped window", show win] + + -- Grab buttons 1 and 2 when our magic modifier is pressed. + grabButton dpy button1 magicMod win False buttonPressMask + grabModeAsync grabModeSync 0 0 + grabButton dpy button2 magicMod win False buttonPressMask + grabModeAsync grabModeSync 0 0 + + -- Get notifications when things happen to the window. + selectInput dpy win (structureNotifyMask .|. propertyChangeMask .|. + enterWindowMask) + + -- Move it to a random location + x <- randomRIO (500, 500) :: IO Int + y <- randomRIO (500, 500) :: IO Int + moveWindow dpy win (fromIntegral x) (fromIntegral y) + + mapWindow dpy win + + (x, y, w, h) <- Whim.Xlib.getWindowAttributes dpy win + return $ Client win (x,y) (w,h) "foo" + +-- | Wrap all existing Clients. +wrapInitialClients :: Display -> Window -> IO ClientMap +wrapInitialClients dpy root = do + wins <- Whim.Xlib.queryTree dpy root + clients <- mapM (wrapWindow dpy) wins + return $ Data.Map.fromList (zip wins clients) + +-- | Grab the keys we're interested in. +grabKeys :: Display -> Window -> IO KeyBindings +grabKeys dpy root = do + codes <- mapM (uncurry bindKey) keyConfig + let keys = zip (repeat magicMod) codes + return $ Data.Map.fromList $ zip keys (map snd keyConfig) + where + bindKey sym f = do + code <- keysymToKeycode dpy sym + ungrabKey dpy code magicMod root + grabKey dpy code magicMod root False grabModeAsync grabModeAsync + return code + +-- | Do all of the initial setup. +initialize :: Display -> State -> IO State +initialize dpy state = do + root <- rootWindow dpy 0 + -- Get notifications when the available window list changes. + -- This fails if there is already a wm running. + selectInput dpy root substructureRedirectMask + bindings <- grabKeys dpy root + clientmap <- wrapInitialClients dpy root + print clientmap + sync dpy False + log ["initialized."] + return $ state { sClients=clientmap, sKeyBindings=bindings } + +-- | Handle a key press. +handleKey :: HandlerFunc XKeyEvent +handleKey dpy win (root, sub, time, x, y, xr, yr, mod, keycode, same) = do + liftIO $ log ["keydown", show keycode] + bindings <- gets sKeyBindings + case lookup (mod, keycode) bindings of + Nothing -> return () + Just cb -> cb + +-- | Handle a key release. +handleKeyRelease :: HandlerFunc XKeyEvent +handleKeyRelease dpy win (root, sub, time, x, y, xr, yr, mod, keycode, same) = do + return () + +handleButton :: HandlerFunc XButtonEvent +handleButton dpy win (root, sub, time, x, y, xr, yr, mod, button, same) = do + liftIO $ log ["buttonpress", show root, show win, + "(" ++ show x ++ "," ++ show y ++ ")", show button] + let mouseMask = buttonPressMask .|. buttonReleaseMask .|. pointerMotionMask + liftIO $ raiseWindow dpy win + liftIO $ grabPointer dpy root False mouseMask + grabModeAsync grabModeAsync 0 0 time + modify $ \s -> + if button == button1 + then s { sMouseGrab = Just (Drag, win, ((fromIntegral xr),(fromIntegral yr))) } + else if button == button2 + then s { sMouseGrab = Just (Resize, win, ((fromIntegral xr),(fromIntegral yr))) } + else s + +handleMotion :: HandlerFunc XMotionEvent +handleMotion dpy win (root, sub, time, x, y, xr, yr, mod, mode, same_screen) = do + grab <- gets sMouseGrab + case grab of + Nothing -> liftIO $ log ["motion but no drag?"] + Just (grabtype, win, lastpos) -> handleGrabbedMotion grabtype win lastpos + + where + handleGrabbedMotion grabtype win lastpos = do + clients <- gets sClients + -- XXX this should fail if client dies while dragging + let client = clients ! win + liftIO $ sync dpy False + let curpos = (fromIntegral xr, fromIntegral yr) + client' <- updateClient client grabtype ((curpos) -: lastpos) + modify $ \s -> s { sClients = Data.Map.insert win client' clients, + sMouseGrab = Just (grabtype, win, (curpos)) } + + updateClient client Drag delta = do + let newpos = (clPos client) +: delta + liftIO $ moveWindow dpy (clWindow client) (fromIntegral $ fst newpos) + (fromIntegral $ snd newpos) + return $ client {clPos=newpos} + updateClient client Resize delta = do + liftIO $ log ["XXX implement resize."] + return client + +handleButtonRelease :: HandlerFunc XButtonEvent +handleButtonRelease dpy win (root, sub, time, x,y, xr,yr, mod, button, same) = do + -- Stop any existing mouse grab. + grab <- gets sMouseGrab + case grab of + Just _ -> do + liftIO $ ungrabPointer dpy time + modify $ \s -> s { sMouseGrab=Nothing } + Nothing -> return () + +handleMapRequest :: HandlerFunc Window +handleMapRequest dpy _ win = do + liftIO $ log ["map", show win] + clients <- gets sClients + if win `Data.Map.member` clients + then return () + else do client <- liftIO $ wrapWindow dpy win + modify $ \s -> s { sClients = Data.Map.insert win client clients } + +emptyHandler :: String -> Handler +emptyHandler name = Handler return (\d w a -> liftIO $ log [name]) +type HandlerFunc a = Display -> Window -> a -> StateM () +data Handler = forall a. Handler (XEventPtr -> IO a) (HandlerFunc a) + +dispatchEvent :: Display -> State -> XEventPtr -> IO State +dispatchEvent dpy state xev = do + evtype <- get_EventType xev + win <- get_Window xev + case Data.Map.lookup evtype dispatchTable of + Just (Handler convertor handler) -> do + param <- convertor xev + execStateT (handler dpy win param) state + Nothing -> do + log $ ["other event:", show evtype] + return state + where + dispatchTable :: Data.Map.Map EventType Handler + dispatchTable = Data.Map.fromList [ + (buttonPress, Handler get_ButtonEvent handleButton), + (buttonRelease, Handler get_ButtonEvent handleButtonRelease), + (keyPress, Handler get_KeyEvent handleKey), + (keyRelease, Handler get_KeyEvent handleKeyRelease), + (enterNotify, emptyHandler "enter"), + (motionNotify, Handler get_MotionEvent handleMotion), + (mapRequest, Handler Whim.Xlib.get_MapRequestEvent handleMapRequest) + ] + +loopState :: a -> (a -> IO a) -> IO b +loopState state f = loop state where loop s = f s >>= loop + +mainLoop :: Display -> State -> IO () +mainLoop dpy state = do + allocaXEvent $ \xev -> do + log ["awaiting events."] + loopState state $ \state -> do + nextEvent dpy xev + dispatchEvent dpy state xev + +main :: IO () +main = do + dpy <- openDisplay "" + state <- initialize dpy $ State { + sClients = undefined, + sMouseGrab = Nothing, + sKeyBindings = undefined + } + print $ sClients state + mainLoop dpy state + putStrLn "done" diff --git a/Whim/Playground.hs b/Whim/Playground.hs new file mode 100644 --- /dev/null +++ b/Whim/Playground.hs @@ -0,0 +1,88 @@ +-- whim: a window manager +-- Copyright (C) 2006 Evan Martin + +-- This module will hopefully be used to test the window layout OpenGL +-- magics without actually needing to boot up a window manager. + +module Whim.Playground where + +import Data.IORef +import Graphics.Rendering.OpenGL hiding (normalize) +import Graphics.UI.GLUT hiding (normalize, Window) +import System.Environment +import System.Exit + +import Whim.Util + +-- A simulation of an X window. +data Window = Window { + wOrigin :: Coord, + wSize :: Coord, + wTitle :: String, + wColor :: Color4 GLfloat + } + +data State = State { + sPlaygroundSize :: Size, + sWindows :: [Window] + } + +updateView state = do + matrixMode $= Projection + loadIdentity + scale 1 (-1 :: GLfloat) 1 + let (Size w h) = sPlaygroundSize state + viewport $= (Position 0 0, sPlaygroundSize state) + ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + +display :: IORef State -> DisplayCallback +display stateref = do + state <- readIORef stateref + clear [ColorBuffer] + --matrixMode $= Modelview 0 + --loadIdentity + + mapM_ renderWindow (sWindows state) + + swapBuffers where + + renderWindow win = do + let (x,y) = wOrigin win + let (w,h) = wSize win + currentColor $= wColor win + renderPrimitive Quads $ do + mapM_ (\(x,y) -> vertex $ Vertex2 ((fromIntegral x)::GLfloat) (fromIntegral y)) + [(x,y), (x,y+h), (x+w,y+h), (x+w,y)] + +key :: IORef State -> KeyboardMouseCallback +key stateref key keystate mods pos = exitWith ExitSuccess + +reshape :: IORef State -> ReshapeCallback +reshape rstate size@(Size w h)= do + viewport $= (Position 0 0, size) + modifyIORef rstate (\s -> s { sPlaygroundSize=size }) + state <- readIORef rstate + updateView state + +main :: IO () +main = do + (name, args) <- getArgsAndInitialize + initialDisplayMode $= [DoubleBuffered, RGBMode] + depthFunc $= Just Less + let windows = [Window (10,10) (400,300) "XTerm" (Color4 0.5 0 0 0)] + let state = State { sPlaygroundSize=(Size 640 480), sWindows=windows } + rstate <- newIORef state + initialWindowSize $= sPlaygroundSize state + createWindow "whim: management test" + + clearColor $= Color4 0.0 0.0 0.0 0.0 + lineSmooth $= Enabled + + updateView state + + matrixMode $= Modelview 0 + + displayCallback $= display rstate + reshapeCallback $= Just (reshape rstate) + keyboardMouseCallback $= Just (key rstate) + mainLoop diff --git a/Whim/Util.hs b/Whim/Util.hs new file mode 100644 --- /dev/null +++ b/Whim/Util.hs @@ -0,0 +1,19 @@ +-- whim: a window manager +-- Copyright (C) 2006 Evan Martin + +module Whim.Util where + +import Data.List (intersperse) + +log :: [String] -> IO () +-- Output a string to the log. +log str = putStrLn $ "whim: " ++ (foldr1 (++) $ intersperse " " str) + +-- Some utilities for working with 2d coordinates. +type Coord = (Int, Int) +-- The mnemonic for these operators is the two dots of the colon = 2d. +(-:) :: Coord -> Coord -> Coord +(x1,y1) -: (x2,y2) = (x1-x2, y1-y2) +(+:) :: Coord -> Coord -> Coord +(x1,y1) +: (x2,y2) = (x1+x2, y1+y2) + diff --git a/Whim/Xlib.hs b/Whim/Xlib.hs new file mode 100644 --- /dev/null +++ b/Whim/Xlib.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- whim: a window manager +-- Copyright (C) 2006 Evan Martin + +-- | Extra functions that the built-in X11 module lacks. + +module Whim.Xlib where + +import Graphics.X11.Xlib +import Foreign + +foreign import ccall "X11/Xlib.h XFree" + x_free :: Ptr a -> IO () +foreign import ccall "X11/Xlib.h XQueryTree" + x_query_tree :: Display -> Window -> Ptr Window -> Ptr Window + -> Ptr (Ptr Window) -> Ptr Int -> IO Int +queryTree :: Display -> Window -> IO [Window] +queryTree dpy win = + with 0 $ \proot -> + with 0 $ \pparent -> + with nullPtr $ \ppchildren -> + with 0 $ \pnchildren -> do + throwIf (== 0) (const "XQueryTree failed") $ + x_query_tree dpy win proot pparent ppchildren pnchildren + nchildren <- peek pnchildren + pchildren <- peek ppchildren + children <- peekArray nchildren pchildren + x_free pchildren + return children + +type WindowAttributes = (Int, Int, Int, Int) +foreign import ccall "X11/Xlib.h XGetWindowAttributes" + x_get_window_attributes :: Display -> Window -> Ptr Int -> IO Int +getWindowAttributes :: Display -> Window -> IO WindowAttributes +getWindowAttributes dpy win = do + let structSize = 23 + allocaArray (structSize*4) $ \carr -> do + throwIf (== 0) (const "XGetWindowAttributes failed") $ + x_get_window_attributes dpy win carr + arr <- peekArray structSize carr + let (x:y:w:h:_) = map fromIntegral arr + return (x, y, w, h) + +get_MapRequestEvent :: XEventPtr -> IO Window +get_MapRequestEvent ptr = peekElemOff (castPtr ptr) 5 diff --git a/boot.sh b/boot.sh new file mode 100644 --- /dev/null +++ b/boot.sh @@ -0,0 +1,12 @@ +#!/bin/sh + +Xnest :1 -ac -fp /usr/share/X11/fonts/misc/ & +export DISPLAY=:1 + +xeyes & +xvt -e /bin/sh & + +xsetroot -solid slategray +#gdb --args ./whim +./whim +killall Xnest diff --git a/whim.cabal b/whim.cabal new file mode 100644 --- /dev/null +++ b/whim.cabal @@ -0,0 +1,33 @@ +name: whim +version: 0.1 +synopsis: A Haskell window manager +description: A simple X Windows window manager in Haskell; written before XMonad. +Stability: Experimental +category: System +license: BSD3 +license-file: LICENSE +author: Evan Martin +maintainer: Evan Martin +homepage: http://neugierig.org/software/darcs/whim/ + +tested-with: GHC==6.8.2 +Cabal-Version: >= 1.2 +build-type: Simple +data-files: NOTES +extra-source-files: boot.sh + +Library + build-depends: base>3, X11, GLUT, OpenGL, random, process, containers, mtl + extensions: ForeignFunctionInterface, ExistentialQuantification + + ghc-options: -O2 -Wall -optl-Wl,-s + ghc-prof-options: -prof -auto-all + + Exposed-modules: Whim.Playground, Whim.Util, Whim.Xlib + +Executable whim + executable: whim + main-is: Whim.hs + + ghc-options: -O2 -Wall -optl-Wl,-s + ghc-prof-options: -prof -auto-al