whim (empty) → 0.1

raw patch · 9 files changed

+477/−0 lines, 9 filesdep +GLUTdep +OpenGLdep +X11setup-changed

Dependencies added: GLUT, OpenGL, X11, base, containers, mtl, process, random

Files

LICENSE +28/−0
NOTES +1/−0
Setup.hs +5/−0
Whim.hs +246/−0
Whim/Playground.hs +88/−0
Whim/Util.hs +19/−0
Whim/Xlib.hs +45/−0
boot.sh +12/−0
whim.cabal +33/−0

+ LICENSE view

@@ -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.

+ NOTES view

@@ -0,0 +1,1 @@+grabButton should take a keyMask, not a buttonMask.

+ Setup.hs view

@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMainWithHooks defaultUserHooks

+ Whim.hs view

@@ -0,0 +1,246 @@+{-# LANGUAGE ForeignFunctionInterface, ExistentialQuantification #-}+-- whim: a window manager+-- Copyright (C) 2006 Evan Martin <martine@danga.com>++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"

+ Whim/Playground.hs view

@@ -0,0 +1,88 @@+-- whim: a window manager+-- Copyright (C) 2006 Evan Martin <martine@danga.com>++-- 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

+ Whim/Util.hs view

@@ -0,0 +1,19 @@+-- whim: a window manager+-- Copyright (C) 2006 Evan Martin <martine@danga.com>++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)+

+ Whim/Xlib.hs view

@@ -0,0 +1,45 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- whim: a window manager+-- Copyright (C) 2006 Evan Martin <martine@danga.com>++-- | 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

+ boot.sh view

@@ -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

+ whim.cabal view

@@ -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 <martine@danga.com>+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