git.iko.soy/patch
on develop help sign in
Buncha instances
commitf7da8e8a3831fc263f984363ef2920ac16272054 authordan bornside <dan.bornside@gmail.com> dateMon 7 Oct 2019, 23:47 (7 years ago) parent55a1e29
2 files changed+72
compare with develop
unifiedsplit
src/Reflex/Patch.hs+44 src/Reflex/Query/Class.hs+28
src/Reflex/Patch.hs+44
@@ -1,4 +1,7 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE StandaloneDeriving #-}
13{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE TypeOperators #-}
25-- |
36-- Module:
47-- Reflex.Patch
@@ -23,6 +26,11 @@ import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewEleme
2326 unsafePatchMapWithMove)
2427import Data.Map.Monoidal (MonoidalMap)
2528import Data.Semigroup (Semigroup (..), (<>))
29+import GHC.Generics
30+import Data.Functor.Identity
31+import Data.Functor.Const
32+import Data.Proxy
33+import Control.Applicative
2634
2735-- | A 'Group' is a 'Monoid' where every element has an inverse.
2836class (Semigroup q, Monoid q) => Group q where
@@ -44,3 +52,39 @@ instance (Ord k, Group q) => Group (MonoidalMap k q) where
4452 negateG = fmap negateG
4553
4654instance (Ord k, Additive q) => Additive (MonoidalMap k q)
55+
56+instance Group () where
57+ negateG _ = ()
58+ _ ~~ _ = ()
59+instance Additive ()
60+
61+instance (Group a, Group b) => Group (a, b) where
62+ negateG (a, b) = (negateG a, negateG b)
63+ (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
64+instance (Additive a, Additive b) => Additive (a, b) where
65+
66+-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
67+-- Base does not define Monoid (Compose f g a) so this has no "home"
68+instance Group (f (g a)) => Group ((f :.: g) a) where
69+ negateG (Comp1 xs) = Comp1 (negateG xs)
70+ Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
71+
72+instance Additive (f (g a)) => Additive ((f :.: g) a) where
73+
74+instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
75+ negateG (a :*: b) = negateG a :*: negateG b
76+ (a :*: b) ~~ (c :*: d) = (a ~~ c :*: b ~~ d)
77+instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a) where
78+
79+instance Group (Proxy x) where
80+ negateG _ = Proxy
81+ _ ~~ _ = Proxy
82+instance Additive (Proxy x)
83+
84+deriving instance Group a => Group (Const a x)
85+deriving instance Group a => Group (Identity a)
86+
87+instance Group b => Group (a -> b) where
88+ negateG f = negateG . f
89+ (~~) = liftA2 (~~)
90+instance Additive b => Additive (a -> b)
src/Reflex/Query/Class.hs+28
@@ -21,6 +21,7 @@ module Reflex.Query.Class
2121 , MonadQuery (..)
2222 , tellQueryDyn
2323 , queryDyn
24+ , subQuery
2425 , mapQuery
2526 , mapQueryResult
2627 ) where
@@ -35,6 +36,9 @@ import Data.Map.Monoidal (MonoidalMap)
3536import qualified Data.Map.Monoidal as MonoidalMap
3637import Data.Semigroup (Semigroup(..))
3738import Foreign.Storable
39+import Data.Void
40+import Data.Monoid
41+import Control.Applicative
3842
3943import Reflex.Class
4044
@@ -50,6 +54,25 @@ instance (Ord k, Query v) => Query (MonoidalMap k v) where
5054 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
5155 crop q r = MonoidalMap.intersectionWith (flip crop) r q
5256
57+-- asking two questions is the same as asking both questions.
58+instance (Query a, Query b) => Query (a, b) where
59+ type QueryResult (a, b) = (QueryResult a, QueryResult b)
60+ crop (x, x') (y, y') = (crop x y, crop x' y')
61+
62+-- ¯\_(ﾟヮﾟ)_/¯ ¯\_(ツ)_/¯
63+instance Query () where
64+ type QueryResult () = ()
65+ crop _ _ = ()
66+
67+instance Query Void where
68+ type QueryResult Void = ()
69+ crop = absurd
70+
71+-- | We can lift queries into monoidal containers.
72+-- But beware of Applicatives who's monoid is different from (pure mempty, liftA2 mappend)
73+instance (Query q, Applicative f) => Query (Ap f q) where
74+ type QueryResult (Ap f q) = Ap f (QueryResult q)
75+ crop = liftA2 crop
5376-- | QueryMorphism's must be group homomorphisms when acting on the query type
5477-- and compatible with the query relationship when acting on the query result.
5578data QueryMorphism q q' = QueryMorphism
@@ -116,3 +139,8 @@ queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t
116139queryDyn q = do
117140 tellQueryDyn q
118141 zipDynWith crop q <$> askQueryResult
142+
143+-- | We can already say this in reflex
144+subQuery :: (Reflex t, MonadQuery t q2 m, Monad m) => QueryMorphism q1 q2 -> Dynamic t q1 -> m (Dynamic t (QueryResult q1))
145+subQuery (QueryMorphism f g) x = fmap g <$> queryDyn (fmap f x)
146+