First try for hdm

hdm.hs

import System.IO.Error
import System.Posix.Process
import Graphics.X11.Xft
import Graphics.X11.Xlib.Context
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Event
import Graphics.X11.Xlib.Misc
import Graphics.X11.Xlib.Screen
import Graphics.X11.Types
import Graphics.X11.Xlib.Window
import Control.Concurrent
import Control.Monad

loginBoxX = 100
loginBoxY = 100
loginBoxW = 500
loginBoxH = 30

xftFontName = "Sans:size=18";
-- xftFontName = "Sans:size=18:bold";

processEvent dsp ev = do
        let     scrnum = defaultScreen dsp
                scr = defaultScreenOfDisplay dsp
                gc = defaultGC dsp scrnum
                win = defaultRootWindow dsp
                colormap = defaultColormapOfScreen scr
                visual   = defaultVisualOfScreen scr
                fc = "red"
        pixmap <- createPixmap dsp win loginBoxW loginBoxH (defaultDepthOfScreen scr)
        setForeground dsp gc (whitePixel dsp scrnum)
        setBackground dsp gc (whitePixel dsp scrnum)
        fillRectangle dsp pixmap gc 0 0 loginBoxW loginBoxH
        font <- xftFontOpen dsp scr "Sans:size=18"
        withXftDraw dsp pixmap visual colormap $
                \draw -> withXftColorName dsp visual colormap fc $
                        \color -> do
                                setForeground dsp gc (blackPixel dsp scrnum)
                                xftDrawString draw color font 2 (loginBoxH - 5) " TEST "
        copyArea dsp pixmap win gc 0 0 loginBoxW loginBoxH loginBoxX loginBoxY
        flushGC dsp gc
        xftFontClose dsp font
        freePixmap dsp pixmap
        sync dsp False

isKeyEvent :: XEventPtr -> IO Bool
isKeyEvent ev = do
        t <- get_EventType ev
        return (t == keyPress)

xEventLoop dsp = do
        allocaXEvent $ \ev -> forever $ do
                putStrLn "waiting for event..."
                keyevent <- isKeyEvent ev
                if keyevent then
                        do
                                processEvent dsp ev
                                putStrLn "key pressed"
                        else putStrLn "other event"
                nextEvent dsp ev
                putStrLn $ "event " ++ (show ev)

xServerDo dsp = do
        let     scr = defaultScreen dsp
                gc = defaultGC dsp scr
                win = defaultRootWindow dsp
        -- putStrLn $ "opened display " ++ displayString dsp ++ ", having rootwin " ++ show win
        -- putStrLn $ "size " ++ (show $ displayWidth dsp scr) ++ "x" ++ (show $ displayHeight dsp scr)
        setForeground dsp gc (whitePixel dsp scr)
        -- setBackground dsp gc (whitePixel dsp scr)
        setFillStyle dsp gc fillSolid
        -- fillRectangle dsp win gc loginBoxX loginBoxY loginBoxW loginBoxH
        -- setForeground dsp gc (blackPixel dsp scr)
        -- drawRectangle dsp win gc loginBoxX loginBoxY loginBoxW loginBoxH
        flushGC dsp gc
        selectInput dsp win keyPressMask
        sync dsp False
        xEventLoop dsp

tryXServerConnect server_param = do
        ret <- tryIOError $ openDisplay server_param
        case ret of
                Right dsp -> xServerDo dsp
                Left _ -> do
                        threadDelay 500000
                        tryXServerConnect server_param

main = do
        pid <- forkProcess $ executeFile "Xnest" True [ server_param ] Nothing
        tryXServerConnect server_param
        where server_param = ":1"