@@ -85,6 +85,7 @@ import qualified Reflex.Class as R
8585import qualified Reflex.Host.Class
8686#endif
8787import Reflex.Patch
88+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
8889
8990-- Note: must come last to silence warnings due to AMP on GHC < 7.10
9091import Prelude hiding (any, concat, mapM, mapM_, sequence)
@@ -725,10 +726,15 @@ data SpiderTimelineEnv x = SpiderTimelineEnv
725726 }
726727type role SpiderTimelineEnv nominal
727728
729+instance Eq (SpiderTimelineEnv x) where
730+ _ == _ = True -- Since only one exists of each type
731+
728732instance GEq SpiderTimelineEnv where
729− a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
730− then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
731− else Nothing
733+ geqToEq _ = id
734+ geqUnify (a :: SpiderTimelineEnv a) (b :: SpiderTimelineEnv b) different same = if _spiderTimeline_lock a == _spiderTimeline_lock b
735+ then case unsafeCoerce Refl :: a :~: b of
736+ Refl -> same -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
737+ else different
732738
733739data EventEnv x
734740 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
@@ -1609,38 +1615,28 @@ mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x
16091615mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy DMap.size
16101616 where
16111617 updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1612− updateMe subscriber heightBagRef oldParents pWrapped = do
1613− let p = unPatchDMapWithMove pWrapped
1614− let f (subscriptionsToKill, ps) (k :=> edit) = do
1615− let deleteHere = return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1616− insertHere e = do
1617− keyRef <- liftIO $ newIORef k
1618− let s = subscriber $ liftIO $ readIORef keyRef
1619− subscription@(EventSubscription _ subd) <- subscribe e s
1620− liftIO $ do
1621− newParentHeight <- getEventSubscribedHeight subd
1622− let newParent = MergeSubscribedParentWithMove subscription keyRef
1623− modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1624− return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1625− (mOldSubd, newPs) <- case edit of
1626− DMapEdit_Delete moved -> do
1627− (toDelete, newPs) <- deleteHere
1628− return (if moved then Nothing else toDelete, newPs)
1629− DMapEdit_Insert moved e -> do
1630− (toDelete, newPs) <- insertHere e
1631− return (if moved then Nothing else toDelete, newPs)
1632− DMapEdit_Move moved sourceKey -> do
1633− (toDelete, newPs) <- case DMap.lookup sourceKey ps of
1634− Nothing -> deleteHere
1635− Just s@(MergeSubscribedParentWithMove _ keyRef) -> do
1636− liftIO $ writeIORef keyRef k
1637− return $ DMap.insertLookupWithKey' (\_ new _ -> new) k s ps
1638− return (if moved then Nothing else toDelete, newPs)
1639− forM_ mOldSubd $ \oldSubd -> do
1640− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription oldSubd
1641− liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1642− return (maybeToList (_mergeSubscribedParentWithMove_subscription <$> mOldSubd) ++ subscriptionsToKill, newPs)
1643− foldM f ([], oldParents) $ DMap.toList p
1618+ updateMe subscriber heightBagRef oldParents p = do
1619+ -- Prepare new parents for insertion
1620+ let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1621+ subscribeParent k e = do
1622+ keyRef <- liftIO $ newIORef k
1623+ let s = subscriber $ liftIO $ readIORef keyRef
1624+ subscription@(EventSubscription _ subd) <- subscribe e s
1625+ liftIO $ do
1626+ newParentHeight <- getEventSubscribedHeight subd
1627+ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1628+ return $ MergeSubscribedParentWithMove subscription keyRef
1629+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1630+ -- Collect old parents for deletion and update the keys of moved parents
1631+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1632+ moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1633+ Nothing -> do
1634+ return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1635+ Just toKey -> do
1636+ liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1637+ return Nothing
1638+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1639+ return (toDelete, applyAlways p' oldParents)
16441640 getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
16451641 getInitialSubscribers initialParents subscriber = do
16461642 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
@@ -1703,7 +1699,7 @@ mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub
17031699 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
17041700 writeIORef heightRef $! height
17051701 subscriberRecalculateHeight sub height
1706− GT -> error $ "revalidateMergeHeight: more heights than parents for Merge"
1702+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (numParents parents) <> ") for Merge"
17071703 subscriber :: forall a. EventM x (k a) -> Subscriber x a
17081704 subscriber getKey = Subscriber
17091705 { subscriberPropagate = \a -> do