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