git.iko.soy/reflex
on ghc-8.2.1 help sign in
reflex/test/QueryT.hs
140 lines 5.5 kB history raw
1{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE RankNTypes #-}
9import Control.Lens
10import Control.Monad.Fix
11import Data.Align
12import Data.AppendMap (AppendMap)
13import qualified Data.AppendMap as AMap
14import Data.Functor.Misc
15import Data.Map (Map)
16import qualified Data.Map as Map
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 :: AppendMap 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 , MonadAdjust 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 , MonadAdjust 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 , MonadAdjust 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 ()
127listHoldWithKey :: forall t m k v a. (Ord k, MonadHold t m, MonadAdjust t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
128listHoldWithKey m0 m' f = do
129 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
130 dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
131 (a0, a') <- sequenceDMapWithAdjust dm0 dm'
132 fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a'
135-- scam it out to test traverseDMapWithAdjustWithMove
136listHoldWithKeyWithMove :: forall t m k v a. (Ord k, MonadHold t m, MonadAdjust t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
137listHoldWithKeyWithMove m0 m' f = do
138 (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing)
139 incrementalToDynamic <$> holdIncremental n0 n'
140-- -}