sodium (empty) → 0.1.0.0
raw patch · 11 files changed
+1637/−0 lines, 11 filesdep +basedep +containersdep +mtlsetup-changedbinary-added
Dependencies added: base, containers, mtl
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- examples/poodle/Engine.hs +180/−0
- examples/poodle/Image.hs +134/−0
- examples/poodle/poodle.hs +111/−0
- examples/poodle/poodle.png binary
- examples/tests.hs +390/−0
- sodium.cabal +41/−0
- src/FRP/Sodium.hs +78/−0
- src/FRP/Sodium/Impl.hs +652/−0
- src/FRP/Sodium/Internal.hs +19/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/poodle/Engine.hs view
@@ -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
+ examples/poodle/Image.hs view
@@ -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 [] = []+
+ examples/poodle/poodle.hs view
@@ -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)+
+ examples/poodle/poodle.png view
binary file changed (absent → 148345 bytes)
+ examples/tests.hs view
@@ -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+
+ sodium.cabal view
@@ -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
+ src/FRP/Sodium.hs view
@@ -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+
+ src/FRP/Sodium/Impl.hs view
@@ -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+
+ src/FRP/Sodium/Internal.hs view
@@ -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+