git.iko.soy/reflex
on develop help sign in
reflex/src/Reflex/Query/Class.hs
158 lines 6.3 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE UndecidableInstances #-}
9-- |
10-- Module:
11-- Reflex.Query.Class
12-- Description:
13-- A class that ties together queries to some data source and their results,
14-- providing methods for requesting data from the source and accumulating
15-- streamed results.
16module Reflex.Query.Class
17 ( Query (..)
18 , QueryMorphism (..)
19 , SelectedCount (..)
20 , combineSelectedCounts
22 , MonadQuery (..)
23 , tellQueryDyn
24 , queryDyn
25 , subQuery
26 , mapQuery
27 , mapQueryResult
28 ) where
30import Control.Category (Category)
31import qualified Control.Category as Cat
32import Control.Monad.Reader
33import Data.Bits
34import Data.Data
35import Data.Ix
36import Data.Map.Monoidal (MonoidalMap)
37import qualified Data.Map.Monoidal as MonoidalMap
38import Data.Semigroup (Semigroup(..))
39import Foreign.Storable
40import Data.Void
41import Data.Monoid hiding ((<>))
42import Control.Applicative
44import Reflex.Class
46-- | A 'Query' can be thought of as a declaration of interest in some set of data.
47-- A 'QueryResult' is the set of data associated with that interest set.
48-- The @crop@ function provides a way to determine what part of a given 'QueryResult'
49-- is relevant to a given 'Query'.
50class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where
51 type QueryResult a :: *
52 crop :: a -> QueryResult a -> QueryResult a
54instance (Ord k, Query v) => Query (MonoidalMap k v) where
55 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
56 crop q r = MonoidalMap.intersectionWith (flip crop) r q
58-- | the result of two queries is both results.
59instance (Query a, Query b) => Query (a, b) where
60 type QueryResult (a, b) = (QueryResult a, QueryResult b)
61 crop (x, x') (y, y') = (crop x y, crop x' y')
63-- | Trivial queries have trivial results.
64instance Query () where
65 type QueryResult () = ()
66 crop _ _ = ()
68-- | The result of an absurd query is trivial; If you can ask the question, the
69-- answer cannot tell you anything you didn't already know.
70--
71-- 'QueryResult Void = @Void@' seems like it would also work, but that has
72-- problems of robustness. In some applications, an unasked question can still
73-- be answered, so it is important that the result is inhabited even when the
74-- question isn't. Applications that wish to prevent this can mandate that the
75-- query result be paired with the query: then the whole response will be
76-- uninhabited as desired.
77instance Query Void where
78 type QueryResult Void = ()
79 crop = absurd
81#if MIN_VERSION_base(4,12,0)
82-- | We can lift queries into monoidal containers.
83-- But beware of Applicatives whose monoid is different from (pure mempty, liftA2 mappend)
84instance (Query q, Applicative f) => Query (Ap f q) where
85 type QueryResult (Ap f q) = Ap f (QueryResult q)
86 crop = liftA2 crop
87#endif
89-- | QueryMorphism's must be group homomorphisms when acting on the query type
90-- and compatible with the query relationship when acting on the query result.
91data QueryMorphism q q' = QueryMorphism
92 { _queryMorphism_mapQuery :: q -> q'
93 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
94 }
96instance Category QueryMorphism where
97 id = QueryMorphism id id
98 qm . qm' = QueryMorphism
99 { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm'
100 , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm
101 }
103-- | Apply a 'QueryMorphism' to a 'Query'
104mapQuery :: QueryMorphism q q' -> q -> q'
105mapQuery = _queryMorphism_mapQuery
107-- | Map a 'QueryMorphism' to a 'QueryResult'
108mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
109mapQueryResult = _queryMorphism_mapQueryResult
111-- | This type can be used to track of the frequency of interest in a given 'Query'. See note on
112-- 'combineSelectedCounts'
113newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
114 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)
116instance Semigroup SelectedCount where
117 SelectedCount a <> SelectedCount b = SelectedCount (a + b)
119instance Monoid SelectedCount where
120 mempty = SelectedCount 0
121 mappend = (<>)
123instance Group SelectedCount where
124 negateG (SelectedCount a) = SelectedCount (negate a)
126instance Additive SelectedCount
128-- | The Semigroup\/Monoid\/Group instances for a Query containing 'SelectedCount's should use
129-- this function which returns Nothing if the result is 0. This allows the pruning of leaves
130-- of the 'Query' that are no longer wanted.
131combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount
132combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j)
134-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly
135-- used interface.
136class (Group q, Additive q, Query q, Monad m) => MonadQuery t q m | m -> q t where
137 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()
138 askQueryResult :: m (Dynamic t (QueryResult q))
139 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
141instance MonadQuery t q m => MonadQuery t q (ReaderT r m) where
142 tellQueryIncremental = lift . tellQueryIncremental
143 askQueryResult = lift askQueryResult
144 queryIncremental = lift . queryIncremental
146-- | Produce and send an 'Incremental' 'Query' from a 'Dynamic' 'Query'.
147tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()
148tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)
150-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'.
151queryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
152queryDyn q = do
153 tellQueryDyn q
154 zipDynWith crop q <$> askQueryResult
156-- | Use a query morphism to operate on a smaller version of a query.
157subQuery :: (Reflex t, MonadQuery t q2 m) => QueryMorphism q1 q2 -> Dynamic t q1 -> m (Dynamic t (QueryResult q1))
158subQuery (QueryMorphism f g) x = fmap g <$> queryDyn (fmap f x)