whim-0.1: Whim.hs

{-# 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"