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