c686c75 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Fix an issue where mergeIncrementalWithMove wasn't applying patches correctly

c686c75Ryan Trinkle10 years ago

src/Reflex/Spider/Internal.hs+32−36

compare with develop

unifiedsplit

@@ -85,6 +85,7 @@ import qualified Reflex.Class as R

85import qualified Reflex.Host.Class

86#endif

87import Reflex.Patch

88+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

89-- Note: must come last to silence warnings due to AMP on GHC < 7.10

90-- Note: must come last to silence warnings due to AMP on GHC < 7.10

90import Prelude hiding (any, concat, mapM, mapM_, sequence)

91import Prelude hiding (any, concat, mapM, mapM_, sequence)

@@ -725,10 +726,15 @@ data SpiderTimelineEnv x = SpiderTimelineEnv

725 }

726 }

726type role SpiderTimelineEnv nominal

727type role SpiderTimelineEnv nominal

727

728

729+instance Eq (SpiderTimelineEnv x) where

730+ _ == _ = True -- Since only one exists of each type

731+

728instance GEq SpiderTimelineEnv where

732instance GEq SpiderTimelineEnv where

733+ geqToEq _ = id

729− a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b

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

730− then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

736+ Refl -> same -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

731− else Nothing

737+ else different

732

738

733data EventEnv x

739data EventEnv x

734 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

740 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

@@ -1609,38 +1615,28 @@ mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x

1609mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1615mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1610 where

1616 where

1611 updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

1617 updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

1612− updateMe subscriber heightBagRef oldParents pWrapped = do

1618+ updateMe subscriber heightBagRef oldParents p = do

1613− let p = unPatchDMapWithMove pWrapped

1619+ -- Prepare new parents for insertion

1614− let f (subscriptionsToKill, ps) (k :=> edit) = do

1620+ let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)

1615− let deleteHere = return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1621+ subscribeParent k e = do

1616− insertHere e = do

1617− keyRef <- liftIO $ newIORef k

1622+ keyRef <- liftIO $ newIORef k

1618− let s = subscriber $ liftIO $ readIORef keyRef

1623+ let s = subscriber $ liftIO $ readIORef keyRef

1619− subscription@(EventSubscription _ subd) <- subscribe e s

1624+ subscription@(EventSubscription _ subd) <- subscribe e s

1620− liftIO $ do

1625+ liftIO $ do

1621− newParentHeight <- getEventSubscribedHeight subd

1626+ newParentHeight <- getEventSubscribedHeight subd

1622− let newParent = MergeSubscribedParentWithMove subscription keyRef

1623− modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1627+ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1624− return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1628+ return $ MergeSubscribedParentWithMove subscription keyRef

1625− (mOldSubd, newPs) <- case edit of

1629+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p

1626− DMapEdit_Delete moved -> do

1630+ -- Collect old parents for deletion and update the keys of moved parents

1627− (toDelete, newPs) <- deleteHere

1631+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1628− return (if moved then Nothing else toDelete, newPs)

1632+ moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

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

1633+ Nothing -> do

1635− Just s@(MergeSubscribedParentWithMove _ keyRef) -> do

1634+ return $ Just $ _mergeSubscribedParentWithMove_subscription parent

1636− liftIO $ writeIORef keyRef k

1635+ Just toKey -> do

1637− return $ DMap.insertLookupWithKey' (\_ new _ -> new) k s ps

1636+ liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

1638− return (if moved then Nothing else toDelete, newPs)

1637+ return Nothing

1639− forM_ mOldSubd $ \oldSubd -> do

1638+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1640− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription oldSubd

1639+ return (toDelete, applyAlways p' oldParents)

1641− liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1642− return (maybeToList (_mergeSubscribedParentWithMove_subscription <$> mOldSubd) ++ subscriptionsToKill, newPs)

1643− foldM f ([], oldParents) $ DMap.toList p

1644 getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)

1640 getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)

1645 getInitialSubscribers initialParents subscriber = do

1641 getInitialSubscribers initialParents subscriber = do

1646 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1642 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

@@ -1703,7 +1699,7 @@ mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub

1703 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1699 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1704 writeIORef heightRef $! height

1700 writeIORef heightRef $! height

1705 subscriberRecalculateHeight sub height

1701 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"

1707 subscriber :: forall a. EventM x (k a) -> Subscriber x a

1703 subscriber :: forall a. EventM x (k a) -> Subscriber x a

1708 subscriber getKey = Subscriber

1704 subscriber getKey = Subscriber

1709 { subscriberPropagate = \a -> do

1705 { subscriberPropagate = \a -> do

test/Reflex/Test/CrossImpl.hs+8−1

@@ -20,6 +20,7 @@ import Control.Monad.Ref

20import Reflex.Class

21import Reflex.Dynamic

22import Reflex.Host.Class

23+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

23import qualified Reflex.Pure as P

24import qualified Reflex.Pure as P

24import qualified Reflex.Spider.Internal as S

25import qualified Reflex.Spider.Internal as S

@@ -27,8 +28,10 @@ import Control.Arrow (second, (&&&))

27import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

28import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

28import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

29import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

29import Control.Monad.Writer hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

30import Control.Monad.Writer hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

30−import Data.Dependent.Map (DSum (..))

31+import Data.Dependent.Map (DMap, DSum (..))

32+import qualified Data.Dependent.Map as DMap

31import Data.Foldable

33import Data.Foldable

34+import Data.Functor.Misc

32import Data.Map.Strict (Map)

35import Data.Map.Strict (Map)

33import qualified Data.Map.Strict as Map

36import qualified Data.Map.Strict as Map

34import qualified Data.Set as Set

37import qualified Data.Set as Set

@@ -225,6 +228,10 @@ testCases =

225 let eInner = switch bd

228 let eInner = switch bd

226 e' = leftmost [eOuter, eInner]

229 e' = leftmost [eOuter, eInner]

227 return (b, e')

230 return (b, e')

231+ , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do

232+ x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e

233+ let e' = mergeIncrementalWithMove x :: Event t (DMap (EitherTag () ()) Identity)

234+ return (b, e')

228 ]

235 ]

229

236

230splitRecombineEvent :: Reflex t => Event t a -> Event t String

237splitRecombineEvent :: Reflex t => Event t a -> Event t String