git.iko.soy/patch
on bd07448 help sign in
patch/test/QueryT.hs
132 lines 5.1 kB history raw
1{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE TypeFamilies #-}
8import Control.Lens
9import Control.Monad.Fix
10import Data.Align
11import Data.AppendMap () -- for the Align instance
12import qualified Data.AppendMap as AMap
13import Data.Functor.Misc
14import Data.Map (Map)
15import qualified Data.Map as Map
16import Data.Map.Monoidal (MonoidalMap)
17import Data.Semigroup
18import Data.These
20import Reflex
21import Reflex.Patch.MapWithMove
22import Test.Run
24newtype MyQuery = MyQuery SelectedCount
25 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
27instance Query MyQuery where
28 type QueryResult MyQuery = ()
29 crop _ _ = ()
31instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where
32 type QueryResult (Selector k a) = Selector k (QueryResult a)
33 crop q r = undefined
35newtype Selector k a = Selector { unSelector :: MonoidalMap k a }
36 deriving (Show, Read, Eq, Ord, Functor)
38instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
39 (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b
40 where
41 f = alignWith $ \case
42 This x -> Just x
43 That y -> Just y
44 These x y ->
45 let z = x `mappend` y
46 in if z == mempty then Nothing else Just z
48instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
49 mempty = Selector AMap.empty
50 mappend = (<>)
52instance (Eq a, Ord k, Group a) => Group (Selector k a) where
53 negateG = fmap negateG
55instance (Eq a, Ord k, Group a) => Additive (Selector k a)
57main :: IO ()
58main = do
59 [0, 1, 1, 0] <- fmap (map fst . concat) $
60 runApp (testQueryT testRunWithReplace) () $ map (Just . That) $
61 [ That (), This (), That () ]
62 [0, 1, 1, 0] <- fmap (map fst . concat) $
63 runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $
64 [ That (), This (), That () ]
65 [0, 1, 1, 0] <- fmap (map fst . concat) $
66 runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $
67 [ That (), This (), That () ]
68 return ()
70testQueryT :: (Reflex t, MonadFix m)
71 => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ())
72 -> AppIn t () (These () ())
73 -> m (AppOut t Int Int)
74testQueryT w (AppIn _ pulse) = do
75 let replace = fmapMaybe (^? here) pulse
76 increment = fmapMaybe (^? there) pulse
77 (_, q) <- runQueryT (w replace increment) $ pure mempty
78 let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q
79 return $ AppOut
80 { _appOut_behavior = current qDyn
81 , _appOut_event = updated qDyn
82 }
84testRunWithReplace :: ( Reflex t
85 , Adjustable t m
86 , MonadHold t m
87 , MonadFix m
88 , MonadQuery t (Selector Int MyQuery) m)
89 => Event t ()
90 -> Event t ()
91 -> m ()
92testRunWithReplace 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 ()
99testSequenceDMapWithAdjust :: ( Reflex t
100 , Adjustable t m
101 , MonadHold t m
102 , MonadFix m
103 , MonadQuery t (Selector Int MyQuery) m)
104 => Event t ()
105 -> Event t ()
106 -> m ()
107testSequenceDMapWithAdjust 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 ()
113testSequenceDMapWithAdjustWithMove :: ( Reflex t
114 , Adjustable t m
115 , MonadHold t m
116 , MonadFix m
117 , MonadQuery t (Selector Int MyQuery) m)
118 => Event t ()
119 -> Event t ()
120 -> m ()
121testSequenceDMapWithAdjustWithMove 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 ()
127-- scam it out to test traverseDMapWithAdjustWithMove
128listHoldWithKeyWithMove :: 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))
129listHoldWithKeyWithMove m0 m' f = do
130 (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing)
131 incrementalToDynamic <$> holdIncremental n0 n'
132-- -}