git.iko.soy/patch
on 1e2c2bb help sign in
patch/src/Reflex/Query/Class.hs
99 lines 3.8 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FunctionalDependencies #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE UndecidableInstances #-}
9module Reflex.Query.Class
10 ( Query (..)
11 , QueryMorphism (..)
12 , SelectedCount (..)
13 , combineSelectedCounts
15 , MonadQuery (..)
16 , tellQueryDyn
17 , queryDyn
18 , mapQuery
19 , mapQueryResult
20 ) where
22import Control.Category (Category)
23import qualified Control.Category as Cat
24import Control.Monad.Reader
25import Data.Bits
26import Data.Data
27import Data.Ix
28import Data.Map.Monoidal (MonoidalMap)
29import qualified Data.Map.Monoidal as MonoidalMap
30import Data.Semigroup
31import Foreign.Storable
33import Reflex.Class
35class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where
36 type QueryResult a :: *
37 crop :: a -> QueryResult a -> QueryResult a
39instance (Ord k, Query v) => Query (MonoidalMap k v) where
40 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
41 crop q r = MonoidalMap.intersectionWith (flip crop) r q
43-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type
44-- and compatible with the query relationship when acting on the query result
45data QueryMorphism q q' = QueryMorphism
46 { _queryMorphism_mapQuery :: q -> q'
47 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
48 }
50instance Category QueryMorphism where
51 id = QueryMorphism id id
52 qm . qm' = QueryMorphism
53 { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm'
54 , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm
55 }
57mapQuery :: QueryMorphism q q' -> q -> q'
58mapQuery = _queryMorphism_mapQuery
60mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
61mapQueryResult = _queryMorphism_mapQueryResult
63-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app
64newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
65 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)
67instance Semigroup SelectedCount where
68 SelectedCount a <> SelectedCount b = SelectedCount (a + b)
70instance Monoid SelectedCount where
71 mempty = SelectedCount 0
72 mappend = (<>)
74instance Group SelectedCount where
75 negateG (SelectedCount a) = SelectedCount (negate a)
77instance Additive SelectedCount
79-- | The Semigroup/Monoid/Group instances for a ViewSelector should use this function which returns Nothing if the result is 0. This allows the pruning of leaves that are no longer wanted.
80combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount
81combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j)
83class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where
84 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()
85 askQueryResult :: m (Dynamic t (QueryResult q))
86 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
88instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where
89 tellQueryIncremental = lift . tellQueryIncremental
90 askQueryResult = lift askQueryResult
91 queryIncremental = lift . queryIncremental
93tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()
94tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)
96queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
97queryDyn q = do
98 tellQueryDyn q
99 zipDynWith crop q <$> askQueryResult