git.iko.soy/patch
on develop help sign in
start fix of QueryT; runWithReplace fixed but no test yet
commit7709fb1dac75d6625b43d14a969a321a1953f9af authorDan Haraj <dan@obsidian.systems> dateMon 5 Jun 2017, 11:01 (9 years ago) parent4e4600f
2 files changed+53−13
compare with develop
unifiedsplit
src/Reflex/Query/Base.hs+19−9 test/QueryT.hs+34−4
src/Reflex/Query/Base.hs+19−9
@@ -60,18 +60,28 @@ getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
6060getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
6161getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
6262
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+
6373instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, MonadAdjust t m) => MonadAdjust t (QueryT t q m) where
6474 runWithReplace (QueryT a0) a' = do
6575 ((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
68− sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
69− bs' = fmapCheap snd $ r'
70− patches = unsafeBuildIncremental (sampleBs bs0) $
71− flip pushCheap bs' $ \bs -> do
72− p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
73− return (Just (AdditivePatch p))
74− in patches
76+ let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
77+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
78+ bs' = fmapCheap snd $ r'
79+ bbs <- hold bs0 bs'
80+ let patches = flip pushAlwaysCheap bs' $ \newBs -> do
81+ oldBs <- sample bbs
82+ (~~) <$> sampleBs newBs <*> sampleBs oldBs
83+ QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
84+ QueryT $ lift $ tellEvent patches
7585 return (r0, fmapCheap fst r')
7686 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'))
7787 traverseDMapWithKeyWithAdjust f dm0 dm' = do
test/QueryT.hs+34−4
@@ -1,8 +1,16 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleContexts #-}
13{-# LANGUAGE TypeFamilies #-}
24{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+import Data.Align
38import qualified Data.AppendMap as Map
49import Data.Semigroup
5−import Reflex.Dom
10+import Data.These
11+
12+import Reflex
13+import Test.Run
614
715newtype MyQuery = MyQuery SelectedCount
816 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
@@ -11,16 +19,38 @@ instance Query MyQuery where
1119 type QueryResult MyQuery = ()
1220 crop _ _ = ()
1321
14−instance (Ord k, Query a) => Query (Map.AppendMap k a) where
15− type QueryResult (Map.AppendMap k a) = Map.AppendMap k (QueryResult a)
22+instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where
23+ type QueryResult (Selector k a) = Selector k (QueryResult a)
1624 crop q r = undefined
1725
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+
1848main :: IO ()
1949main = mainWidget $ do
2050 let w = do
2151 n <- count =<< button "Increment"
2252 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
2454 return ()
2555 outer = do
2656 replace <- button "Replace"