Move some query morphisms into Reflex.Query.Class

Author: Ryan Trinkle

src/Reflex/Query/Base.hs

@@ -278,13 +278,6 @@ instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where
 instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where
   (<>) = liftA2 (S.<>)
 
-
-mapQuery :: QueryMorphism q q' -> q -> q'
-mapQuery = _queryMorphism_mapQuery
-
-mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
-mapQueryResult = _queryMorphism_mapQueryResult
-
 -- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
 withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
            => QueryMorphism q q'

src/Reflex/Query/Class.hs

@@ -15,12 +15,18 @@ module Reflex.Query.Class
   , MonadQuery (..)
   , tellQueryDyn
   , queryDyn
+  , mapQuery
+  , mapQueryResult
   ) where
 
+import Control.Category (Category)
+import qualified Control.Category as Cat
 import Control.Monad.Reader
 import Data.Bits
 import Data.Data
 import Data.Ix
+import Data.Map.Monoidal (MonoidalMap)
+import qualified Data.Map.Monoidal as MonoidalMap
 import Data.Semigroup
 import Foreign.Storable
 
@@ -30,13 +36,30 @@ class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where
   type QueryResult a :: *
   crop :: a -> QueryResult a -> QueryResult a
 
+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
+
 -- | NB: 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
   { _queryMorphism_mapQuery :: q -> q'
   , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
   }
 
+instance Category QueryMorphism where
+  id = QueryMorphism id id
+  qm . qm' = QueryMorphism
+    { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm'
+    , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm
+    }
+
+mapQuery :: QueryMorphism q q' -> q -> q'
+mapQuery = _queryMorphism_mapQuery
+
+mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
+mapQueryResult = _queryMorphism_mapQueryResult
+
 -- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app
 newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
   deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)