reflex (empty) → 0.0.1

raw patch · 13 files changed

+2386/−0 lines, 13 filesdep +basedep +containersdep +dependent-mapsetup-changed

Dependencies added: base, containers, dependent-map, dependent-sum, lens, mtl, primitive, semigroups, template-haskell, these

Files

• LICENSE +12/−0
• Setup.hs +2/−0
• reflex.cabal +47/−0
• src/Control/Monad/Ref.hs +85/−0
• src/Control/Monad/TypedId.hs +50/−0
• src/Data/Functor/Misc.hs +71/−0
• src/Reflex.hs +10/−0
• src/Reflex/Class.hs +240/−0
• src/Reflex/Dynamic.hs +423/−0
• src/Reflex/Dynamic/TH.hs +39/−0
• src/Reflex/Host/Class.hs +56/−0
• src/Reflex/Spider.hs +5/−0
• src/Reflex/Spider/Internal.hs +1346/−0

@@ -0,0 +1,12 @@+Copyright (c) 2015, Obsidian Systems LLC+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,47 @@+Name: reflex+Version: 0.0.1+Synopsis: Higher-order Functional Reactive Programming+Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system+License: BSD3+License-file: LICENSE+Author: Ryan Trinkle+Maintainer: ryan.trinkle@gmail.com+Stability: Experimental+Category: FRP+Build-type: Simple+Cabal-version: >=1.9.2+bug-reports: https://github.com/ryantrinkle/reflex/issues++library+  hs-source-dirs: src+  build-depends:+    base == 4.8.*,+    dependent-sum == 0.2.*,+    dependent-map == 0.1.*,+    semigroups == 0.16.*,+    mtl == 2.2.*,+    containers == 0.5.*,+    these == 0.4.*,+    lens == 4.7.*,+    primitive == 0.5.*,+    template-haskell == 2.10.*++  exposed-modules:+    Reflex,+    Reflex.Spider,+    Reflex.Spider.Internal,+    Reflex.Class,+    Reflex.Dynamic,+    Reflex.Dynamic.TH,+    Reflex.Host.Class,+    Data.Functor.Misc,+    Control.Monad.TypedId,+    Control.Monad.Ref++  other-extensions: TemplateHaskell+  ghc-prof-options: -fprof-auto+  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2++source-repository head+  type: git+  location: https://github.com/ryantrinkle/reflex

@@ -0,0 +1,85 @@+{-# LANGUAGE RecursiveDo, TypeFamilies, LambdaCase #-}+module Control.Monad.Ref where++import Control.Monad+import Control.Monad.Trans+import Control.Monad.Reader+import Control.Monad.Writer+import Data.IORef++class Monad m => MonadRef m where+  type Ref m :: * -> *+  newRef :: a -> m (Ref m a)+  readRef :: Ref m a -> m a+  writeRef :: Ref m a -> a -> m ()+  atomicModifyRef :: Ref m a -> (a -> (a, b)) -> m b++instance MonadRef IO where+  type Ref IO = IORef+  {-# INLINE newRef #-}+  newRef = newIORef+  {-# INLINE readRef #-}+  readRef = readIORef+  {-# INLINE writeRef #-}+  writeRef = writeIORef+  {-# INLINE atomicModifyRef #-}+  atomicModifyRef r f = do+    result <- atomicModifyIORef' r f+--    evaluate =<< readIORef r --TODO: Verify that ghcjs now strictly evaluates the values in atomicModifyIORef', then remove this line+    return result++{-# INLINE cacheM #-}+cacheM :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a, m ())+cacheM a = do+  r <- newRef undefined+  let invalidate = writeRef r $ do+        result <- a+        writeRef r $ return result+        return result+  invalidate+  return (join $ readRef r, invalidate)++{-# INLINE cacheMWithTry #-}+cacheMWithTry :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a, m (Maybe a), m ())+cacheMWithTry a = do+  r <- newRef $ Left a+  let invalidate = writeRef r $ Left a+      get = readRef r >>= \case+        Left a' -> do+          result <- a'+          writeRef r $ Right result+          return result+        Right result -> return result+      tryGet = readRef r >>= \case+        Left _ -> return Nothing+        Right result -> return $ Just result+  return (get, tryGet, invalidate)++-- | Not thread-safe or reentrant+{-# INLINE memoM #-}+memoM :: (MonadRef m, MonadRef m', Ref m ~ Ref m') => m' a -> m (m' a)+memoM = liftM fst . cacheM++{-# INLINE replaceRef #-}+replaceRef :: MonadRef m => Ref m a -> a -> m a+replaceRef r new = atomicModifyRef r $ \old -> (new, old)++{-# INLINE modifyRef #-}+modifyRef :: MonadRef m => Ref m a -> (a -> a) -> m ()+modifyRef r f = atomicModifyRef r $ \a -> (f a, ())++instance (Monoid w, MonadRef m) => MonadRef (WriterT w m) where+  {-# SPECIALIZE instance Monoid w => MonadRef (WriterT w IO) #-}+  type Ref (WriterT w m) = Ref m+  newRef = lift . newRef+  readRef = lift . readRef+  writeRef r = lift . writeRef r+  atomicModifyRef r f = lift $ atomicModifyRef r f++instance MonadRef m => MonadRef (ReaderT r m) where+  {-# SPECIALIZE instance MonadRef (ReaderT r IO) #-}+  type Ref (ReaderT r m) = Ref m+  newRef = lift . newRef+  readRef = lift . readRef+  writeRef r = lift . writeRef r+  atomicModifyRef r f = lift $ atomicModifyRef r f

@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+module Control.Monad.TypedId ( MonadTypedId (..)+                             ) where++import Data.GADT.Compare+import Data.IORef++import Control.Monad.State+import Control.Monad.Reader++import Unsafe.Coerce+import System.IO.Unsafe++class (Monad m, GCompare (TypedId m)) => MonadTypedId m where+  type TypedId m :: * -> *+  getTypedId :: m (TypedId m a)++nextTypedIdIO :: IORef Int+{-# NOINLINE nextTypedIdIO #-}+nextTypedIdIO = unsafePerformIO $ newIORef 1++newtype TypedId_IO a = TypedId_IO Int deriving (Show)++instance MonadTypedId IO where+  type TypedId IO = TypedId_IO+  {-# INLINE getTypedId #-}+  getTypedId = do+    n <- atomicModifyIORef' nextTypedIdIO $ \n -> (succ n, n)+    return $ TypedId_IO n++instance GCompare TypedId_IO where+  {-# INLINE gcompare #-}+  TypedId_IO a `gcompare` TypedId_IO b = case a `compare` b of+    LT -> GLT+    EQ -> unsafeCoerce GEQ+    GT -> GGT++instance GEq TypedId_IO where+  {-# INLINE geq #-}+  TypedId_IO a `geq` TypedId_IO b = if a == b then Just $ unsafeCoerce Refl else Nothing++instance MonadTypedId m => MonadTypedId (StateT s m) where+  type TypedId (StateT s m) = TypedId m+  {-# INLINE getTypedId #-}+  getTypedId = lift getTypedId++instance MonadTypedId m => MonadTypedId (ReaderT r m) where+  type TypedId (ReaderT r m) = TypedId m+  {-# INLINE getTypedId #-}+  getTypedId = lift getTypedId

@@ -0,0 +1,71 @@+{-# LANGUAGE KindSignatures, GADTs, DeriveDataTypeable, RankNTypes, ScopedTypeVariables #-}+module Data.Functor.Misc where++import Data.GADT.Compare+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Dependent.Map (DMap, DSum (..))+import qualified Data.Dependent.Map as DMap+import Data.Typeable hiding (Refl)+import Data.These++data WrapArg :: (* -> *) -> (* -> *) -> * -> * where+  WrapArg :: f a -> WrapArg g f (g a)++instance GEq f => GEq (WrapArg g f) where+  geq (WrapArg a) (WrapArg b) = fmap (\Refl -> Refl) $ geq a b++instance GCompare f => GCompare (WrapArg g f) where+  gcompare (WrapArg a) (WrapArg b) = case gcompare a b of+    GLT -> GLT+    GEQ -> GEQ+    GGT -> GGT++data Const2 :: * -> * -> * -> * where+  Const2 :: k -> Const2 k v v+  deriving (Typeable)++instance Eq k => GEq (Const2 k v) where+  geq (Const2 a) (Const2 b) =+    if a == b+    then Just Refl+    else Nothing++instance Ord k => GCompare (Const2 k v) where+  gcompare (Const2 a) (Const2 b) = case compare a b of+    LT -> GLT+    EQ -> GEQ+    GT -> GGT++{-# INLINE sequenceDmap #-}+sequenceDmap :: (Monad m, GCompare f) => DMap (WrapArg m f) -> m (DMap f)+sequenceDmap = DMap.foldrWithKey (\(WrapArg k) mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k v x) (return DMap.empty)++{-# INLINE combineDMapsWithKey #-}+combineDMapsWithKey :: forall f g h i. GCompare f => (forall a. f a -> These (g a) (h a) -> i a) -> DMap (WrapArg g f) -> DMap (WrapArg h f) -> DMap (WrapArg i f)+combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)+  where go :: [DSum (WrapArg g f)] -> [DSum (WrapArg h f)] -> [DSum (WrapArg i f)]+        go [] hs = map (\(WrapArg hk :=> hv) -> WrapArg hk :=> f hk (That hv)) hs+        go gs [] = map (\(WrapArg gk :=> gv) -> WrapArg gk :=> f gk (This gv)) gs+        go gs@((WrapArg gk :=> gv) : gs') hs@((WrapArg hk :=> hv) : hs') = case gk `gcompare` hk of+          GLT -> (WrapArg gk :=> f gk (This gv)) : go gs' hs+          GEQ -> (WrapArg gk :=> f gk (These gv hv)) : go gs' hs'+          GGT -> (WrapArg hk :=> f hk (That hv)) : go gs hs'++wrapDMap :: (forall a. a -> f a) -> DMap k -> DMap (WrapArg f k)+wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> WrapArg k :=> f v) . DMap.toAscList++rewrapDMap :: (forall a. f a -> g a) -> DMap (WrapArg f k) -> DMap (WrapArg g k)+rewrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> WrapArg k :=> f v) . DMap.toAscList++unwrapDMap :: (forall a. f a -> a) -> DMap (WrapArg f k) -> DMap k+unwrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> k :=> f v) . DMap.toAscList++mapToDMap :: Map k v -> DMap (Const2 k v)+mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList++mapWithFunctorToDMap :: Map k (f v) -> DMap (WrapArg f (Const2 k v))+mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> WrapArg (Const2 k) :=> v) . Map.toAscList++dmapToMap :: DMap (Const2 k v) -> Map k v+dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, v)) . DMap.toAscList

@@ -0,0 +1,10 @@+module Reflex ( module Reflex.Class+              , module Reflex.Dynamic+              , module Reflex.Dynamic.TH+              , module Reflex.Spider+              ) where++import Reflex.Class+import Reflex.Dynamic+import Reflex.Dynamic.TH+import Reflex.Spider

@@ -0,0 +1,240 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase #-}+module Reflex.Class where++import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)++import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import Control.Monad.Writer hiding (mapM, mapM_, forM, forM_, sequence, sequence_, (<>))+import Data.List.NonEmpty (NonEmpty (..))+import Data.These+import Data.Align+import Data.GADT.Compare (GEq (..), (:~:) (..))+import Data.GADT.Show (GShow (..))+import Data.Dependent.Sum (ShowTag (..))+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))+import qualified Data.Dependent.Map as DMap+import Data.Functor.Misc+import Data.Semigroup++import Debug.Trace (trace)++class (MonadHold t (PushM t), MonadSample t (PullM t), Functor (Event t), Functor (Behavior t)) => Reflex t where+  -- | A container for a value that can change over time.  Behaviors can be sampled at will, but it is not possible to be notified when they change+  data Behavior t :: * -> *+  -- | A stream of occurrences.  During any given frame, an Event is either occurring or not occurring; if it is occurring, it will contain a value of the given type (its "occurrence type")+  data Event t :: * -> *+  -- | An Event with no occurrences+  never :: Event t a+  -- | Create a Behavior that always has the given value+  constant :: a -> Behavior t a --TODO: Refactor to use 'pure' from Applicative instead; however, we need to make sure that encouraging Applicative-style use of Behaviors doesn't have a negative performance impact+  -- | Create an Event from another Event; the provided function can sample Behaviors and hold Events, and use the results to produce a occurring (Just) or non-occurring (Nothing) result+  push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b+  -- | A monad for doing complex push-based calculations efficiently+  type PushM t :: * -> *+  -- | Create a Behavior by reading from other Behaviors; the result will be recomputed whenever any of the read Behaviors changes+  pull :: PullM t a -> Behavior t a+  -- | A monad for doing complex pull-based calculations efficiently+  type PullM t :: * -> *+  -- | Merge a collection of events; the resulting Event will only occur if at least one input event is occuring, and will contain all of the input keys that are occurring simultaneously+  merge :: GCompare k => DMap (WrapArg (Event t) k) -> Event t (DMap k) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty+  -- | Efficiently fan-out an event to many destinations.  This function should be partially applied, and then the result applied repeatedly to create child events +  fan :: GCompare k => Event t (DMap k) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here?  The combinator is worthless without it+  -- | Create an Event that will occur whenever the currently-selected input Event occurs+  switch :: Behavior t (Event t a) -> Event t a+  -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring+  coincidence :: Event t (Event t a) -> Event t a++class Monad m => MonadSample t m | m -> t where+  -- | Get the current value in the Behavior+  sample :: Behavior t a -> m a++class MonadSample t m => MonadHold t m where+  -- | Create a new Behavior whose value will initially be equal to the given value and will be updated whenever the given Event occurs+  hold :: a -> Event t a -> m (Behavior t a)++newtype EventSelector t k = EventSelector { select :: forall a. k a -> Event t a }++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++instance MonadSample t m => MonadSample t (ReaderT r m) where+  sample = lift . sample++instance MonadHold t m => MonadHold t (ReaderT r m) where+  hold a0 = lift . hold a0++--------------------------------------------------------------------------------+-- Convenience functions+--------------------------------------------------------------------------------++pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b+pushAlways f e = push (liftM Just . f) e++ffor :: Functor f => f a -> (a -> b) -> f b+ffor = flip fmap++instance Reflex t => Functor (Behavior t) where+  fmap f = pull . liftM f . sample++--TODO: See if there's a better class in the standard libraries already+class FunctorMaybe f where+  fmapMaybe :: (a -> Maybe b) -> f a -> f b++fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b+fforMaybe = flip fmapMaybe++ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a+ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing++instance Reflex t => FunctorMaybe (Event t) where+  fmapMaybe f = push $ return . f++instance Reflex t => Functor (Event t) where+  fmap f = fmapMaybe $ Just . f++zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)+zipListWithEvent f l e = do+  rec lb <- hold l eTail+      let eBoth = flip push e $ \o -> do+            l' <- sample lb+            return $ case l' of+              (h : t) -> Just (f h o, t)+              [] -> Nothing+      let eTail = fmap snd eBoth+      lb `seq` eBoth `seq` eTail `seq` return ()+  return $ fmap fst eBoth++-- | Replace the occurrence value of the Event with the value of the Behavior at the time of the occurrence+tag :: Reflex t => Behavior t b -> Event t a -> Event t b+tag b = pushAlways $ \_ -> sample b++attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c+attachWithMaybe f b e = flip push e $ \o -> liftM (flip f o) $ sample b++attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c+attachWith f = attachWithMaybe $ \a b -> Just $ f a b++attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)+attach = attachWith (,)++onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)+onceE = headE++headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)+headE e = do+  rec be <- hold e $ fmap (const never) e'+      let e' = switch be+      e' `seq` return ()+  return e'++tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)+tailE e = liftM snd $ headTailE e++headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)+headTailE e = do+  eHead <- headE e+  be <- hold never $ fmap (const e) eHead+  return (eHead, switch be)++splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)+splitE e = (fmap fst e, fmap snd e)++traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a+traceEvent s = traceEventWith $ \x -> s <> ": " <> show x++traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a+traceEventWith f = push $ \x -> trace (f x) $ return $ Just x++data EitherTag l r a where+  LeftTag :: EitherTag l r l+  RightTag :: EitherTag l r r++instance GEq (EitherTag l r) where+  geq a b = case (a, b) of+    (LeftTag, LeftTag) -> Just Refl+    (RightTag, RightTag) -> Just Refl+    _ -> Nothing++instance GCompare (EitherTag l r) where+  gcompare a b = case (a, b) of+    (LeftTag, LeftTag) -> GEQ+    (LeftTag, RightTag) -> GLT+    (RightTag, LeftTag) -> GGT+    (RightTag, RightTag) -> GEQ++instance GShow (EitherTag l r) where+  gshowsPrec _ a = case a of+    LeftTag -> showString "LeftTag"+    RightTag -> showString "RightTag"++instance (Show l, Show r) => ShowTag (EitherTag l r) where+  showTaggedPrec t n a = case t of+    LeftTag -> showsPrec n a+    RightTag -> showsPrec n a++eitherToDSum :: Either a b -> DSum (EitherTag a b)+eitherToDSum = \case+  Left a -> LeftTag :=> a+  Right b -> RightTag :=> b++dsumToEither :: DSum (EitherTag a b) -> Either a b+dsumToEither = \case+  LeftTag :=> a -> Left a+  RightTag :=> b -> Right b++dmapToThese :: DMap (EitherTag a b) -> Maybe (These a b)+dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of+  (Nothing, Nothing) -> Nothing+  (Just a, Nothing) -> Just $ This a+  (Nothing, Just b) -> Just $ That b+  (Just a, Just b) -> Just $ These a b++appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a+appendEvents e1 e2 = fmap (mergeThese mappend) $ align e1 e2++sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)+sequenceThese t = case t of+  This ma -> liftM This ma+  These ma mb -> liftM2 These ma mb+  That mb -> liftM That mb++instance (Semigroup a, Reflex t) => Monoid (Event t a) where+  mempty = never+  mappend a b = mconcat [a, b]+  mconcat = fmap sconcat . mergeList++mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a+mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) $ merge $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es++leftmost :: Reflex t => [Event t a] -> Event t a+leftmost = mergeWith const++mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)+mergeList [] = never+mergeList es = mergeWith (<>) $ map (fmap (:|[])) es++mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)+mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap++fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)+fanMap = fan . fmap mapToDMap++-- | Switches to the new event whenever it receives one; the new event is used immediately, on the same frame that it is switched to+switchPromptly :: forall t m a. (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)+switchPromptly ea0 eea = do+  bea <- hold ea0 eea+  let eLag = switch bea+      eCoincidences = coincidence eea+  return $ leftmost [eCoincidences, eLag]++instance Reflex t => Align (Event t) where+  nil = never+  align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [WrapArg LeftTag :=> ea, WrapArg RightTag :=> eb]++gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a+gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing

@@ -0,0 +1,423 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, DataKinds, PolyKinds #-}+module Reflex.Dynamic ( Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update+                      , current+                      , updated+                      , constDyn+                      , holdDyn+                      , nubDyn+                      , count+                      , toggle+                      , switchPromptlyDyn+                      , tagDyn+                      , attachDyn+                      , attachDynWith+                      , attachDynWithMaybe+                      , mapDyn+                      , forDyn+                      , mapDynM+                      , foldDyn+                      , foldDynM+                      , combineDyn+                      , collectDyn+                      , mconcatDyn+                      , distributeDMapOverDyn+                      , joinDyn+                      , joinDynThroughMap+                      , traceDyn+                      , traceDynWith+                      , splitDyn+                      , Demux+                      , demux+                      , getDemuxed+                        -- Things that probably aren't very useful:+                      , HList (..)+                      , FHList (..)+                      , distributeFHListOverDyn+                        -- Unsafe+                      , unsafeDynamic+                      ) where++import Reflex.Class+import Data.Functor.Misc++import Control.Monad+import Control.Monad.Fix+import Control.Monad.Identity+import Data.These+import Data.Align+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Sum (DSum (..))+import Data.GADT.Compare (GCompare (..), GEq (..), (:~:) (..), GOrdering (..))+import Data.Monoid+--import Data.HList (HList (..), hBuild)++data HList (l::[*]) where+    HNil  :: HList '[]+    HCons :: e -> HList l -> HList (e ': l)++infixr 2 `HCons`++type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]+type instance HRevApp '[] l = l+type instance HRevApp (e ': l) l' = HRevApp l (e ': l')++hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)+hRevApp HNil l = l+hRevApp (HCons x l) l' = hRevApp l (HCons x l')++hReverse l = hRevApp l HNil++hEnd :: HList l -> HList l+hEnd = id++hBuild :: (HBuild' '[] r) => r+hBuild =  hBuild' HNil++class HBuild' l r where+    hBuild' :: HList l -> r++instance (l' ~ HRevApp l '[])+      => HBuild' l (HList l') where+  hBuild' l = hReverse l++instance HBuild' (a ': l) r+      => HBuild' l (a->r) where+  hBuild' l x = hBuild' (HCons x l)+++data Dynamic t a+  = Dynamic (Behavior t a) (Event t a)++unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a+unsafeDynamic = Dynamic++current :: Dynamic t a -> Behavior t a+current (Dynamic b _) = b++updated :: Dynamic t a -> Event t a+updated (Dynamic _ e) = e++constDyn :: Reflex t => a -> Dynamic t a+constDyn x = Dynamic (constant x) never++holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a)+holdDyn v0 e = do+  b <- hold v0 e+  return $ Dynamic b e++nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a+nubDyn d =+  let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)+  in Dynamic (current d) e' --TODO: Avoid invalidating the outgoing Behavior++{-+instance Reflex t => Functor (Dynamic t) where+  fmap f d =+    let e' = fmap f $ updated d+        eb' = push (\b' -> liftM Just $ constant b') e'+        b0 = fmap f $ current d+    +-}      ++mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)+mapDyn f = mapDynM $ return . f++forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)+forDyn = flip mapDyn++{-# INLINE mapDynM #-}+mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b)+mapDynM f d = do+  let e' = push (liftM Just . f :: a -> PushM t (Maybe b)) $ updated d+      eb' = fmap constant e'+      v0 = pull $ f =<< sample (current d)+  bb' :: Behavior t (Behavior t b) <- hold v0 eb'+  let b' = pull $ sample =<< sample bb'+  return $ Dynamic b' e'++foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)+foldDyn f = foldDynM (\o v -> return $ f o v)++foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)+foldDynM f z e = do+  rec let e' = flip push e $ \o -> do+            v <- sample b'+            liftM Just $ f o v+      b' <- hold z e'+  return $ Dynamic b' e'++count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)+count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e++toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)+toggle = foldDyn (const not)++-- | Switches to the new event whenever it receives one.  Switching occurs *before* occurring the inner event.+switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a+switchPromptlyDyn de =+  let eLag = switch $ current de+      eCoincidences = coincidence $ updated de+  in leftmost [eCoincidences, eLag]++{-++mergeEventsWith :: Reflex t m => (a -> a -> a) -> Event t a -> Event t a -> m (Event t a)+mergeEventsWith f ea eb = mapE (mergeThese f) =<< alignEvents ea eb++firstE :: (Reflex t m) => [Event t a] -> m (Event t a)+firstE [] = return never+firstE (h:t) = mergeEventsLeftBiased h =<< firstE t++concatEventsWith :: (Reflex t m) => (a -> a -> a) -> [Event t a] -> m (Event t a)+concatEventsWith _ [] = return never+concatEventsWith _ [e] = return e+concatEventsWith f es = mapEM (liftM (foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) . sequenceDmap) <=< mergeEventDMap $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es+--concatEventsWith f (h:t) = mergeEventsWith f h =<< concatEventsWith f t++mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)+mconcatE = concatEventsWith mappend+-}++splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)+splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)++mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)+mconcatDyn es = do+  ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es+  mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm++distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k))+distributeDMapOverDyn dm = case DMap.toList dm of+  [] -> return $ constDyn DMap.empty+  [WrapArg k :=> v] -> mapDyn (DMap.singleton k) v+  _ -> do+    let edmPre = merge $ rewrapDMap updated dm+        edm :: Event t (DMap k) = flip push edmPre $ \o -> return . Just =<< do+          let f _ = \case+                This origDyn -> sample $ current origDyn+                That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap"+                These _ (Identity newVal) -> return newVal+          sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)+        dm0 :: Behavior t (DMap k) = pull $ do+          liftM DMap.fromList $ forM (DMap.toList dm) $ \(WrapArg k :=> dv) -> liftM (k :=>) $ sample $ current dv+    bbdm :: Behavior t (Behavior t (DMap k)) <- hold dm0 $ fmap constant edm+    let bdm = pull $ sample =<< sample bbdm+    return $ Dynamic bdm edm++combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)+combineDyn f da db = do+  let eab = align (updated da) (updated db)+      ec = flip push eab $ \o -> do+        (a, b) <- case o of+          This a -> do+            b <- sample $ current db+            return (a, b)+          That b -> do+            a <- sample $ current da+            return (a, b)+          These a b -> return (a, b)+        return $ Just $ f a b+      c0 :: Behavior t c = pull $ liftM2 f (sample $ current da) (sample $ current db)+  bbc :: Behavior t (Behavior t c) <- hold c0 $ fmap constant ec+  let bc :: Behavior t c = pull $ sample =<< sample bbc+  return $ Dynamic bc ec++{-+tagInnerDyn :: Reflex t => Event t (Dynamic t a) -> Event t a+tagInnerDyn e =+  let eSlow = push (liftM Just . sample . current) e+      eFast = coincidence $ fmap updated e+  in leftmost [eFast, eSlow]+-}++joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a+joinDyn dd =+  let b' = pull $ sample . current =<< sample (current dd)+      eOuter :: Event t a = pushAlways (sample . current) $ updated dd+      eInner :: Event t a = switch $ fmap updated (current dd)+      eBoth :: Event t a = coincidence $ fmap updated (updated dd)+      e' = leftmost [eBoth, eOuter, eInner]+  in Dynamic b' e'++--TODO: Generalize this to functors other than Maps+joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)+joinDynThroughMap dd =+  let b' = pull $ mapM (sample . current) =<< sample (current dd)+      eOuter :: Event t (Map k a) = pushAlways (mapM (sample . current)) $ updated dd+      eInner :: Event t (Map k a) = attachWith (flip Map.union) b' $ switch $ fmap (mergeMap . fmap updated) (current dd) --Note: the flip is important because Map.union is left-biased+      readNonFiring :: MonadSample t m => These (Dynamic t a) a -> m a+      readNonFiring = \case+        This d -> sample $ current d+        That a -> return a+        These _ a -> return a+      eBoth :: Event t (Map k a) = coincidence $ fmap (\m -> pushAlways (mapM readNonFiring . align m) $ mergeMap $ fmap updated m) (updated dd)+      e' = leftmost [eBoth, eOuter, eInner]+  in Dynamic b' e'++traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a+traceDyn s = traceDynWith $ \x -> s <> ": " <> show x++traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a+traceDynWith f d =+  let e' = traceEventWith f $ updated d+  in Dynamic (current d) e'++tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a+tagDyn = attachDynWith const++attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)+attachDyn = attachDynWith (,)++attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c+attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b++attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c+attachDynWithMaybe f d e =+  let e' = attach (current d) e+  in fforMaybe (align e' $ updated d) $ \case+       This (a, b) -> f a b -- Only the tagging event is firing, so use that+       These (_, b) a -> f a b -- Both events are firing, so use the newer value+       That _ -> Nothing -- The tagging event isn't firing, so don't fire++--------------------------------------------------------------------------------+-- Demux+--------------------------------------------------------------------------------++data Demux t k = Demux { demuxValue :: Behavior t k+                       , demuxSelector :: EventSelector t (Const2 k Bool)+                       }++demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k+demux k = Demux (current k) (fan $ attachWith (\k0 k1 -> if k0 == k1 then DMap.empty else DMap.fromList [Const2 k0 :=> False, Const2 k1 :=> True]) (current k) (updated k))++--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out+getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)+getDemuxed d k = do+  let e = select (demuxSelector d) (Const2 k)+  bb <- hold (liftM (==k) $ sample $ demuxValue d) $ fmap return e+  let b = pull $ join $ sample bb+  return $ Dynamic b e++--------------------------------------------------------------------------------+-- collectDyn+--------------------------------------------------------------------------------++--TODO: This whole section is badly in need of cleanup++data FHList f l where+  FHNil :: FHList f '[]+  FHCons :: f e -> FHList f l -> FHList f (e ': l)++natMap :: (forall a. f a -> g a) -> FHList f l -> FHList g l+natMap f = \case+  FHNil -> FHNil+  h `FHCons` t -> f h `FHCons` natMap f t++sequenceFHList :: Monad m => FHList m l -> m (HList l)+sequenceFHList = \case+  FHNil -> return HNil+  h `FHCons` t -> do+    hResult <- h+    tResult <- sequenceFHList t+    return $ hResult `HCons` tResult++instance GEq (HListPtr l) where+  HHeadPtr `geq` HHeadPtr = Just Refl+  HHeadPtr `geq` HTailPtr _ = Nothing+  HTailPtr _ `geq` HHeadPtr = Nothing+  HTailPtr a `geq` HTailPtr b = a `geq` b++instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break+  HHeadPtr `gcompare` HHeadPtr = GEQ+  HHeadPtr `gcompare` HTailPtr _ = GLT+  HTailPtr _ `gcompare` HHeadPtr = GGT+  HTailPtr a `gcompare` HTailPtr b = a `gcompare` b++data HListPtr l a where+  HHeadPtr :: HListPtr (h ': t) h+  HTailPtr :: HListPtr t a -> HListPtr (h ': t) a++fhlistToDMap :: forall f l. FHList f l -> DMap (WrapArg f (HListPtr l))+fhlistToDMap = DMap.fromList . go+  where go :: forall l'. FHList f l' -> [DSum (WrapArg f (HListPtr l'))]+        go = \case+          FHNil -> []+          FHCons h t -> (WrapArg HHeadPtr :=> h) : map (\(WrapArg p :=> v) -> WrapArg (HTailPtr p) :=> v) (go t)++class RebuildSortedHList l where+  rebuildSortedFHList :: [DSum (WrapArg f (HListPtr l))] -> FHList f l+  rebuildSortedHList :: [DSum (HListPtr l)] -> HList l++instance RebuildSortedHList '[] where+  rebuildSortedFHList [] = FHNil+  rebuildSortedHList [] = HNil++instance RebuildSortedHList t => RebuildSortedHList (h ': t) where+  rebuildSortedFHList ((WrapArg HHeadPtr :=> h) : t) = FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t+  rebuildSortedHList ((HHeadPtr :=> h) : t) = HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t+++dmapToFHList :: forall f l. RebuildSortedHList l => DMap (WrapArg f (HListPtr l)) -> FHList f l+dmapToFHList = rebuildSortedFHList . DMap.toList++dmapToHList :: forall f l. RebuildSortedHList l => DMap (HListPtr l) -> HList l+dmapToHList = rebuildSortedHList . DMap.toList++distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))+distributeFHListOverDyn l = mapDyn dmapToHList =<< distributeDMapOverDyn (fhlistToDMap l)+{-+distributeFHListOverDyn l = do+  let ec = undefined+      c0 = pull $ sequenceFHList $ natMap (sample . current) l+  bbc <- hold c0 $ fmap constant ec+  let bc = pull $ sample =<< sample bbc+  return $ Dynamic bc ec+-}++class AllAreFunctors (f :: a -> *) (l :: [a]) where+  type FunctorList f l :: [*]+  toFHList :: HList (FunctorList f l) -> FHList f l+  fromFHList :: FHList f l -> HList (FunctorList f l)++instance AllAreFunctors f '[] where+  type FunctorList f '[] = '[]+  toFHList HNil = FHNil+  fromFHList FHNil = HNil++instance AllAreFunctors f t => AllAreFunctors f (h ': t) where+  type FunctorList f (h ': t) = f h ': FunctorList f t+  toFHList (a `HCons` b) = a `FHCons` toFHList b+  fromFHList (a `FHCons` b) = a `HCons` fromFHList b++collectDyn :: ( RebuildSortedHList (HListElems b)+              , IsHList a, IsHList b+              , AllAreFunctors (Dynamic t) (HListElems b)+              , Reflex t, MonadHold t m+              , HListElems a ~ FunctorList (Dynamic t) (HListElems b)+              ) => a -> m (Dynamic t b)+collectDyn ds =+  mapDyn fromHList =<< distributeFHListOverDyn (toFHList $ toHList ds)++-- Poor man's Generic+class IsHList a where+  type HListElems a :: [*]+  toHList :: a -> HList (HListElems a)+  fromHList :: HList (HListElems a) -> a++instance IsHList (a, b) where+  type HListElems (a, b) = [a, b]+  toHList (a, b) = hBuild a b+  fromHList (a `HCons` b `HCons` HNil) = (a, b)++instance IsHList (a, b, c, d) where+  type HListElems (a, b, c, d) = [a, b, c, d]+  toHList (a, b, c, d) = hBuild a b c d+  fromHList (a `HCons` b `HCons` c `HCons` d `HCons` HNil) = (a, b, c, d)++instance IsHList (a, b, c, d, e, f) where+  type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]+  toHList (a, b, c, d, e, f) = hBuild a b c d e f+  fromHList (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) = (a, b, c, d, e, f)

@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeOperators, GADTs, EmptyDataDecls #-}+module Reflex.Dynamic.TH (qDyn, unqDyn) where++import Reflex.Dynamic++import Language.Haskell.TH+import Data.Data+import Control.Monad+import Control.Monad.State++-- | Quote a Dynamic expression.  Within the quoted expression, you can use '$(unqDyn [| x |])' to refer to any expression 'x' of type 'Dynamic t a'; the unquoted result will be of type 'a'+qDyn :: Q Exp -> Q Exp+qDyn qe = do+  e <- qe+  let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d+      f d = case eqT of+        Just (Refl :: d :~: Exp)+          | AppE (VarE m) eInner <- d+          , m == 'unqMarker+          -> do n <- lift $ newName "dyn"+                modify ((n, eInner):)+                return $ VarE n+        _ -> gmapM f d+  (e', exprsReversed) <- runStateT (gmapM f e) []+  let exprs = reverse exprsReversed+      arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs+      param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs+  [| mapDyn $(return $ LamE [param] e') =<< distributeFHListOverDyn $(return arg) |]++unqDyn :: Q Exp -> Q Exp+unqDyn e = [| unqMarker $e |]++-- | This type represents an occurrence of unqDyn before it has been processed by qDyn.  If you see it in a type error, it probably means that unqDyn has been used outside of a qDyn context.+data UnqDyn++-- unqMarker must not be exported; it is used only as a way of smuggling data from unqDyn to qDyn+--TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery+unqMarker :: a -> UnqDyn+unqMarker = error "An unqDyn expression was used outside of a qDyn expression"

@@ -0,0 +1,56 @@+{-# LANGUAGE ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, FunctionalDependencies #-}+module Reflex.Host.Class where++import Prelude hiding (mapM, mapM_, sequence, sequence_, foldl)++import Reflex.Class++import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)+import Data.Dependent.Sum (DSum)+import Control.Monad.Ref++class Reflex t => ReflexHost t where+  type EventTrigger t :: * -> *+  type EventHandle t :: * -> *+  type HostFrame t :: * -> *++class (ReflexHost t, Monad m) => MonadReadEvent t m | m -> t where+  readEvent :: EventHandle t a -> m (Maybe (m a))++class (Monad m, ReflexHost t) => MonadReflexCreateTrigger t m | m -> t where+  newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)++class (Monad m, ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexHost t m | m -> t where+  fireEventsAndRead :: [DSum (EventTrigger t)] -> (forall m'. (MonadReadEvent t m') => m' a) -> m a+  subscribeEvent :: Event t a -> m (EventHandle t a) --TODO: Return a handle, and use them in fireEventsAnRead+  runFrame :: PushM t a -> m a+  runHostFrame :: HostFrame t a -> m a++fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t)] -> m ()+{-# INLINE fireEvents #-}+fireEvents dm = fireEventsAndRead dm $ return ()++{-# INLINE newEventWithTriggerRef #-}+newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a)))+newEventWithTriggerRef = do+  rt <- newRef Nothing+  e <- newEventWithTrigger $ \t -> do+    writeRef rt $ Just t+    return $ writeRef rt Nothing+  return (e, rt)++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++instance (Reflex t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (ReaderT r m) where+  newEventWithTrigger initializer = do+    r <- ask+    lift $ newEventWithTrigger initializer++instance (Reflex t, MonadReflexHost t m) => MonadReflexHost t (ReaderT r m) where+  fireEventsAndRead dm a = lift $ fireEventsAndRead dm a+  subscribeEvent = lift . subscribeEvent+  runFrame = lift . runFrame

@@ -0,0 +1,5 @@+module Reflex.Spider ( Spider+                     , SpiderHost (..) --Temporary, until Widget no longer uses unsafePerformIO+                     ) where++import Reflex.Spider.Internal

@@ -0,0 +1,1346 @@+{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase #-}+module Reflex.Spider.Internal where++import Prelude hiding (mapM, mapM_, any, sequence, concat)++import qualified Reflex.Class as R+import qualified Reflex.Host.Class as R++import Data.IORef+import System.Mem.Weak+import Data.Foldable+import Data.Traversable+import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)+import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)+import GHC.Exts+import Control.Applicative+import Data.Dependent.Map (DMap, DSum (..))+import qualified Data.Dependent.Map as DMap+import Data.GADT.Compare+import Data.Functor.Misc+import Data.Maybe+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Control.Lens hiding (coerce)+import Control.Monad.TypedId+import Control.Monad.Ref+import Data.Monoid ((<>))++import System.IO.Unsafe+import Unsafe.Coerce+import Control.Monad.Primitive++debugPropagate :: Bool++debugInvalidateHeight :: Bool++#ifdef DEBUG++#define DEBUG_NODEIDS++debugPropagate = True++debugInvalidateHeight = True++class HasNodeId a where+  getNodeId :: a -> Int++instance HasNodeId (Hold a) where+  getNodeId = holdNodeId++instance HasNodeId (PushSubscribed a b) where+  getNodeId = pushSubscribedNodeId++instance HasNodeId (SwitchSubscribed a) where+  getNodeId = switchSubscribedNodeId++instance HasNodeId (MergeSubscribed a) where+  getNodeId = mergeSubscribedNodeId++instance HasNodeId (FanSubscribed a) where+  getNodeId = fanSubscribedNodeId++instance HasNodeId (CoincidenceSubscribed a) where+  getNodeId = coincidenceSubscribedNodeId++instance HasNodeId (RootSubscribed a) where+  getNodeId = rootSubscribedNodeId++showNodeId :: HasNodeId a => a -> String+showNodeId = ("#"<>) . show . getNodeId++#else++debugPropagate = False++debugInvalidateHeight = False++showNodeId :: a -> String+showNodeId = const ""++#endif++#ifdef DEBUG_NODEIDS+{-# NOINLINE nextNodeIdRef #-}+nextNodeIdRef :: IORef Int+nextNodeIdRef = unsafePerformIO $ newIORef 1++{-# NOINLINE unsafeNodeId #-}+unsafeNodeId :: a -> Int+unsafeNodeId a = unsafePerformIO $ do+  touch a+  atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)+#endif++--TODO: Figure out why certain things are not 'representational', then make them representational so we can use coerce+--type role Hold representational+data Hold a+   = Hold { holdValue :: !(IORef a)+          , holdInvalidators :: !(IORef [Weak Invalidator])+            -- We need to use 'Any' for the next two things, because otherwise Hold inherits a nominal role for its 'a' parameter, and we want to be able to use 'coerce'+          , holdSubscriber :: !(IORef Any) -- Keeps its subscription alive; for some reason, a regular (or strict) reference to the Subscriber itself wasn't working, so had to use an IORef+          , holdParent :: !(IORef Any) -- Keeps its parent alive (will be undefined until the hold is initialized --TODO: Probably shouldn't be an IORef+#ifdef DEBUG_NODEIDS+          , holdNodeId :: Int+#endif+          }++data EventEnv+   = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment])+              , eventEnvHoldInits :: !(IORef [SomeHoldInit])+              , eventEnvClears :: !(IORef [SomeMaybeIORef])+              , eventEnvCurrentHeight :: !(IORef Int)+              , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])+              , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))+              }++runEventM :: EventM a -> EventEnv -> IO a+runEventM = runReaderT . unEventM++askToAssignRef :: EventM (IORef [SomeAssignment])+askToAssignRef = EventM $ asks eventEnvAssignments++askHoldInitRef :: EventM (IORef [SomeHoldInit])+askHoldInitRef = EventM $ asks eventEnvHoldInits++getCurrentHeight :: EventM Int+getCurrentHeight = EventM $ do+  heightRef <- asks eventEnvCurrentHeight+  liftIO $ readIORef heightRef++putCurrentHeight :: Int -> EventM ()+putCurrentHeight h = EventM $ do+  heightRef <- asks eventEnvCurrentHeight+  liftIO $ writeIORef heightRef h++scheduleClear :: IORef (Maybe a) -> EventM ()+scheduleClear r = EventM $ do+  clears <- asks eventEnvClears+  liftIO $ modifyIORef' clears (SomeMaybeIORef r :)++scheduleMerge :: Int -> MergeSubscribed a -> EventM ()+scheduleMerge height subscribed = EventM $ do+  delayedRef <- asks eventEnvDelayedMerges+  liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) height [DelayedMerge subscribed]++emitCoincidenceInfo :: SomeCoincidenceInfo -> EventM ()+emitCoincidenceInfo sci = EventM $ do+  ciRef <- asks eventEnvCoincidenceInfos+  liftIO $ modifyIORef' ciRef (sci:)++-- Note: hold cannot examine its event until after the phase is over+hold :: a -> Event a -> EventM (Behavior a)+hold v0 e = do+  holdInitRef <- askHoldInitRef+  liftIO $ do+    valRef <- newIORef v0+    invsRef <- newIORef []+    parentRef <- newIORef $ error "hold not yet initialized (parent)"+    subscriberRef <- newIORef $ error "hold not yet initialized (subscriber)"+    let h = Hold+          { holdValue = valRef+          , holdInvalidators = invsRef+          , holdSubscriber = subscriberRef+          , holdParent = parentRef+#ifdef DEBUG_NODEIDS+          , holdNodeId = unsafeNodeId (v0, e)+#endif+          }+        !s = SubscriberHold h+    writeIORef subscriberRef $ unsafeCoerce s+    modifyIORef' holdInitRef (SomeHoldInit e h :)+    return $ BehaviorHold h++subscribeHold :: Event a -> Hold a -> EventM ()+subscribeHold e h = do+  toAssignRef <- askToAssignRef+  !s <- liftIO $ liftM unsafeCoerce $ readIORef $ holdSubscriber h -- This must be performed strictly so that the weak pointer points at the actual item+  ws <- liftIO $ mkWeakPtrWithDebug s "holdSubscriber"+  subd <- subscribe e $ WeakSubscriberSimple ws+  liftIO $ writeIORef (holdParent h) $ unsafeCoerce subd+  occ <- liftIO $ getEventSubscribedOcc subd+  case occ of+    Nothing -> return ()+    Just o -> liftIO $ modifyIORef' toAssignRef (SomeAssignment h o :)++--type role BehaviorM representational+-- BehaviorM can sample behaviors+newtype BehaviorM a = BehaviorM { unBehaviorM :: ReaderT (Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed])) IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)++data BehaviorSubscribed a+   = BehaviorSubscribedHold (Hold a)+   | BehaviorSubscribedPull (PullSubscribed a)++data SomeBehaviorSubscribed = forall a. SomeBehaviorSubscribed (BehaviorSubscribed a)++--type role PullSubscribed representational+data PullSubscribed a+   = PullSubscribed { pullSubscribedValue :: !a+                    , pullSubscribedInvalidators :: !(IORef [Weak Invalidator])+                    , pullSubscribedOwnInvalidator :: !Invalidator+                    , pullSubscribedParents :: ![SomeBehaviorSubscribed] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated+                    }++--type role Pull representational+data Pull a+   = Pull { pullValue :: !(IORef (Maybe (PullSubscribed a)))+          , pullCompute :: !(BehaviorM a)+          }++data Invalidator+   = forall a. InvalidatorPull (Pull a)+   | forall a. InvalidatorSwitch (SwitchSubscribed a)++data RootSubscribed a+   = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])+                    , rootSubscribedOccurrence :: !(IORef (Maybe a)) -- Alias to rootOccurrence+                    }++data Root a+   = Root { rootOccurrence :: !(IORef (Maybe a)) -- The currently-firing occurrence of this event+          , rootSubscribed :: !(IORef (Maybe (RootSubscribed a)))+          , rootInit :: !(RootTrigger a -> IO (IO ()))+          }++data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)++-- EventM can do everything BehaviorM can, plus create holds+newtype EventM a = EventM { unEventM :: ReaderT EventEnv IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over++data PushSubscribed a b+   = PushSubscribed { pushSubscribedOccurrence :: !(IORef (Maybe b)) -- If the current height is less than our height, this should always be Nothing; during our height, this will get filled in at some point, always before our children are notified; after our height, this will be filled in with the correct value (Nothing if we are not firing, Just if we are)+                    , pushSubscribedHeight :: !(IORef Int)+                    , pushSubscribedSubscribers :: !(IORef [WeakSubscriber b])+                    , pushSubscribedSelf :: !(Subscriber a) -- Hold this in memory to ensure our WeakReferences don't die+                    , pushSubscribedParent :: !(EventSubscribed a)+#ifdef DEBUG_NODEIDS+                    , pushSubscribedNodeId :: Int+#endif+                    }++data Push a b+   = Push { pushCompute :: !(a -> EventM (Maybe b)) -- Compute the current firing value; assumes that its parent has been computed+          , pushParent :: !(Event a)+          , pushSubscribed :: !(IORef (Maybe (PushSubscribed a b))) --TODO: Can we replace this with an unsafePerformIO thunk?+          }++data MergeSubscribed k+   = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k)))+                     , mergeSubscribedAccum :: !(IORef (DMap k)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence+                     , mergeSubscribedHeight :: !(IORef Int)+                     , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k)])+                     , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory+                     , mergeSubscribedParents :: !(DMap (WrapArg EventSubscribed k))+#ifdef DEBUG_NODEIDS+                     , mergeSubscribedNodeId :: Int+#endif+                     }++--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)+data Merge k+   = Merge { mergeParents :: !(DMap (WrapArg Event k))+           , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk?+           }++data FanSubscriberKey k a where+  FanSubscriberKey :: k a -> FanSubscriberKey k [WeakSubscriber a]++instance GEq k => GEq (FanSubscriberKey k) where+  geq (FanSubscriberKey a) (FanSubscriberKey b) = case geq a b of+    Nothing -> Nothing+    Just Refl -> Just Refl++instance GCompare k => GCompare (FanSubscriberKey k) where+  gcompare (FanSubscriberKey a) (FanSubscriberKey b) = case gcompare a b of+    GLT -> GLT+    GEQ -> GEQ+    GGT -> GGT++data FanSubscribed k+   = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k)))+                   , fanSubscribedParent :: !(EventSubscribed (DMap k))+                   , fanSubscribedSelf :: !(Subscriber (DMap k))+#ifdef DEBUG_NODEIDS+                   , fanSubscribedNodeId :: Int+#endif+                   }++data Fan k+   = Fan { fanParent :: !(Event (DMap k))+         , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))+         }++data SwitchSubscribed a+   = SwitchSubscribed { switchSubscribedOccurrence :: !(IORef (Maybe a))+                      , switchSubscribedHeight :: !(IORef Int)+                      , switchSubscribedSubscribers :: !(IORef [WeakSubscriber a])+                      , switchSubscribedSelf :: !(Subscriber a)+                      , switchSubscribedSelfWeak :: !(IORef (Weak (Subscriber a)))+                      , switchSubscribedOwnInvalidator :: !Invalidator+                      , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak Invalidator))+                      , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed])+                      , switchSubscribedParent :: !(Behavior (Event a))+                      , switchSubscribedCurrentParent :: !(IORef (EventSubscribed a))+#ifdef DEBUG_NODEIDS+                      , switchSubscribedNodeId :: Int+#endif+                      }++data Switch a+   = Switch { switchParent :: !(Behavior (Event a))+            , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed a)))+            }++data CoincidenceSubscribed a+   = CoincidenceSubscribed { coincidenceSubscribedOccurrence :: !(IORef (Maybe a))+                           , coincidenceSubscribedSubscribers :: !(IORef [WeakSubscriber a])+                           , coincidenceSubscribedHeight :: !(IORef Int)+                           , coincidenceSubscribedOuter :: !(Subscriber (Event a))+                           , coincidenceSubscribedOuterParent :: !(EventSubscribed (Event a))+                           , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed a)))+#ifdef DEBUG_NODEIDS+                           , coincidenceSubscribedNodeId :: Int+#endif+                           }++data Coincidence a+   = Coincidence { coincidenceParent :: !(Event (Event a))+                 , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed a)))+                 }++data Box a = Box { unBox :: a }++--type WeakSubscriber a = Weak (Subscriber a)+data WeakSubscriber a+   = forall k. GCompare k => WeakSubscriberMerge !(k a) !(Weak (Box (MergeSubscribed k))) --TODO: Can we inline the GCompare?+   | WeakSubscriberSimple !(Weak (Subscriber a))++showWeakSubscriberType :: WeakSubscriber a -> String+showWeakSubscriberType = \case+  WeakSubscriberMerge _ _ -> "WeakSubscriberMerge"+  WeakSubscriberSimple _ -> "WeakSubscriberSimple"++deRefWeakSubscriber :: WeakSubscriber a -> IO (Maybe (Subscriber a))+deRefWeakSubscriber ws = case ws of+  WeakSubscriberSimple w -> deRefWeak w+  WeakSubscriberMerge k w -> liftM (fmap $ SubscriberMerge k . unBox) $ deRefWeak w++data Subscriber a+   = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b)+   | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?+   | forall k. (GCompare k, a ~ DMap k) => SubscriberFan (FanSubscribed k)+   | SubscriberHold !(Hold a)+   | SubscriberSwitch (SwitchSubscribed a)+   | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)+   | SubscriberCoincidenceInner (CoincidenceSubscribed a)++showSubscriberType :: Subscriber a -> String+showSubscriberType = \case+  SubscriberPush _ _ -> "SubscriberPush"+  SubscriberMerge _ _ -> "SubscriberMerge"+  SubscriberFan _ -> "SubscriberFan"+  SubscriberHold _ -> "SubscriberHold"+  SubscriberSwitch _ -> "SubscriberSwitch"+  SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"+  SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"++data Event a+   = EventRoot !(Root a)+   | EventNever+   | forall b. EventPush !(Push b a)+   | forall k. (GCompare k, a ~ DMap k) => EventMerge !(Merge k)+   | forall k. GCompare k => EventFan !(k a) !(Fan k)+   | EventSwitch !(Switch a)+   | EventCoincidence !(Coincidence a)++showEventType :: Event a -> String+showEventType = \case+  EventRoot _ -> "EventRoot"+  EventNever -> "EventNever"+  EventPush _ -> "EventPush"+  EventMerge _ -> "EventMerge"+  EventFan _ _ -> "EventFan"+  EventSwitch _ -> "EventSwitch"+  EventCoincidence _ -> "EventCoincidence"++data EventSubscribed a+   = EventSubscribedRoot !(RootSubscribed a)+   | EventSubscribedNever+   | forall b. EventSubscribedPush !(PushSubscribed b a)+   | forall k. (GCompare k, a ~ DMap k) => EventSubscribedMerge !(MergeSubscribed k)+   | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)+   | EventSubscribedSwitch !(SwitchSubscribed a)+   | EventSubscribedCoincidence !(CoincidenceSubscribed a)++--type role Behavior representational+data Behavior a+   = BehaviorHold !(Hold a)+   | BehaviorConst !a+   | BehaviorPull !(Pull a)++-- ResultM can read behaviors and events+type ResultM = EventM++{-# NOINLINE unsafeNewIORef #-}+unsafeNewIORef :: a -> b -> IORef b+unsafeNewIORef _ b = unsafePerformIO $ newIORef b++instance Functor Event where+  fmap f = push $ return . Just . f++instance Functor Behavior where+  fmap f = pull . liftM f . readBehaviorTracked++{-# NOINLINE push #-} --TODO: If this is helpful, we can get rid of the unsafeNewIORef and use unsafePerformIO directly+push :: (a -> EventM (Maybe b)) -> Event a -> Event b+push f e = EventPush $ Push+  { pushCompute = f+  , pushParent = e+  , pushSubscribed = unsafeNewIORef (f, e) Nothing --TODO: Does the use of the tuple here create unnecessary overhead?+  }+{-# RULES "push/push" forall f g e. push f (push g e) = push (maybe (return Nothing) f <=< g) e #-}++{-# NOINLINE pull #-}+pull :: BehaviorM a -> Behavior a+pull a = BehaviorPull $ Pull+  { pullCompute = a+  , pullValue = unsafeNewIORef a Nothing+  }+{-# RULES "pull/pull" forall a. pull (readBehaviorTracked (pull a)) = pull a #-}++{-# NOINLINE switch #-}+switch :: Behavior (Event a) -> Event a+switch a = EventSwitch $ Switch+  { switchParent = a+  , switchSubscribed = unsafeNewIORef a Nothing+  }+{-# RULES "switch/constB" forall e. switch (BehaviorConst e) = e #-}++coincidence :: Event (Event a) -> Event a+coincidence a = EventCoincidence $ Coincidence+  { coincidenceParent = a+  , coincidenceSubscribed = unsafeNewIORef a Nothing+  }++newRoot :: IO (Root a)+newRoot = do+  occRef <- newIORef Nothing+  subscribedRef <- newIORef Nothing+  return $ Root+    { rootOccurrence = occRef+    , rootSubscribed = subscribedRef+    , rootInit = const $ return $ return ()+    }++propagateAndUpdateSubscribersRef subscribersRef a = do+  subscribers <- liftIO $ readIORef subscribersRef+  liftIO $ writeIORef subscribersRef []+  stillAlive <- propagate a subscribers+  liftIO $ modifyIORef' subscribersRef (++stillAlive)++-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors+run :: [DSum RootTrigger] -> ResultM b -> IO b+run roots after = do+  when debugPropagate $ putStrLn "Running an event frame"+  result <- runFrame $ do+    forM_ roots $ \(RootTrigger (_, occRef) :=> a) -> do+      liftIO $ writeIORef occRef $ Just a+      scheduleClear occRef+    forM_ roots $ \(RootTrigger (subscribersRef, _) :=> a) -> do+      propagateAndUpdateSubscribersRef subscribersRef a+    delayedRef <- EventM $ asks eventEnvDelayedMerges+    let go = do+          delayed <- liftIO $ readIORef delayedRef+          case IntMap.minViewWithKey delayed of+            Nothing -> return ()+            Just ((currentHeight, current), future) -> do+              when debugPropagate $ liftIO $ putStrLn $ "Running height " ++ show currentHeight+              putCurrentHeight currentHeight+              liftIO $ writeIORef delayedRef future+              forM_ current $ \d -> case d of+                DelayedMerge subscribed -> do+                  height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed+                  case height `compare` currentHeight of+                    LT -> error "Somehow a merge's height has been decreased after it was scheduled"+                    GT -> scheduleMerge height subscribed -- The height has been increased (by a coincidence event; TODO: is this the only way?)+                    EQ -> do+                      m <- liftIO $ readIORef $ mergeSubscribedAccum subscribed+                      liftIO $ writeIORef (mergeSubscribedAccum subscribed) DMap.empty+                      --TODO: Assert that m is not empty+                      liftIO $ writeIORef (mergeSubscribedOccurrence subscribed) $ Just m+                      scheduleClear $ mergeSubscribedOccurrence subscribed+                      propagateAndUpdateSubscribersRef (mergeSubscribedSubscribers subscribed) m+              go+    go+    putCurrentHeight maxBound+    after+  when debugPropagate $ putStrLn "Done running an event frame"+  return result++data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))++data SomeAssignment = forall a. SomeAssignment (Hold a) a++data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)++debugFinalize :: Bool+debugFinalize = False++mkWeakPtrWithDebug :: a -> String -> IO (Weak a)+mkWeakPtrWithDebug x debugNote = mkWeakPtr x $+  if debugFinalize+  then Just $ putStrLn $ "finalizing: " ++ debugNote+  else Nothing++type WeakList a = [Weak a]++--TODO: Is it faster to clean up every time, or to occasionally go through and clean up as needed?+traverseAndCleanWeakList_ :: Monad m => (wa -> m (Maybe a)) -> [wa] -> (a -> m ()) -> m [wa]+traverseAndCleanWeakList_ deRef ws f = go ws+  where go [] = return []+        go (h:t) = do+          ma <- deRef h+          case ma of+            Just a -> do+              f a+              t' <- go t+              return $ h : t'+            Nothing -> go t++-- | Propagate everything at the current height+propagate :: a -> [WeakSubscriber a] -> EventM [WeakSubscriber a]+propagate a subscribers = do+  traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subscribers $ \s -> case s of+    SubscriberPush compute subscribed -> do+      when debugPropagate $ liftIO $ putStrLn $ "SubscriberPush" <> showNodeId subscribed+      occ <- compute a+      case occ of+        Nothing -> return () -- No need to write a Nothing back into the Ref+        Just o -> do+          liftIO $ writeIORef (pushSubscribedOccurrence subscribed) occ+          scheduleClear $ pushSubscribedOccurrence subscribed+          liftIO . writeIORef (pushSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (pushSubscribedSubscribers subscribed))+    SubscriberMerge k subscribed -> do+      when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed+      oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed+      liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k a oldM+      when (DMap.null oldM) $ do -- Only schedule the firing once+        height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed+        --TODO: assertions about height+        currentHeight <- getCurrentHeight+        when (height <= currentHeight) $ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")"+        scheduleMerge height subscribed+    SubscriberFan subscribed -> do+      subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed+      when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"+      --TODO: We need a better DMap intersection; here, we are assuming that the number of firing keys is small and the number of subscribers is large+      forM_ (DMap.toList a) $ \(k :=> v) -> case DMap.lookup (FanSubscriberKey k) subs of+        Nothing -> do+          when debugPropagate $ liftIO $ putStrLn "No subscriber for key"+          return ()+        Just subsubs -> do+          _ <- propagate v subsubs --TODO: use the value of this+          return ()+      --TODO: The following is way too slow to do all the time+      subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> subsubs) -> do+        subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())+        return $ if null subsubs' then Nothing else Just $ FanSubscriberKey k :=> subsubs') :: DSum (FanSubscriberKey k) -> IO (Maybe (DSum (FanSubscriberKey k))))+      liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'+    SubscriberHold h -> do+      invalidators <- liftIO $ readIORef $ holdInvalidators h+      when debugPropagate $ liftIO $ putStrLn $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)+      toAssignRef <- askToAssignRef+      liftIO $ modifyIORef' toAssignRef (SomeAssignment h a :)+    SubscriberSwitch subscribed -> do+      when debugPropagate $ liftIO $ putStrLn $ "SubscriberSwitch" <> showNodeId subscribed+      liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a+      scheduleClear $ switchSubscribedOccurrence subscribed+      subs <- liftIO $ readIORef $ switchSubscribedSubscribers subscribed+      liftIO . writeIORef (switchSubscribedSubscribers subscribed) =<< propagate a subs+    SubscriberCoincidenceOuter subscribed -> do+      when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceOuter" <> showNodeId subscribed+      outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed+      when debugPropagate $ liftIO $ putStrLn $ "  outerHeight = " <> show outerHeight+      (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed+      when debugPropagate $ liftIO $ putStrLn $ "  isJust occ = " <> show (isJust occ)+      when debugPropagate $ liftIO $ putStrLn $ "  innerHeight = " <> show innerHeight+      liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd+      scheduleClear $ coincidenceSubscribedInnerParent subscribed+      case occ of+        Nothing -> do+          when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height+            writeIORef (coincidenceSubscribedHeight subscribed) innerHeight+            mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)+            mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)+        Just o -> do -- Since it's already firing, no need to adjust height+          liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ+          scheduleClear $ coincidenceSubscribedOccurrence subscribed+          liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate o =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))+    SubscriberCoincidenceInner subscribed -> do+      when debugPropagate $ liftIO $ putStrLn $ "SubscriberCoincidenceInner" <> showNodeId subscribed+      liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a+      scheduleClear $ coincidenceSubscribedOccurrence subscribed+      liftIO . writeIORef (coincidenceSubscribedSubscribers subscribed) =<< propagate a =<< liftIO (readIORef (coincidenceSubscribedSubscribers subscribed))++data SomeCoincidenceInfo = forall a. SomeCoincidenceInfo (Weak (Subscriber a)) (Subscriber a) (Maybe (CoincidenceSubscribed a)) -- The CoincidenceSubscriber will be present only if heights need to be reset++subscribeCoincidenceInner :: Event a -> Int -> CoincidenceSubscribed a -> EventM (Maybe a, Int, EventSubscribed a)+subscribeCoincidenceInner o outerHeight subscribedUnsafe = do+  let !subInner = SubscriberCoincidenceInner subscribedUnsafe+  wsubInner <- liftIO $ mkWeakPtrWithDebug subInner "SubscriberCoincidenceInner"+  innerSubd <- {-# SCC "innerSubd" #-} (subscribe o $ WeakSubscriberSimple wsubInner)+  innerOcc <- liftIO $ getEventSubscribedOcc innerSubd+  innerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef innerSubd+  let height = max innerHeight outerHeight+  emitCoincidenceInfo $ SomeCoincidenceInfo wsubInner subInner $ if height > outerHeight then Just subscribedUnsafe else Nothing+  return (innerOcc, height, innerSubd)++readBehavior :: Behavior a -> IO a+readBehavior b = runBehaviorM (readBehaviorTracked b) Nothing --TODO: Specialize readBehaviorTracked to the Nothing and Just cases++runBehaviorM :: BehaviorM a -> Maybe (Weak Invalidator, IORef [SomeBehaviorSubscribed]) -> IO a+runBehaviorM a mwi = runReaderT (unBehaviorM a) mwi++askInvalidator :: BehaviorM (Maybe (Weak Invalidator))+askInvalidator = liftM (fmap fst) $ BehaviorM ask++askParentsRef :: BehaviorM (Maybe (IORef [SomeBehaviorSubscribed]))+askParentsRef = liftM (fmap snd) $ BehaviorM ask++readBehaviorTracked :: Behavior a -> BehaviorM a+readBehaviorTracked b = case b of+  BehaviorHold h -> do+    result <- liftIO $ readIORef $ holdValue h+    askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))+    askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))+    liftIO $ touch $ holdSubscriber h+    return result+  BehaviorConst a -> return a+  BehaviorPull p -> do+    val <- liftIO $ readIORef $ pullValue p+    case val of+      Just subscribed -> do+        askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))+        askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))+        liftIO $ touch $ pullSubscribedOwnInvalidator subscribed+        return $ pullSubscribedValue subscribed+      Nothing -> do+        let !i = InvalidatorPull p+        wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"+        parentsRef <- liftIO $ newIORef []+        a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) $ Just (wi, parentsRef)+        invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator+        parents <- liftIO $ readIORef parentsRef+        let subscribed = PullSubscribed+              { pullSubscribedValue = a+              , pullSubscribedInvalidators = invsRef+              , pullSubscribedOwnInvalidator = i+              , pullSubscribedParents = parents+              }+        liftIO $ writeIORef (pullValue p) $ Just subscribed+        askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))+        return a++readEvent :: Event a -> ResultM (Maybe a)+readEvent e = case e of+  EventRoot r -> liftIO $ readIORef $ rootOccurrence r+  EventNever -> return Nothing+  EventPush p -> do+    subscribed <- getPushSubscribed p+    liftIO $ do+      result <- readIORef $ pushSubscribedOccurrence subscribed -- Since ResultM is always called after the final height is reached, this will always be valid+      touch $ pushSubscribedSelf subscribed+      return result+  EventMerge m -> do+    subscribed <- getMergeSubscribed m+    liftIO $ do+      result <- readIORef $ mergeSubscribedOccurrence subscribed+      touch $ mergeSubscribedSelf subscribed+      return result+  EventFan k f -> do+    parentOcc <- readEvent $ fanParent f+    return $ DMap.lookup k =<< parentOcc+  EventSwitch s -> do+    subscribed <- getSwitchSubscribed s+    liftIO $ do+      result <- readIORef $ switchSubscribedOccurrence subscribed+      touch $ switchSubscribedSelf subscribed+      touch $ switchSubscribedOwnInvalidator subscribed+      return result+  EventCoincidence c -> do+    subscribed <- getCoincidenceSubscribed c+    liftIO $ do+      result <- readIORef $ coincidenceSubscribedOccurrence subscribed+      touch $ coincidenceSubscribedOuter subscribed+      --TODO: do we need to touch the inner subscriber?+      return result++-- Always refers to 0+{-# NOINLINE zeroRef #-}+zeroRef :: IORef Int+zeroRef = unsafePerformIO $ newIORef 0++getEventSubscribed :: Event a -> EventM (EventSubscribed a)+getEventSubscribed e = case e of+  EventRoot r -> liftM EventSubscribedRoot $ getRootSubscribed r+  EventNever -> return EventSubscribedNever+  EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p+  EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f+  EventMerge m -> liftM EventSubscribedMerge $ getMergeSubscribed m+  EventSwitch s -> liftM EventSubscribedSwitch $ getSwitchSubscribed s+  EventCoincidence c -> liftM EventSubscribedCoincidence $ getCoincidenceSubscribed c++debugSubscribe :: Bool+debugSubscribe = False++subscribeEventSubscribed :: EventSubscribed a -> WeakSubscriber a -> IO ()+subscribeEventSubscribed es ws = case es of+  EventSubscribedRoot r -> do+    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Root"+    modifyIORef' (rootSubscribedSubscribers r) (ws:)+  EventSubscribedNever -> do+    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Never"+    return ()+  EventSubscribedPush subscribed -> do+    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Push"+    modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)+  EventSubscribedFan k subscribed -> do+    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"+    modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (++) (FanSubscriberKey k) [ws]+  EventSubscribedMerge subscribed -> do+    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"+    modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)+  EventSubscribedSwitch subscribed -> do+    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Switch"+    modifyIORef' (switchSubscribedSubscribers subscribed) (ws:)+  EventSubscribedCoincidence subscribed -> do+    when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Coincidence"+    modifyIORef' (coincidenceSubscribedSubscribers subscribed) (ws:)++getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)+getEventSubscribedOcc es = case es of+  EventSubscribedRoot r -> readIORef $ rootSubscribedOccurrence r+  EventSubscribedNever -> return Nothing+  EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed+  EventSubscribedFan k subscribed -> do+    parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed+    let occ = DMap.lookup k =<< parentOcc+    return occ+  EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed+  EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed+  EventSubscribedCoincidence subscribed -> readIORef $ coincidenceSubscribedOccurrence subscribed++eventSubscribedHeightRef :: EventSubscribed a -> IORef Int+eventSubscribedHeightRef es = case es of+  EventSubscribedRoot _ -> zeroRef+  EventSubscribedNever -> zeroRef+  EventSubscribedPush subscribed -> pushSubscribedHeight subscribed+  EventSubscribedFan _ subscribed -> eventSubscribedHeightRef $ fanSubscribedParent subscribed+  EventSubscribedMerge subscribed -> mergeSubscribedHeight subscribed+  EventSubscribedSwitch subscribed -> switchSubscribedHeight subscribed+  EventSubscribedCoincidence subscribed -> coincidenceSubscribedHeight subscribed++subscribe :: Event a -> WeakSubscriber a -> EventM (EventSubscribed a)+subscribe e ws = do+  subd <- getEventSubscribed e+  liftIO $ subscribeEventSubscribed subd ws+  return subd++getRootSubscribed :: Root a -> EventM (RootSubscribed a)+getRootSubscribed r = do+  mSubscribed <- liftIO $ readIORef $ rootSubscribed r+  case mSubscribed of+    Just subscribed -> return subscribed+    Nothing -> liftIO $ do+      subscribersRef <- newIORef []+      let !subscribed = RootSubscribed+            { rootSubscribedOccurrence = rootOccurrence r+            , rootSubscribedSubscribers = subscribersRef+            }+      -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory+      uninit <- rootInit r $ RootTrigger (subscribersRef, rootOccurrence r)+      addFinalizer subscribed $ do+--        putStrLn "Uninit root"+        uninit+      liftIO $ writeIORef (rootSubscribed r) $ Just subscribed+      return subscribed++-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in+getPushSubscribed :: Push a b -> EventM (PushSubscribed a b)+getPushSubscribed p = do+  mSubscribed <- liftIO $ readIORef $ pushSubscribed p+  case mSubscribed of+    Just subscribed -> return subscribed+    Nothing -> do -- Not yet subscribed+      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ pushSubscribed p+      let !s = SubscriberPush (pushCompute p) subscribedUnsafe+      ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberPush"+      subd <- subscribe (pushParent p) $ WeakSubscriberSimple ws+      parentOcc <- liftIO $ getEventSubscribedOcc subd+      occ <- liftM join $ mapM (pushCompute p) parentOcc+      occRef <- liftIO $ newIORef occ+      when (isJust occ) $ scheduleClear occRef+      subscribersRef <- liftIO $ newIORef []+      let subscribed = PushSubscribed+            { pushSubscribedOccurrence = occRef+            , pushSubscribedHeight = eventSubscribedHeightRef subd -- Since pushes have the same height as their parents, share the ref+            , pushSubscribedSubscribers = subscribersRef+            , pushSubscribedSelf = unsafeCoerce s+            , pushSubscribedParent = subd+#ifdef DEBUG_NODEIDS+            , pushSubscribedNodeId = unsafeNodeId p+#endif+            }+      liftIO $ writeIORef (pushSubscribed p) $ Just subscribed+      return subscribed++getMergeSubscribed :: forall k. GCompare k => Merge k -> EventM (MergeSubscribed k)+getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do+  mSubscribed <- liftIO $ readIORef $ mergeSubscribed m+  case mSubscribed of+    Just subscribed -> return subscribed+    Nothing -> if DMap.null $ mergeParents m then emptyMergeSubscribed else do+      subscribedRef <- liftIO $ newIORef $ error "getMergeSubscribed: subscribedRef not yet initialized"+      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef+      let !s = Box subscribedUnsafe+      ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"+      subscribers :: [(Any, Maybe (DSum k), Int, DSum (WrapArg EventSubscribed k))] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(WrapArg k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do+        parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws+        parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd+        height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd+        return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (k :=>) parentOcc, height, WrapArg k :=> parentSubd)+      let dm = DMap.fromDistinctAscList $ catMaybes $ map (^._2) subscribers+          subscriberHeights = map (^._3) subscribers+          myHeight =+            if any (==invalidHeight) subscriberHeights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'+            then invalidHeight+            else succ $ Prelude.maximum subscriberHeights -- This is safe because the DMap will never be empty here+      currentHeight <- getCurrentHeight+      let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now+                         then (if DMap.null dm then Nothing else Just dm, DMap.empty)+                         else (Nothing, dm)+      when (not $ DMap.null accum) $ do+        scheduleMerge myHeight subscribedUnsafe+      occRef <- liftIO $ newIORef occ+      when (isJust occ) $ scheduleClear occRef+      accumRef <- liftIO $ newIORef accum+      heightRef <- liftIO $ newIORef myHeight+      subsRef <- liftIO $ newIORef []+      let subscribed = MergeSubscribed+            { mergeSubscribedOccurrence = occRef+            , mergeSubscribedAccum = accumRef+            , mergeSubscribedHeight = heightRef+            , mergeSubscribedSubscribers = subsRef+            , mergeSubscribedSelf = unsafeCoerce $ map (\(x, _, _, _) -> x) subscribers --TODO: Does lack of strictness make this leak?+            , mergeSubscribedParents = DMap.fromDistinctAscList $ map (^._4) subscribers+#ifdef DEBUG_NODEIDS+            , mergeSubscribedNodeId = unsafeNodeId m+#endif+            }+      liftIO $ writeIORef subscribedRef subscribed+      return subscribed+  where emptyMergeSubscribed = do --TODO: This should never happen+          occRef <- liftIO $ newIORef Nothing+          accumRef <- liftIO $ newIORef DMap.empty+          subsRef <- liftIO $ newIORef []+          return $ MergeSubscribed+            { mergeSubscribedOccurrence = occRef+            , mergeSubscribedAccum = accumRef+            , mergeSubscribedHeight = zeroRef+            , mergeSubscribedSubscribers = subsRef --TODO: This will definitely leak+            , mergeSubscribedSelf = unsafeCoerce ()+            , mergeSubscribedParents = DMap.empty+#ifdef DEBUG_NODEIDS+            , mergeSubscribedNodeId = -1+#endif+            }++getFanSubscribed :: GCompare k => Fan k -> EventM (FanSubscribed k)+getFanSubscribed f = do+  mSubscribed <- liftIO $ readIORef $ fanSubscribed f+  case mSubscribed of+    Just subscribed -> return subscribed+    Nothing -> do+      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ liftM fromJust $ readIORef $ fanSubscribed f+      let !sub = SubscriberFan subscribedUnsafe+      wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberFan"+      subd <- subscribe (fanParent f) $ WeakSubscriberSimple wsub+      subscribersRef <- liftIO $ newIORef DMap.empty+      let subscribed = FanSubscribed+            { fanSubscribedParent = subd+            , fanSubscribedSubscribers = subscribersRef+            , fanSubscribedSelf = sub+#ifdef DEBUG_NODEIDS+            , fanSubscribedNodeId = unsafeNodeId f+#endif+            }+      liftIO $ writeIORef (fanSubscribed f) $ Just subscribed+      return subscribed++getSwitchSubscribed :: Switch a -> EventM (SwitchSubscribed a)+getSwitchSubscribed s = do+  mSubscribed <- liftIO $ readIORef $ switchSubscribed s+  case mSubscribed of+    Just subscribed -> return subscribed+    Nothing -> do+      subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"+      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef+      let !i = InvalidatorSwitch subscribedUnsafe+          !sub = SubscriberSwitch subscribedUnsafe+      wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"+      wiRef <- liftIO $ newIORef wi+      wsub <- liftIO $ mkWeakPtrWithDebug sub "SubscriberSwitch"+      selfWeakRef <- liftIO $ newIORef wsub+      parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior+      e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) $ Just (wi, parentsRef)+      subd <- subscribe e $ WeakSubscriberSimple wsub+      subdRef <- liftIO $ newIORef subd+      parentOcc <- liftIO $ getEventSubscribedOcc subd+      occRef <- liftIO $ newIORef parentOcc+      when (isJust parentOcc) $ scheduleClear occRef+      heightRef <- liftIO $ newIORef =<< readIORef (eventSubscribedHeightRef subd)+      subscribersRef <- liftIO $ newIORef []+      let subscribed = SwitchSubscribed+            { switchSubscribedOccurrence = occRef+            , switchSubscribedHeight = heightRef+            , switchSubscribedSubscribers = subscribersRef+            , switchSubscribedSelf = sub+            , switchSubscribedSelfWeak = selfWeakRef+            , switchSubscribedOwnInvalidator = i+            , switchSubscribedOwnWeakInvalidator = wiRef+            , switchSubscribedBehaviorParents = parentsRef+            , switchSubscribedParent = switchParent s+            , switchSubscribedCurrentParent = subdRef+#ifdef DEBUG_NODEIDS+            , switchSubscribedNodeId = unsafeNodeId s+#endif+            }+      liftIO $ writeIORef subscribedRef subscribed+      liftIO $ writeIORef (switchSubscribed s) $ Just subscribed+      return subscribed++getCoincidenceSubscribed :: forall a. Coincidence a -> EventM (CoincidenceSubscribed a)+getCoincidenceSubscribed c = do+  mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c+  case mSubscribed of+    Just subscribed -> return subscribed+    Nothing -> do+      subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"+      subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef+      let !subOuter = SubscriberCoincidenceOuter subscribedUnsafe+      wsubOuter <- liftIO $ mkWeakPtrWithDebug subOuter "subOuter"+      outerSubd <- subscribe (coincidenceParent c) $ WeakSubscriberSimple wsubOuter+      outerOcc <- liftIO $ getEventSubscribedOcc outerSubd+      outerHeight <- liftIO $ readIORef $ eventSubscribedHeightRef outerSubd+      (occ, height, mInnerSubd) <- case outerOcc of+        Nothing -> return (Nothing, outerHeight, Nothing)+        Just o -> do+          (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe+          return (occ, height, Just innerSubd)+      occRef <- liftIO $ newIORef occ+      when (isJust occ) $ scheduleClear occRef+      heightRef <- liftIO $ newIORef height+      innerSubdRef <- liftIO $ newIORef mInnerSubd+      scheduleClear innerSubdRef+      subscribersRef <- liftIO $ newIORef []+      let subscribed = CoincidenceSubscribed+            { coincidenceSubscribedOccurrence = occRef+            , coincidenceSubscribedHeight = heightRef+            , coincidenceSubscribedSubscribers = subscribersRef+            , coincidenceSubscribedOuter = subOuter+            , coincidenceSubscribedOuterParent = outerSubd+            , coincidenceSubscribedInnerParent = innerSubdRef+#ifdef DEBUG_NODEIDS+            , coincidenceSubscribedNodeId = unsafeNodeId c+#endif+            }+      liftIO $ writeIORef subscribedRef subscribed+      liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed+      return subscribed++merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)+merge m = EventMerge $ Merge+  { mergeParents = m+  , mergeSubscribed = unsafeNewIORef m Nothing+  }++newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }++fan :: GCompare k => Event (DMap k) -> EventSelector k+fan e =+  let f = Fan+        { fanParent = e+        , fanSubscribed = unsafeNewIORef e Nothing+        }+  in EventSelector $ \k -> EventFan k f++-- | Run an event action outside of a frame+runFrame :: EventM a -> IO a+runFrame a = do+  toAssignRef <- newIORef [] -- This should only actually get used when events are firing+  holdInitRef <- newIORef []+  heightRef <- newIORef 0+  toClearRef <- newIORef []+  coincidenceInfosRef <- newIORef []+  delayedRef <- liftIO $ newIORef IntMap.empty+  result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef heightRef coincidenceInfosRef delayedRef) $ do+    result <- a+    let runHoldInits = do+          holdInits <- liftIO $ readIORef holdInitRef+          if null holdInits then return () else do+            liftIO $ writeIORef holdInitRef []+            forM_ holdInits $ \(SomeHoldInit e h) -> subscribeHold e h+            runHoldInits+    runHoldInits -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events+    return result+  toClear <- readIORef toClearRef+  forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing+  toAssign <- readIORef toAssignRef+  toReconnectRef <- newIORef []+  forM_ toAssign $ \(SomeAssignment h v) -> do+    writeIORef (holdValue h) v+    writeIORef (holdInvalidators h) =<< invalidate toReconnectRef =<< readIORef (holdInvalidators h)+  coincidenceInfos <- readIORef coincidenceInfosRef+  forM_ coincidenceInfos $ \(SomeCoincidenceInfo wsubInner subInner mcs) -> do+    touch subInner+    finalize wsubInner+    mapM_ invalidateCoincidenceHeight mcs+  toReconnect <- readIORef toReconnectRef+  forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do+    wsub <- readIORef $ switchSubscribedSelfWeak subscribed+    finalize wsub+    wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed+    finalize wi+    let !i = switchSubscribedOwnInvalidator subscribed+    wi' <- mkWeakPtrWithDebug i "wi'"+    writeIORef (switchSubscribedBehaviorParents subscribed) []+    e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed))+    --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times+    let !sub = switchSubscribedSelf subscribed -- Must be done strictly, or the weak pointer will refer to a useless thunk+    wsub' <- mkWeakPtrWithDebug sub "wsub'"+    writeIORef (switchSubscribedSelfWeak subscribed) wsub'+    subd' <- runFrame $ subscribe e $ WeakSubscriberSimple wsub' --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient+    {-+    stackTrace <- liftIO $ liftM renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)+    liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of+      EventRoot _ -> "EventRoot"+      EventNever -> "EventNever"+      _ -> "something else"+    -}+    writeIORef (switchSubscribedCurrentParent subscribed) subd'+    parentHeight <- readIORef $ eventSubscribedHeightRef subd'+    myHeight <- readIORef $ switchSubscribedHeight subscribed+    if parentHeight == myHeight then return () else do+      writeIORef (switchSubscribedHeight subscribed) parentHeight+      mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)+  forM_ coincidenceInfos $ \(SomeCoincidenceInfo _ _ mcs) -> mapM_ recalculateCoincidenceHeight mcs+  forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do+    mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)+  return result++invalidHeight :: Int+invalidHeight = -1000++invalidateSubscriberHeight :: WeakSubscriber a -> IO ()+invalidateSubscriberHeight ws = do+  ms <- deRefWeakSubscriber ws+  case ms of+    Nothing -> return () --TODO: cleanup?+    Just s -> case s of+      SubscriberPush _ subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed+        mapM_ invalidateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"+      SubscriberMerge _ subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed+        oldHeight <- readIORef $ mergeSubscribedHeight subscribed+        when (oldHeight /= invalidHeight) $ do+          writeIORef (mergeSubscribedHeight subscribed) $ invalidHeight+          mapM_ invalidateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"+      SubscriberFan subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed+        subscribers <- readIORef $ fanSubscribedSubscribers subscribed+        forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"+      SubscriberHold _ -> return ()+      SubscriberSwitch subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed+        oldHeight <- readIORef $ switchSubscribedHeight subscribed+        when (oldHeight /= invalidHeight) $ do+          writeIORef (switchSubscribedHeight subscribed) $ invalidHeight+          mapM_ invalidateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"+      SubscriberCoincidenceOuter subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed+        invalidateCoincidenceHeight subscribed+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"+      SubscriberCoincidenceInner subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed+        invalidateCoincidenceHeight subscribed+        when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"++invalidateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()+invalidateCoincidenceHeight subscribed = do+  oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed+  when (oldHeight /= invalidHeight) $ do+    writeIORef (coincidenceSubscribedHeight subscribed) $ invalidHeight+    mapM_ invalidateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed)++--TODO: The recalculation algorithm seems a bit funky; make sure it doesn't miss stuff or hit stuff twice; also, it should probably be lazy++recalculateSubscriberHeight :: WeakSubscriber a -> IO ()+recalculateSubscriberHeight ws = do+  ms <- deRefWeakSubscriber ws+  case ms of+    Nothing -> return () --TODO: cleanup?+    Just s -> case s of+      SubscriberPush _ subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed+        mapM_ recalculateSubscriberHeight =<< readIORef (pushSubscribedSubscribers subscribed)+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberPush" <> showNodeId subscribed <> " done"+      SubscriberMerge _ subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed+        oldHeight <- readIORef $ mergeSubscribedHeight subscribed+        when (oldHeight == invalidHeight) $ do+          height <- calculateMergeHeight subscribed+          when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height+          when (height /= invalidHeight) $ do -- If height == invalidHeight, that means some of the prereqs have not yet been recomputed; when they do recompute, they'll catch this node again --TODO: this is O(n*m), where n is the number of children of this noe and m is the number that have been invalidated+            writeIORef (mergeSubscribedHeight subscribed) height+            mapM_ recalculateSubscriberHeight =<< readIORef (mergeSubscribedSubscribers subscribed)+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberMerge" <> showNodeId subscribed <> " done"+      SubscriberFan subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed+        subscribers <- readIORef $ fanSubscribedSubscribers subscribed+        forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"+      SubscriberHold _ -> return ()+      SubscriberSwitch subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed+        oldHeight <- readIORef $ switchSubscribedHeight subscribed+        when (oldHeight == invalidHeight) $ do+          height <- calculateSwitchHeight subscribed+          when (height /= invalidHeight) $ do+            writeIORef (switchSubscribedHeight subscribed) height+            mapM_ recalculateSubscriberHeight =<< readIORef (switchSubscribedSubscribers subscribed)+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"+      SubscriberCoincidenceOuter subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed+        void $ recalculateCoincidenceHeight subscribed+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"+      SubscriberCoincidenceInner subscribed -> do+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed+        void $ recalculateCoincidenceHeight subscribed+        when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"++recalculateCoincidenceHeight :: CoincidenceSubscribed a -> IO ()+recalculateCoincidenceHeight subscribed = do+  oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed+  when (oldHeight == invalidHeight) $ do+    height <- calculateCoincidenceHeight subscribed+    when (height /= invalidHeight) $ do+      writeIORef (coincidenceSubscribedHeight subscribed) height+      mapM_ recalculateSubscriberHeight =<< readIORef (coincidenceSubscribedSubscribers subscribed) --TODO: This should probably be mandatory, just like with the merge and switch ones++calculateMergeHeight :: MergeSubscribed k -> IO Int+calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do+  heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(WrapArg _ :=> es) -> do+    readIORef $ eventSubscribedHeightRef es+  return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'++calculateSwitchHeight :: SwitchSubscribed a -> IO Int+calculateSwitchHeight subscribed = readIORef . eventSubscribedHeightRef =<< readIORef (switchSubscribedCurrentParent subscribed)++calculateCoincidenceHeight :: CoincidenceSubscribed a -> IO Int+calculateCoincidenceHeight subscribed = do+  outerHeight <- readIORef $ eventSubscribedHeightRef $ coincidenceSubscribedOuterParent subscribed+  innerHeight <- maybe (return 0) (readIORef . eventSubscribedHeightRef) =<< readIORef (coincidenceSubscribedInnerParent subscribed)+  return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight++{-+recalculateEventSubscribedHeight :: EventSubscribed a -> IO Int+recalculateEventSubscribedHeight es = case es of+  EventSubscribedRoot _ -> return 0+  EventSubscribedNever -> return 0+  EventSubscribedPush subscribed -> recalculateEventSubscribedHeight $ pushSubscribedParent subscribed+  EventSubscribedMerge subscribed -> do+    oldHeight <- readIORef $ mergeSubscribedHeight subscribed+    if oldHeight /= invalidHeight then return oldHeight else do+      height <- calculateMergeHeight subscribed+      writeIORef (mergeSubscribedHeight subscribed) height+      return height+  EventSubscribedFan _ subscribed -> recalculateEventSubscribedHeight $ fanSubscribedParent subscribed+  EventSubscribedSwitch subscribed -> do+    oldHeight <- readIORef $ switchSubscribedHeight subscribed+    if oldHeight /= invalidHeight then return oldHeight else do+      height <- calculateSwitchHeight subscribed+      writeIORef (switchSubscribedHeight subscribed) height+      return height+  EventSubscribedCoincidence subscribed -> recalculateCoincidenceHeight subscribed+-}++data SomeSwitchSubscribed = forall a. SomeSwitchSubscribed (SwitchSubscribed a)++debugInvalidate :: Bool+debugInvalidate = False++invalidate :: IORef [SomeSwitchSubscribed] -> WeakList Invalidator -> IO (WeakList Invalidator)+invalidate toReconnectRef wis = do+  forM_ wis $ \wi -> do+    mi <- deRefWeak wi+    case mi of+      Nothing -> do+        when debugInvalidate $ liftIO $ putStrLn "invalidate Dead"+        return () --TODO: Should we clean this up here?+      Just i -> do+        finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict+        case i of+          InvalidatorPull p -> do+            when debugInvalidate $ liftIO $ putStrLn "invalidate Pull"+            mVal <- readIORef $ pullValue p+            forM_ mVal $ \val -> do+              writeIORef (pullValue p) Nothing+              writeIORef (pullSubscribedInvalidators val) =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)+          InvalidatorSwitch subscribed -> do+            when debugInvalidate $ liftIO $ putStrLn "invalidate Switch"+            modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)+  return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them++--------------------------------------------------------------------------------+-- Reflex integration+--------------------------------------------------------------------------------++data Spider++instance R.Reflex Spider where+  newtype Behavior Spider a = SpiderBehavior { unSpiderBehavior :: Behavior a }+  newtype Event Spider a = SpiderEvent { unSpiderEvent :: Event a }+  type PullM Spider = BehaviorM+  type PushM Spider = EventM+  {-# INLINE never #-}+  {-# INLINE constant #-}+  never = SpiderEvent EventNever+  constant = SpiderBehavior . BehaviorConst+  push f = SpiderEvent. push f . unSpiderEvent+  pull = SpiderBehavior . pull+  merge = SpiderEvent . merge . (unsafeCoerce :: DMap (WrapArg (R.Event Spider) k) -> DMap (WrapArg Event k))+  fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))+  switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior+  coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent++instance R.MonadSample Spider SpiderHost where+  {-# INLINE sample #-}+  sample = SpiderHost . readBehavior . unSpiderBehavior++instance R.MonadHold Spider SpiderHost where+  hold v0 = SpiderHost . liftM SpiderBehavior . runFrame . hold v0 . unSpiderEvent++instance R.MonadSample Spider BehaviorM where+  {-# INLINE sample #-}+  sample = readBehaviorTracked . unSpiderBehavior++instance R.MonadSample Spider EventM where+  {-# INLINE sample #-}+  sample = liftIO . readBehavior . unSpiderBehavior++instance R.MonadHold Spider EventM where+  {-# INLINE hold #-}+  hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)++newtype RootTrigger a = RootTrigger (IORef [WeakSubscriber a], IORef (Maybe a))++instance R.ReflexHost Spider where+  type EventTrigger Spider = RootTrigger+  type EventHandle Spider = R.Event Spider+  type HostFrame Spider = SpiderHostFrame++instance R.MonadReadEvent Spider ResultM where+  {-# INLINE readEvent #-}+  readEvent = liftM (fmap return) . readEvent . unSpiderEvent++--TODO: Can probably get rid of this now that we're not using it for performEvent+instance MonadTypedId EventM where+  type TypedId EventM = TypedId IO+  {-# INLINE getTypedId #-}+  getTypedId = do+    liftIO getTypedId++instance MonadRef EventM where+  type Ref EventM = Ref IO+  {-# INLINE newRef #-}+  {-# INLINE readRef #-}+  {-# INLINE writeRef #-}+  {-# INLINE atomicModifyRef #-}+  newRef = liftIO . newRef+  readRef = liftIO . readRef+  writeRef r a = liftIO $ writeRef r a+  atomicModifyRef r f = liftIO $ atomicModifyRef r f++newtype SpiderHost a = SpiderHost { runSpiderHost :: IO a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)++newtype SpiderHostFrame a = SpiderHostFrame { runSpiderHostFrame :: EventM a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO)++instance R.MonadSample Spider SpiderHostFrame where+  sample = SpiderHostFrame . R.sample --TODO: This can cause problems with laziness, so we should get rid of it if we can+  +instance R.MonadHold Spider SpiderHostFrame where+  {-# INLINE hold #-}+  hold v0 e = SpiderHostFrame $ R.hold v0 e++newEventWithTriggerIO f= do+  occRef <- newIORef Nothing+  subscribedRef <- newIORef Nothing+  let !r = Root+        { rootOccurrence = occRef+        , rootSubscribed = subscribedRef+        , rootInit = f+        }+  return $ SpiderEvent $ EventRoot r++instance R.MonadReflexCreateTrigger Spider SpiderHost where+  newEventWithTrigger = SpiderHost . newEventWithTriggerIO++instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where+  newEventWithTrigger = SpiderHostFrame . EventM . liftIO . newEventWithTriggerIO++instance R.MonadReflexHost Spider SpiderHost where+  fireEventsAndRead es a = SpiderHost $ run es a+  subscribeEvent e = SpiderHost $ do+    _ <- runFrame $ getEventSubscribed $ unSpiderEvent e --TODO: The result of this should actually be used+    return e+  runFrame = SpiderHost . runFrame+  runHostFrame = SpiderHost . runFrame . runSpiderHostFrame++instance MonadRef SpiderHost where+  type Ref SpiderHost = Ref IO+  newRef = SpiderHost . newRef+  readRef = SpiderHost . readRef+  writeRef r = SpiderHost . writeRef r+  atomicModifyRef r = SpiderHost . atomicModifyRef r++instance MonadRef SpiderHostFrame where+  type Ref SpiderHostFrame = Ref IO+  newRef = SpiderHostFrame . newRef+  readRef = SpiderHostFrame . readRef+  writeRef r = SpiderHostFrame . writeRef r+  atomicModifyRef r = SpiderHostFrame . atomicModifyRef r