@@ -4,6 +4,9 @@
44{-# LANGUAGE GeneralizedNewtypeDeriving #-}
55{-# LANGUAGE LambdaCase #-}
66{-# LANGUAGE OverloadedStrings #-}
7+
8+import Control.Lens
9+import Control.Monad.Fix
710import Data.Align
811import qualified Data.AppendMap as Map
912import Data.Semigroup
@@ -46,14 +49,26 @@ instance (Eq a, Ord k, Group a) => Group (Selector k a) where
4649instance (Eq a, Ord k, Group a) => Additive (Selector k a)
4750
4851main :: IO ()
49−main = mainWidget $ do
50− let w = do
51− n <- count =<< button "Increment"
52− display n
52+main = do
53+ [0, 1, 1, 0] <- fmap (map fst . concat) $ runApp app () $ map (Just . That) $
54+ [ That ()
55+ , This ()
56+ , That ()
57+ ]
58+ return ()
59+
60+app :: (Reflex t, MonadHold t m, MonadAdjust t m, MonadFix m)
61+ => AppIn t () (These () ())
62+ -> m (AppOut t Int Int)
63+app (AppIn _ pulse) = do
64+ let replace = fmapMaybe (^? here) pulse
65+ increment = fmapMaybe (^? there) pulse
66+ w = do
67+ n <- count increment
5368 queryDyn $ zipDynWith (\x y -> Selector (Map.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
54− return ()
55− outer = do
56− replace <- button "Replace"
57− widgetHold w $ w <$ replace
58− (_, q) <- runQueryT outer $ pure mempty
59− display $ incrementalToDynamic q
69+ (_, q) <- runQueryT (runWithReplace w $ w <$ replace) $ pure mempty
70+ let qDyn = fmap (head . Map.keys . unSelector) $ incrementalToDynamic q
71+ return $ AppOut
72+ { _appOut_behavior = current qDyn
73+ , _appOut_event = updated qDyn
74+ }