@@ -1,8 +1,25 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE RankNTypes #-}
10+import Control.Monad.Fix
12+import Data.AppendMap (AppendMap)
3−import qualified Data.AppendMap as Map
13+import qualified Data.AppendMap as AMap
14+import Data.Functor.Misc
16+import qualified Data.Map as Map
4import Data.Semigroup
17import Data.Semigroup
5−import Reflex.Dom
18+import Data.These
21+import Reflex.Patch.MapWithMove
7newtype MyQuery = MyQuery SelectedCount
24newtype MyQuery = MyQuery SelectedCount
8 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
25 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
@@ -11,19 +28,113 @@ instance Query MyQuery where
11 type QueryResult MyQuery = ()
28 type QueryResult MyQuery = ()
12 crop _ _ = ()
29 crop _ _ = ()
14−instance (Ord k, Query a) => Query (Map.AppendMap k a) where
31+instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where
15− type QueryResult (Map.AppendMap k a) = Map.AppendMap k (QueryResult a)
32+ type QueryResult (Selector k a) = Selector k (QueryResult a)
16 crop q r = undefined
33 crop q r = undefined
35+newtype Selector k a = Selector { unSelector :: AppendMap k a }
36+ deriving (Show, Read, Eq, Ord, Functor)
38+instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
39+ (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b
41+ f = alignWith $ \case
45+ let z = x `mappend` y
46+ in if z == mempty then Nothing else Just z
48+instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
49+ mempty = Selector AMap.empty
52+instance (Eq a, Ord k, Group a) => Group (Selector k a) where
53+ negateG = fmap negateG
55+instance (Eq a, Ord k, Group a) => Additive (Selector k a)
18main :: IO ()
57main :: 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 () ]
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
80+ { _appOut_behavior = current qDyn
81+ , _appOut_event = updated qDyn
84+testRunWithReplace :: ( Reflex t
88+ , MonadQuery t (Selector Int MyQuery) m)
92+testRunWithReplace replace increment = do
20 let w = do
93 let w = do
21− n <- count =<< button "Increment"
94+ n <- count increment
22− display n
95+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
96+ _ <- runWithReplace w $ w <$ replace
99+testSequenceDMapWithAdjust :: ( Reflex t
103+ , MonadQuery t (Selector Int MyQuery) 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
113+testSequenceDMapWithAdjustWithMove :: ( Reflex t
117+ , MonadQuery t (Selector Int MyQuery) m)
121+testSequenceDMapWithAdjustWithMove replace increment = do
122+ _ <- listHoldWithKeyWithMove (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
123+ n <- count increment
23− queryDyn $ zipDynWith Map.singleton n $ pure $ MyQuery $ SelectedCount 1
124+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
24− return ()
125+ return ()
26− replace <- button "Replace"
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))
27− widgetHold w $ w <$ replace
128+listHoldWithKey m0 m' f = do
28− (_, q) <- runQueryT outer $ pure mempty
129+ let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
29− display $ incrementalToDynamic q
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'
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'