@@ -1,8 +1,25 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleContexts #-}
13{-# LANGUAGE TypeFamilies #-}
24{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−import qualified Data.AppendMap as Map
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE RankNTypes #-}
8+
9+import Control.Lens
10+import Control.Monad.Fix
11+import Data.Align
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
417import Data.Semigroup
5−import Reflex.Dom
18+import Data.These
19+
20+import Reflex
21+import Reflex.Patch.MapWithMove
22+import Test.Run
623
724newtype MyQuery = MyQuery SelectedCount
825 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
@@ -11,19 +28,113 @@ instance Query MyQuery where
1128 type QueryResult MyQuery = ()
1229 crop _ _ = ()
1330
14−instance (Ord k, Query a) => Query (Map.AppendMap k a) where
15− type QueryResult (Map.AppendMap k a) = Map.AppendMap k (QueryResult a)
31+instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where
32+ type QueryResult (Selector k a) = Selector k (QueryResult a)
1633 crop q r = undefined
1734
35+newtype Selector k a = Selector { unSelector :: AppendMap k a }
36+ deriving (Show, Read, Eq, Ord, Functor)
37+
38+instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
39+ (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b
40+ where
41+ f = alignWith $ \case
42+ This x -> Just x
43+ That y -> Just y
44+ These x y ->
45+ let z = x `mappend` y
46+ in if z == mempty then Nothing else Just z
47+
48+instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
49+ mempty = Selector AMap.empty
50+ mappend = (<>)
51+
52+instance (Eq a, Ord k, Group a) => Group (Selector k a) where
53+ negateG = fmap negateG
54+
55+instance (Eq a, Ord k, Group a) => Additive (Selector k a)
56+
1857main :: IO ()
19−main = mainWidget $ do
58+main = do
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 () ]
68+ return ()
69+
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
75+ let replace = fmapMaybe (^? here) pulse
76+ increment = fmapMaybe (^? there) pulse
77+ (_, q) <- runQueryT (w replace increment) $ pure mempty
78+ let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q
79+ return $ AppOut
80+ { _appOut_behavior = current qDyn
81+ , _appOut_event = updated qDyn
82+ }
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
2093 let w = do
21− n <- count =<< button "Increment"
22− display n
23− queryDyn $ zipDynWith Map.singleton n $ pure $ MyQuery $ SelectedCount 1
24− return ()
25− outer = do
26− replace <- button "Replace"
27− widgetHold w $ w <$ replace
28− (_, q) <- runQueryT outer $ pure mempty
29− display $ incrementalToDynamic q
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+-- -}