git.iko.soy/patch
on 5480222 help sign in
patch/src/Reflex/Query/Class.hs
118 lines 4.7 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FunctionalDependencies #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE UndecidableInstances #-}
8-- |
9-- Module:
10-- Reflex.Query.Class
11-- Description:
12-- A class that ties together queries to some data source and their results,
13-- providing methods for requesting data from the source and accumulating
14-- streamed results.
15module Reflex.Query.Class
16 ( Query (..)
17 , QueryMorphism (..)
18 , SelectedCount (..)
19 , combineSelectedCounts
21 , MonadQuery (..)
22 , tellQueryDyn
23 , queryDyn
24 , mapQuery
25 , mapQueryResult
26 ) where
28import Control.Category (Category)
29import qualified Control.Category as Cat
30import Control.Monad.Reader
31import Data.Bits
32import Data.Data
33import Data.Ix
34import Data.Map.Monoidal (MonoidalMap)
35import qualified Data.Map.Monoidal as MonoidalMap
36import Data.Semigroup (Semigroup(..))
37import Foreign.Storable
39import Reflex.Class
41-- | A 'Query' can be thought of as a declaration of interest in some set of data.
42-- A 'QueryResult' is the set of data associated with that interest set.
43-- The @crop@ function provides a way to determine what part of a given 'QueryResult'
44-- is relevant to a given 'Query'.
45class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where
46 type QueryResult a :: *
47 crop :: a -> QueryResult a -> QueryResult a
49instance (Ord k, Query v) => Query (MonoidalMap k v) where
50 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
51 crop q r = MonoidalMap.intersectionWith (flip crop) r q
53-- | QueryMorphism's must be group homomorphisms when acting on the query type
54-- and compatible with the query relationship when acting on the query result.
55data QueryMorphism q q' = QueryMorphism
56 { _queryMorphism_mapQuery :: q -> q'
57 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
58 }
60instance Category QueryMorphism where
61 id = QueryMorphism id id
62 qm . qm' = QueryMorphism
63 { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm'
64 , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm
65 }
67-- | Apply a 'QueryMorphism' to a 'Query'
68mapQuery :: QueryMorphism q q' -> q -> q'
69mapQuery = _queryMorphism_mapQuery
71-- | Map a 'QueryMorphism' to a 'QueryResult'
72mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
73mapQueryResult = _queryMorphism_mapQueryResult
75-- | This type can be used to track of the frequency of interest in a given 'Query'. See note on
76-- 'combineSelectedCounts'
77newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
78 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)
80instance Semigroup SelectedCount where
81 SelectedCount a <> SelectedCount b = SelectedCount (a + b)
83instance Monoid SelectedCount where
84 mempty = SelectedCount 0
85 mappend = (<>)
87instance Group SelectedCount where
88 negateG (SelectedCount a) = SelectedCount (negate a)
90instance Additive SelectedCount
92-- | The Semigroup/Monoid/Group instances for a Query containing 'SelectedCount's should use
93-- this function which returns Nothing if the result is 0. This allows the pruning of leaves
94-- of the 'Query' that are no longer wanted.
95combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount
96combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j)
98-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly
99-- used interface.
100class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where
101 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()
102 askQueryResult :: m (Dynamic t (QueryResult q))
103 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
105instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where
106 tellQueryIncremental = lift . tellQueryIncremental
107 askQueryResult = lift askQueryResult
108 queryIncremental = lift . queryIncremental
110-- | Produce and send an 'Incremental' 'Query' from a 'Dynamic' 'Query'.
111tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()
112tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)
114-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'.
115queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
116queryDyn q = do
117 tellQueryDyn q
118 zipDynWith crop q <$> askQueryResult