Another try of FRP

Event.hs

{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}

module Event where

import Control.Monad

import Data.IORef
import Data.Map as Map

data Signal a
  = The a
  | Done

data Registration a = Registration
  { list   :: Map Int a
  , lastId :: Int
  }

emptyRegister = Registration Map.empty 0

register (Registration list lastId) thing =
    let newId = lastId + 1 in
    (newId, Registration (Map.insert newId thing list) newId)

unregister (Registration list lastId) index =
    Registration (Map.delete index list) lastId

data Event a = Event { handlers :: IORef (Registration (Signal a -> IO ())) }

data Behaviour a = Behaviour (IORef a)

newEvent :: IO (Event a)
newEvent = do
    empty <- newIORef emptyRegister
    return (Event empty)

newBehaviour def = do
    empty <- newIORef def
    return (Behaviour empty)

now (Behaviour cell) = do
    readIORef cell

push = flip (feed . The)

feed crap (Event listeners) = do
    Registration list _ <- readIORef listeners

    forM_ (Map.elems list) ($ crap)

stop = feed Done

value (Event listeners) def = do
    result @ (Behaviour cell) <- newBehaviour def
    
    listeners `addAutostoppedHandler` writeIORef cell

    return result

registrationRef `addHandler` handler = do
    registration <- readIORef registrationRef
    let (number, new) = registration `register` handler
    writeIORef registrationRef new
    return number

registrationRef `addAutostoppedHandler` handler = do
    rec index <- registrationRef `addHandler` autostop registrationRef index handler
    return ()

autostop registrationRef index handler Done = do
    modifyIORef registrationRef (`unregister` index)

autostop _ _ handler (The a) = handler a

delay :: t -> Event t -> IO (Event t)
delay withThing (Event listeners) = do
    result <- newEvent
    buffer <- newIORef (The withThing)

    rec 
        index <- listeners `addHandler` \signal -> case signal of
            The a -> do
                old <- readIORef buffer
                writeIORef buffer (The a)
                feed old result

            Done -> do
                last <- readIORef buffer
                feed last result
                feed Done result

    return result

mapE (Event listeners) f = do
    mapped <- newEvent

    listeners `addAutostoppedHandler` \a -> do
        feed (The (f a)) mapped

    return mapped

filterE (Event listeners) pred = do
    filtered <- newEvent

    listeners `addAutostoppedHandler` \a -> do
        when (pred a) $ do
            feed (The a) filtered

    return filtered

reduceE (Event listeners) initial op = do
    reduced <- newEvent
    buffer  <- newIORef initial

    listeners `addAutostoppedHandler` \a -> do
        buffer `modifyIORef` (`op` a)
        current <- readIORef buffer
        feed (The current) reduced

    return reduced

merge (Event l) (Event r) = do
    merged <- newEvent

    l `addAutostoppedHandler` push merged
    r `addAutostoppedHandler` push merged

    return merged    

switch :: Event a -> Event (Event a) -> IO (Event a)
switch (Event def) (Event joined) = do
    result  <- newEvent
    index   <- def `addHandler` (`feed` result)
    current <- newIORef (index, def)

    joined `addAutostoppedHandler` \(Event event) -> do
        (at, who) <- readIORef current
        reg       <- readIORef who

        writeIORef who (reg `unregister` at)

        index <- event `addHandler` (`feed` result)

        writeIORef current (index, event)

    return result

consume (Event listeners) consumer = do
    listeners `addAutostoppedHandler` consumer

watch e = e `consume` print

main = do
    input <- newEvent
    steps <- filterE input validStep            -- filter input
    diffs <- mapE    steps toDiffs              -- convert to 2-vector
    reloc <- reduceE diffs (0, 0) (scalar (+))  -- add steps
    shown <- mapE    reloc prettify             -- show cuurent state

    pos   <- value reloc (0, 0)                 -- current location

    watch shown                                 -- on state change: dump to the console

    let goTo loc = do
        putStrLn "Locate (5, 5). [WSAD]"
        cur <- now pos                          -- get current pos

        if cur /= loc
        then do
            line <- getLine
            push input line
            goTo loc

        else do
            putStrLn "Got there!"
            stop input

    goTo (5, 5)

  where
    validStep [c] = c `elem` "WASD"
    validStep  _  = False

    toDiffs "W" = (0, 1)
    toDiffs "A" = (1, 0)
    toDiffs "S" = (0, -1)
    toDiffs "D" = (-1, 0)

    scalar (?) (a, b) (c, d) = (a ? c, b ? d)

    prettify (x, y) = "We're at " ++ show x ++ ", " ++ show y ++ " now."