git.iko.soy/patch
on 45056ff help sign in
patch/src/Reflex/Query/Class.hs
119 lines 4.7 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 #-}
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 , mapQuery
26 , mapQueryResult
27 ) where
29import Control.Category (Category)
30import qualified Control.Category as Cat
31import Control.Monad.Reader
32import Data.Bits
33import Data.Data
34import Data.Ix
35import Data.Map.Monoidal (MonoidalMap)
36import qualified Data.Map.Monoidal as MonoidalMap
37import Data.Semigroup (Semigroup(..))
38import Foreign.Storable
40import Reflex.Class
42-- | A 'Query' can be thought of as a declaration of interest in some set of data.
43-- A 'QueryResult' is the set of data associated with that interest set.
44-- The @crop@ function provides a way to determine what part of a given 'QueryResult'
45-- is relevant to a given 'Query'.
46class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where
47 type QueryResult a :: *
48 crop :: a -> QueryResult a -> QueryResult a
50instance (Ord k, Query v) => Query (MonoidalMap k v) where
51 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
52 crop q r = MonoidalMap.intersectionWith (flip crop) r q
54-- | QueryMorphism's must be group homomorphisms when acting on the query type
55-- and compatible with the query relationship when acting on the query result.
56data QueryMorphism q q' = QueryMorphism
57 { _queryMorphism_mapQuery :: q -> q'
58 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
59 }
61instance Category QueryMorphism where
62 id = QueryMorphism id id
63 qm . qm' = QueryMorphism
64 { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm'
65 , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm
66 }
68-- | Apply a 'QueryMorphism' to a 'Query'
69mapQuery :: QueryMorphism q q' -> q -> q'
70mapQuery = _queryMorphism_mapQuery
72-- | Map a 'QueryMorphism' to a 'QueryResult'
73mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
74mapQueryResult = _queryMorphism_mapQueryResult
76-- | This type can be used to track of the frequency of interest in a given 'Query'. See note on
77-- 'combineSelectedCounts'
78newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
79 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)
81instance Semigroup SelectedCount where
82 SelectedCount a <> SelectedCount b = SelectedCount (a + b)
84instance Monoid SelectedCount where
85 mempty = SelectedCount 0
86 mappend = (<>)
88instance Group SelectedCount where
89 negateG (SelectedCount a) = SelectedCount (negate a)
91instance Additive SelectedCount
93-- | The Semigroup/Monoid/Group instances for a Query containing 'SelectedCount's should use
94-- this function which returns Nothing if the result is 0. This allows the pruning of leaves
95-- of the 'Query' that are no longer wanted.
96combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount
97combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j)
99-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly
100-- used interface.
101class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where
102 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()
103 askQueryResult :: m (Dynamic t (QueryResult q))
104 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
106instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where
107 tellQueryIncremental = lift . tellQueryIncremental
108 askQueryResult = lift askQueryResult
109 queryIncremental = lift . queryIncremental
111-- | Produce and send an 'Incremental' 'Query' from a 'Dynamic' 'Query'.
112tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()
113tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)
115-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'.
116queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
117queryDyn q = do
118 tellQueryDyn q
119 zipDynWith crop q <$> askQueryResult