Simple netwire program - is there some way to write this simpler?

I've written a simple program to test out the capabilities of netwire (or rather, how to write programs using netwire). The goal is to have an application that shows a window, starting out as completely filled with red. Pressing space should switch from red to blue and vice versa. Pressing escape or closing the window should terminate the program. I've been able to write something that works (using Allegro, but that doesn't matter too much - the Allegro part can't be simplified, at least not by much), but it's gotten a bit lengthy for something that sounds so simple.

Here's the code (if there's anything particularly unidiomatic, I'd be glad if someone could tell me that too):

{-# LANGUAGE OverloadedStrings #-}

module Main(main) where

import Control.Wire hiding (when)
import Prelude hiding ((.),id)
import qualified Graphics.UI.Allegro.Raw as Al
import Data.Monoid
import Control.Monad.Reader
import qualified Data.Set as S
import Data.Set (Set)

iff True  a _  = a
iff False _ b  = b

data Game = Game {
    keyState :: Set Al.Key,
    isClosed :: Bool
}

data Result = GameColor Al.Color | Quit

colRed = Al.Color {Al.colorR = 1.0, Al.colorG = 0.0, Al.colorB = 0.0, Al.colorA = 1.0}
colBlue = Al.Color {Al.colorR = 0.0, Al.colorG = 0.0, Al.colorB = 1.0, Al.colorA = 1.0}

initG = Game { keyState = S.empty, isClosed = False }
addKey (g@ Game {keyState = s}) k = g {keyState = S.insert k s}

-- Produce when event occurs, inhibit otherwise
gameEvent :: Monoid e => (Game -> Bool) -> Event e (ReaderT Game IO) a
gameEvent f = mkFixM $ \_ a ->
  iff <$> asks f <*> (return $ Right a) <*> (return $ Left mempty)

windowClosed = gameEvent isClosed

keyPressed k = gameEvent (S.member k . keyState)

doQuit = pure Quit . (keyPressed Al.KeyEscape <|> windowClosed)
color = doColorRed


-- The once prevents infinite recursion in case space was pressed
doColorRed = pure (GameColor colRed) . (once <|> notE (keyPressed Al.KeySpace)) -->
              doColorBlue
doColorBlue = pure (GameColor colBlue) . (once <|> notE (keyPressed Al.KeySpace)) -->
                doColorRed

colorApp :: Wire () (ReaderT Game IO) a Result
colorApp = doQuit <|>
            color

main = do
  Al.initialize
  Al.installKeyboard
  Just window <- Al.createDisplay 800 600
  Al.setTargetBackbuffer window
  Just q <- Al.createEventQueue
  t <- Al.createTimer $ 1/60
  Al.registerEventSource q =<< Al.getKeyboardEventSource
  Al.registerEventSource q =<< Al.getDisplayEventSource window
  Al.registerEventSource q =<< Al.getTimerEventSource t
  Al.startTimer t
  loop colorApp clockSession q
  Al.destroyEventQueue q
  Al.destroyDisplay window where
    loop w session q = do
      game <- handleEvents initG q
      (mx, w', session') <- runReaderT (stepSession w session ()) game
      case mx of
         Left ex -> putStrLn $ "Inhibited: " ++ show ex -- this should never happen
         Right (GameColor c) -> do
           Al.clearToColor c
           Al.flipDisplay
           loop w' session' q
         Right Quit -> return ()
    handleEvents g q = do 
      ev <- Al.waitForEvent q
      case ev of
        Al.KeyDownEvent{Al.eventKeycode = k} -> handleEvents (addKey g k) q
        Al.Timer{}                           -> return g
        Al.DisplayClose{}                    -> return g{isClosed = True}
        _                                    -> handleEvents g q