@@ -4,15 +4,21 @@
44{-# LANGUAGE GeneralizedNewtypeDeriving #-}
55{-# LANGUAGE LambdaCase #-}
66{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE RankNTypes #-}
78
89import Control.Lens
910import Control.Monad.Fix
1011import Data.Align
11−import qualified Data.AppendMap as Map
12+import Data.AppendMap (AppendMap)
13+import qualified Data.AppendMap as AMap
14+import Data.Functor.Misc
15+import Data.Map (Map)
16+import qualified Data.Map as Map
1217import Data.Semigroup
1318import Data.These
1419
1520import Reflex
21+import Reflex.Patch.MapWithMove
1622import Test.Run
1723
1824newtype MyQuery = MyQuery SelectedCount
@@ -26,7 +32,7 @@ instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where
2632 type QueryResult (Selector k a) = Selector k (QueryResult a)
2733 crop q r = undefined
2834
29−newtype Selector k a = Selector { unSelector :: Map.AppendMap k a }
35+newtype Selector k a = Selector { unSelector :: AppendMap k a }
3036 deriving (Show, Read, Eq, Ord, Functor)
3137
3238instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
@@ -40,7 +46,7 @@ instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
4046 in if z == mempty then Nothing else Just z
4147
4248instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
43− mempty = Selector Map.empty
49+ mempty = Selector AMap.empty
4450 mappend = (<>)
4551
4652instance (Eq a, Ord k, Group a) => Group (Selector k a) where
@@ -50,25 +56,85 @@ instance (Eq a, Ord k, Group a) => Additive (Selector k a)
5056
5157main :: IO ()
5258main = do
53− [0, 1, 1, 0] <- fmap (map fst . concat) $ runApp app () $ map (Just . That) $
54− [ That ()
55− , This ()
56− , That ()
57− ]
59+ [0, 1, 1, 0] <- fmap (map fst . concat) $
60+ runApp (testQueryT testRunWithReplace) () $ map (Just . That) $
61+ [ That (), This (), That () ]
62+ [0, 1, 1, 0] <- fmap (map fst . concat) $
63+ runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $
64+ [ That (), This (), That () ]
65+ [0, 1, 1, 0] <- fmap (map fst . concat) $
66+ runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $
67+ [ That (), This (), That () ]
5868 return ()
5969
60−app :: (Reflex t, MonadHold t m, MonadAdjust t m, MonadFix m)
61− => AppIn t () (These () ())
62− -> m (AppOut t Int Int)
63−app (AppIn _ pulse) = do
70+testQueryT :: (Reflex t, MonadFix m)
71+ => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ())
72+ -> AppIn t () (These () ())
73+ -> m (AppOut t Int Int)
74+testQueryT w (AppIn _ pulse) = do
6475 let replace = fmapMaybe (^? here) pulse
6576 increment = fmapMaybe (^? there) pulse
66− w = do
67− n <- count increment
68− queryDyn $ zipDynWith (\x y -> Selector (Map.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
69− (_, q) <- runQueryT (runWithReplace w $ w <$ replace) $ pure mempty
70− let qDyn = fmap (head . Map.keys . unSelector) $ incrementalToDynamic q
77+ (_, q) <- runQueryT (w replace increment) $ pure mempty
78+ let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q
7179 return $ AppOut
7280 { _appOut_behavior = current qDyn
7381 , _appOut_event = updated qDyn
7482 }
83+
84+testRunWithReplace :: ( Reflex t
85+ , MonadAdjust t m
86+ , MonadHold t m
87+ , MonadFix m
88+ , MonadQuery t (Selector Int MyQuery) m)
89+ => Event t ()
90+ -> Event t ()
91+ -> m ()
92+testRunWithReplace replace increment = do
93+ let w = do
94+ n <- count increment
95+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
96+ _ <- runWithReplace w $ w <$ replace
97+ return ()
98+
99+testSequenceDMapWithAdjust :: ( Reflex t
100+ , MonadAdjust t m
101+ , MonadHold t m
102+ , MonadFix m
103+ , MonadQuery t (Selector Int MyQuery) m)
104+ => Event t ()
105+ -> Event t ()
106+ -> m ()
107+testSequenceDMapWithAdjust replace increment = do
108+ _ <- listHoldWithKey (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
109+ n <- count increment
110+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
111+ return ()
112+
113+testSequenceDMapWithAdjustWithMove :: ( Reflex t
114+ , MonadAdjust t m
115+ , MonadHold t m
116+ , MonadFix m
117+ , MonadQuery t (Selector Int MyQuery) m)
118+ => Event t ()
119+ -> Event t ()
120+ -> m ()
121+testSequenceDMapWithAdjustWithMove replace increment = do
122+ _ <- listHoldWithKeyWithMove (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
123+ n <- count increment
124+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
125+ return ()
126+
127+listHoldWithKey :: forall t m k v a. (Ord k, MonadHold t m, MonadAdjust t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
128+listHoldWithKey m0 m' f = do
129+ let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
130+ dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
131+ (a0, a') <- sequenceDMapWithAdjust dm0 dm'
132+ fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a'
133+
134+
135+-- scam it out to test traverseDMapWithAdjustWithMove
136+listHoldWithKeyWithMove :: forall t m k v a. (Ord k, MonadHold t m, MonadAdjust t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
137+listHoldWithKeyWithMove m0 m' f = do
138+ (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing)
139+ incrementalToDynamic <$> holdIncremental n0 n'
140+-- -}