[reactive] Fun with existentials

[Achim Schneider]

XHB uses existentials to enable X extensions to define their own events
and still have them delivered to the user by the main library, so I had
the chance to mess around with them and reactive. If you comment out
the keyPressH, things are perfectly fine, but there's no dispatch on
event types. With the forkIO, the program stumbles over an indefinite
block on the next event. The adaptE without fromEventE is the only
thing keeping the program alive: It seems that if there is only a
single event that is possibly not handled, things go haywire... even if
every event is guaranteed to be handled (in some other adaptE).

Without any adaptE things work fine, too.

I don't know if multiple adaptE's are supposed to work, but it'd be
certainly nice if they would. I'm going to try to join the
Nothings sorted out by joinMaybes back into the stream, hopefully
that'll convince the RTS.




{-# LANGUAGE ExistentialQuantification #-}
module Main where

-- current darcs XHB
-- hack it to export Graphics.XHB.Connection.Types
-- port of http://en.wikibooks.org/wiki/X_Window_Programming/XCB
-- run your X server on :0 or change getScreen

import Graphics.XHB as X
import FRP.Reactive as R
import FRP.Reactive.LegacyAdapters
import Control.Concurrent
import Control.Monad
import System.Exit
import Control.Applicative


printErrors c = (forkIO . forever) $ waitForError c >>= print
getScreen = head . roots_Setup . conf_setup . conn_conf
castXid = fromXid . toXid

main = do
    (Just c) <- connect
    printErrors c
    print $ displayInfo c
    let s     = getScreen c
        black = black_pixel_SCREEN s
        white = white_pixel_SCREEN s
        root  = root_SCREEN s
        depth = root_depth_SCREEN s
        visual = root_visual_SCREEN s


    g <- newResource c
    createGC c (MkCreateGC 
        g 
        (castXid root) 
        (toValueParam 
            [(GCForeground,white)
            ,(GCGraphicsExposures,0)
            ]
        ))

    w <- newResource c
    createWindow c (MkCreateWindow 
        depth w root     
        0 0 640 480
        0 0 visual
        (toValueParam
            [(CWBackPixel,black)
            ,(CWEventMask,toMask
                [ EventMaskExposure
                , EventMaskKeyPress 
                ]
             )
            ]
         ))

    lock <- newEmptyMVar
    sync <- makeSync
    evs <- eventsE sync c
    mapWindow c w
    forkIO $ adaptE $ keyPressH lock c $ fromEventE evs 
--    forkIO $ adaptE $ exposeH c $ fromEventE evs 
    adaptE $ (fmap.const) (putStrLn "some event" ) evs

    --readMVar lock

keyPressH :: MVar () -> Connection -> R.Event KeyPress -> R.Event Action
keyPressH lock _ = (fmap.const) $ putStrLn "key" >> putMVar lock ()

exposeH :: Connection -> R.Event KeyPress -> R.Event Action
exposeH _ = fmap print

fromEventE :: X.Event a => R.Event SomeEvent -> R.Event a
fromEventE = joinMaybes <$> fmap fromEvent

type Sync = Clock TimeT
makeSync = makeClock

eventsE :: Sync -> Connection -> IO (R.Event SomeEvent)
eventsE cl c = do
    (sink, res) <- makeEvent cl
    (forkIO . forever) $
        putStrLn "tick " >> waitForEvent c >>= sink
    return res



-- 
(c) this sig last receiving data processing entity. Inspect headers
for copyright history. All rights reserved. Copying, hiring, renting,
performance and/or quoting of this signature prohibited.