Editing X window programming in Haskell (section)

==Dealing with events==
Now try this.

In updateWin set threadDelay to something like:

<haskell>
  threadDelay (60 * 1000000)
</haskell>

Run the clock, switch to a console (with Alt+Ctrl+F1) and come back to the X server where the clock is running.

What happened? The window disappeared, and came back after being redrawn by drawInWin.

The problem is that our application does not respond to the events the X server is sending to our window. If a window is covered or anyway no more visible on the screen, when the covered area becomes visible again the X server will send to that window an ''Expose'' event, so that the application using that window may redraw it. Since our clock doesn't listen for any event, the window will not be redrawn till a new call to drawInWin is done.

Citing from
[http://en.wikipedia.org/wiki/X_Window_System_core_protocol#Events Wikipedia]:

<blockquote>"Events are packets sent by the server to a client to communicate that something the client may be interested in has happened. For example, an event is sent when the user presses a key or clicks a mouse button.

Events are not only used for input: for example, events are sent to indicate the creation of new subwindows of a given window. Every event is relative to a window. For example, if the user clicks when the pointer is in a window, the event will be relative to that window. The event packet contains the identifier of that window."</blockquote>

The list of events a window will be reacting too is set as the
[http://www.tronche.com/gui/x/xlib/window/attributes/event-and-do-not-propagate.html event mask] attribute of that window, and so may be set at creation time, as we have seen for the background pixel, or with XChangeWindowAttributes, or by using
[http://hackage.haskell.org/packages/archive/X11/1.2.2/doc/html/Graphics-X11-Xlib-Event.html#v%3AselectInput selectInput], the interface to
[http://www.tronche.com/gui/x/xlib/event-handling/XSelectInput.html XSelectInput].

In any case an event mask, [http://www.tronche.com/gui/x/xlib/window/attributes/event-and-do-not-propagate.html defined as] "the bitwise inclusive OR of zero or more of the valid event mask bits", must be specified in a way very similar to the attribute mask specification.

This is the type signature of selectInput:

<haskell>
selectInput :: Display -> Window -> EventMask -> IO ()
</haskell>

The possible events to be included in the event must, separated by a bitwise inclusive OR, are listed [http://www.tronche.com/gui/x/xlib/events/mask.html here] and [http://hackage.haskell.org/packages/archive/X11/1.2.2/doc/html/Graphics-X11-Types.html#3 here].

For a list of events types refer to the [http://www.tronche.com/gui/x/xlib/events/types.html Xlib Manual].

In order to capture ''Expose'' events, we will need to set the [http://hackage.haskell.org/packages/archive/X11/1.2.2/doc/html/Graphics-X11-Types.html#v%3AexposureMask exposureMask] with something like this, right after the new window has been mapped, in our main function:

<haskell>
  selectInput dpy win exposureMask
</haskell>

This is all we need to do in order to configure the window in such a way that it will receive ''Expose'' events.

Our problem is far bigger than that, unfortunately. Our problem, indeed, is that we must update (redraw) our window either in the case of an ''Expose'' event is received '''and''' when a given amount of time is elapsed. This second requirement was met by blocking our program execution with threadDelay. But when our program is blocked it cannot receive any event.

But if we start listening for events and no ''Expose'' event happens, after some time is elapsed we must update our window anyhow.

How can we achieve this?

Just to explain our problem with other words, if we change, in the last example, main and updateWin to listen to events we end up with something like this:

<haskell>
main :: IO ()
main = do 
  dpy <- openDisplay ""
  let dflt = defaultScreen dpy
      scr = defaultScreenOfDisplay dpy
  rootw  <- rootWindow dpy dflt
  win <- mkUnmanagedWindow dpy scr rootw 0 0 200 100
  setTextProperty dpy win "The Clock" wM_NAME 
  mapWindow dpy win
  selectInput dpy win (exposureMask .|. buttonPress)
  updateWin dpy win

updateWin :: Display -> Window -> IO ()
updateWin dpy win = do
  drawInWin dpy win =<< date
  sync dpy True
  allocaXEvent $ \e -> 
      do nextEvent dpy e
         ev <- getEvent e
         putStrLn $ eventName ev
  updateWin dpy win
</haskell>

In main we added the selectInput call. Note that the event mask includes both ''Expose'' events, and mouse button press events (you may specify different types of events).

The second function, updateWin, required more modifications.

Now the sync call takes a True, and not a False any more. This means that when flushing the output buffer all events in the event queue will be discarded. This is necessary otherwise we are going to intercept previous events. For instance, if you change the Boolean to False, you will see a ''[http://www.tronche.com/gui/x/xlib/events/exposure/graphics-expose-and-no-expose.html NoExpose]'' event, that is the result of the application of XCopyArea in drawInWin.

Please note the use of
[http://hackage.haskell.org/packages/archive/X11/1.2.2/doc/html/Graphics-X11-Xlib-Event.html#v%3AallocaXEvent allocaXEvent], very similar to the use of allocaSetWindowAttributes, as shown by its type signature:

<haskell>
allocaXEvent :: (XEventPtr -> IO a) -> IO a
</haskell>

Within allocaXEvent we can use the pointer to the XEvent to:
# wait for the next event with [http://hackage.haskell.org/packages/archive/X11/1.2.2/doc/html/Graphics-X11-Xlib-Event.html#v%3AnextEvent nextEvent], the interface to [http://www.tronche.com/gui/x/xlib/event-handling/manipulating-event-queue/XNextEvent.html XNextEvent];
# get the occurred event with getEvent (which requires X11-extras);
# convert the event in a string with eventName (which requires X11-extras);
# print the event name to the standard output: if we run our program from the command line, we can see the events received by our window.

I've also removed the threadDelay call. Guess why?

Just give it a run and you'll find out. If sync discards previous events, now nextEvent will block the program execution till an event occurs. If you don't press the mouse button over the window, or force an ''Expose'' event to occur, for instance by switching to a text console and back, the thread will be blocked in the safe foreign call to
[http://www.tronche.com/gui/x/xlib/event-handling/manipulating-event-queue/XNextEvent.html XNextEvent], which, "if the event queue is empty, flushes the output buffer and blocks until an event is received".

This is the implementation of nextEvent:

<haskell>
-- | interface to the X11 library function @XNextEvent()@.
foreign import ccall safe "HsXlib.h XNextEvent"
	nextEvent    :: Display -> XEventPtr  -> IO ()
</haskell>

How can we unblock nextEvent after a given amount of time is elapsed?

===Events and threads===
One possible solution is to use a second thread to ask the X server to send an ''Expose'' event after some time.

This is the code:

<haskell>
module Main where
import Data.Bits
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import System.Exit (exitWith, ExitCode(..))
import System.Time
import Control.Concurrent (threadDelay, forkIO)

main :: IO ()
main = do 
  dpy <- openDisplay ""
  let dflt = defaultScreen dpy
      scr = defaultScreenOfDisplay dpy
  rootw  <- rootWindow dpy dflt
  win <- mkUnmanagedWindow dpy scr rootw 0 0 200 100
  setTextProperty dpy win "The Clock" wM_NAME 
  mapWindow dpy win
  selectInput dpy win (exposureMask .|. buttonPress)
  updateWin dpy win

updateWin :: Display -> Window -> IO ()
updateWin dpy win = do
  forkIO $ sendExposeEvent dpy win
  drawInWin dpy win =<< date
  sync dpy True
  allocaXEvent $ \e -> 
      do nextEvent dpy e
         ev <- getEvent e
         putStrLn $ eventName ev
  updateWin dpy win

sendExposeEvent :: Display -> Window -> IO ()
sendExposeEvent dpy w = 
    do threadDelay (1 * 1000000)
       allocaXEvent $ \e -> do
         setEventType e expose
         sendEvent dpy w False noEventMask e
       sync dpy False

date :: IO String
date = do 
  t <- toCalendarTime =<< getClockTime
  return $ calendarTimeToString t

drawInWin :: Display -> Window -> String ->IO ()
drawInWin dpy win str = do
  bgcolor <- initColor dpy "green"
  fgcolor <- initColor dpy "blue"
  gc <- createGC dpy win
  fontStruc <- loadQueryFont dpy "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
  p <- createPixmap dpy win 200 100 (defaultDepthOfScreen (defaultScreenOfDisplay dpy))
  setForeground dpy gc bgcolor
  fillRectangle dpy p gc 0 0 200 100
  setForeground dpy gc fgcolor
  fillRectangle dpy p gc 2 2 196 96
  printString dpy p gc fontStruc str
  copyArea dpy p win gc 0 0 200 100 0 0
  freeGC dpy gc
  freeFont dpy fontStruc
  freePixmap dpy p


printString :: Display 
             -> Drawable 
             -> GC
             -> FontStruct
             -> String
             -> IO ()
printString dpy d gc fontst str =
    do let strLen = textWidth fontst str
           (_,asc,_,_) = textExtents fontst str
           valign = (100 + fromIntegral asc) `div` 2
           remWidth = 200 - strLen
           offset =  remWidth `div` 2
       fgcolor <- initColor dpy "white"
       bgcolor <- initColor dpy "blue"
       setForeground dpy gc fgcolor
       setBackground dpy gc bgcolor
       drawImageString dpy d gc offset valign str

mkUnmanagedWindow :: Display
                  -> Screen
                  -> Window
                  -> Position
                  -> Position
                  -> Dimension
                  -> Dimension
                  -> IO Window
mkUnmanagedWindow dpy scr rw x y w h = do
  let visual = defaultVisualOfScreen scr
  win <- allocaSetWindowAttributes $ 
         \attributes -> do
           set_override_redirect attributes True
           createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr)
                        inputOutput visual cWOverrideRedirect attributes                                
  return win


initColor :: Display -> String -> IO Pixel
initColor dpy color = do
  let colormap = defaultColormap dpy (defaultScreen dpy)
  (apros,real) <- allocNamedColor dpy colormap color
  return $ color_pixel apros
</haskell>

This is going to work only if compiled with the ghc flag ''-threaded'', otherwise it will not work.

A clear explanation of why can be found [http://haskell.org/ghc/docs/latest/html/libraries/base/Control-Concurrent.html#10 here].

===A new nextEvent with asynchronous exceptions===
This is a second solution and was proposed by Spencer Janssen.

It uses a version of nextEvent that will not block in a foreign call. An [http://haskell.org/ghc/docs/latest/html/libraries/base/Control-Exception.html#14 asynchronous exception] will be used to interrupt threadWaitRead.

This is the code:

<haskell>
import Prelude hiding (catch)
import Data.Bits
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import System.Exit (exitWith, ExitCode(..))
import System.Time
import Control.Concurrent
import Control.Exception
import System.Posix.Types (Fd(..))


main :: IO ()
main = do 
  dpy <- openDisplay ""
  let dflt = defaultScreen dpy
      scr = defaultScreenOfDisplay dpy
  rootw  <- rootWindow dpy dflt
  win <- mkUnmanagedWindow dpy scr rootw 0 0 200 100
  setTextProperty dpy win "The Clock" wM_NAME 
  mapWindow dpy win
  selectInput dpy win (exposureMask .|. buttonPress)
  updateWin dpy win

-- | A version of nextEvent that does not block in foreign calls.
nextEvent' :: Display -> XEventPtr -> IO ()
nextEvent' d p = do
    pend <- pending d
    if pend /= 0
        then nextEvent d p
        else do
            threadWaitRead (Fd fd)
            nextEvent' d p
 where
    fd = connectionNumber d

-- | The event loop
updateWin :: Display -> Window -> IO ()
updateWin dpy win = do
    t <- forkIO (block go)
    timer t
 where
    -- interrupt the drawing thread every so often
    timer t = do
        threadDelay (1 * 1000000)
        throwTo t (ErrorCall "done")
        timer t
    -- Continuously wait for a timer interrupt or an expose event
    go = do
        drawInWin dpy win =<< date
        catch (unblock $ allocaXEvent $ nextEvent' dpy) (const $ return ())
        go

sendExposeEvent :: Display -> Window -> IO ()
sendExposeEvent dpy w = 
    do threadDelay (1 * 1000000)
       allocaXEvent $ \e -> do
         setEventType e expose
         sendEvent dpy w False noEventMask e
       sync dpy False

date :: IO String
date = do 
  t <- toCalendarTime =<< getClockTime
  return $ calendarTimeToString t

drawInWin :: Display -> Window -> String ->IO ()
drawInWin dpy win str = do
  bgcolor <- initColor dpy "green"
  fgcolor <- initColor dpy "blue"
  gc <- createGC dpy win
  fontStruc <- loadQueryFont dpy "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
  p <- createPixmap dpy win 200 100 (defaultDepthOfScreen (defaultScreenOfDisplay dpy))
  setForeground dpy gc bgcolor
  fillRectangle dpy p gc 0 0 200 100
  setForeground dpy gc fgcolor
  fillRectangle dpy p gc 2 2 196 96
  printString dpy p gc fontStruc str
  copyArea dpy p win gc 0 0 200 100 0 0
  freeGC dpy gc
  freeFont dpy fontStruc
  freePixmap dpy p


printString :: Display 
             -> Drawable 
             -> GC
             -> FontStruct
             -> String
             -> IO ()
printString dpy d gc fontst str =
    do let strLen = textWidth fontst str
           (_,asc,_,_) = textExtents fontst str
           valign = (100 + fromIntegral asc) `div` 2
           remWidth = 200 - strLen
           offset =  remWidth `div` 2
       fgcolor <- initColor dpy "white"
       bgcolor <- initColor dpy "blue"
       setForeground dpy gc fgcolor
       setBackground dpy gc bgcolor
       drawImageString dpy d gc offset valign str

mkUnmanagedWindow :: Display
                  -> Screen
                  -> Window
                  -> Position
                  -> Position
                  -> Dimension
                  -> Dimension
                  -> IO Window
mkUnmanagedWindow dpy scr rw x y w h = do
  let visual = defaultVisualOfScreen scr
  win <- allocaSetWindowAttributes $ 
         \attributes -> do
           set_override_redirect attributes True
           createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr)
                        inputOutput visual cWOverrideRedirect attributes                                
  return win


initColor :: Display -> String -> IO Pixel
initColor dpy color = do
  let colormap = defaultColormap dpy (defaultScreen dpy)
  (apros,real) <- allocNamedColor dpy colormap color
  return $ color_pixel apros
</haskell>

[[Category:Tutorials]]