git.iko.soy/patch
on develop help sign in
Make names clearer for tests for RequesterT and EventWriterT; add QueryT tests
6185f41Dan Haraj
test/EventWriterT.hs+6−13
compare with develop
unifiedsplit
@@ -9,21 +9,14 @@ import Reflex
9import Reflex.EventWriter
9import Reflex.EventWriter
10import Test.Run
10import Test.Run
11
11
12−import System.Exit (exitFailure)
13−
14−import Data.IORef
15−import Control.Monad.Ref
16−import Reflex.Host.Class
17−import Data.List
18−
19main :: IO ()
12main :: IO ()
20main = do
13main = do
21− os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp app1) $
14+ os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $
22 [ Just ()
15 [ Just ()
23 ]
16 ]
24 print os1
17 print os1
25 os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]
18 os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]
26− <- runApp' (unwrapApp app2) $ map Just $
19+ <- runApp' (unwrapApp testSimultaneous) $ map Just $
27 [ This ()
20 [ This ()
28 , That ()
21 , That ()
29 , This ()
22 , This ()
@@ -37,13 +30,13 @@ unwrapApp x appIn = do
37 ((), e) <- runEventWriterT $ x appIn
30 ((), e) <- runEventWriterT $ x appIn
38 return e
31 return e
39
32
40−app1 :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()
33+testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()
41−app1 pulse = do
34+testOrdering pulse = do
42 forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)
35 forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)
43 return ()
36 return ()
44
37
45−app2 :: (Reflex t, MonadAdjust t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()
38+testSimultaneous :: (Reflex t, MonadAdjust t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()
46−app2 pulse = do
39+testSimultaneous pulse = do
47 let e0 = fmapMaybe (^? here) pulse
40 let e0 = fmapMaybe (^? here) pulse
48 e1 = fmapMaybe (^? there) pulse
41 e1 = fmapMaybe (^? there) pulse
49 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)
42 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)
test/QueryT.hs+83−17
@@ -4,15 +4,21 @@
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE RankNTypes #-}
7
8
8import Control.Lens
9import Control.Lens
9import Control.Monad.Fix
10import Control.Monad.Fix
10import Data.Align
11import Data.Align
12+import Data.AppendMap (AppendMap)
11−import qualified Data.AppendMap as Map
13+import qualified Data.AppendMap as AMap
14+import Data.Functor.Misc
15+import Data.Map (Map)
16+import qualified Data.Map as Map
12import Data.Semigroup
17import Data.Semigroup
13import Data.These
18import Data.These
14
19
15import Reflex
20import Reflex
21+import Reflex.Patch.MapWithMove
16import Test.Run
22import Test.Run
17
23
18newtype MyQuery = MyQuery SelectedCount
24newtype MyQuery = MyQuery SelectedCount
@@ -26,7 +32,7 @@ instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where
26 type QueryResult (Selector k a) = Selector k (QueryResult a)
32 type QueryResult (Selector k a) = Selector k (QueryResult a)
27 crop q r = undefined
33 crop q r = undefined
28
34
29−newtype Selector k a = Selector { unSelector :: Map.AppendMap k a }
35+newtype Selector k a = Selector { unSelector :: AppendMap k a }
30 deriving (Show, Read, Eq, Ord, Functor)
36 deriving (Show, Read, Eq, Ord, Functor)
31
37
32instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
38instance (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
40 in if z == mempty then Nothing else Just z
46 in if z == mempty then Nothing else Just z
41
47
42instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
48instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
43− mempty = Selector Map.empty
49+ mempty = Selector AMap.empty
44 mappend = (<>)
50 mappend = (<>)
45
51
46instance (Eq a, Ord k, Group a) => Group (Selector k a) where
52instance (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)
50
56
51main :: IO ()
57main :: IO ()
52main = do
58main = do
53− [0, 1, 1, 0] <- fmap (map fst . concat) $ runApp app () $ map (Just . That) $
59+ [0, 1, 1, 0] <- fmap (map fst . concat) $
60+ runApp (testQueryT testRunWithReplace) () $ map (Just . That) $
54− [ That ()
61+ [ That (), This (), That () ]
62+ [0, 1, 1, 0] <- fmap (map fst . concat) $
63+ runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $
55− , This ()
64+ [ That (), This (), That () ]
56− , That ()
65+ [0, 1, 1, 0] <- fmap (map fst . concat) $
57− ]
66+ runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $
67+ [ That (), This (), That () ]
58 return ()
68 return ()
59
69
60−app :: (Reflex t, MonadHold t m, MonadAdjust t m, MonadFix m)
70+testQueryT :: (Reflex t, MonadFix m)
71+ => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ())
61− => AppIn t () (These () ())
72+ -> AppIn t () (These () ())
62− -> m (AppOut t Int Int)
73+ -> m (AppOut t Int Int)
63−app (AppIn _ pulse) = do
74+testQueryT w (AppIn _ pulse) = do
64 let replace = fmapMaybe (^? here) pulse
75 let replace = fmapMaybe (^? here) pulse
65 increment = fmapMaybe (^? there) pulse
76 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
77+ (_, q) <- runQueryT (w replace increment) $ pure mempty
70− let qDyn = fmap (head . Map.keys . unSelector) $ incrementalToDynamic q
78+ let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q
71 return $ AppOut
79 return $ AppOut
72 { _appOut_behavior = current qDyn
80 { _appOut_behavior = current qDyn
73 , _appOut_event = updated qDyn
81 , _appOut_event = updated qDyn
74 }
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
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+-- -}
test/RequesterT.hs+43−40
@@ -1,62 +1,65 @@
1{-# LANGUAGE FlexibleContexts, GADTs, RankNTypes, ScopedTypeVariables #-}
1{-# LANGUAGE FlexibleContexts, GADTs, RankNTypes, ScopedTypeVariables #-}
2module Main where
2module Main where
3
3
4+import Control.Lens
4import Control.Monad
5import Control.Monad
5−import Control.Monad.IO.Class
6−import Control.Monad.Ref
7import qualified Data.Dependent.Map as DMap
6import qualified Data.Dependent.Map as DMap
8import Data.Dependent.Sum
7import Data.Dependent.Sum
9−import Data.IORef
8+import Data.These
10−import Data.List
11−import Data.Functor.Identity
12
9
13import Reflex
10import Reflex
14−import Reflex.Host.Class
15−import Reflex.PerformEvent.Base
16import Reflex.Requester.Base
11import Reflex.Requester.Base
17import Reflex.Requester.Class
12import Reflex.Requester.Class
18import Test.Run
13import Test.Run
19
14
20−import System.Exit (exitFailure, exitSuccess)
21−
22data RequestInt a where
15data RequestInt a where
23 RequestInt :: Int -> RequestInt Int
16 RequestInt :: Int -> RequestInt Int
24
17
25main :: IO ()
18main :: IO ()
26main = do
19main = do
20+ os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $
21+ [ Just ()
22+ ]
23+ print os1
24+ os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]
25+ <- runApp' (unwrapApp testSimultaneous) $ map Just $
26+ [ This ()
27+ , That ()
28+ , This ()
29+ , These () ()
30+ ]
31+ print os2
27 return ()
32 return ()
28
33
29−{-
30−
31−main :: IO ()
32−main = do
33− (Just out1, Nothing) <- runApp $ unwrapApp app1
34− print out1
35− (Just out2, Just (out3, out4)) <- runApp $ unwrapApp app2
36− print out2
37− print out3
38− print out4
39− when (sort out1 /= out1 || map (+1) out2 /= out3 || out3 /= out4) exitFailure
40−
41unwrapRequest :: DSum tag RequestInt -> Int
34unwrapRequest :: DSum tag RequestInt -> Int
42unwrapRequest (_ :=> RequestInt i) = i
35unwrapRequest (_ :=> RequestInt i) = i
43
36
44−unwrapApp :: forall x t a response. (Reflex t, ReflexHost t)
37+unwrapApp :: ( Reflex t, Monad m )
45− => (x -> RequesterT t RequestInt response (PerformEventT t (SpiderHost Global)) a)
38+ => (a -> RequesterT t RequestInt Identity m ())
46− -> x -> PerformEventT t (SpiderHost Global) (a, Event t [Int])
39+ -> a
40+ -> m (Event t [Int])
47−unwrapApp x e = do
41+unwrapApp x appIn = do
48− (a, b) <- runRequesterT (x e) never
42+ ((), e) <- runRequesterT (x appIn) never
49− return (a, fmap (map unwrapRequest . DMap.toList) b)
43+ return $ fmap (map unwrapRequest . DMap.toList) e
50−
44+
51−app1 :: (Reflex t, Ref m ~ IORef, Requester t m, Response m ~ Identity, Request m ~ RequestInt) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))
45+testOrdering :: ( Response m ~ Identity
52−app1 e = do
46+ , Request m ~ RequestInt
47+ , Requester t m
48+ , MonadAdjust t m)
49+ => Event t ()
50+ -> m ()
51+testOrdering pulse = do
53− forM_ [1..10] $ \i -> requestingIdentity (RequestInt i <$ e)
52+ forM_ [10,9..1] $ \i -> requestingIdentity (RequestInt i <$ pulse)
54− return Nothing
53+ return ()
55−
54+
56−app2 :: (Reflex t, Ref m ~ IORef, Requester t m, Response m ~ Identity, Request m ~ RequestInt, MonadAdjust t m, MonadReflexCreateTrigger t m, MonadRef m) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))
55+testSimultaneous :: ( Response m ~ Identity
57−app2 e = do
56+ , Request m ~ RequestInt
58− (pulse, pulseTriggerRef) <- newEventWithTriggerRef
57+ , Requester t m
58+ , MonadAdjust t m)
59+ => Event t (These () ())
60+ -> m ()
61+testSimultaneous pulse = do
62+ let tellE = fmapMaybe (^? here) pulse
63+ switchE = fmapMaybe (^? there) pulse
59− forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ e)) $ ffor pulse $ \_ -> requestingIdentity (RequestInt (i+1) <$ e)
64+ forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
60− return (Just pulseTriggerRef)
65+ requestingIdentity (RequestInt (i+1) <$ tellE)
61−
62−-}