git.iko.soy/reflex
on test-ci help sign in
reflex/test/QueryT.hs
142 lines 5.5 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE StandaloneDeriving #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE UndecidableInstances #-}
11import Control.Lens
12import Control.Monad.Fix
13import Data.Align
14import qualified Data.AppendMap as AMap
15import Data.Functor.Misc
16import Data.Map (Map)
17import qualified Data.Map as Map
18import Data.Map.Monoidal (MonoidalMap)
19import Data.Semigroup
20import Data.These
22#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
23import Data.These.Lens
24#endif
26import Reflex
27import Reflex.Patch.MapWithMove
28import Test.Run
30newtype MyQuery = MyQuery SelectedCount
31 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
33instance Query MyQuery where
34 type QueryResult MyQuery = ()
35 crop _ _ = ()
37instance (Ord k, Query a, Eq (QueryResult a), Align (MonoidalMap k)) => Query (Selector k a) where
38 type QueryResult (Selector k a) = Selector k (QueryResult a)
39 crop q r = undefined
41newtype Selector k a = Selector { unSelector :: MonoidalMap k a }
42 deriving (Show, Read, Eq, Ord, Functor)
44#if !(MIN_VERSION_monoidal_containers(0,4,1))
45deriving instance Ord k => Align (MonoidalMap k)
46#endif
48instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k a) where
49 (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b
50 where
51 f = alignWith $ \case
52 This x -> Just x
53 That y -> Just y
54 These x y ->
55 let z = x `mappend` y
56 in if z == mempty then Nothing else Just z
58instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Monoid (Selector k a) where
59 mempty = Selector AMap.empty
60 mappend = (<>)
62instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Group (Selector k a) where
63 negateG = fmap negateG
65instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Additive (Selector k a)
67main :: IO ()
68main = do
69 [0, 1, 1, 0] <- fmap (map fst . concat) $
70 runApp (testQueryT testRunWithReplace) () $ map (Just . That) $
71 [ That (), This (), That () ]
72 [0, 1, 1, 0] <- fmap (map fst . concat) $
73 runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $
74 [ That (), This (), That () ]
75 [0, 1, 1, 0] <- fmap (map fst . concat) $
76 runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $
77 [ That (), This (), That () ]
78 return ()
80testQueryT :: (Reflex t, MonadFix m)
81 => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ())
82 -> AppIn t () (These () ())
83 -> m (AppOut t Int Int)
84testQueryT w (AppIn _ pulse) = do
85 let replace = fmapMaybe (^? here) pulse
86 increment = fmapMaybe (^? there) pulse
87 (_, q) <- runQueryT (w replace increment) $ pure mempty
88 let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q
89 return $ AppOut
90 { _appOut_behavior = current qDyn
91 , _appOut_event = updated qDyn
92 }
94testRunWithReplace :: ( Reflex t
95 , Adjustable t m
96 , MonadHold t m
97 , MonadFix m
98 , MonadQuery t (Selector Int MyQuery) m)
99 => Event t ()
100 -> Event t ()
101 -> m ()
102testRunWithReplace replace increment = do
103 let w = do
104 n <- count increment
105 queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
106 _ <- runWithReplace w $ w <$ replace
107 return ()
109testSequenceDMapWithAdjust :: ( Reflex t
110 , Adjustable t m
111 , MonadHold t m
112 , MonadFix m
113 , MonadQuery t (Selector Int MyQuery) m)
114 => Event t ()
115 -> Event t ()
116 -> m ()
117testSequenceDMapWithAdjust replace increment = do
118 _ <- listHoldWithKey (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
119 n <- count increment
120 queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
121 return ()
123testSequenceDMapWithAdjustWithMove :: ( Reflex t
124 , Adjustable t m
125 , MonadHold t m
126 , MonadFix m
127 , MonadQuery t (Selector Int MyQuery) m)
128 => Event t ()
129 -> Event t ()
130 -> m ()
131testSequenceDMapWithAdjustWithMove replace increment = do
132 _ <- listHoldWithKeyWithMove (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
133 n <- count increment
134 queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
135 return ()
137-- scam it out to test traverseDMapWithAdjustWithMove
138listHoldWithKeyWithMove :: forall t m k v a. (Ord k, MonadHold t m, Adjustable t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
139listHoldWithKeyWithMove m0 m' f = do
140 (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing)
141 incrementalToDynamic <$> holdIncremental n0 n'
142-- -}