diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2012, Stephen Blackheath
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Stephen Blackheath nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/examples/poodle/Engine.hs b/examples/poodle/Engine.hs
new file mode 100644
--- /dev/null
+++ b/examples/poodle/Engine.hs
@@ -0,0 +1,180 @@
+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, EmptyDataDecls #-}
+module Engine where
+
+import FRP.Sodium
+
+import Control.Applicative
+import Control.Monad
+import Data.List
+import Data.Typeable
+import Graphics.Rendering.OpenGL as GL hiding (Triangle, Rect, translate)
+import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.UI.GLUT as GLUT hiding (Rect, translate)
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import System.Time
+import Debug.Trace
+
+import Image
+
+frameRate :: Num a => a
+frameRate = 40
+
+type Coord = Double
+type Point = (Coord, Coord)
+type Vector = (Coord, Coord)
+type Rect = (Point, Vector)   -- Central point and size from centre to edge
+type Sprite = (Rect, String)
+
+data MouseEvent = MouseDown Point | MouseMove Point | MouseUp Point
+    deriving Show
+
+-- | True if the point is inside the rectangle
+inside :: Point -> Rect -> Bool
+inside (x, y) ((ox, oy), (wx, wy)) =
+    x >= ox - wx && x <= ox + wx &&
+    y >= oy - wy && y <= oy + wy
+
+-- | True if the two rectangles overlap
+overlaps :: Rect -> Rect -> Bool
+overlaps ((x0, y0), (w0, h0)) ((x1, y1), (w1, h1)) =
+    let ax0 = x0 - w0
+        ay0 = y0 - h0
+        ax1 = x0 + w0
+        ay1 = y0 + h0
+        bx0 = x1 - w1
+        by0 = y1 - h1
+        bx1 = x1 + w1
+        by1 = y1 + h1
+    in ax1 > bx0 &&
+       ay1 > by0 &&
+       ax0 < bx1 &&
+       ay0 < by1
+
+-- | Get system time in seconds since the start of the Unix epoch
+-- (1 Jan 1970).
+getTime :: IO Double
+getTime = do
+    (TOD sec pico) <- getClockTime
+    return $!
+        (fromIntegral sec) +
+        (fromIntegral pico) / 1000000000000
+
+data M deriving Typeable
+
+-- | Game, which takes mouse event and time as input, and a list of sprites to draw
+-- as output. Time is updated once per animation frame.
+type Game p = Event p MouseEvent -> Behaviour p Double -> Reactive p (Behaviour p [Sprite])
+
+runGame :: String -> Game M -> IO ()
+runGame title game = do
+
+    (eMouse, pushMouse) <- newEvent
+    (eTime, pushTime) <- newEvent
+    spritesRef <- newIORef []
+    _ <- synchronously $ do
+        time <- hold 0 eTime
+        sprites <- game eMouse time
+        listenValueIO sprites (writeIORef spritesRef)
+
+    _ <- GLUT.getArgsAndInitialize
+    GLUT.initialDisplayMode $= [GLUT.DoubleBuffered]
+    GLUT.createWindow title
+    GLUT.windowSize $= GLUT.Size 700 500
+    blend $= Enabled
+    blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
+    multisample $= Enabled
+    shadeModel $= Smooth
+    polygonSmooth $= Enabled
+    hint PolygonSmooth $= Nicest
+    hint LineSmooth $= Nicest
+    normalize $= Enabled
+
+    texturesRef <- newIORef M.empty
+    t0 <- getTime
+    GLUT.displayCallback $= display texturesRef t0 pushTime spritesRef
+    let motion (GLUT.Position x y) = do
+            pt <- toScreen x y
+            synchronously $ pushMouse (MouseMove pt)
+    GLUT.motionCallback $= Just motion
+    GLUT.passiveMotionCallback $= Just motion
+    GLUT.keyboardMouseCallback $= Just (\key keyState mods pos -> do
+            case (key, keyState, pos) of
+                (GLUT.MouseButton GLUT.LeftButton, GLUT.Down, GLUT.Position x y) ->
+                    synchronously . pushMouse . MouseDown =<< toScreen x y
+                (GLUT.MouseButton GLUT.LeftButton, GLUT.Up,   GLUT.Position x y) ->
+                    synchronously . pushMouse . MouseUp   =<< toScreen x y
+                _ -> return ()
+        )
+    GLUT.addTimerCallback (1000 `div` frameRate) $ repaint
+    GLUT.mainLoop
+  where
+    toScreen :: GLint -> GLint -> IO (Coord, Coord)
+    toScreen x y = do
+        (_, Size w h) <- get viewport
+        let aspect = fromIntegral w / fromIntegral h
+            sx = 0.001/aspect
+            sy = 0.001
+            xx = 2 * ((fromIntegral x / fromIntegral w) - 0.5) / sx
+            yy = 2 * (0.5 - (fromIntegral y / fromIntegral h)) / sy
+        return (xx, yy)
+    repaint = do
+        GLUT.postRedisplay Nothing
+        GLUT.addTimerCallback (1000 `div` frameRate) $ repaint
+
+    period = 1 / frameRate
+
+    display :: IORef (Map String (TextureImage, TextureObject))
+            -> Double
+            -> (Double -> Reactive M ())
+            -> IORef [Sprite]
+            -> IO ()
+    display texturesRef t0 pushTime spritesRef = do
+
+        t <- subtract t0 <$> getTime
+        synchronously $ pushTime t
+
+        sprites <- readIORef spritesRef
+
+        clearColor $= Color4 0 0 0 (1 :: GLclampf)
+        --clearColor $= Color4 0.1 0.1 0.15 (1 :: GLclampf)
+        clear [ColorBuffer{-, DepthBuffer-}]
+        loadIdentity
+
+        (_, Size w h) <- get viewport
+        let aspect = fromIntegral w / fromIntegral h
+        scale (0.001/aspect) 0.001 (0.001 :: GLfloat)
+
+        forM_ sprites $ \(((posX, posY),(sizeX, sizeY)),imgFile) -> do
+            textures <- readIORef texturesRef
+            (TextureImage iWidth iHeight pWidth pHeight _ _, to) <- case imgFile `M.lookup` textures of
+                Just (ti, to) -> return (ti, to)
+                Nothing       -> do
+                    ti <- loadTexture imgFile False
+                    to <- createTexture ti
+                    modifyIORef texturesRef (M.insert imgFile (ti, to))
+                    return $ (ti, to)
+
+            preservingMatrix $ do
+                texture Texture2D $= Enabled
+                textureBinding Texture2D $= Just to
+                GL.translate $ Vector3 (realToFrac posX) (realToFrac posY) (0 :: GLdouble)
+                let w2 = realToFrac sizeX :: GLdouble
+                    h2 = realToFrac sizeY :: GLdouble
+                    cx = realToFrac pWidth / realToFrac iWidth :: GLfloat
+                    cy = realToFrac pHeight / realToFrac iHeight :: GLfloat
+                renderPrimitive Polygon $ do
+                    texCoord $ TexCoord2 0 cy
+                    vertex $ Vertex2 (-w2) (-h2)
+                    texCoord $ TexCoord2 cx cy
+                    vertex $ Vertex2 w2 (-h2)
+                    texCoord $ TexCoord2 cx 0
+                    vertex $ Vertex2 w2 h2
+                    texCoord $ TexCoord2 0 (0 :: GLfloat)
+                    vertex $ Vertex2 (-w2) h2
+                texture Texture2D $= Disabled
+            --translate $ Vector3 0 0 (0.001 :: GLdouble)
+
+        GLUT.swapBuffers
diff --git a/examples/poodle/Image.hs b/examples/poodle/Image.hs
new file mode 100644
--- /dev/null
+++ b/examples/poodle/Image.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module Image where
+
+import Data.ByteString (ByteString)     
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Internal as B
+import qualified Data.ByteString.Unsafe as B
+import Graphics.Rendering.OpenGL as GL hiding (RGB, RGBA)
+import qualified Graphics.Rendering.OpenGL as GL
+import Codec.Image.STB
+import Data.Bitmap.IO
+import Data.Char
+import Control.Exception
+import Control.Monad
+import Data.Typeable
+import Data.Word
+import Foreign
+import Foreign.C
+
+
+data Format = RGB | RGBA deriving (Eq, Show)
+
+data TextureImage_ d = TextureImage !Int !Int !Int !Int Format d deriving Show
+type TextureImage = TextureImage_ ByteString
+data ImageException = ImageException String
+    deriving Typeable
+instance Exception ImageException
+instance Show ImageException where
+    showsPrec _ (ImageException err) = ("ImageException: "++) . (err++)
+
+loadTexture :: FilePath
+            -> Bool               -- ^ True to invert it
+            -> IO TextureImage
+loadTexture path invert = do
+        eImg <- loadImage path
+        img <- case eImg of
+            Left err -> throwIO $ ImageException $
+                "Failed to load image file "++path++": "++err
+            Right img -> return img
+        withBitmap img $ \(width, height) components padding imgData0 -> do
+            fmt <- case components of
+                3 -> return RGB
+                4 -> return RGBA
+                _ -> throwIO $ ImageException $
+                    "Failed to load image file "++path++": we only support RGB images"
+            let len = width * height * components
+            imgData <- mallocBytes len
+            B.memcpy imgData imgData0 (fromIntegral len)
+            when invert $ do
+                let row = width * bytesPerPixel fmt
+                    row_sz = fromIntegral row
+                allocaBytes row $ \tempRow -> do
+                    forM_ [0..height `div` 2] $ \y -> do
+                        let r0 = row * y
+                            s0 = row * (height - 1 - y)
+                        B.memcpy tempRow (imgData `plusPtr` r0) row_sz
+                        B.memcpy (imgData `plusPtr` r0) (imgData `plusPtr` s0) row_sz
+                        B.memcpy (imgData `plusPtr` s0) tempRow row_sz
+            let tex = TextureImage width height width height fmt imgData
+            transparent <- hasTransparency tex
+            tex' <- if transparent then return tex else removeAlphaChannel tex
+            unsafeTextureToBS tex'
+
+-- | Converts a buffer-based Texture to to a ByteString-based one.  Frees
+-- the input byte buffer.
+unsafeTextureToBS :: TextureImage_ (Ptr Word8) -> IO TextureImage
+unsafeTextureToBS (TextureImage iWidth iHeight pWidth pHeight fmt buf) = do
+    let bpp = bytesPerPixel fmt
+        sz = bpp * iWidth * iHeight
+    bytes <- peekArray sz buf
+    free buf
+    return $ TextureImage iWidth iHeight pWidth pHeight fmt (B.pack bytes)
+
+bytesPerPixel :: Format -> Int
+bytesPerPixel RGB = 3
+bytesPerPixel RGBA = 4
+
+hasTransparency :: TextureImage_ (Ptr Word8) -> IO Bool
+hasTransparency (TextureImage _ _ _ _ RGB _) = return False
+hasTransparency (TextureImage width height _ _ fmt@RGBA imgData) = h 0
+  where
+    limit = width * height
+    bpp = bytesPerPixel fmt
+    h ix | ix >= limit = return False
+    h ix = do
+        alpha <- peekByteOff imgData (ix * bpp + 3) :: IO Word8
+        if alpha < 255
+            then return True
+            else h (ix + 1)
+
+removeAlphaChannel :: TextureImage_ (Ptr Word8) -> IO (TextureImage_ (Ptr Word8))
+removeAlphaChannel tex@(TextureImage _ _ _ _ RGB _) = return tex
+removeAlphaChannel (TextureImage iWidth iHeight pWidth pHeight fmt@RGBA imgData) = do
+    forM_ [1..limit-1] $ \ix -> do
+        r <- peekByteOff imgData (ix * bpp) :: IO Word8
+        pokeByteOff imgData (ix * 3) r
+        g <- peekByteOff imgData (ix * bpp + 1) :: IO Word8
+        pokeByteOff imgData (ix * 3 + 1) g
+        b <- peekByteOff imgData (ix * bpp + 2) :: IO Word8
+        pokeByteOff imgData (ix * 3 + 2) b
+    return (TextureImage iWidth iHeight pWidth pHeight RGB imgData)
+  where
+    limit = iWidth * iHeight
+    bpp = bytesPerPixel fmt
+
+-- | Convert texture data into an OpenGL handle
+createTexture :: TextureImage
+              -> IO TextureObject
+createTexture (TextureImage iWid iHt _ _ fmt imgBS) = do
+    [texName] <- genObjectNames 1  -- generate our texture.
+    --rowAlignment  Unpack $= 1
+    textureBinding Texture2D $= Just texName  -- make our new texture the current texture.
+    generateMipmap Texture2D $= Enabled
+    B.unsafeUseAsCStringLen imgBS $ \(buf, len) -> do
+        let glFmt = case fmt of
+                RGB  -> GL.RGB
+                RGBA -> GL.RGBA
+            pixels = PixelData glFmt UnsignedByte buf
+        build2DMipmaps Texture2D RGBA' (fromIntegral iWid) (fromIntegral iHt) pixels
+    GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
+    return texName
+
+-- | Ensure this label can be a valid filename
+cleanLabel :: String -> String
+cleanLabel =
+    scrunch .
+    map (\c -> if (c >= 'a' && c <= 'z') ||
+                  (c >= 'A' && c <= 'Z') ||
+                  (c >= '0' && c <= '9') then c else '_')
+  where
+    scrunch ('_':'_':cs) = scrunch ('_':cs)
+    scrunch (c:cs) = c:scrunch cs
+    scrunch [] = []
+
diff --git a/examples/poodle/poodle.hs b/examples/poodle/poodle.hs
new file mode 100644
--- /dev/null
+++ b/examples/poodle/poodle.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE DoRec, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
+-- Package dependencies:
+--     random
+--     stb-image
+--     OpenGL
+--     GLUT
+import FRP.Sodium
+import Control.Applicative
+import Control.Monad.Trans
+import Data.Maybe
+import Data.Typeable
+import Engine
+import System.Random
+
+poodleSprite :: Point -> Sprite
+poodleSprite pt = ((pt,(120,120)), "poodle.png")
+
+-- | Active poodle logic (which could be made much more interesting).
+poodle :: Typeable p =>
+          PoodleID
+       -> Point
+       -> Event p MouseEvent
+       -> Behaviour p Double
+       -> Reactive p (Behaviour p (PoodleID, Sprite))
+poodle iD pos@(x0,y0) eMouse time = do
+    t0 <- sample time
+    let dt = subtract t0 <$> time
+        bounce dt =
+            let t = snd $ properFraction dt
+            in  800 * t + (-800) * t^2
+        sprite = (\dt -> (iD, poodleSprite (x0, y0 + bounce dt))) <$> dt
+    return sprite
+
+-- | Peel a new item off the list each time the event fires.
+peelList :: Typeable p => Event p x -> [a] -> Reactive p (Behaviour p a)
+peelList ev xs0 =
+    hold (head xs0)
+            =<< collectE (\_ (x:xs) -> (x, xs)) (tail xs0) ev
+
+-- | Generate events at random intervals.
+randomTimes :: Typeable p => StdGen -> Behaviour p Double -> Reactive p (Event p Double)
+randomTimes rng time = do
+    -- Infinite list of random intervals from 0.25 to 1.2 seconds.
+    let intervals = randomRs (0.25, 1.2) rng
+    rec
+        tLast <- hold 0 eAppear
+        interval <- peelList eAppear intervals
+        let eTime = valueEvent time
+            eAppear = justE $ attachWith (\t (tLast, interval) ->
+                    if t >= tLast + interval then Just t else Nothing
+                ) eTime ((,) <$> tLast <*> interval)
+    return eAppear
+
+newtype PoodleID = PoodleID Int deriving (Eq, Enum, Show)
+data Action p = Create PoodleID (Behaviour p (PoodleID, Sprite)) | Destroy PoodleID
+
+poodleGame :: forall p . Typeable p => StdGen -> Game p
+poodleGame rng eMouse time = do
+
+    -- Random times for appearance of new poodles
+    let (rng1, rng2_) = split rng
+        (rng2, rng3) = split rng2_
+    eAppear <- do
+        randomTimes rng1 time
+
+    -- Pick a position for each new poodle
+    eNewPosition <- do
+        -- Infinite list of random poodle positions
+        let xs = randomRs (-900, 900) rng2
+            ys = randomRs (-900, 500) rng3
+        let idsAndPoses = zip [PoodleID 1..] (zip xs ys)
+        -- Peel an item off the list for each new poodle
+        collectE (\_ ((iD, pos):xs) -> ((iD, pos), xs)) idsAndPoses eAppear
+
+    -- Construct a new active poodle for each new position
+    let eCreations = execute $ (\(iD, pos) -> do
+                beh <- poodle iD pos eMouse time
+                return $ Create iD beh
+            ) <$> eNewPosition
+
+    rec
+        -- Destroy poodles that are clicked on
+        let eDestructions = justE $ attachWith (\mev poodles ->
+                    case mev of
+                        MouseDown clickPos -> listToMaybe
+                            [ Destroy iD | (iD, (rect, _)) <- poodles,
+                                   clickPos `inside` rect]
+                        _ -> Nothing
+                ) eMouse poodles
+
+        -- Handle creations and destructions giving a behaviour containing a
+        -- list of poodle behaviours.
+        poodleBehs <- hold [] =<< collectE (\change poodles ->
+                let poodles' = case change of
+                        Create iD beh -> (iD, beh) : poodles
+                        Destroy iD    -> filter (\(thisID, _) -> iD /= thisID) poodles
+                in  (map snd poodles', poodles')
+            ) [] (eCreations `merge` eDestructions)
+
+        -- Convert list of behaviours into a behaviour containing a list,
+        -- then flatten behaviour within behaviour down to a single behaviour of
+        -- poodle sprites.
+        poodles <- switch $ foldr (\ba bt -> (:) <$> ba <*> bt) (pure []) <$> poodleBehs
+
+    -- Return poodle sprites without their ids
+    return (map snd <$> poodles)
+
+main = do
+    rng <- newStdGen
+    runGame "Poodle invasion - click the poodles to keep them under control" (poodleGame rng)
+
diff --git a/examples/poodle/poodle.png b/examples/poodle/poodle.png
new file mode 100644
Binary files /dev/null and b/examples/poodle/poodle.png differ
diff --git a/examples/tests.hs b/examples/tests.hs
new file mode 100644
--- /dev/null
+++ b/examples/tests.hs
@@ -0,0 +1,390 @@
+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, EmptyDataDecls #-}
+import FRP.Sodium
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans
+import Data.Char
+import Data.IORef
+import Data.Typeable
+import Test.HUnit
+
+data M deriving Typeable  -- Define a main partition
+data N deriving Typeable  -- Define a secondary partition
+
+event1 = TestCase $ do
+    (ev :: Event M Char, push) <- newEvent
+    outRef <- newIORef ""
+    synchronously $ do
+        push '?'
+    unlisten <- synchronously $ do
+        push 'h'
+        push 'e'
+        unlisten <- listenIO ev $ \letter -> modifyIORef outRef (++ [letter]) 
+        push 'l'
+        return unlisten
+    synchronously $ do
+        push 'l'
+        push 'o'
+    unlisten
+    synchronously $ do
+        push '!'
+    out <- readIORef outRef
+    assertEqual "event1" "hello" =<< readIORef outRef
+
+fmap1 = TestCase $ do
+    (ev :: Event M Char, push) <- newEvent
+    outRef <- newIORef ""
+    synchronously $ do
+        listenIO (toUpper `fmap` ev) $ \letter -> modifyIORef outRef (++ [letter])
+        push 'h'
+        push 'e'
+        push 'l'
+        push 'l'
+        push 'o'
+    out <- readIORef outRef
+    assertEqual "fmap1" "HELLO" =<< readIORef outRef
+
+merge1 = TestCase $ do
+    (ev1 :: Event M String, push1) <- newEvent
+    (ev2, push2) <- newEvent
+    let ev = merge ev1 ev2
+    outRef <- newIORef []
+    unlisten <- synchronously $ listenIO ev $ \a -> modifyIORef outRef (++ [a])
+    synchronously $ do
+        push1 "hello"
+        push2 "world"
+    synchronously $ push1 "people"
+    synchronously $ push1 "everywhere"
+    unlisten
+    assertEqual "merge1" ["hello","world","people","everywhere"] =<< readIORef outRef
+
+justE1 = TestCase $ do
+    (ema :: Event M (Maybe String), push) <- newEvent
+    outRef <- newIORef []
+    synchronously $ do
+        listenIO (justE ema) $ \a -> modifyIORef outRef (++ [a])
+        push (Just "yes")
+        push Nothing
+        push (Just "no")
+    assertEqual "justE1" ["yes", "no"] =<< readIORef outRef
+
+filterE1 = TestCase $ do
+    (ec, push) <- newEvent
+    outRef <- newIORef ""
+    synchronously $ do
+        let ed = filterE isDigit (ec :: Event M Char)
+        listenIO ed $ \a -> modifyIORef outRef (++ [a])
+        push 'a'
+        push '2'
+        push 'X'
+        push '3'
+    assertEqual "filterE1" "23" =<< readIORef outRef
+
+beh1 = TestCase $ do
+    (ea :: Event M String, push) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        beh <- hold "init" ea
+        listenValueIO beh $ \a -> modifyIORef outRef (++ [a])
+    synchronously $ do
+        push "next"
+    unlisten
+    assertEqual "beh1" ["init", "next"] =<< readIORef outRef
+
+beh2 = TestCase $ do
+    (ea :: Event M String, push) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        beh <- hold "init" ea
+        listenValueIO beh $ \a -> modifyIORef outRef (++ [a])
+    unlisten
+    synchronously $ do
+        push "next"
+    assertEqual "beh2" ["init"] =<< readIORef outRef
+
+beh3 = TestCase $ do
+    (ea :: Event M String, push) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        beh <- hold "init" ea
+        listenValueIO beh $ \a -> modifyIORef outRef (++ [a])
+    synchronously $ do
+        push "first"
+        push "second"
+    unlisten
+    assertEqual "beh3" ["init", "second"] =<< readIORef outRef
+
+-- | This demonstrates the fact that if there are multiple updates to a behaviour
+-- in a given transaction, the second one prevails.
+beh4 = TestCase $ do
+    (ea :: Event M String, push) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        beh <- hold "init" ea
+        unlisten <- listenValueIO beh $ \a -> modifyIORef outRef (++ [a])
+        push "other"
+        return unlisten
+    synchronously $ do
+        push "first"
+        push "second"
+    unlisten
+    assertEqual "beh4" ["other", "second"] =<< readIORef outRef
+
+beh5 = TestCase $ do
+    (ea :: Event M String, push) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        beh <- hold "init" ea
+        unlisten <- listenIO (valueEvent beh) $ \a -> modifyIORef outRef (++ [a])
+        push "other"
+        return unlisten
+    synchronously $ do
+        push "first"
+        push "second"
+    unlisten
+    assertEqual "beh5" ["other", "second"] =<< readIORef outRef
+
+beh6 = TestCase $ do
+    (ea :: Event M String, push) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        beh <- hold "init" ea
+        unlisten <- listenIO (map toUpper <$> valueEvent beh) $ \a -> modifyIORef outRef (++ [a])
+        push "other"
+        return unlisten
+    synchronously $ do
+        push "first"
+        push "second"
+    unlisten
+    assertEqual "beh6" ["OTHER", "SECOND"] =<< readIORef outRef
+
+appl1 = TestCase $ do
+    (ea :: Event M Int, pusha) <- newEvent
+    ba <- synchronously $ hold 0 ea
+    (eb, pushb) <- newEvent
+    bb <- synchronously $ hold 0 eb
+    let esum = (+) <$> ba <*> bb
+    outRef <- newIORef []
+    unlisten <- synchronously $ listenValueIO esum $ \sum -> modifyIORef outRef (++ [sum])
+    synchronously $ pusha 5
+    synchronously $ pushb 100
+    synchronously $ pusha 10 >> pushb 200
+    unlisten
+    assertEqual "appl1" [0, 5, 105, 210] =<< readIORef outRef
+
+appl2 = TestCase $ do  -- variant that uses listenIO (valueEvent esum) instead of listenValueIO
+    (ea :: Event M Int, pusha) <- newEvent
+    ba <- synchronously $ hold 0 ea
+    (eb, pushb) <- newEvent
+    bb <- synchronously $ hold 0 eb
+    let esum = (+) <$> ba <*> bb
+    outRef <- newIORef []
+    unlisten <- synchronously $ listenIO (valueEvent esum) $ \sum -> modifyIORef outRef (++ [sum])
+    synchronously $ pusha 5
+    synchronously $ pushb 100
+    synchronously $ pusha 10 >> pushb 200
+    unlisten
+    assertEqual "appl2" [0, 5, 105, 210] =<< readIORef outRef
+    
+attach1 = TestCase $ do
+    (ea :: Event M Char, pusha) <- newEvent
+    (eb :: Event M Int, pushb) <- newEvent
+    bb <- synchronously $ hold 0 eb
+    let ec = attach ea bb
+    outRef <- newIORef []
+    unlisten <- synchronously $ listenIO ec $ \c -> modifyIORef outRef (++ [c])
+    synchronously $ pusha 'A'
+    synchronously $ pushb 50
+    synchronously $ pusha 'B'
+    synchronously $ pusha 'C' >> pushb 60
+    synchronously $ pusha 'D'
+    unlisten
+    assertEqual "attach1" [('A',0),('B',50),('C',50),('D',60)] =<< readIORef outRef
+
+count1 = TestCase $ do
+    (ea :: Event M (), push) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        eCount <- countE ea
+        listenIO eCount $ \c -> modifyIORef outRef (++ [c])
+    synchronously $ push ()
+    synchronously $ push ()
+    synchronously $ push ()
+    unlisten
+    assertEqual "count1" [1,2,3] =<< readIORef outRef
+
+collect1 = TestCase $ do
+    (ea :: Event M Int, push) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        ba <- hold 100 ea
+        sum <- collect (\a s -> (a+s, a+s)) 0 ba
+        listenValueIO sum $ \sum -> modifyIORef outRef (++ [sum])
+    synchronously $ push 5
+    synchronously $ push 7
+    synchronously $ push 1
+    synchronously $ push 2
+    synchronously $ push 3
+    unlisten
+    assertEqual "collect1" [100, 105, 112, 113, 115, 118] =<< readIORef outRef
+
+collect2 = TestCase $ do
+    (ea :: Event M Int, push) <- newEvent
+    outRef <- newIORef []
+    -- This behaviour is a little bit odd but difficult to fix in the
+    -- implementation. However, it shouldn't be too much of a problem in
+    -- practice. Here we are defining it.
+    unlisten <- synchronously $ do
+        ba <- hold 100 ea
+        sum <- collect (\a s -> (a + s, a + s)) 0 ba
+        push 5
+        listenValueIO sum $ \sum -> modifyIORef outRef (++ [sum])
+    synchronously $ push 7
+    synchronously $ push 1
+    unlisten
+    assertEqual "collect2" [105, 112, 113] =<< readIORef outRef
+
+collectE1 = TestCase $ do
+    (ea :: Event M Int, push) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        sum <- collectE (\a s -> (a+s, a+s)) 100 ea
+        listenIO sum $ \sum -> modifyIORef outRef (++ [sum])
+    synchronously $ push 5
+    synchronously $ push 7
+    synchronously $ push 1
+    synchronously $ push 2
+    synchronously $ push 3
+    unlisten
+    assertEqual "collectE1" [105, 112, 113, 115, 118] =<< readIORef outRef
+
+collectE2 = TestCase $ do
+    (ea :: Event M Int, push) <- newEvent
+    outRef <- newIORef []
+    -- This behaviour is a little bit odd but difficult to fix in the
+    -- implementation. However, it shouldn't be too much of a problem in
+    -- practice. Here we are defining it.
+    unlisten <- synchronously $ do
+        sum <- collectE (\a s -> (a + s, a + s)) 100 ea
+        push 5
+        listenIO sum $ \sum -> modifyIORef outRef (++ [sum])
+    synchronously $ push 7
+    synchronously $ push 1
+    unlisten
+    assertEqual "collectE2" [105, 112, 113] =<< readIORef outRef
+
+switchE1 = TestCase $ do
+    (ea :: Event M Char, pusha) <- newEvent
+    (eb :: Event M Char, pushb) <- newEvent
+    (esw :: Event M (Event M Char), pushsw) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        sw <- hold ea esw
+        let eo = switchE sw
+        unlisten <- listenIO eo $ \o -> modifyIORef outRef (++ [o])
+        pusha 'A'
+        pushb 'a'
+        return unlisten
+    synchronously $ pusha 'B' >> pushb 'b'
+    synchronously $ pushsw eb >> pusha 'C' >> pushb 'c'
+    synchronously $ pusha 'D' >> pushb 'd'
+    synchronously $ pusha 'E' >> pushb 'e' >> pushsw ea
+    synchronously $ pusha 'F' >> pushb 'f'
+    synchronously $ pusha 'G' >> pushb 'g' >> pushsw eb
+    synchronously $ pusha 'H' >> pushb 'h' >> pushsw ea
+    synchronously $ pusha 'I' >> pushb 'i' >> pushsw ea
+    unlisten
+    assertEqual "switchE1" "ABCdeFGhI" =<< readIORef outRef
+
+switch1 = TestCase $ do
+    (ea :: Event M Char, pusha) <- newEvent
+    (eb :: Event M Char, pushb) <- newEvent
+    (esw :: Event M (Behaviour M Char), pushsw) <- newEvent
+    outRef <- newIORef []
+    (ba, bb, unlisten) <- synchronously $ do
+        ba <- hold 'A' ea
+        bb <- hold 'a' eb
+        bsw <- hold ba esw
+        bo <- switch bsw
+        unlisten <- listenValueIO bo $ \o -> modifyIORef outRef (++ [o])
+        return (ba, bb, unlisten)
+    synchronously $ pusha 'B' >> pushb 'b'
+    synchronously $ pushsw bb >> pusha 'C' >> pushb 'c'
+    synchronously $ pusha 'D' >> pushb 'd'
+    synchronously $ pusha 'E' >> pushb 'e' >> pushsw ba
+    synchronously $ pusha 'F' >> pushb 'f'
+    synchronously $ pushsw bb
+    synchronously $ pushsw ba
+    synchronously $ pusha 'G' >> pushb 'g' >> pushsw bb
+    synchronously $ pusha 'H' >> pushb 'h' >> pushsw ba
+    synchronously $ pusha 'I' >> pushb 'i' >> pushsw ba
+    unlisten
+    assertEqual "switch1" "ABcdEFfFgHI" =<< readIORef outRef
+    
+once1 = TestCase $ do
+    (ea :: Event M Char, pusha) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        oea <- once ea
+        listenIO oea $ \a -> modifyIORef outRef (++ [a])
+    synchronously $ pusha 'A'
+    synchronously $ pusha 'B'
+    synchronously $ pusha 'C'
+    unlisten
+    assertEqual "switch1" "A" =<< readIORef outRef
+
+once2 = TestCase $ do
+    (ea :: Event M Char, pusha) <- newEvent
+    outRef <- newIORef []
+    unlisten <- synchronously $ do
+        oea <- once ea
+        pusha 'A'
+        listenIO oea $ \a -> modifyIORef outRef (++ [a])
+    synchronously $ pusha 'B'
+    synchronously $ pusha 'C'
+    unlisten
+    assertEqual "switch1" "A" =<< readIORef outRef
+
+crossE1 = TestCase $ do
+    outRef <- newIORef []
+    (ema :: Event M Char, push) <- newEvent
+    (ena :: Event N Char) <- synchronously $ crossE ema
+    unlisten <- synchronously $ listenIO ena $ \a -> modifyIORef outRef (++ [a])
+    synchronously $ push 'A'
+    synchronously $ push 'M'
+    synchronously $ push 'T'
+    unlisten
+    assertEqual "crossE1" "AMT" =<< readIORef outRef
+
+cross1 = TestCase $ do
+    outRef <- newIORef []
+    (ema :: Event M Char, push) <- newEvent
+    bma <- synchronously $ hold 'A' ema
+    synchronously $ push 'B'
+    (bna :: Behaviour N Char) <- synchronously $ cross bma
+    unlisten <- synchronously $ listenValueIO bna $ \a -> modifyIORef outRef (++ [a])
+    synchronously $ push 'C'
+    synchronously $ push 'D'
+    synchronously $ push 'E'
+    unlisten
+    assertEqual "cross1" "BCDE" =<< readIORef outRef
+
+cross2 = TestCase $ do
+    outRef <- newIORef []
+    (ema :: Event M Char, push) <- newEvent
+    bma <- synchronously $ hold 'A' ema
+    (bna :: Behaviour N Char) <- synchronously $ cross bma
+    unlisten <- synchronously $ listenValueIO bna $ \a -> modifyIORef outRef (++ [a])
+    synchronously $ push 'B'
+    synchronously $ push 'C'
+    synchronously $ push 'D'
+    synchronously $ push 'E'
+    unlisten
+    assertEqual "cross1" "ABCDE" =<< readIORef outRef
+
+tests = test [ event1, fmap1, merge1, justE1, filterE1, beh1, beh2, beh3, beh4, beh5, beh6,
+    appl1, appl2, attach1, count1, collect1, collect2, collectE1, collectE2, switchE1,
+    switch1, once1, once2, crossE1, cross1, cross2 ]
+
+main = {-forever $-} runTestTT tests
+
diff --git a/sodium.cabal b/sodium.cabal
new file mode 100644
--- /dev/null
+++ b/sodium.cabal
@@ -0,0 +1,41 @@
+name:                sodium
+version:             0.1.0.0
+synopsis:            Sodium Reactive Programming (FRP) System
+description:         
+  A general purpose Reactive Programming (FRP) system intended for \'industrial strength\'
+  applications. It's a translation of a C++ implementation used for data acquisition, so
+  the design, at least, has had some real-world testing.
+  .
+   * Applicative style: Event implements Functor and Behaviour implements Applicative.
+  .
+   * FRP logic is tied to partitions, within which consistency is guaranteed.
+     This allows you to selectively relax consistency guarantees to facilitate parallelism.
+  .
+   * Instead of the common approach where inputs are fed into the front of a monolithic
+     \'reactimate\', Sodium allows you to push inputs in from scattered places in IO.
+  .
+   * Integration with IO: Extensible to provide lots of scope for lifting IO into FRP
+     logic.
+  .
+   * Push-based imperative implementation.
+license:             BSD3
+license-file:        LICENSE
+author:              Stephen Blackheath
+maintainer:          http://blacksapphire.com/antispam/
+copyright:           (c) Stephen Blackheath 2012
+category:            FRP
+build-type:          Simple
+cabal-version:       >=1.8
+extra-source-files:  examples/tests.hs
+                     examples/poodle/poodle.hs
+                     examples/poodle/Engine.hs
+                     examples/poodle/Image.hs
+                     examples/poodle/poodle.png
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     FRP.Sodium, FRP.Sodium.Internal
+  other-modules:       FRP.Sodium.Impl       
+  build-depends:       base >= 4.3.0.0 && < 4.6.0.0,
+                       containers >= 0.4.0.0 && < 0.5.0.0,
+                       mtl >= 2.0.0.0 && < 2.1.0.0
diff --git a/src/FRP/Sodium.hs b/src/FRP/Sodium.hs
new file mode 100644
--- /dev/null
+++ b/src/FRP/Sodium.hs
@@ -0,0 +1,78 @@
+-- | Sodium Reactive Programming (FRP) system.
+--
+-- The @p@ type parameter determines the /partition/ that your FRP is running
+-- on. A thread is automatically created for each partition used in the system based
+-- on the unique concrete p type, which must be an instance of Typeable. FRP
+-- processing runs on this thread, but 'synchronously' will block the calling thread
+-- while it waits for FRP processing to complete.
+--
+-- The 'cross' and 'crossE' functions are used to move events and behaviours between
+-- partitions. The separation thus created allows your FRP logic to be partitioned
+-- so that the different partitions can run in parallel, with more relaxed guarantees
+-- of consistency between partitions.
+--
+-- Some functions are pure, and others need to run under the 'Reactive' monad via
+-- 'synchronously' or 'asynchronously'.
+--
+-- In addition to the functions supplied here, note that you can use
+--
+--   * Functor on 'Event' and 'Behaviour'
+--
+--   * Applicative on 'behaviour', e.g. @let bsum = (+) \<$\> ba \<*\> bb@
+--
+--   * Applicative 'pure' is used to give a constant 'Behaviour'.
+--
+--   * Recursive do (via DoRec) to make state loops with the @rec@ keyword.
+--
+-- Here's an example of recursive do to write state-keeping loops. Note that
+-- attachWith will capture the /old/ value of the state /s/.
+--
+-- > {-# LANGUAGE DoRec #-}
+-- > -- | Accumulate on input event, outputting the new state each time.
+-- > accumE :: (a -> s -> s) -> s -> Event p a -> Reactive p (Event p s) 
+-- > accumE f z ea = do
+-- >     rec
+-- >         let es = attachWith f ea s
+-- >         s <- hold z es
+-- >     return es
+module FRP.Sodium (
+        -- * Running FRP code
+        Reactive,
+        synchronously,
+        asynchronously,
+        newEvent,
+        listen,
+        listenIO,
+        listenValue,
+        listenValueIO,
+        -- * FRP language
+        Event,
+        never,
+        merge,
+        justE,
+        filterE,
+        Behaviour,
+        Behavior,
+        hold,
+        valueEvent,
+        attachWith,
+        attach,
+        tag,
+        gate,
+        collectE,
+        collect,
+        accumE,
+        countE,
+        count,
+        switchE,
+        switch,
+        once,
+        execute,
+        sample,
+        -- * Partitions
+        crossE,
+        cross
+    ) where
+
+import FRP.Sodium.Impl
+
diff --git a/src/FRP/Sodium/Impl.hs b/src/FRP/Sodium/Impl.hs
new file mode 100644
--- /dev/null
+++ b/src/FRP/Sodium/Impl.hs
@@ -0,0 +1,652 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DoRec #-}
+{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}
+module FRP.Sodium.Impl where
+
+-- Note: the 'full-laziness' optimization messes up finalizers, so we're
+-- disabling it. It'd be nice to find a really robust solution to this.
+-- -fno-cse just in case, since we're using unsafePerformIO.
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Concurrent.Chan
+import Control.Concurrent.MVar
+import Control.Exception (evaluate)
+import Control.Monad
+import Control.Monad.State.Strict
+import Control.Monad.Trans
+import Data.Int
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Sequence (Seq, (|>))
+import qualified Data.Sequence as Seq
+import Data.Typeable
+import GHC.Exts
+import System.Mem.Weak
+import System.IO.Unsafe
+import Unsafe.Coerce
+
+type ID = Int64
+
+data ReactiveState p = ReactiveState {
+        asQueue1 :: Seq (Reactive p ()),
+        asQueue2 :: Map Int64 (Reactive p ()),
+        asFinal  :: IO ()
+    }
+
+newtype Reactive p a = Reactive (StateT (ReactiveState p) IO a)
+    deriving (Functor, Applicative, Monad, MonadFix)
+    
+ioReactive :: IO a -> Reactive p a
+ioReactive io = Reactive $ liftIO io
+
+newtype NodeID = NodeID Int deriving (Eq, Ord, Enum)
+
+data Partition p = Partition {
+        paRun        :: Reactive p () -> IO () -> IO (),
+        paNextNodeID :: IORef NodeID
+    }
+
+-- | Queue the specified atomic to run at the end of the priority 1 queue
+schedulePriority1 :: Reactive p () -> Reactive p ()
+schedulePriority1 task = Reactive $ modify $ \as -> as { asQueue1 = asQueue1 as |> task }
+
+-- | Queue the specified atomic to run at the end of the priority 2 queue
+schedulePriority2 :: Int64 -> Reactive p () -> Reactive p ()
+schedulePriority2 priority task = Reactive $ modify $ \as -> as {
+        asQueue2 = M.alter (\mOldTask -> Just $ case mOldTask of
+                Just oldTask -> oldTask >> task
+                Nothing      -> task) priority (asQueue2 as)
+    }
+
+onFinal :: IO () -> Reactive p ()
+onFinal task = Reactive $ modify $ \as -> as { asFinal = asFinal as >> task }
+
+partitionRegistry :: MVar (Map String Any)
+{-# NOINLINE partitionRegistry #-}
+partitionRegistry = unsafePerformIO $ newMVar M.empty
+
+-- | Get the globally unique partition handle for this partition type.
+partition :: forall p . Typeable p => IO (Partition p)
+partition = do
+    let typ = show $ typeOf (undefined :: p)
+    modifyMVar partitionRegistry $ \reg ->
+        case M.lookup typ reg of
+            Just part -> return (reg, unsafeCoerce part)
+            Nothing   -> do
+                part <- createPartition
+                return (M.insert typ (unsafeCoerce part) reg, part)
+
+createPartition :: IO (Partition p)
+createPartition = do
+    ch <- newChan
+    forkIO $ forever $ do
+        (task, onCompletion) <- readChan ch
+        let loop = do
+                queue1 <- gets asQueue1
+                if not $ Seq.null queue1 then do
+                    let Reactive task = Seq.index queue1 0
+                    modify $ \as -> as { asQueue1 = Seq.drop 1 queue1 }
+                    task
+                    loop
+                  else do
+                    queue2 <- gets asQueue2
+                    if not $ M.null queue2 then do
+                        let (k, Reactive task) = M.findMin queue2
+                        modify $ \as -> as { asQueue2 = M.delete k queue2 }
+                        task
+                        loop
+                      else do
+                        final <- gets asFinal
+                        liftIO final
+                        return ()
+        runStateT loop $ ReactiveState {
+                asQueue1 = Seq.singleton task,
+                asQueue2 = M.empty,
+                asFinal = return ()
+            }
+        onCompletion
+
+    nextNodeIDRef <- newIORef (NodeID 0)
+    return $ Partition {
+            paRun = \task onCompletion -> writeChan ch (task, onCompletion),
+            paNextNodeID = nextNodeIDRef
+        }
+
+-- | Fire an FRP transaction off without waiting for it to complete. It will be queued
+-- for executing on the FRP thread for the selected partition.
+asynchronously :: Typeable p => Reactive p () -> IO ()
+asynchronously task = do
+    part <- partition
+    paRun part task (return ())
+
+-- | Run the specified FRP transaction, blocking the caller until all resulting
+-- processing is complete and all callbacks have been called.
+synchronously :: Typeable p => Reactive p a -> IO a
+synchronously task = do
+    mvOutput <- newEmptyMVar
+    mvCompleted <- newEmptyMVar
+    part <- partition
+    paRun part (task >>= ioReactive . putMVar mvOutput) (putMVar mvCompleted ())
+    takeMVar mvCompleted
+    takeMVar mvOutput
+
+data Listen p a = Listen { runListen_ :: Maybe (MVar (Node p)) -> (a -> Reactive p ()) -> Reactive p (IO ()) }
+
+runListen :: Listen p a -> Maybe (MVar (Node p)) -> (a -> Reactive p ()) -> Reactive p (IO ())
+{-# NOINLINE runListen #-}
+runListen l mv handle = do
+    o <- runListen_ l mv handle
+    _ <- ioReactive $ evaluate l
+    return o
+
+-- | A stream of events. The individual firings of events are called \'event occurrences\'.
+data Event p a = Event {  -- Must be data not newtype, because we need to attach finalizers to it
+        -- | Listen for event occurrences on this event, to be handled by the specified
+        -- handler. The returned action is used to unregister the listener.
+        getListenRaw :: Reactive p (Listen p a),
+        evCacheRef   :: IORef (Maybe (Listen p a))
+    }
+
+-- | An event that never fires.
+never :: Event p a
+never = Event {
+        getListenRaw = return $ Listen $ \_ _ -> return (return ()), 
+        evCacheRef   = unsafePerformIO $ newIORef Nothing
+    }
+
+-- | Unwrap an event's listener machinery.
+getListen :: Event p a -> Reactive p (Listen p a)
+getListen (Event getLRaw cacheRef) = do
+    mL <- ioReactive $ readIORef cacheRef
+    case mL of
+        Just l -> return l
+        Nothing -> do
+            l <- getLRaw
+            ioReactive $ writeIORef cacheRef (Just l)
+            return l
+
+-- | Listen for firings of this event. The returned @IO ()@ is an IO action
+-- that unregisters the listener. This is the observer pattern.
+linkedListen :: Event p a -> Maybe (MVar (Node p)) -> (a -> Reactive p ()) -> Reactive p (IO ())
+linkedListen ev mMvTarget handle = do
+    l <- getListen ev
+    runListen l mMvTarget handle
+
+-- | Listen for firings of this event. The returned @IO ()@ is an IO action
+-- that unregisters the listener. This is the observer pattern.
+listen :: Event p a -> (a -> Reactive p ()) -> Reactive p (IO ())
+listen ev handle = linkedListen ev Nothing handle
+
+-- | Variant of 'listen' that takes an IO action.
+listenIO :: Event p a -> (a -> IO ()) -> Reactive p (IO ())
+listenIO ev handle = listen ev (ioReactive . handle)
+
+data Observer p a = Observer {
+        obNextID    :: ID,
+        obListeners :: Map ID (a -> Reactive p ()),
+        obFirings   :: [a]
+    }
+
+data Node p = Node {
+        noID        :: NodeID,
+        noSerial    :: Int64,
+        noListeners :: Map ID (MVar (Node p))
+    }
+
+newNode :: forall p . Typeable p => IO (MVar (Node p))
+newNode = do
+    part <- partition :: IO (Partition p)
+    nodeID <- readIORef (paNextNodeID part)
+    modifyIORef (paNextNodeID part) succ
+    newMVar (Node nodeID 0 M.empty)
+
+wrap :: (Maybe (MVar (Node p)) -> (a -> Reactive p ()) -> Reactive p (IO ())) -> IO (Listen p a)
+{-# NOINLINE wrap #-}
+wrap l = return (Listen l)
+
+touch :: Listen p a -> IO ()
+{-# NOINLINE touch #-}
+touch l = evaluate l >> return ()
+
+linkNode :: MVar (Node p) -> ID -> MVar (Node p) -> IO ()
+linkNode mvNode iD mvTarget = do
+    no <- readMVar mvNode
+    ensureBiggerThan S.empty mvTarget (noSerial no)
+    modifyMVar_ mvNode $ \no -> return $
+        no { noListeners = M.insert iD mvTarget (noListeners no) }
+
+ensureBiggerThan :: Set NodeID -> MVar (Node p) -> Int64 -> IO ()
+ensureBiggerThan visited mvNode limit = do
+    no <- readMVar mvNode
+    if noID no `S.member` visited || noSerial no > limit then
+            return ()
+        else do
+            let newSerial = succ limit
+            --putStrLn $ show (noSerial no) ++ " -> " ++ show newSerial
+            modifyMVar_ mvNode $ \no -> return $ no { noSerial = newSerial }
+            forM_ (M.elems . noListeners $ no) $ \mvTarget -> do
+                ensureBiggerThan (S.insert (noID no) visited) mvTarget newSerial
+
+unlinkNode :: MVar (Node p) -> ID -> IO ()
+unlinkNode mvNode iD = do
+    modifyMVar_ mvNode $ \no -> return $
+        no { noListeners = M.delete iD (noListeners no) }
+
+-- | Returns a 'Listen' for registering listeners, and a push action for pushing
+-- a value into the event.
+newSink :: forall p a . Typeable p => IO (Listen p a, a -> Reactive p (), MVar (Node p))
+newSink = do
+    mvNode <- newNode
+    mvObs <- newMVar (Observer 0 M.empty [])
+    cacheRef <- newIORef Nothing
+    rec
+        let l mMvTarget handle = do
+                (firings, unlisten, iD) <- ioReactive $ modifyMVar mvObs $ \ob -> return $
+                    let iD = obNextID ob
+                        handle' a = handle a >> ioReactive (touch listen)
+                        ob' = ob { obNextID    = succ iD,
+                                   obListeners = M.insert iD handle' (obListeners ob) }
+                        unlisten = do
+                            modifyMVar_ mvObs $ \ob -> return $ ob {
+                                    obListeners = M.delete iD (obListeners ob)
+                                }
+                            unlinkNode mvNode iD
+                            return ()
+                    in (ob', (reverse . obFirings $ ob, unlisten, iD))
+                case mMvTarget of
+                    Just mvTarget -> ioReactive $ linkNode mvNode iD mvTarget
+                    Nothing       -> return ()
+                mapM_ handle firings
+                return unlisten
+        listen <- wrap l  -- defeat optimizer on ghc-7.0.4
+    let push a = do
+            ob <- ioReactive $ modifyMVar mvObs $ \ob -> return $
+                (ob { obFirings = a : obFirings ob }, ob)
+            -- If this is the first firing...
+            when (null (obFirings ob)) $ onFinal $ do
+                modifyMVar_ mvObs $ \ob -> return $ ob { obFirings = [] }
+            let seqa = seq a a
+            mapM_ ($ seqa) (M.elems . obListeners $ ob)
+    return (listen, push, mvNode)
+
+-- | Returns an event, and a push action for pushing a value into the event.
+newEventLinked :: Typeable p => IO (Event p a, a -> Reactive p (), MVar (Node p))
+newEventLinked = do
+    (listen, push, mvNode) <- newSink
+    cacheRef <- newIORef Nothing
+    let ev = Event {
+                getListenRaw = return listen,
+                evCacheRef = cacheRef
+            }
+    return (ev, push, mvNode)
+
+-- | Returns an event, and a push action for pushing a value into the event.
+newEvent :: Typeable p => IO (Event p a, a -> Reactive p ())
+newEvent = do
+    (ev, push, _) <- newEventLinked
+    return (ev, push)
+
+instance Functor (Event p) where
+    f `fmap` (Event getListen cacheRef) = Event getListen' cacheRef
+      where
+        cacheRef = unsafePerformIO $ newIORef Nothing
+        getListen' = do
+            return $ Listen $ \mMvNode handle -> do
+                l <- getListen
+                runListen l mMvNode (handle . f)
+
+-- | Merge two streams of events of the same type.
+merge :: Typeable p => Event p a -> Event p a -> Event p a
+merge ea eb = Event gl cacheRef
+  where
+    cacheRef = unsafePerformIO $ newIORef Nothing
+    gl = do
+        l1 <- getListen ea
+        l2 <- getListen eb
+        (l, push, mvNode) <- ioReactive newSink
+        unlisten1 <- runListen l1 (Just mvNode) push
+        unlisten2 <- runListen l2 (Just mvNode) push
+        ioReactive $ finalizeListen l $ unlisten1 >> unlisten2
+
+-- | Unwrap Just values, and discard event occurrences with Nothing values.
+justE :: Typeable p => Event p (Maybe a) -> Event p a
+justE ema = Event gl cacheRef
+  where
+    cacheRef = unsafePerformIO $ newIORef Nothing
+    gl = do
+        (l', push, mvNode) <- ioReactive newSink
+        l <- getListen ema
+        unlisten <- runListen l (Just mvNode) $ \ma -> case ma of
+            Just a -> push a
+            Nothing -> return ()
+        ioReactive $ finalizeListen l' unlisten
+
+-- | Only keep event occurrences for which the predicate is true.
+filterE :: Typeable p => (a -> Bool) -> Event p a -> Event p a
+filterE pred = justE . ((\a -> if pred a then Just a else Nothing) <$>)
+
+-- | A time-varying value, American spelling.
+type Behavior p a = Behaviour p a
+
+data Accessor p a = Accessor {
+        acSample        :: Reactive p a,
+        acListenUpdates :: (a -> Reactive p ()) -> Reactive p (IO ())
+    }
+
+-- | A time-varying value, British spelling.
+data Behaviour p a = Behaviour {
+        -- | Internal: Extract the underlyingEvent event for this behaviour.
+        underlyingEvent :: Event p a,
+        -- | Obtain the current value of a behaviour.
+        sample          :: Reactive p a
+    }
+
+instance Functor (Behaviour p) where
+    f `fmap` Behaviour underlyingEvent sample =
+        Behaviour (f `fmap` underlyingEvent) (f `fmap` sample)
+
+constant :: a -> Behaviour p a
+constant a = Behaviour {
+        underlyingEvent = never,
+        sample = return a
+    }
+
+data BehaviourState p a = BehaviourState {
+        bsCurrent :: a,
+        bsUpdate  :: Maybe a
+    }
+
+-- | Add a finalizer to an event.
+finalizeEvent :: Event p a -> IO () -> Event p a
+{-# NOINLINE finalizeEvent #-}
+finalizeEvent ea unlisten = Event gl (evCacheRef ea)
+  where
+    gl = do
+        l <- getListen ea
+        ioReactive $ finalizeListen l unlisten
+
+finalizeListen :: Listen p a -> IO () -> IO (Listen p a)
+{-# NOINLINE finalizeListen #-}
+finalizeListen l unlisten = do
+    addFinalizer l unlisten
+    return l
+
+-- | Create a behaviour with the specified initial value, that gets updated
+-- by the values coming through the event. The \'current value\' of the behaviour
+-- is notionally the value as it was 'at the start of the transaction'.
+-- That is, state updates caused by event firings get processed at the end of
+-- the transaction.
+hold :: a -> Event p a -> Reactive p (Behaviour p a)
+hold initA ea = do
+    bsRef <- ioReactive $ newIORef (BehaviourState initA Nothing)
+    unlistenRef <- ioReactive $ newMVar (Just $ return ())
+    schedulePriority1 $ do
+        mOldUnlisten <- ioReactive $ takeMVar unlistenRef
+        case mOldUnlisten of
+            Just _ -> do
+                unlisten <- listen ea $ \a -> do
+                    bs <- ioReactive $ readIORef bsRef
+                    ioReactive $ writeIORef bsRef $ bs { bsUpdate = Just a }
+                    when (isNothing (bsUpdate bs)) $ onFinal $ do
+                        bs <- readIORef bsRef
+                        let newCurrent = fromJust (bsUpdate bs)
+                            bs' = newCurrent `seq` BehaviourState newCurrent Nothing
+                        --evaluate bs'
+                        writeIORef bsRef bs'
+                ioReactive $ putMVar unlistenRef (Just unlisten)
+            Nothing ->
+                -- If the unlisten has already been executed, then don't listen at all.
+                ioReactive $ putMVar unlistenRef mOldUnlisten
+    let gl = do
+            l <- getListen ea
+            ioReactive $ finalizeListen l $ do
+                mUnlisten <- takeMVar unlistenRef
+                case mUnlisten of
+                    Just unlisten -> unlisten
+                    Nothing -> return ()
+                putMVar unlistenRef Nothing
+        beh = Behaviour {
+                underlyingEvent = Event gl (evCacheRef ea),
+                sample = ioReactive $ bsCurrent <$> readIORef bsRef
+            }
+    return beh
+
+-- | Sample the behaviour at the time of the event firing. Note that the 'current value'
+-- of the behaviour that's sampled is the value as at the start of the transaction
+-- before any state changes of the current transaction are applied through 'hold's.
+attachWith :: Typeable p => (a -> b -> c) -> Event p a -> Behaviour p b -> Event p c
+attachWith f ea bb = Event gl cacheRef
+  where
+    cacheRef = unsafePerformIO $ newIORef Nothing
+    gl = do
+        (l, push, mvNode) <- ioReactive newSink
+        unlisten <- linkedListen ea (Just mvNode) $ \a -> do
+            b <- sample bb
+            push (f a b)
+        ioReactive $ finalizeListen l unlisten
+
+-- | Variant of attachWith defined as /attachWith (,)/ 
+attach :: Typeable p => Event p a -> Behaviour p b -> Event p (a,b)
+attach = attachWith (,)
+
+-- | Variant of attachWith that throws away the event's value and captures the behaviour's.
+tag :: Typeable p => Event p a -> Behaviour p b -> Event p b
+tag = attachWith (flip const)
+
+-- | Listen to the value of this behaviour with an initial callback giving
+-- the current value. Can get multiple values per transaction, the last of
+-- which is considered valid. You would normally want to use 'listenValue',
+-- which removes the extra unwanted values.
+listenValueRaw :: Behaviour p a -> Maybe (MVar (Node p)) -> (a -> Reactive p ()) -> Reactive p (IO ())
+listenValueRaw ba mMvNode handle = do
+    a <- sample ba
+    handle a
+    linkedListen (underlyingEvent ba) mMvNode handle
+
+-- Clean up the listener so it gives only one value per transaction, specifically
+-- the last one.                
+tidy :: (Maybe (MVar (Node p)) -> (a -> Reactive p ()) -> Reactive p (IO ()))
+      -> Maybe (MVar (Node p)) -> (a -> Reactive p ()) -> Reactive p (IO ())
+tidy listen mMvNode handle = do
+    aRef <- ioReactive $ newIORef Nothing
+    listen mMvNode $ \a -> do
+        ma <- ioReactive $ readIORef aRef
+        ioReactive $ writeIORef aRef (Just a)
+        priority <- case mMvNode of
+            Just mvNode -> do
+                node <- ioReactive $ readMVar mvNode
+                return (noSerial node)
+            Nothing -> return maxBound
+        when (isNothing ma) $ schedulePriority2 priority $ do
+            Just a <- ioReactive $ readIORef aRef
+            ioReactive $ writeIORef aRef Nothing
+            handle a
+
+-- | Listen to the value of this behaviour with a guaranteed initial callback
+-- giving the current value, followed by callbacks for any updates. 
+linkedListenValue :: Behaviour p a -> Maybe (MVar (Node p)) -> (a -> Reactive p ()) -> Reactive p (IO ())
+linkedListenValue ba = tidy (listenValueRaw ba)
+
+-- | Listen to the value of this behaviour with a guaranteed initial callback
+-- giving the current value, followed by callbacks for any updates. 
+listenValue :: Behaviour p a -> (a -> Reactive p ()) -> Reactive p (IO ())
+listenValue ba = linkedListenValue ba Nothing
+
+-- | Variant of 'listenValue' that takes an IO action.
+listenValueIO :: Behaviour p a -> (a -> IO ()) -> Reactive p (IO ())
+listenValueIO ba handle = listenValue ba (ioReactive . handle)
+
+eventify :: Typeable p => (Maybe (MVar (Node p)) -> (a -> Reactive p ()) -> Reactive p (IO ())) -> Event p a
+eventify listen = Event gl cacheRef
+  where
+    cacheRef = unsafePerformIO $ newIORef Nothing
+    gl = do
+        (l, push, mvNode) <- ioReactive newSink
+        unlisten <- listen (Just mvNode) push
+        ioReactive $ finalizeListen l unlisten
+
+-- | An event that fires once for the current value of the behaviour, and then
+-- for all changes that occur after that.
+valueEvent :: Typeable p => Behaviour p a -> Event p a
+valueEvent ba = eventify (linkedListenValue ba)
+
+instance Typeable p => Applicative (Behaviour p) where
+    pure = constant
+    Behaviour u1 s1 <*> Behaviour u2 s2 = Behaviour u s
+      where
+        cacheRef = unsafePerformIO $ newIORef Nothing
+        u = Event gl cacheRef
+        gl = do
+            fRef <- ioReactive . newIORef =<< s1
+            aRef <- ioReactive . newIORef =<< s2
+            l1 <- getListen u1
+            l2 <- getListen u2
+            (l, push, mvNode) <- ioReactive newSink
+            unlisten1 <- runListen l1 (Just mvNode) $ \f -> do
+                ioReactive $ writeIORef fRef f
+                a <- ioReactive $ readIORef aRef
+                push (f a)
+            unlisten2 <- runListen l2 (Just mvNode) $ \a -> do
+                f <- ioReactive $ readIORef fRef
+                ioReactive $ writeIORef aRef a
+                push (f a)
+            ioReactive $ finalizeListen l (unlisten1 >> unlisten2)
+        s = ($) <$> s1 <*> s2
+
+-- | Let event occurrences through only when the behaviour's value is True.
+-- Note that the behaviour's value is as it was at the start of the transaction,
+-- that is, no state changes from the current transaction are taken into account.
+gate :: Typeable p => Event p a -> Behaviour p Bool -> Event p a
+gate ea = justE . attachWith (\a b -> if b then Just a else Nothing) ea
+
+-- | Transform an event with a generalized state loop (a mealy machine). The function
+-- is passed the input and the old state and returns the new state and output value.
+collectE :: Typeable p => (a -> s -> (b, s)) -> s -> Event p a -> Reactive p (Event p b)
+collectE f z ea = do
+    rec
+        let ebs = attachWith f ea s
+            eb = fst <$> ebs
+            es = snd <$> ebs
+        s <- hold z es
+    return eb
+
+-- | Transform a behaviour with a generalized state loop (a mealy machine). The function
+-- is passed the input and the old state and returns the new state and output value.
+collect :: Typeable p => (a -> s -> (b, s)) -> s -> Behaviour p a -> Reactive p (Behaviour p b)
+collect f zs bea = do
+    let ea = eventify . tidy . linkedListen $ underlyingEvent bea
+    za <- sample bea
+    let (zb, zs') = f za zs
+    rec
+        let ebs = attachWith f ea (snd <$> bs)
+        bs <- hold (zb, zs') ebs
+    return (fst <$> bs)
+
+-- | Accumulate on input event, outputting the new state each time.
+accumE :: Typeable p => (a -> s -> s) -> s -> Event p a -> Reactive p (Event p s) 
+accumE f z ea = do
+    rec
+        let es = attachWith f ea s
+        s <- hold z es
+    return es
+
+-- | Count event occurrences, starting at 0.
+countE :: Typeable p => Event p a -> Reactive p (Event p Int)
+countE = accumE (+) 0 . (const 1 <$>)
+
+-- | Count event occurrences, giving a behaviour.
+count :: Typeable p => Event p a -> Reactive p (Behaviour p Int)
+count = hold 0 <=< countE
+
+splitLessThan :: Ord k => k -> Map k a -> (Map k a, Map k a)
+splitLessThan k m =
+    let (lt, mEq, gt) = M.splitLookup k m
+    in  (lt, case mEq of
+            Just eq -> M.insert k eq gt
+            Nothing -> gt)
+
+unlistenLessThan :: IORef (Map ID (IO ())) -> ID -> IO ()
+unlistenLessThan unlistensRef iD = do
+    uls <- readIORef unlistensRef
+    let (toDelete, uls') = splitLessThan iD uls
+    do
+        writeIORef unlistensRef uls'
+        {-when (M.size toDelete > 0) $
+            putStrLn $ "deleting "++show (M.size toDelete) -}
+        forM_ (M.elems toDelete) $ \unl -> unl
+
+-- | Unwrap an event inside a behaviour to give a time-varying event implementation.
+switchE :: Typeable p => Behaviour p (Event p a) -> Event p a
+switchE bea = Event gl cacheRef
+  where
+    cacheRef = unsafePerformIO $ newIORef Nothing
+    unlistensRef = unsafePerformIO $ newIORef M.empty
+    gl = do
+        -- assign ID numbers to the incoming events
+        beaId <- collect (\ea nxtID -> ((ea, nxtID), succ nxtID)) (0 :: ID) bea
+        (l, push, mvNode) <- ioReactive newSink
+        unlisten1 <- linkedListenValue beaId (Just mvNode) $ \(ea, iD) -> do
+            let filtered = justE $ attachWith (\a activeID ->
+                        if activeID == iD
+                            then Just a
+                            else Nothing
+                    ) ea (snd <$> beaId)
+            unlisten2 <- listen filtered $ \a -> do
+                push a
+                ioReactive $ unlistenLessThan unlistensRef iD
+            ioReactive $ modifyIORef unlistensRef (M.insert iD unlisten2)
+        ioReactive $ finalizeListen l unlisten1
+
+-- | Unwrap a behaviour inside another behaviour to give a time-varying behaviour implementation.
+switch :: Typeable p => Behaviour p (Behaviour p a) -> Reactive p (Behaviour p a)
+switch bba = do
+    ba <- sample bba
+    za <- sample ba
+    (ev, push, mvNode) <- ioReactive newEventLinked
+    activeIDRef <- ioReactive $ newIORef (0 :: ID)
+    unlistensRef <- ioReactive $ newIORef M.empty
+    unlisten1 <- listenValueRaw bba (Just mvNode) $ \ba -> do
+        iD <- ioReactive $ do
+            modifyIORef activeIDRef succ
+            readIORef activeIDRef
+        unlisten2 <- listenValueRaw ba (Just mvNode) $ \a -> do
+            activeID <- ioReactive $ readIORef activeIDRef
+            when (activeID == iD) $ do
+                push a
+                ioReactive $ unlistenLessThan unlistensRef iD
+        ioReactive $ modifyIORef unlistensRef (M.insert iD unlisten2)
+    hold za (finalizeEvent ev unlisten1)
+
+-- | Throw away all event occurrences except for the first one.
+once :: Typeable p => Event p a -> Reactive p (Event p a)
+once ea = justE <$> collectE (\a active -> (if active then Just a else Nothing, False)) True ea
+
+-- | Execute the specified 'Reactive' action inside an event.
+execute :: Typeable p => Event p (Reactive p a) -> Event p a
+execute ev = Event gl cacheRef
+  where
+    cacheRef = unsafePerformIO $ newIORef Nothing
+    gl = do
+        (l', push, mvNode) <- ioReactive newSink
+        l <- getListen ev
+        unlisten <- runListen l (Just mvNode) $ \action -> action >>= push
+        ioReactive $ finalizeListen l' unlisten
+
+-- | Cross the specified event over to a different partition.
+crossE :: (Typeable p, Typeable q) => Event p a -> Reactive p (Event q a)
+crossE epa = do
+    (ev, push) <- ioReactive newEvent
+    unlisten <- listenIO epa $ synchronously . push
+    return $ finalizeEvent ev unlisten
+
+-- | Cross the specified behaviour over to a different partition.
+cross :: (Typeable p, Typeable q) => Behaviour p a -> Reactive p (Behaviour q a)
+cross bpa = do
+    a <- sample bpa
+    ea <- crossE (underlyingEvent bpa)
+    ioReactive $ synchronously $ hold a ea
+
diff --git a/src/FRP/Sodium/Internal.hs b/src/FRP/Sodium/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/FRP/Sodium/Internal.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DoRec #-}
+{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}
+module FRP.Sodium.Internal (
+        Event(..),
+        Behaviour(..),
+        schedulePriority1,
+        schedulePriority2,
+        Listen(..),
+        getListen,
+        linkedListen,
+        Node,
+        newEventLinked,
+        newSink,
+        finalizeEvent,
+        ioReactive
+    ) where
+
+import FRP.Sodium.Impl
+