Merge branch 'master' of https://github.com/mikesol/purescript-hyrule

src/FRP/Behavior.purs

@@ -141,17 +141,19 @@ integral
   -> ABehavior event a
   -> ABehavior event a
 integral g initial t b =
-    ABehavior \e ->
-      let x = sample b (e $> identity)
-          y = withLast (sampleBy Tuple t x)
-          z = fold approx initial y
-      in sampleOnRight z e
+  ABehavior \e ->
+    let
+      x = sample b (e $> identity)
+      y = withLast (sampleBy Tuple t x)
+      z = fold approx initial y
+    in
+      sampleOnRight z e
   where
-    approx s { last: Nothing } = s
-    approx s { now: Tuple t1 a1, last: Just (Tuple t0 a0) } = s + g (\f -> f (a0 + a1) * (t1 - t0) / two)
+  approx s { last: Nothing } = s
+  approx s { now: Tuple t1 a1, last: Just (Tuple t0 a0) } = s + g (\f -> f (a0 + a1) * (t1 - t0) / two)
 
-    two :: t
-    two = one + one
+  two :: t
+  two = one + one
 
 -- | Integrate with respect to some measure of time.
 -- |
@@ -186,14 +188,16 @@ derivative
   -> ABehavior event a
   -> ABehavior event a
 derivative g t b =
-    ABehavior \e ->
-      let x = sample b (e $> identity)
-          y = withLast (sampleBy Tuple t x)
-          z = map approx y
-      in sampleOnRight z e
+  ABehavior \e ->
+    let
+      x = sample b (e $> identity)
+      y = withLast (sampleBy Tuple t x)
+      z = map approx y
+    in
+      sampleOnRight z e
   where
-    approx { last: Nothing } = zero
-    approx { now: Tuple t1 a1, last: Just (Tuple t0 a0) } = g (\f -> f (a1 - a0) / (t1 - t0))
+  approx { last: Nothing } = zero
+  approx { now: Tuple t1 a1, last: Just (Tuple t0 a0) } = g (\f -> f (a1 - a0) / (t1 - t0))
 
 -- | Differentiate with respect to some measure of time.
 -- |
@@ -284,8 +288,9 @@ solve2
 solve2 g a0 da0 t f =
   fixB a0 \b ->
     integral g a0 t
-      (fixB da0 \db ->
-        integral g da0 t (f b db))
+      ( fixB da0 \db ->
+          integral g da0 t (f b db)
+      )
 
 -- | Solve a second order differential equation.
 -- |

src/FRP/Event.js

@@ -1,3 +1,9 @@
+export const fastForeachThunk = (as) => {
+    for (var i = 0, l = as.length; i < l; i++) {
+        as[i]();
+    }
+}
+
 export const fastForeachE = (as, f) => {
     for (var i = 0, l = as.length; i < l; i++) {
         f(as[i]);

src/FRP/Event.purs

@@ -3,20 +3,22 @@ module FRP.Event
   , Bus(..)
   , BusT
   , Create(..)
-  , CreateT
   , CreateO(..)
   , CreateOT
   , CreatePure(..)
-  , CreatePureT
   , CreatePureO(..)
   , CreatePureOT
+  , CreatePureT
+  , CreateT
   , Delay(..)
   , DelayT
   , Event
   , EventIO
   , EventIO'
   , Hot(..)
   , HotT
+  , Mailbox(..)
+  , MailboxT
   , Mailboxed(..)
   , MailboxedT
   , MakeEvent(..)
@@ -33,24 +35,26 @@ module FRP.Event
   , MemoizeT
   , PureEventIO
   , PureEventIO'
-  , Subscriber(..)
   , Subscribe(..)
-  , SubscribeT
-  , SubscribePure(..)
-  , SubscribePureT
   , SubscribeO(..)
   , SubscribeOT
+  , SubscribePure(..)
   , SubscribePureO(..)
   , SubscribePureOT
+  , SubscribePureT
+  , SubscribeT
+  , Subscriber(..)
   , backdoor
   , burning
   , bus
+  , merge
   , create
   , createO
   , createPure
   , createPureO
   , delay
   , hot
+  , mailbox
   , mailboxed
   , makeEvent
   , makeEventO
@@ -79,7 +83,8 @@ import Data.Array.ST as STArray
 import Data.Compactable (class Compactable)
 import Data.Either (Either(..), either, hush)
 import Data.Filterable as Filterable
-import Data.Foldable (for_)
+import Data.Foldable (class Foldable, for_)
+import Data.Foldable as M
 import Data.HeytingAlgebra (ff, implies, tt)
 import Data.Map as Map
 import Data.Maybe (Maybe(..), maybe)
@@ -157,6 +162,18 @@ instance altEvent :: Alt Event where
           c1
           c2
 
+-- | Merge together several events. This has the same functionality
+-- | as `oneOf`, but it is faster and less prone to stack explosions.
+merge :: forall f a. Foldable f => f (Event a) → Event a
+merge f = Event $ mkEffectFn2 \tf k -> do
+  a <- liftST $ STArray.new
+  f # M.foldMap \(Event i) -> do
+    u <- runEffectFn2 i tf k
+    void $ liftST $ STArray.push u a
+  pure do
+      o <- liftST (STArray.freeze a)
+      runEffectFn1 fastForeachThunk o
+
 instance plusEvent :: Plus Event where
   empty = Event (mkEffectFn2 \_ _ -> pure (pure unit))
 
@@ -541,6 +558,46 @@ type MailboxedT = forall r a b. Ord a => Event { address :: a, payload :: b } ->
 
 newtype Mailboxed = Mailboxed MailboxedT
 
+mailbox' :: forall a b. Ord a => Effect { push :: EffectFn1 { address :: a, payload :: b } Unit, event :: a -> Event b }
+mailbox' = do
+  r <- Ref.new Map.empty
+  pure
+    { event: \a -> Event $ mkEffectFn2 \_ k2 -> do
+        void $ Ref.modify
+          ( Map.alter
+              ( case _ of
+                  Nothing -> Just [ k2 ]
+                  Just arr -> Just (arr <> [ k2 ])
+              )
+              a
+          )
+          r
+        pure $ void $ Ref.modify
+          ( Map.alter
+              ( case _ of
+                  Nothing -> Nothing
+                  Just arr -> Just (deleteBy unsafeRefEq k2 arr)
+              )
+              a
+          )
+          r
+    , push: mkEffectFn1 \{ address, payload } -> do
+        o <- Ref.read r
+        case Map.lookup address o of
+          Nothing -> pure unit
+          Just arr -> runEffectFn2 fastForeachE arr $ mkEffectFn1 \i -> runEffectFn1 i payload
+    }
+
+-- like mailbox, but in effect
+mailbox :: MailboxT
+mailbox = do
+  pure unit
+  (\(Mailbox nt) -> nt) backdoor.mailbox
+
+type MailboxT = forall a b. Ord a => Effect { push :: { address :: a, payload :: b } -> Effect Unit, event :: a -> Event b }
+
+newtype Mailbox = Mailbox MailboxT
+
 -- | Takes an event and memoizes it within a closure.
 -- | All interactions with the event in the closure will not trigger a fresh
 -- | subscription. Outside the closure does, however, trigger a fresh subscription.
@@ -584,6 +641,7 @@ burning i (Event e) = do
     }
 
 --
+foreign import fastForeachThunk :: EffectFn1 (Array (Effect Unit)) Unit
 foreign import fastForeachE :: forall a. EffectFn2 (Array a) (EffectFn1 a Unit) Unit
 foreign import fastForeachOhE :: forall a. EffectFn2 (ObjHack a) (EffectFn1 a Unit) Unit
 
@@ -613,6 +671,7 @@ type Backdoor =
   , memoize :: Memoize
   , hot :: Hot
   , mailboxed :: Mailboxed
+  , mailbox :: Mailbox
   , delay :: Delay
   }
 
@@ -780,39 +839,21 @@ backdoor = do
           pure { event, unsubscribe }
       in
         hot_
+  , mailbox:
+      let
+        mailbox_ :: Mailbox
+        mailbox_ = Mailbox do
+          { push, event } <- mailbox'
+          pure { event, push: \k -> runEffectFn1 push k }
+      in
+        mailbox_
   , mailboxed:
       let
         mailboxed_ :: Mailboxed
-        mailboxed_ = Mailboxed \(Event e) f -> Event $ mkEffectFn2 \tf k1 -> do
-          r <- Ref.new Map.empty
-          runEffectFn1 k1 $ f \a -> Event $ mkEffectFn2 \_ k2 -> do
-            void $ Ref.modify
-              ( Map.alter
-                  ( case _ of
-                      Nothing -> Just [ k2 ]
-                      Just arr -> Just (arr <> [ k2 ])
-                  )
-                  a
-              )
-              r
-            pure $ void $ Ref.modify
-              ( Map.alter
-                  ( case _ of
-                      Nothing -> Nothing
-                      Just arr -> Just (deleteBy unsafeRefEq k2 arr)
-                  )
-                  a
-              )
-              r
-          unsub <- runEffectFn2 e tf $ mkEffectFn1 \{ address, payload } -> do
-            o <- Ref.read r
-            case Map.lookup address o of
-              Nothing -> pure unit
-              Just arr -> runEffectFn2 fastForeachE arr $ mkEffectFn1 \i -> runEffectFn1 i payload
-          pure do
-            -- free references - helps gc?
-            void $ Ref.write (Map.empty) r
-            unsub
+        mailboxed_ = Mailboxed \(Event e) f -> Event $ mkEffectFn2 \b k -> do
+          { push, event } <- mailbox'
+          runEffectFn1 k (f event)
+          runEffectFn2 e b push
       in
         mailboxed_
   , delay:

src/FRP/Event/AnimationFrame.purs

@@ -10,12 +10,13 @@ import Web.HTML.Window (requestAnimationFrame)
 
 -- | Create an event which fires every frame (using `requestAnimationFrame`).
 animationFrame :: Event Unit
-animationFrame = makeEvent \k -> do 
+animationFrame = makeEvent \k -> do
   w <- window
   cancelled <- Ref.new false
-  let loop = void do
-        w # requestAnimationFrame do
-          k unit
-          unlessM (Ref.read cancelled) loop
+  let
+    loop = void do
+      w # requestAnimationFrame do
+        k unit
+        unlessM (Ref.read cancelled) loop
   loop
   pure (Ref.write true cancelled)

src/FRP/Event/Class.purs

@@ -124,8 +124,8 @@ gateBy
   -> event b
 gateBy f sampled sampler = compact $
   (\p x -> if f p x then Just x else Nothing)
-  <$> (pure Nothing <|> Just <$> sampled)
-  <|*> sampler
+    <$> (pure Nothing <|> Just <$> sampled)
+    <|*> sampler
 
 -- | Fold over values received from some `Event`, creating a new `Event`.
 fold :: forall event a b. IsEvent event => (b -> a -> b) -> b -> event a -> event b

src/FRP/Event/Keyboard.purs

@@ -25,7 +25,7 @@ newtype Keyboard = Keyboard
   { keys :: Ref.Ref (Set.Set String)
   , dispose :: Effect Unit
   }
-  
+
 -- | Get a handle for working with the keyboard.
 getKeyboard :: Effect Keyboard
 getKeyboard = do
@@ -39,9 +39,10 @@ getKeyboard = do
       Ref.modify (Set.delete (code ke)) keys
   addEventListener (wrap "keydown") keyDownListener false target
   addEventListener (wrap "keyup") keyUpListener false target
-  let dispose = do
-        removeEventListener (wrap "keydown") keyDownListener false target
-        removeEventListener (wrap "keyup") keyUpListener false target
+  let
+    dispose = do
+      removeEventListener (wrap "keydown") keyDownListener false target
+      removeEventListener (wrap "keyup") keyUpListener false target
   pure (Keyboard { keys, dispose })
 
 disposeKeyboard :: Keyboard -> Effect Unit

src/FRP/Event/Mouse.purs

@@ -49,10 +49,11 @@ getMouse = do
   addEventListener (wrap "mousemove") mouseMoveListener false target
   addEventListener (wrap "mousedown") mouseDownListener false target
   addEventListener (wrap "mouseup") mouseUpListener false target
-  let dispose = do
-        removeEventListener (wrap "mousemove") mouseMoveListener false target
-        removeEventListener (wrap "mousedown") mouseDownListener false target
-        removeEventListener (wrap "mouseup") mouseUpListener false target
+  let
+    dispose = do
+      removeEventListener (wrap "mousemove") mouseMoveListener false target
+      removeEventListener (wrap "mousedown") mouseDownListener false target
+      removeEventListener (wrap "mouseup") mouseUpListener false target
   pure (Mouse { position, buttons, dispose })
 
 disposeMouse :: Mouse -> Effect Unit