John Ky
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.