develop...26fecd3 · reflex

git.iko.soy/reflex

on 26fecd3 help sign in

default.nix+1−1

since splitsnapshots

unifiedsplit

@@ -4,7 +4,7 @@

4}:

5mkDerivation {

6 pname = "reflex";

7− version = "0.3.2";

7+ version = "0.4.0";

8 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;

9 buildDepends = [

10 dependent-map dependent-sum mtl ref-tf semigroups these exception-transformers

reflex.cabal+3−3

@@ -1,5 +1,5 @@

1Name: reflex

2−Version: 0.3.2

2+Version: 0.4.0

3Synopsis: Higher-order Functional Reactive Programming

4Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system

5License: BSD3

@@ -17,8 +17,8 @@ library

17 hs-source-dirs: src

18 build-depends:

19 base >= 4.7 && < 4.9,

20− dependent-sum == 0.2.*,

20+ dependent-sum == 0.3.*,

21− dependent-map == 0.1.*,

21+ dependent-map == 0.2.*,

22 semigroups >= 0.16 && < 0.18,

23 mtl >= 2.1 && < 2.3,

24 containers == 0.5.*,

src/Data/Functor/Misc.hs+26−25

@@ -8,7 +8,7 @@ import Data.Dependent.Map (DMap, DSum (..))

8import qualified Data.Dependent.Map as DMap

9import Data.Typeable hiding (Refl)

10import Data.These

11−import Data.Maybe

11+import Control.Monad.Identity

13data WrapArg :: (k -> *) -> (k -> *) -> * -> * where

14 WrapArg :: f a -> WrapArg g f (g a)

@@ -39,37 +39,38 @@ instance Ord k => GCompare (Const2 k v) where

39 GT -> GGT

41{-# INLINE sequenceDmap #-}

42−sequenceDmap :: (Monad m, GCompare f) => DMap (WrapArg m f) -> m (DMap f)

42+sequenceDmap :: (Monad m, GCompare f) => DMap f m -> m (DMap f Identity)

43−sequenceDmap = DMap.foldrWithKey (\(WrapArg k) mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k v x) (return DMap.empty)

43+sequenceDmap = DMap.foldrWithKey (\k mv mx -> mx >>= \x -> mv >>= \v -> return $ DMap.insert k (Identity v) x)

44+ (return DMap.empty)

45{-# INLINE combineDMapsWithKey #-}

46{-# INLINE combineDMapsWithKey #-}

46−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)

47+combineDMapsWithKey :: forall f g h i. GCompare f => (forall (a :: *). f a -> These (g a) (h a) -> i a) -> DMap f g -> DMap f h -> DMap f i

47combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)

48combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)

48− where go :: [DSum (WrapArg g f)] -> [DSum (WrapArg h f)] -> [DSum (WrapArg i f)]

49+ where go :: [DSum f g] -> [DSum f h] -> [DSum f i]

49− go [] hs = map (\(WrapArg hk :=> hv) -> WrapArg hk :=> f hk (That hv)) hs

50+ go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs

50− go gs [] = map (\(WrapArg gk :=> gv) -> WrapArg gk :=> f gk (This gv)) gs

51+ go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs

51− go gs@((WrapArg gk :=> gv) : gs') hs@((WrapArg hk :=> hv) : hs') = case gk `gcompare` hk of

52+ go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of

52− GLT -> (WrapArg gk :=> f gk (This gv)) : go gs' hs

53+ GLT -> (gk :=> f gk (This gv)) : go gs' hs

53− GEQ -> (WrapArg gk :=> f gk (These gv hv)) : go gs' hs'

54+ GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'

54− GGT -> (WrapArg hk :=> f hk (That hv)) : go gs hs'

55+ GGT -> (hk :=> f hk (That hv)) : go gs hs'

56−wrapDMap :: (forall a. a -> f a) -> DMap k -> DMap (WrapArg f k)

57+wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f

57−wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> WrapArg k :=> f v) . DMap.toAscList

58+wrapDMap f = DMap.fromDistinctAscList . map (\(k :=> Identity v) -> k :=> f v) . DMap.toAscList

59−rewrapDMap :: (forall a. f a -> g a) -> DMap (WrapArg f k) -> DMap (WrapArg g k)

60+rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g

60−rewrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> WrapArg k :=> f v) . DMap.toAscList

61+rewrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> f v) . DMap.toAscList

62−unwrapDMap :: (forall a. f a -> a) -> DMap (WrapArg f k) -> DMap k

63+unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity

63−unwrapDMap f = DMap.fromDistinctAscList . map (\(WrapArg k :=> v) -> k :=> f v) . DMap.toAscList

64+unwrapDMap f = DMap.fromDistinctAscList . map (\(k :=> v) -> k :=> Identity (f v)) . DMap.toAscList

65−unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap (WrapArg f k) -> DMap k

66+unwrapDMapMaybe :: (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity

66−unwrapDMapMaybe f = DMap.fromDistinctAscList . catMaybes . map (\(WrapArg k :=> v) -> fmap (k :=>) $ f v) . DMap.toAscList

67+unwrapDMapMaybe f m = DMap.fromDistinctAscList [k :=> Identity w | (k :=> v) <- DMap.toAscList m, Just w <- [f v]]

68−mapToDMap :: Map k v -> DMap (Const2 k v)

69+mapToDMap :: Map k v -> DMap (Const2 k v) Identity

69−mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList

70+mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList

71−mapWithFunctorToDMap :: Map k (f v) -> DMap (WrapArg f (Const2 k v))

72+mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f

72−mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> WrapArg (Const2 k) :=> v) . Map.toAscList

73+mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> (Const2 k) :=> v) . Map.toAscList

74−dmapToMap :: DMap (Const2 k v) -> Map k v

75+dmapToMap :: DMap (Const2 k v) Identity -> Map k v

75−dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, v)) . DMap.toAscList

76+dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList

src/Reflex/Class.hs+20−16

@@ -45,9 +45,9 @@ class (MonadHold t (PushM t), MonadSample t (PullM t), MonadFix (PushM t), Funct

45 -- | A monad for doing complex pull-based calculations efficiently

46 type PullM t :: * -> *

47 -- | 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

48− 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

48+ merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty

49 -- | Efficiently fan-out an event to many destinations. This function should be partially applied, and then the result applied repeatedly to create child events

50− 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

50+ fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it

51 -- | Create an Event that will occur whenever the currently-selected input Event occurs

52 switch :: Behavior t (Event t a) -> Event t a

53 -- | Create an Event that will occur whenever the input event is occurring and its occurrence value, another Event, is also occurring

@@ -273,30 +273,30 @@ instance GShow (EitherTag l r) where

273 LeftTag -> showString "LeftTag"

274 RightTag -> showString "RightTag"

275

276−instance (Show l, Show r) => ShowTag (EitherTag l r) where

276+instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where

277− showTaggedPrec t n a = case t of

277+ showTaggedPrec t n (Identity a) = case t of

278 LeftTag -> showsPrec n a

279 RightTag -> showsPrec n a

280

281-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.

282−eitherToDSum :: Either a b -> DSum (EitherTag a b)

282+eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity

283eitherToDSum = \case

284− Left a -> LeftTag :=> a

284+ Left a -> (LeftTag :=> Identity a)

285− Right b -> RightTag :=> b

285+ Right b -> (RightTag :=> Identity b)

286

287-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.

288−dsumToEither :: DSum (EitherTag a b) -> Either a b

288+dsumToEither :: DSum (EitherTag a b) Identity -> Either a b

289dsumToEither = \case

290− LeftTag :=> a -> Left a

290+ (LeftTag :=> Identity a) -> Left a

291− RightTag :=> b -> Right b

291+ (RightTag :=> Identity b) -> Right b

292

293-- | Extract the values of a 'DMap' of 'EitherTag's.

294−dmapToThese :: DMap (EitherTag a b) -> Maybe (These a b)

294+dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)

295dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of

296 (Nothing, Nothing) -> Nothing

297− (Just a, Nothing) -> Just $ This a

297+ (Just (Identity a), Nothing) -> Just $ This a

298− (Nothing, Just b) -> Just $ That b

298+ (Nothing, Just (Identity b)) -> Just $ That b

299− (Just a, Just b) -> Just $ These a b

299+ (Just (Identity a), Just (Identity b)) -> Just $ These a b

300

301-- | Create a new 'Event' that occurs if at least one of the supplied

302-- 'Event's occurs. If both occur at the same time they are combined

@@ -320,7 +320,11 @@ instance (Semigroup a, Reflex t) => Monoid (Event t a) where

320-- in the list occurs. If multiple occur at the same time they are

321-- folded from the left with the given function.

322mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

323−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

323+mergeWith f es = fmap (Prelude.foldl1 f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)

324+ . merge

325+ . DMap.fromList

326+ . map (\(k, v) -> (Const2 k) :=> v)

327+ $ zip [0 :: Int ..] es

324

328

325-- | Create a new 'Event' that occurs if at least one of the 'Event's

329-- | Create a new 'Event' that occurs if at least one of the 'Event's

326-- in the list occurs. If multiple occur at the same time the value is

330-- in the list occurs. If multiple occur at the same time the value is

@@ -356,7 +360,7 @@ switchPromptly ea0 eea = do

356

360

357instance Reflex t => Align (Event t) where

361instance Reflex t => Align (Event t) where

358 nil = never

362 nil = never

359− align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [WrapArg LeftTag :=> ea, WrapArg RightTag :=> eb]

363+ align ea eb = fmapMaybe dmapToThese $ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

360

364

361-- | Create a new 'Event' that only occurs if the supplied 'Event'

365-- | Create a new 'Event' that only occurs if the supplied 'Event'

362-- occurs and the 'Behavior' is true at the time of occurence.

366-- occurs and the 'Behavior' is true at the time of occurence.

src/Reflex/Dynamic.hs+22−17

@@ -222,26 +222,26 @@ splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)

222-- | Merge the 'Dynamic' values using their 'Monoid' instance.

223mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)

224mconcatDyn es = do

225− ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es

225+ ddm :: Dynamic t (DMap (Const2 Int a) Identity) <- distributeDMapOverDyn . DMap.fromList . map (\(k, v) -> Const2 k :=> v) $ zip [0 :: Int ..] es

226− mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm

226+ mapDyn (mconcat . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) ddm

227

228-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of

229-- Dynamic values.

230−distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k))

230+distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))

231distributeDMapOverDyn dm = case DMap.toList dm of

232 [] -> return $ constDyn DMap.empty

233− [WrapArg k :=> v] -> mapDyn (DMap.singleton k) v

233+ [k :=> v] -> mapDyn (DMap.singleton k . Identity) v

234 _ -> do

235 let edmPre = merge $ rewrapDMap updated dm

236− edm :: Event t (DMap k) = flip push edmPre $ \o -> return . Just =<< do

236+ edm :: Event t (DMap k Identity) = flip push edmPre $ \o -> return . Just =<< do

237 let f _ = \case

238 This origDyn -> sample $ current origDyn

239 That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap"

240 These _ (Identity newVal) -> return newVal

241 sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)

242− dm0 :: Behavior t (DMap k) = pull $ do

242+ dm0 :: Behavior t (DMap k Identity) = pull $ do

243− liftM DMap.fromList $ forM (DMap.toList dm) $ \(WrapArg k :=> dv) -> liftM (k :=>) $ sample $ current dv

243+ liftM DMap.fromList . forM (DMap.toList dm) $ \(k :=> dv) -> liftM ((k :=>) . Identity) . sample $ current dv

244− bbdm :: Behavior t (Behavior t (DMap k)) <- hold dm0 $ fmap constant edm

244+ bbdm :: Behavior t (Behavior t (DMap k Identity)) <- hold dm0 $ fmap constant edm

245 let bdm = pull $ sample =<< sample bbdm

246 return $ Dynamic bdm edm

247

@@ -379,7 +379,12 @@ data Demux t k = Demux { demuxValue :: Behavior t k

379

380-- | Demultiplex an input value to a 'Demux' with many outputs. At any given time, whichever output is indicated by the given 'Dynamic' will be 'True'.

381demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k

382−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))

382+demux k = Demux (current k)

383+ (fan $ attachWith (\k0 k1 -> if k0 == k1

384+ then DMap.empty

385+ else DMap.fromList [Const2 k0 :=> Identity False,

386+ Const2 k1 :=> Identity True])

387+ (current k) (updated k))

383

388

384--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

389--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

385-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)

390-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)

@@ -417,16 +422,16 @@ data HListPtr l a where

417 HHeadPtr :: HListPtr (h ': t) h

422 HHeadPtr :: HListPtr (h ': t) h

418 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a

423 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a

419

424

420−fhlistToDMap :: forall f l. FHList f l -> DMap (WrapArg f (HListPtr l))

425+fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f

421fhlistToDMap = DMap.fromList . go

426fhlistToDMap = DMap.fromList . go

422− where go :: forall l'. FHList f l' -> [DSum (WrapArg f (HListPtr l'))]

427+ where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]

423 go = \case

428 go = \case

424 FHNil -> []

429 FHNil -> []

425− FHCons h t -> (WrapArg HHeadPtr :=> h) : map (\(WrapArg p :=> v) -> WrapArg (HTailPtr p) :=> v) (go t)

430+ FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> (HTailPtr p) :=> v) (go t)

426

431

427class RebuildSortedHList l where

432class RebuildSortedHList l where

428− rebuildSortedFHList :: [DSum (WrapArg f (HListPtr l))] -> FHList f l

433+ rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l

429− rebuildSortedHList :: [DSum (HListPtr l)] -> HList l

434+ rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l

430

435

431instance RebuildSortedHList '[] where

436instance RebuildSortedHList '[] where

432 rebuildSortedFHList l = case l of

437 rebuildSortedFHList l = case l of

@@ -438,13 +443,13 @@ instance RebuildSortedHList '[] where

438

443

439instance RebuildSortedHList t => RebuildSortedHList (h ': t) where

444instance RebuildSortedHList t => RebuildSortedHList (h ': t) where

440 rebuildSortedFHList l = case l of

445 rebuildSortedFHList l = case l of

441− ((WrapArg HHeadPtr :=> h) : t) -> FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t

446+ ((HHeadPtr :=> h) : t) -> FHCons h . rebuildSortedFHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t

442 _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"

447 _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"

443 rebuildSortedHList l = case l of

448 rebuildSortedHList l = case l of

444− ((HHeadPtr :=> h) : t) -> HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t

449+ ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t

445 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"

450 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"

446

451

447−dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l

452+dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l

448dmapToHList = rebuildSortedHList . DMap.toList

453dmapToHList = rebuildSortedHList . DMap.toList

449

454

450distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))

455distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))

src/Reflex/Host/Class.hs+5−4

@@ -6,6 +6,7 @@ import Reflex.Class

6import Control.Applicative

7import Control.Monad

8import Control.Monad.Fix

9+import Control.Monad.Identity

9import Control.Monad.Trans

10import Control.Monad.Trans

10import Control.Monad.Trans.Reader (ReaderT())

11import Control.Monad.Trans.Reader (ReaderT())

11import Control.Monad.Trans.Writer (WriterT())

12import Control.Monad.Trans.Writer (WriterT())

@@ -84,7 +85,7 @@ class (ReflexHost t, MonadReflexCreateTrigger t m, MonadSubscribeEvent t m, Mona

84 -- The main loop waits for external events to happen (such as keyboard input or a mouse click)

85 -- The main loop waits for external events to happen (such as keyboard input or a mouse click)

85 -- and then fires the corresponding events using this function. The read callback can be used

86 -- and then fires the corresponding events using this function. The read callback can be used

86 -- to read output events and perform a corresponding response action to the external event.

87 -- to read output events and perform a corresponding response action to the external event.

87− fireEventsAndRead :: [DSum (EventTrigger t)] -> (ReadPhase m a) -> m a

88+ fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> (ReadPhase m a) -> m a

89 -- | Run a frame without any events firing.

90 -- | Run a frame without any events firing.

90 --

91 --

@@ -96,7 +97,7 @@ class (ReflexHost t, MonadReflexCreateTrigger t m, MonadSubscribeEvent t m, Mona

96 runHostFrame :: HostFrame t a -> m a

97 runHostFrame :: HostFrame t a -> m a

98-- | Like 'fireEventsAndRead', but without reading any events.

99-- | Like 'fireEventsAndRead', but without reading any events.

99−fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t)] -> m ()

100+fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t) Identity] -> m ()

100fireEvents dm = fireEventsAndRead dm $ return ()

101fireEvents dm = fireEventsAndRead dm $ return ()

101{-# INLINE fireEvents #-}

102{-# INLINE fireEvents #-}

102

103

@@ -120,14 +121,14 @@ fireEventRef mtRef input = do

120 mt <- readRef mtRef

121 mt <- readRef mtRef

121 case mt of

122 case mt of

122 Nothing -> return ()

123 Nothing -> return ()

123− Just trigger -> fireEvents [trigger :=> input]

124+ Just trigger -> fireEvents [trigger :=> Identity input]

124

125

125fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b)

126fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b)

126fireEventRefAndRead mtRef input e = do

127fireEventRefAndRead mtRef input e = do

127 mt <- readRef mtRef

128 mt <- readRef mtRef

128 case mt of

129 case mt of

129 Nothing -> return Nothing -- Since we aren't firing the input, the output can't fire

130 Nothing -> return Nothing -- Since we aren't firing the input, the output can't fire

130− Just trigger -> fireEventsAndRead [trigger :=> input] $ do

131+ Just trigger -> fireEventsAndRead [trigger :=> Identity input] $ do

131 mGetValue <- readEvent e

132 mGetValue <- readEvent e

132 case mGetValue of

133 case mGetValue of

133 Nothing -> return Nothing

134 Nothing -> return Nothing

src/Reflex/Spider/Internal.hs+43−41

@@ -9,13 +9,13 @@ import System.Mem.Weak

9import Data.Foldable

10import Data.Traversable

11import Control.Monad hiding (mapM, mapM_, forM_, forM, sequence)

12+import Control.Monad.Identity

12import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)

13import Control.Monad.Reader hiding (mapM, mapM_, forM_, forM, sequence)

13import GHC.Exts

14import GHC.Exts

14import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2

15import Control.Applicative -- Unconditionally import, because otherwise it breaks on GHC 7.10.1RC2

15import Data.Dependent.Map (DMap, DSum (..))

16import Data.Dependent.Map (DMap, DSum (..))

16import qualified Data.Dependent.Map as DMap

17import qualified Data.Dependent.Map as DMap

17import Data.GADT.Compare

18import Data.GADT.Compare

18−import Data.Functor.Misc

19import Data.Maybe

20import Data.IntMap (IntMap)

21import qualified Data.IntMap as IntMap

@@ -139,7 +139,7 @@ scheduleClear r = EventM $ do

139 clears <- asks eventEnvClears

140 liftIO $ modifyIORef' clears (SomeMaybeIORef r :)

141

142−scheduleRootClear :: IORef (DMap k) -> EventM ()

142+scheduleRootClear :: IORef (DMap k Identity) -> EventM ()

143scheduleRootClear r = EventM $ do

144 clears <- asks eventEnvRootClears

145 liftIO $ modifyIORef' clears (SomeDMapIORef r :)

@@ -223,8 +223,8 @@ data RootSubscribed a

223 }

224

225data Root (k :: * -> *)

226− = Root { rootOccurrence :: !(IORef (DMap k)) -- The currently-firing occurrence of this event

226+ = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event

227− , rootSubscribed :: !(IORef (DMap (WrapArg RootSubscribed k)))

227+ , rootSubscribed :: !(IORef (DMap k RootSubscribed))

228 , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))

229 }

230

@@ -251,12 +251,12 @@ data Push a b

251 }

252

253data MergeSubscribed k

254− = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k)))

254+ = MergeSubscribed { mergeSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))

255− , mergeSubscribedAccum :: !(IORef (DMap k)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence

255+ , mergeSubscribedAccum :: !(IORef (DMap k Identity)) -- This will accumulate occurrences until our height is reached, at which point it will be transferred to mergeSubscribedOccurrence

256 , mergeSubscribedHeight :: !(IORef Int)

257− , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k)])

257+ , mergeSubscribedSubscribers :: !(IORef [WeakSubscriber (DMap k Identity)])

258 , mergeSubscribedSelf :: !Any -- Hold all our Subscribers in memory

259− , mergeSubscribedParents :: !(DMap (WrapArg EventSubscribed k))

259+ , mergeSubscribedParents :: !(DMap k EventSubscribed)

260#ifdef DEBUG_NODEIDS

261 , mergeSubscribedNodeId :: Int

262#endif

@@ -264,7 +264,7 @@ data MergeSubscribed k

264

265--TODO: DMap sucks; we should really write something better (with a functor for the value as well as the key)

266data Merge k

267− = Merge { mergeParents :: !(DMap (WrapArg Event k))

267+ = Merge { mergeParents :: !(DMap k Event)

268 , mergeSubscribed :: !(IORef (Maybe (MergeSubscribed k))) --TODO: Can we replace this with an unsafePerformIO thunk?

269 }

270

@@ -283,16 +283,16 @@ instance GCompare k => GCompare (FanSubscriberKey k) where

283 GGT -> GGT

284

285data FanSubscribed k

286− = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k)))

286+ = FanSubscribed { fanSubscribedSubscribers :: !(IORef (DMap (FanSubscriberKey k) Identity))

287− , fanSubscribedParent :: !(EventSubscribed (DMap k))

287+ , fanSubscribedParent :: !(EventSubscribed (DMap k Identity))

288− , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k))

288+ , fanSubscribedSelf :: {-# NOUNPACK #-} (Subscriber (DMap k Identity))

289#ifdef DEBUG_NODEIDS

290 , fanSubscribedNodeId :: Int

291#endif

292 }

293

294data Fan k

295− = Fan { fanParent :: !(Event (DMap k))

295+ = Fan { fanParent :: !(Event (DMap k Identity))

296 , fanSubscribed :: !(IORef (Maybe (FanSubscribed k)))

297 }

298

@@ -354,7 +354,7 @@ deRefWeakSubscriber ws = case ws of

354data Subscriber a

355 = forall b. SubscriberPush !(a -> EventM (Maybe b)) (PushSubscribed a b)

356 | forall k. GCompare k => SubscriberMerge !(k a) (MergeSubscribed k) --TODO: Can we inline the GCompare?

357− | forall k. (GCompare k, a ~ DMap k) => SubscriberFan (FanSubscribed k)

357+ | forall k. (GCompare k, a ~ DMap k Identity) => SubscriberFan (FanSubscribed k)

358 | SubscriberHold !(Hold a)

359 | SubscriberSwitch (SwitchSubscribed a)

360 | forall b. a ~ Event b => SubscriberCoincidenceOuter (CoincidenceSubscribed b)

@@ -374,7 +374,7 @@ data Event a

374 = forall k. GCompare k => EventRoot !(k a) !(Root k)

375 | EventNever

376 | forall b. EventPush !(Push b a)

377− | forall k. (GCompare k, a ~ DMap k) => EventMerge !(Merge k)

377+ | forall k. (GCompare k, a ~ DMap k Identity) => EventMerge !(Merge k)

378 | forall k. GCompare k => EventFan !(k a) !(Fan k)

379 | EventSwitch !(Switch a)

380 | EventCoincidence !(Coincidence a)

@@ -393,7 +393,7 @@ data EventSubscribed a

393 = EventSubscribedRoot {-# NOUNPACK #-} (RootSubscribed a)

394 | EventSubscribedNever

395 | forall b. EventSubscribedPush !(PushSubscribed b a)

396− | forall k. (GCompare k, a ~ DMap k) => EventSubscribedMerge !(MergeSubscribed k)

396+ | forall k. (GCompare k, a ~ DMap k Identity) => EventSubscribedMerge !(MergeSubscribed k)

397 | forall k. GCompare k => EventSubscribedFan !(k a) !(FanSubscribed k)

398 | EventSubscribedSwitch !(SwitchSubscribed a)

399 | EventSubscribedCoincidence !(CoincidenceSubscribed a)

@@ -424,7 +424,7 @@ newSubscriberHold :: Hold a -> IO (Subscriber a)

424newSubscriberHold h = return $! SubscriberHold h

425

426{-# NOINLINE newSubscriberFan #-}

427−newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k))

427+newSubscriberFan :: GCompare k => FanSubscribed k -> IO (Subscriber (DMap k Identity))

428newSubscriberFan subd = return $! SubscriberFan subd

429

430{-# NOINLINE newSubscriberSwitch #-}

@@ -519,7 +519,7 @@ propagateAndUpdateSubscribersRef subscribersRef a = do

519 liftIO $ modifyIORef' subscribersRef (++stillAlive)

520

521-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors

522−run :: [DSum RootTrigger] -> ResultM b -> IO b

522+run :: [DSum RootTrigger Identity] -> ResultM b -> IO b

523run roots after = do

524 when debugPropagate $ putStrLn "Running an event frame"

525 result <- runFrame $ do

@@ -532,7 +532,7 @@ run roots after = do

532 then do scheduleRootClear occRef

533 return $ Just r

534 else return Nothing

535− forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> a) -> do

535+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do

536 propagateAndUpdateSubscribersRef subscribersRef a

537 delayedRef <- EventM $ asks eventEnvDelayedMerges

538 let go = do

@@ -565,7 +565,7 @@ run roots after = do

565

566data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))

567

568−data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k))

568+data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k Identity))

569

570data SomeAssignment = forall a. SomeAssignment (Hold a) a

571

@@ -611,7 +611,7 @@ propagate a subscribers = do

611 SubscriberMerge k subscribed -> do

612 when debugPropagate $ liftIO $ putStrLn $ "SubscriberMerge" <> showNodeId subscribed

613 oldM <- liftIO $ readIORef $ mergeSubscribedAccum subscribed

614− liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k a oldM

614+ liftIO $ writeIORef (mergeSubscribedAccum subscribed) $ DMap.insertWith (error "Same key fired multiple times for") k (Identity a) oldM

615 when (DMap.null oldM) $ do -- Only schedule the firing once

616 height <- liftIO $ readIORef $ mergeSubscribedHeight subscribed

617 --TODO: assertions about height

@@ -622,17 +622,19 @@ propagate a subscribers = do

622 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

623 when debugPropagate $ liftIO $ putStrLn $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"

624 --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

625− forM_ (DMap.toList a) $ \(k :=> v) -> case DMap.lookup (FanSubscriberKey k) subs of

625+ forM_ (DMap.toList a) $ \(k :=> Identity v) -> case DMap.lookup (FanSubscriberKey k) subs of

626 Nothing -> do

627 when debugPropagate $ liftIO $ putStrLn "No subscriber for key"

628 return ()

629− Just subsubs -> do

629+ Just (Identity subsubs) -> do

630 _ <- propagate v subsubs --TODO: use the value of this

631 return ()

632 --TODO: The following is way too slow to do all the time

633− subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> subsubs) -> do

633+ subs' <- liftIO $ forM (DMap.toList subs) $ ((\(FanSubscriberKey k :=> Identity subsubs) -> do

634 subsubs' <- traverseAndCleanWeakList_ (liftIO . deRefWeakSubscriber) subsubs (const $ return ())

635+ return $ if null subsubs'

636+ then Nothing

635− return $ if null subsubs' then Nothing else Just $ FanSubscriberKey k :=> subsubs') :: DSum (FanSubscriberKey k) -> IO (Maybe (DSum (FanSubscriberKey k))))

637+ else Just $ FanSubscriberKey k :=> Identity subsubs') :: DSum (FanSubscriberKey k) Identity -> IO (Maybe (DSum (FanSubscriberKey k) Identity)))

636 liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'

638 liftIO $ writeIORef (fanSubscribedSubscribers subscribed) $ DMap.fromDistinctAscList $ catMaybes subs'

637 SubscriberHold h -> do

639 SubscriberHold h -> do

638 invalidators <- liftIO $ readIORef $ holdInvalidators h

640 invalidators <- liftIO $ readIORef $ holdInvalidators h

@@ -731,7 +733,7 @@ readBehaviorTracked b = case b of

731

733

732readEvent :: Event a -> ResultM (Maybe a)

734readEvent :: Event a -> ResultM (Maybe a)

733readEvent e = case e of

735readEvent e = case e of

734− EventRoot k r -> liftIO $ liftM (DMap.lookup k) $ readIORef $ rootOccurrence r

736+ EventRoot k r -> liftIO . liftM (fmap runIdentity . DMap.lookup k) . readIORef $ rootOccurrence r

735 EventNever -> return Nothing

737 EventNever -> return Nothing

736 EventPush p -> do

738 EventPush p -> do

737 subscribed <- getPushSubscribed p

739 subscribed <- getPushSubscribed p

@@ -747,7 +749,7 @@ readEvent e = case e of

747 return result

749 return result

748 EventFan k f -> do

750 EventFan k f -> do

749 parentOcc <- readEvent $ fanParent f

751 parentOcc <- readEvent $ fanParent f

750− return $ DMap.lookup k =<< parentOcc

752+ return . fmap runIdentity $ DMap.lookup k =<< parentOcc

751 EventSwitch s -> do

753 EventSwitch s -> do

752 subscribed <- getSwitchSubscribed s

754 subscribed <- getSwitchSubscribed s

753 liftIO $ do

755 liftIO $ do

@@ -794,7 +796,7 @@ subscribeEventSubscribed es ws = case es of

794 modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)

796 modifyIORef' (pushSubscribedSubscribers subscribed) (ws:)

795 EventSubscribedFan k subscribed -> do

797 EventSubscribedFan k subscribed -> do

796 when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"

798 when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Fan"

797− modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (++) (FanSubscriberKey k) [ws]

799+ modifyIORef' (fanSubscribedSubscribers subscribed) $ DMap.insertWith (liftA2 (++)) (FanSubscriberKey k) (Identity [ws])

798 EventSubscribedMerge subscribed -> do

800 EventSubscribedMerge subscribed -> do

799 when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"

801 when debugSubscribe $ liftIO $ putStrLn $ "subscribeEventSubscribed Merge"

800 modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)

802 modifyIORef' (mergeSubscribedSubscribers subscribed) (ws:)

@@ -812,7 +814,7 @@ getEventSubscribedOcc es = case es of

812 EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed

814 EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed

813 EventSubscribedFan k subscribed -> do

815 EventSubscribedFan k subscribed -> do

814 parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed

816 parentOcc <- getEventSubscribedOcc $ fanSubscribedParent subscribed

815− let occ = DMap.lookup k =<< parentOcc

817+ let occ = fmap runIdentity $ DMap.lookup k =<< parentOcc

816 return occ

818 return occ

817 EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed

819 EventSubscribedMerge subscribed -> readIORef $ mergeSubscribedOccurrence subscribed

818 EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed

820 EventSubscribedSwitch subscribed -> readIORef $ switchSubscribedOccurrence subscribed

@@ -841,18 +843,18 @@ noinlineFalse = False

841getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)

843getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)

842getRootSubscribed k r = do

844getRootSubscribed k r = do

843 mSubscribed <- liftIO $ readIORef $ rootSubscribed r

845 mSubscribed <- liftIO $ readIORef $ rootSubscribed r

844− case DMap.lookup (WrapArg k) mSubscribed of

846+ case DMap.lookup k mSubscribed of

845 Just subscribed -> return subscribed

847 Just subscribed -> return subscribed

846 Nothing -> liftIO $ do

848 Nothing -> liftIO $ do

847 subscribersRef <- newIORef []

849 subscribersRef <- newIORef []

848− subscribed <- newRootSubscribed (liftM (DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef

850+ subscribed <- newRootSubscribed (liftM (fmap runIdentity . DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef

849 -- 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

851 -- 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

850 uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)

852 uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)

851 addFinalizer subscribed $ do

853 addFinalizer subscribed $ do

852 when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should

854 when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should

853-- putStrLn "Uninit root"

855-- putStrLn "Uninit root"

854 uninit

856 uninit

855− liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert (WrapArg k) subscribed

857+ liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert k subscribed

856 return subscribed

858 return subscribed

857

859

858-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in

860-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in

@@ -894,11 +896,11 @@ getMergeSubscribed m = {-# SCC "getMergeSubscribed.entire" #-} do

894 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

896 subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef

895 s <- liftIO $ newBox subscribedUnsafe

897 s <- liftIO $ newBox subscribedUnsafe

896 ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"

898 ws <- liftIO $ mkWeakPtrWithDebug s "SubscriberMerge"

897− 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

899+ subscribers :: [(Any, Maybe (DSum k Identity), Int, DSum k EventSubscribed)] <- forM (DMap.toList $ mergeParents m) $ {-# SCC "getMergeSubscribed.a" #-} \(k :=> e) -> {-# SCC "getMergeSubscribed.a1" #-} do

898 parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws

900 parentSubd <- {-# SCC "getMergeSubscribed.a.parentSubd" #-} subscribe e $ WeakSubscriberMerge k ws

899 parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd

901 parentOcc <- {-# SCC "getMergeSubscribed.a.parentOcc" #-} liftIO $ getEventSubscribedOcc parentSubd

900 height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd

902 height <- {-# SCC "getMergeSubscribed.a.height" #-} liftIO $ readIORef $ eventSubscribedHeightRef parentSubd

901− return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap (k :=>) parentOcc, height, WrapArg k :=> parentSubd)

903+ return $ {-# SCC "getMergeSubscribed.a.returnVal" #-} (unsafeCoerce s :: Any, fmap ((k :=>) . Identity) parentOcc, height, k :=> parentSubd)

902 let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers

904 let dm = DMap.fromDistinctAscList $ catMaybes $ map (\(_, x, _, _) -> x) subscribers

903 subscriberHeights = map (\(_, _, x, _) -> x) subscribers

905 subscriberHeights = map (\(_, _, x, _) -> x) subscribers

904 myHeight =

906 myHeight =

@@ -1048,7 +1050,7 @@ getCoincidenceSubscribed c = do

1048 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed

1050 liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed

1049 return subscribed

1051 return subscribed

1050

1052

1051−merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)

1053+merge :: GCompare k => DMap k Event -> Event (DMap k Identity)

1052merge m = EventMerge $ Merge

1054merge m = EventMerge $ Merge

1053 { mergeParents = m

1055 { mergeParents = m

1054 , mergeSubscribed = unsafeNewIORef m Nothing

1056 , mergeSubscribed = unsafeNewIORef m Nothing

@@ -1056,7 +1058,7 @@ merge m = EventMerge $ Merge

1056

1058

1057newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }

1059newtype EventSelector k = EventSelector { select :: forall a. k a -> Event a }

1058

1060

1059−fan :: GCompare k => Event (DMap k) -> EventSelector k

1061+fan :: GCompare k => Event (DMap k Identity) -> EventSelector k

1060fan e =

1062fan e =

1061 let f = Fan

1063 let f = Fan

1062 { fanParent = e

1064 { fanParent = e

@@ -1154,7 +1156,7 @@ invalidateSubscriberHeight ws = do

1154 SubscriberFan subscribed -> do

1156 SubscriberFan subscribed -> do

1155 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1157 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1156 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1158 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1157− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())

1159+ forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ invalidateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())

1158 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1160 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1159 SubscriberHold _ -> return ()

1161 SubscriberHold _ -> return ()

1160 SubscriberSwitch subscribed -> do

1162 SubscriberSwitch subscribed -> do

@@ -1205,7 +1207,7 @@ recalculateSubscriberHeight ws = do

1205 SubscriberFan subscribed -> do

1207 SubscriberFan subscribed -> do

1206 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1208 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

1207 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1209 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1208− forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) -> IO ())

1210+ forM_ (DMap.toList subscribers) $ ((\(FanSubscriberKey _ :=> Identity v) -> mapM_ recalculateSubscriberHeight v) :: DSum (FanSubscriberKey k) Identity -> IO ())

1209 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1211 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

1210 SubscriberHold _ -> return ()

1212 SubscriberHold _ -> return ()

1211 SubscriberSwitch subscribed -> do

1213 SubscriberSwitch subscribed -> do

@@ -1237,7 +1239,7 @@ recalculateCoincidenceHeight subscribed = do

1237

1239

1238calculateMergeHeight :: MergeSubscribed k -> IO Int

1240calculateMergeHeight :: MergeSubscribed k -> IO Int

1239calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do

1241calculateMergeHeight subscribed = if DMap.null (mergeSubscribedParents subscribed) then return 0 else do

1240− heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(WrapArg _ :=> es) -> do

1242+ heights <- forM (DMap.toList $ mergeSubscribedParents subscribed) $ \(_ :=> es) -> do

1241 readIORef $ eventSubscribedHeightRef es

1243 readIORef $ eventSubscribedHeightRef es

1242 return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'

1244 return $ if any (== invalidHeight) heights then invalidHeight else succ $ Prelude.maximum heights --TODO: Replace 'any' with invalidHeight-preserving 'maximum'

1243

1245

@@ -1316,7 +1318,7 @@ instance R.Reflex Spider where

1316 constant = SpiderBehavior . BehaviorConst

1318 constant = SpiderBehavior . BehaviorConst

1317 push f = SpiderEvent. push f . unSpiderEvent

1319 push f = SpiderEvent. push f . unSpiderEvent

1318 pull = SpiderBehavior . pull

1320 pull = SpiderBehavior . pull

1319− merge = SpiderEvent . merge . (unsafeCoerce :: DMap (WrapArg (R.Event Spider) k) -> DMap (WrapArg Event k))

1321+ merge = SpiderEvent . merge . (unsafeCoerce :: DMap k (R.Event Spider) -> DMap k Event)

1320 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

1322 fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

1321 switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior

1323 switch = SpiderEvent . switch . (unsafeCoerce :: Behavior (R.Event Spider a) -> Behavior (Event a)) . unSpiderBehavior

1322 coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent

1324 coincidence = SpiderEvent . coincidence . (unsafeCoerce :: Event (R.Event Spider a) -> Event (Event a)) . unSpiderEvent

@@ -1340,7 +1342,7 @@ instance R.MonadHold Spider EventM where

1340 {-# INLINE hold #-}

1342 {-# INLINE hold #-}

1341 hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)

1343 hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)

1342

1344

1343−data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k), k a)

1345+data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k Identity), k a)

1344newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }

1346newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }

1345

1347

1346instance R.MonadSubscribeEvent Spider SpiderHostFrame where

1348instance R.MonadSubscribeEvent Spider SpiderHostFrame where

test/Reflex/Pure.hs+4−4

@@ -9,7 +9,7 @@ module Reflex.Pure where

10import Reflex.Class

11import Data.Functor.Misc

12−

12+import Control.Monad.Identity

13import Control.Monad

14import Data.MemoTrie

15import Data.Dependent.Map (DMap, GCompare)

@@ -40,15 +40,15 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

40 pull :: PullM (Pure t) a -> Behavior (Pure t) a

41 pull = Behavior . memo

43− merge :: GCompare k => DMap (WrapArg (Event (Pure t)) k) -> Event (Pure t) (DMap k)

43+ merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)

44 merge events = Event $ memo $ \t ->

45 let currentOccurrences = unwrapDMapMaybe (($ t) . unEvent) events

46 in if DMap.null currentOccurrences

47 then Nothing

48 else Just currentOccurrences

50− fan :: GCompare k => Event (Pure t) (DMap k) -> EventSelector (Pure t) k

50+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k

51− fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k

51+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k

53 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a

54 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t

test/Reflex/Test/CrossImpl.hs+2−2

@@ -71,12 +71,12 @@ testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do

71 let times = relevantTestingTimes (bMap, eMap)

72 liftIO performGC

73 outputs <- forM times $ \t -> do

74− forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> val]) =<< readRef rbTrigger

74+ forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger

75 bOutput <- sample b'

76 eOutput <- liftM join $ forM (Map.lookup t eMap) $ \val -> do

77 mret <- readRef reTrigger

78 let firing = case mret of

79− Just ret -> [ret :=> val]

79+ Just ret -> [ret :=> Identity val]

80 Nothing -> []

81 fireEventsAndRead firing $ sequence =<< readEvent e'Handle

82 liftIO performGC