git.iko.soy/patch
on ef4da28 help sign in
patch/test/QueryT.hs
59 lines 1.8 kB history raw
1{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE OverloadedStrings #-}
7import Data.Align
8import qualified Data.AppendMap as Map
9import Data.Semigroup
10import Data.These
12import Reflex
13import Test.Run
15newtype MyQuery = MyQuery SelectedCount
16 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
18instance Query MyQuery where
19 type QueryResult MyQuery = ()
20 crop _ _ = ()
22instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where
23 type QueryResult (Selector k a) = Selector k (QueryResult a)
24 crop q r = undefined
26newtype Selector k a = Selector { unSelector :: Map.AppendMap k a }
27 deriving (Show, Read, Eq, Ord, Functor)
29instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
30 (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b
31 where
32 f = alignWith $ \case
33 This x -> Just x
34 That y -> Just y
35 These x y ->
36 let z = x `mappend` y
37 in if z == mempty then Nothing else Just z
39instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
40 mempty = Selector Map.empty
41 mappend = (<>)
43instance (Eq a, Ord k, Group a) => Group (Selector k a) where
44 negateG = fmap negateG
46instance (Eq a, Ord k, Group a) => Additive (Selector k a)
48main :: IO ()
49main = mainWidget $ do
50 let w = do
51 n <- count =<< button "Increment"
52 display n
53 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