diff --git a/examples/games/poodle.hs b/examples/games/poodle.hs --- a/examples/games/poodle.hs +++ b/examples/games/poodle.hs @@ -4,7 +4,7 @@ -- stb-image -- OpenGL -- GLUT -import FRP.Sodium +import FRP.Sodium hiding (split) import Control.Applicative import Control.Monad.Trans import Data.Maybe diff --git a/examples/tests/unit-tests.hs b/examples/tests/unit-tests.hs --- a/examples/tests/unit-tests.hs +++ b/examples/tests/unit-tests.hs @@ -526,12 +526,36 @@ unlisten assertEqual "coalesce1" [2, 11] =<< readIORef outRef +split1 = TestCase $ do + outRef <- newIORef [] + (ea, pushA) <- sync newEvent + let ewords = coalesce (++) $ split $ words <$> ea + unlisten <- sync $ listen ewords $ \o -> modifyIORef outRef (++ [o]) + sync $ pushA "the common cormorant" + sync $ pushA "or shag" + unlisten + assertEqual "split1" ["the","common","cormorant","or","shag"] =<< readIORef outRef + +split2 = TestCase $ do + outRef <- newIORef [] + (ea, pushA) <- sync newEvent + let halve [] = [] + halve [_] = [] + halve str = [take (length str `div` 2) str, + drop (length str `div` 2) str] + ehalves = split $ (halve <$> ea) `merge` (halve <$> ehalves) + unlisten <- sync $ listen ehalves $ \o -> modifyIORef outRef (++ [o]) + sync $ pushA "abcdefgh" + unlisten + assertEqual "split2" ["abcd","ab","a","b","cd","c","d", + "efgh","ef","e","f","gh","g","h"] =<< readIORef outRef + tests = test [ event1, fmap1, merge1, filterJust1, filterE1, gate1, beh1, beh2, beh3, beh4, beh5, behConstant, valuesThenMap, valuesTwiceThenMap, valuesThenCoalesce, valuesTwiceThenCoalesce, valuesThenSnapshot, valuesTwiceThenSnapshot, valuesThenMerge, valuesThenFilter, valuesTwiceThenFilter, valuesThenOnce, valuesTwiceThenOnce, valuesLateListen, holdIsDelayed, appl1, snapshot1, count1, collect1, collect2, collectE1, collectE2, switchE1, - switch1, once1, once2, cycle1{-, mergeWith1, mergeWith2, mergeWith3, + switch1, once1, once2, cycle1, split1, split2 {-, mergeWith1, mergeWith2, mergeWith3, coalesce1-} ] main = {-forever $ -} runTestTT tests diff --git a/sodium.cabal b/sodium.cabal --- a/sodium.cabal +++ b/sodium.cabal @@ -1,5 +1,5 @@ name: sodium -version: 0.6.0.2 +version: 0.7.0.0 synopsis: Sodium Reactive Programming (FRP) System description: A general purpose Reactive Programming (FRP) system. This is part of a project to @@ -20,15 +20,28 @@ . See the /examples/ directory for test cases and examples. . - Changes: 0.2.0.0 Fix some value recursion deadlocks and improve docs; - 0.3.0.0 Add mergeWith, make cross asynchronous; - 0.4.0.0 API revamp to remove an excess type variable. Parallelism stuff to be rethought; - 0.5.0.0 Improved tests cases + add Freecell example, API tweaks; - 0.5.0.1 Internal improvements; - 0.5.0.2 Fix multiple memory leaks; - 0.6 Minor API changes, particular with accum; - 0.6.0.1 ghc-7.8 compatibility; - 0.6.0.2 Fix memory leak - see memory-test-8 & memory-test-8a. + Changes: + . + * 0.2.0.0 - Fix some value recursion deadlocks and improve docs; + . + * 0.3.0.0 - Add mergeWith, make cross asynchronous; + . + * 0.4.0.0 - API revamp to remove an excess type variable. Parallelism stuff to be rethought; + . + * 0.5.0.0 - Improved tests cases + add Freecell example, API tweaks; + . + * 0.5.0.1 - Internal improvements; + . + * 0.5.0.2 - Fix multiple memory leaks; + . + * 0.6 - Minor API changes, particular with accum; + . + * 0.6.0.1 - ghc-7.8 compatibility; + . + * 0.6.0.2 - Fix memory leak - see memory-test-8 & memory-test-8a; + . + * 0.7.0.0 - Add split primitive. + license: BSD3 license-file: LICENSE author: Stephen Blackheath diff --git a/src/FRP/Sodium.hs b/src/FRP/Sodium.hs --- a/src/FRP/Sodium.hs +++ b/src/FRP/Sodium.hs @@ -55,6 +55,7 @@ sample, coalesce, once, + split, -- * Derived FRP functions mergeWith, filterE, diff --git a/src/FRP/Sodium/Context.hs b/src/FRP/Sodium/Context.hs --- a/src/FRP/Sodium/Context.hs +++ b/src/FRP/Sodium/Context.hs @@ -82,6 +82,12 @@ coalesce :: (a -> a -> a) -> Event r a -> Event r a -- | Throw away all event occurrences except for the first one. once :: Context r => Event r a -> Event r a + -- | Take each list item and put it into a new transaction of its own. + -- + -- An example use case of this might be a situation where we are splitting + -- a block of input data into frames. We obviously want each frame to have + -- its own transaction so that state is updated separately each frame. + split :: Event r [a] -> Event r a -- | A time-varying value, British spelling. type Behaviour r a = Behavior r a diff --git a/src/FRP/Sodium/Plain.hs b/src/FRP/Sodium/Plain.hs --- a/src/FRP/Sodium/Plain.hs +++ b/src/FRP/Sodium/Plain.hs @@ -24,7 +24,7 @@ import Data.Maybe import Data.Set (Set) import qualified Data.Set as S -import Data.Sequence (Seq, (|>)) +import Data.Sequence (Seq, (|>), (><)) import qualified Data.Sequence as Seq import GHC.Exts import System.Mem.Weak @@ -126,6 +126,7 @@ sample = sample coalesce = coalesce once = once + split = split -- | An event that gives the updates for the behavior. If the behavior was created -- with 'hold', then 'changes' gives you back the event that was passed to 'hold'. @@ -164,6 +165,13 @@ loop else return () + post <- gets asPost + unless (Seq.null post) $ do + let Reactive task = post `Seq.index` 0 + modify $ \as -> as { asPost = Seq.drop 1 post } + task + loop + outVar <- newIORef undefined let lock = paLock partition putMVar lock () @@ -171,7 +179,8 @@ evalStateT loop $ ReactiveState { asQueue1 = Seq.singleton (task >>= ioReactive . writeIORef outVar), asQueue2 = q, - asFinal = Seq.empty + asFinal = Seq.empty, + asPost = Seq.empty } takeMVar lock readIORef outVar @@ -386,6 +395,21 @@ return unlisten addCleanup_Listen unlistener l +-- | Take each list item and put it into a new transaction of its own. +-- +-- An example use case of this might be a situation where we are splitting +-- a block of input data into frames. We obviously want each frame to have +-- its own transaction so that state is updated separately each frame. +split :: Event [a] -> Event a +split esa = Event gl cacheRef (dep esa) + where + cacheRef = unsafeNewIORef Nothing esa + gl = do + (l, push, nodeRef) <- ioReactive newEventImpl + unlistener <- later $ linkedListen esa (Just nodeRef) False $ \as -> + schedulePost $ map push as + addCleanup_Listen unlistener l + -- | Create a new 'Behavior' along with an action to push changes into it. -- American spelling. newBehavior :: a -- ^ Initial behavior value @@ -502,7 +526,8 @@ data ReactiveState = ReactiveState { asQueue1 :: Seq (Reactive ()), asQueue2 :: PriorityQueue (Maybe (MVar Node)) (Reactive ()), - asFinal :: Seq (Reactive ()) + asFinal :: Seq (Reactive ()), + asPost :: Seq (Reactive ()) } instance Functor (R.Reactive Plain) where @@ -541,6 +566,9 @@ scheduleLast :: Reactive () -> Reactive () scheduleLast task = Reactive $ modify $ \as -> as { asFinal = asFinal as |> task } +schedulePost :: [Reactive ()] -> Reactive () +schedulePost tasks = Reactive $ modify $ \as -> as { asPost = Seq.fromList tasks >< asPost as } + data Listen a = Listen { runListen_ :: Maybe (MVar Node) -> Bool -> (a -> Reactive ()) -> Reactive (IO ()) } -- | Unwrap an event's listener machinery. @@ -626,7 +654,7 @@ let listeners' = M.delete iD (noListeners no) return $ listeners' `seq` no { noListeners = listeners' } -data Dep = Dep Any +newtype Dep = Dep Any dep :: a -> Dep dep = Dep . unsafeCoerce