git.iko.soy/reflex
on aa-docs help sign in
reflex/test/QueryT.hs
138 lines 5.3 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
22import Reflex
23import Reflex.Patch.MapWithMove
24import Test.Run
26newtype MyQuery = MyQuery SelectedCount
27 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
29instance Query MyQuery where
30 type QueryResult MyQuery = ()
31 crop _ _ = ()
33instance (Ord k, Query a, Eq (QueryResult a), Align (MonoidalMap k)) => Query (Selector k a) where
34 type QueryResult (Selector k a) = Selector k (QueryResult a)
35 crop q r = undefined
37newtype Selector k a = Selector { unSelector :: MonoidalMap k a }
38 deriving (Show, Read, Eq, Ord, Functor)
40#if !(MIN_VERSION_monoidal_containers(0,4,1))
41deriving instance Ord k => Align (MonoidalMap k)
42#endif
44instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k a) where
45 (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b
46 where
47 f = alignWith $ \case
48 This x -> Just x
49 That y -> Just y
50 These x y ->
51 let z = x `mappend` y
52 in if z == mempty then Nothing else Just z
54instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Monoid (Selector k a) where
55 mempty = Selector AMap.empty
56 mappend = (<>)
58instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Group (Selector k a) where
59 negateG = fmap negateG
61instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Additive (Selector k a)
63main :: IO ()
64main = do
65 [0, 1, 1, 0] <- fmap (map fst . concat) $
66 runApp (testQueryT testRunWithReplace) () $ map (Just . That) $
67 [ That (), This (), That () ]
68 [0, 1, 1, 0] <- fmap (map fst . concat) $
69 runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $
70 [ That (), This (), That () ]
71 [0, 1, 1, 0] <- fmap (map fst . concat) $
72 runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $
73 [ That (), This (), That () ]
74 return ()
76testQueryT :: (Reflex t, MonadFix m)
77 => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ())
78 -> AppIn t () (These () ())
79 -> m (AppOut t Int Int)
80testQueryT w (AppIn _ pulse) = do
81 let replace = fmapMaybe (^? here) pulse
82 increment = fmapMaybe (^? there) pulse
83 (_, q) <- runQueryT (w replace increment) $ pure mempty
84 let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q
85 return $ AppOut
86 { _appOut_behavior = current qDyn
87 , _appOut_event = updated qDyn
88 }
90testRunWithReplace :: ( Reflex t
91 , Adjustable t m
92 , MonadHold t m
93 , MonadFix m
94 , MonadQuery t (Selector Int MyQuery) m)
95 => Event t ()
96 -> Event t ()
97 -> m ()
98testRunWithReplace replace increment = do
99 let w = do
100 n <- count increment
101 queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
102 _ <- runWithReplace w $ w <$ replace
103 return ()
105testSequenceDMapWithAdjust :: ( Reflex t
106 , Adjustable t m
107 , MonadHold t m
108 , MonadFix m
109 , MonadQuery t (Selector Int MyQuery) m)
110 => Event t ()
111 -> Event t ()
112 -> m ()
113testSequenceDMapWithAdjust replace increment = do
114 _ <- listHoldWithKey (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
115 n <- count increment
116 queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
117 return ()
119testSequenceDMapWithAdjustWithMove :: ( Reflex t
120 , Adjustable t m
121 , MonadHold t m
122 , MonadFix m
123 , MonadQuery t (Selector Int MyQuery) m)
124 => Event t ()
125 -> Event t ()
126 -> m ()
127testSequenceDMapWithAdjustWithMove replace increment = do
128 _ <- listHoldWithKeyWithMove (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
129 n <- count increment
130 queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
131 return ()
133-- scam it out to test traverseDMapWithAdjustWithMove
134listHoldWithKeyWithMove :: 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))
135listHoldWithKeyWithMove m0 m' f = do
136 (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing)
137 incrementalToDynamic <$> holdIncremental n0 n'
138-- -}