git.iko.soy/patch
on develop help sign in
start fix of QueryT; runWithReplace fixed but no test yet
7709fb1Dan Haraj
src/Reflex/Query/Base.hs+19−9
compare with develop
unifiedsplit
@@ -60,18 +60,28 @@ getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
60getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
60getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
61getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
61getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
62
62
63+{-
64+let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
65+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
66+ bs' = fmapCheap snd $ r'
67+ patches = unsafeBuildIncremental (sampleBs bs0) $
68+ flip pushCheap bs' $ \bs -> do
69+ p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
70+ return (Just (AdditivePatch p))
71+-}
72+
63instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, MonadAdjust t m) => MonadAdjust t (QueryT t q m) where
73instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, MonadAdjust t m) => MonadAdjust t (QueryT t q m) where
64 runWithReplace (QueryT a0) a' = do
74 runWithReplace (QueryT a0) a' = do
65 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
75 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
66− tellQueryIncremental $
67− let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
76+ let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
68− sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
77+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
69− bs' = fmapCheap snd $ r'
78+ bs' = fmapCheap snd $ r'
70− patches = unsafeBuildIncremental (sampleBs bs0) $
79+ bbs <- hold bs0 bs'
71− flip pushCheap bs' $ \bs -> do
80+ let patches = flip pushAlwaysCheap bs' $ \newBs -> do
72− p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
81+ oldBs <- sample bbs
73− return (Just (AdditivePatch p))
82+ (~~) <$> sampleBs newBs <*> sampleBs oldBs
83+ QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
74− in patches
84+ QueryT $ lift $ tellEvent patches
75 return (r0, fmapCheap fst r')
85 return (r0, fmapCheap fst r')
76 traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))
86 traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))
77 traverseDMapWithKeyWithAdjust f dm0 dm' = do
87 traverseDMapWithKeyWithAdjust f dm0 dm' = do
test/QueryT.hs+34−4
@@ -1,8 +1,16 @@
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+import Data.Align
3import qualified Data.AppendMap as Map
8import qualified Data.AppendMap as Map
4import Data.Semigroup
9import Data.Semigroup
10+import Data.These
11+
5−import Reflex.Dom
12+import Reflex
13+import Test.Run
6
14
7newtype MyQuery = MyQuery SelectedCount
15newtype MyQuery = MyQuery SelectedCount
8 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
16 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
@@ -11,16 +19,38 @@ instance Query MyQuery where
11 type QueryResult MyQuery = ()
19 type QueryResult MyQuery = ()
12 crop _ _ = ()
20 crop _ _ = ()
13
21
14−instance (Ord k, Query a) => Query (Map.AppendMap k a) where
22+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)
23+ type QueryResult (Selector k a) = Selector k (QueryResult a)
16 crop q r = undefined
24 crop q r = undefined
17
25
26+newtype Selector k a = Selector { unSelector :: Map.AppendMap k a }
27+ deriving (Show, Read, Eq, Ord, Functor)
28+
29+instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
30+ (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b
31+ where
32+ f = alignWith $ \case
33+ This x -> Just x
34+ That y -> Just y
35+ These x y ->
36+ let z = x `mappend` y
37+ in if z == mempty then Nothing else Just z
38+
39+instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
40+ mempty = Selector Map.empty
41+ mappend = (<>)
42+
43+instance (Eq a, Ord k, Group a) => Group (Selector k a) where
44+ negateG = fmap negateG
45+
46+instance (Eq a, Ord k, Group a) => Additive (Selector k a)
47+
18main :: IO ()
48main :: IO ()
19main = mainWidget $ do
49main = mainWidget $ do
20 let w = do
50 let w = do
21 n <- count =<< button "Increment"
51 n <- count =<< button "Increment"
22 display n
52 display n
23− queryDyn $ zipDynWith Map.singleton n $ pure $ MyQuery $ SelectedCount 1
53+ queryDyn $ zipDynWith (\x y -> Selector (Map.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
24 return ()
54 return ()
25 outer = do
55 outer = do
26 replace <- button "Replace"
56 replace <- button "Replace"