[Haskell-cafe] Re: Writing a generic event handler

[Achim Schneider]

John Ky <newhoggy at gmail.com> wrote:

> My question is: Is it possible to write a generic doLoop that works
> over arbitrary functions?
>
Yes and no, that is, you can overcome the no.

The following code typechecks, and would run nicely if there was a
fixed version of reactive, by now[1]. Event handlers can take one
arbitrary argument and return anything (as long as it's the same as
other handlers), and may be curried before registration, of course. As
you can stuff anything you please into one argument, I doubt you'll hit
a wall there. Note the usage of Maybe to dispatch, you should be able
to do something similar with a plain Maybe monad, without all that
Event stuff. Either might also be a good idea.

[1] It would also feature splices that can be spliced further and other
    things quite similar to pattern-matching. TBH, I got tired of not
    running the code and intimidated by fixpoints of Event streams.


module Main where

-- current darcs XHB
-- hack it to export Graphics.XHB.Connection.Types
-- get rid of the Show constraint in Reactive's filterE (or was it
justE?)

import Graphics.XHB as X
import FRP.Reactive as R
import FRP.Reactive.LegacyAdapters
import Control.Concurrent
import Control.Monad
import Control.Applicative
import Data.Maybe
import Data.Monoid

createSimpleWindow :: Connection -> Int -> Int -> Int -> Int -> IO
WINDOW createSimpleWindow c x y w h = 
    let s     = getScreen c
        black = black_pixel_SCREEN s
        root  = root_SCREEN s
        depth = root_depth_SCREEN s
        visual = root_visual_SCREEN s
    in do 
        id <- newResource c
        createWindow c (MkCreateWindow 
            depth id root     
            (fromIntegral x) (fromIntegral y)
            (fromIntegral w) (fromIntegral h)
            0 0 visual
            (toValueParam
                [(CWBackPixel,black)
                ,(CWEventMask,toMask
                    [ EventMaskExposure
                    , EventMaskKeyPress 
                    --, EventMaskFocusChange
                    ])]))
        return id

createSimpleGC :: Connection -> IO GCONTEXT
createSimpleGC c =
    let s = getScreen c
        root = root_SCREEN s
        white = white_pixel_SCREEN s
    in do
    g <- newResource c
    createGC c (MkCreateGC 
        g 
        (castXid root) 
        (toValueParam 
            [(GCForeground,white)
            ,(GCGraphicsExposures,0)
            ]))
    return g




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

    gc <- createSimpleGC c
    w <- createSimpleWindow c 0 0 640 480


    lock <- newEmptyMVar
    let quit = putMVar lock ()
    mapWindow c w

    sync <- makeSync
    evs <- eventsX sync c
    forkIO $ adaptE $ braidE
        (const $ putStrLn "Unhandled Event")
        [ xEventSplice expose
        , xEventSplice (keyPress quit)
        ] evs

    readMVar lock

type Splice a b = (R.Event a, R.Event b) -> (R.Event a, R.Event b)

xEventSplice :: X.Event c => (c -> b) -> Splice SomeEvent b
xEventSplice = mkSplice fromEvent

mkSplice :: (a -> Maybe c) -> (c -> b) -> Splice a b
mkSplice f g (a,b) = ( filterE (isNothing . f) a 
                     , (fmap g . justE . fmap f) a `mappend` b )

braidE :: (a -> b) -> [Splice a b] -> R.Event a -> R.Event b
braidE f ss i =  b `mappend` fmap f a
    where (a, b) = (foldr (.) id ss) (i, mzero)

expose :: Expose -> Action
expose = const $ putStrLn "expose"

keyPress :: Action -> KeyPress -> Action
keyPress quit = const $ putStrLn "keyPress" >> quit


type Sync = Clock TimeT
makeSync = makeClock

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