Merge pull request #358 from danbornside/extra-query-instances

Buncha instances

ChangeLog.md

@@ -9,6 +9,8 @@
 * The `Reflex.Patch.*` modules were moved to the `patch` library.
   They are `Data.Patch.*` there, but reexported under their old names for backwards compatability here.
 
+* Additional instances for `Query` classes for basic types.
+
 ## 0.6.3
 
 * `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated.

reflex.cabal

@@ -62,7 +62,7 @@ library
     lens >= 4.7 && < 5,
     monad-control >= 1.0.1 && < 1.1,
     mtl >= 2.1 && < 2.3,
-    patch >= 0.0 && < 0.1,
+    patch >= 0.0.1 && < 0.1,
     prim-uniq >= 0.1.0.1 && < 0.2,
     primitive >= 0.5 && < 0.8,
     profunctors >= 5.3 && < 5.6,

src/Reflex/Query/Class.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -21,6 +22,7 @@ module Reflex.Query.Class
   , MonadQuery (..)
   , tellQueryDyn
   , queryDyn
+  , subQuery
   , mapQuery
   , mapQueryResult
   ) where
@@ -35,6 +37,9 @@ import Data.Map.Monoidal (MonoidalMap)
 import qualified Data.Map.Monoidal as MonoidalMap
 import Data.Semigroup (Semigroup(..))
 import Foreign.Storable
+import Data.Void
+import Data.Monoid hiding ((<>))
+import Control.Applicative
 
 import Reflex.Class
 
@@ -50,6 +55,37 @@ instance (Ord k, Query v) => Query (MonoidalMap k v) where
   type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
   crop q r = MonoidalMap.intersectionWith (flip crop) r q
 
+-- | the result of two queries is both results.
+instance (Query a, Query b) => Query (a, b) where
+  type QueryResult (a, b) = (QueryResult a, QueryResult b)
+  crop (x, x') (y, y') = (crop x y, crop x' y')
+
+-- | Trivial queries have trivial results.
+instance Query () where
+  type QueryResult () = ()
+  crop _ _ = ()
+
+-- | The result of an absurd query is trivial; If you can ask the question, the
+-- answer cannot tell you anything you didn't already know.
+--
+-- 'QueryResult Void = @Void@' seems like it would also work, but that has
+-- problems of robustness. In some applications, an unasked question can still
+-- be answered, so it is important that the result is inhabited even when the
+-- question isn't. Applications that wish to prevent this can mandate that the
+-- query result be paired with the query: then the whole response will be
+-- uninhabited as desired.
+instance Query Void where
+  type QueryResult Void = ()
+  crop = absurd
+
+#if MIN_VERSION_base(4,12,0)
+-- | We can lift queries into monoidal containers.
+-- But beware of Applicatives whose monoid is different from (pure mempty, liftA2 mappend)
+instance (Query q, Applicative f) => Query (Ap f q) where
+  type QueryResult (Ap f q) = Ap f (QueryResult q)
+  crop = liftA2 crop
+#endif
+
 -- | QueryMorphism's must be group homomorphisms when acting on the query type
 -- and compatible with the query relationship when acting on the query result.
 data QueryMorphism q q' = QueryMorphism
@@ -116,3 +152,7 @@ queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t
 queryDyn q = do
   tellQueryDyn q
   zipDynWith crop q <$> askQueryResult
+
+-- | Use a query morphism to operate on a smaller version of a query.
+subQuery :: (Reflex t, MonadQuery t q2 m, Monad m) => QueryMorphism q1 q2 -> Dynamic t q1 -> m (Dynamic t (QueryResult q1))
+subQuery (QueryMorphism f g) x = fmap g <$> queryDyn (fmap f x)