Polymorphic viewmorphisms

src/Data/Vessel/Disperse.hs

@@ -74,3 +74,10 @@ instance Ord k => Disperse (MonoidalMap k) where
  One k v -> fmap (Map.singleton k) v
  Split pivot _l _r -> uncurry (alignWith (mergeThese unionDistinctAsc)) $ condense *** condense $ splitLT pivot row
 
+instance Disperse Maybe where
+ disperse xs =
+ let xs' = catMaybes xs
+ in if null xs' then Nothing else Just xs'
+ condense = \case
+ Nothing -> nil
+ Just xs -> Just <$> xs

src/Data/Vessel/Identity.hs

@@ -16,6 +16,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Data.Vessel.Identity where
 
@@ -54,17 +55,17 @@ instance Selectable (IdentityV a) () where
 lookupIdentityV :: IdentityV a Identity -> a
 lookupIdentityV = runIdentity . unIdentityV
 
-type instance ViewQueryResult (IdentityV a (Const g)) = IdentityV a Identity
+type instance ViewQueryResult (IdentityV a f) = IdentityV a (ViewQueryResult f)
 
-identityV :: (Applicative m, Applicative n) => ViewMorphism m n (Const g a) (IdentityV a (Const g))
+identityV :: (Applicative m, Applicative n, ViewQueryResult (f a) ~ ViewQueryResult f a) => ViewMorphism m n (f a) (IdentityV a f)
 identityV = ViewMorphism toIdentityV fromIdentityV
 
-toIdentityV :: (Applicative m, Applicative n) => ViewHalfMorphism m n (Const g a) (IdentityV a (Const g))
+toIdentityV :: (Applicative m, Applicative n, ViewQueryResult (f a) ~ ViewQueryResult f a) => ViewHalfMorphism m n (f a) (IdentityV a f)
 toIdentityV = ViewHalfMorphism
  { _viewMorphism_mapQuery = pure . IdentityV
  , _viewMorphism_mapQueryResult = pure . unIdentityV
  }
-fromIdentityV :: (Applicative m, Applicative n) => ViewHalfMorphism m n (IdentityV a (Const g)) (Const g a)
+fromIdentityV :: (Applicative m, Applicative n, ViewQueryResult (f a) ~ ViewQueryResult f a) => ViewHalfMorphism m n (IdentityV a f) (f a)
 fromIdentityV = ViewHalfMorphism
  { _viewMorphism_mapQuery = pure . unIdentityV
  , _viewMorphism_mapQueryResult = pure . IdentityV

src/Data/Vessel/Orphans.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.Vessel.Orphans () where
+
+import Control.Arrow (Kleisli(..))
+import Data.These (these, These(..))
+import Data.These.Combinators
+import Data.Void
+import qualified Control.Categorical.Bifunctor as Cat
+import qualified Control.Category.Associative as Cat
+import qualified Control.Category.Braided as Cat
+import qualified Control.Category.Monoidal as Cat
+import qualified Data.Bitraversable as Base
+
+instance Cat.PFunctor These (->) (->) where
+ first = mapHere
+instance Cat.QFunctor These (->) (->) where
+ second = mapThere
+instance Cat.Bifunctor These (->) (->) (->) where
+ bimap = bimapThese
+instance Cat.Associative (->) These where
+ associate = assocThese
+ disassociate = unassocThese
+
+instance Cat.Monoidal (->) These where
+ type Id (->) These = Void
+ idl = these absurd id absurd
+ idr = these id absurd (const absurd)
+ coidl = That
+ coidr = This
+
+instance Cat.Braided (->) These where
+ braid = swapThese
+
+instance Cat.Symmetric (->) These
+
+
+
+-- $Kleisli m$ preserves most structure,
+instance (Base.Bitraversable p, Monad m) => Cat.PFunctor p (Kleisli m) (Kleisli m) where
+ first (Kleisli f) = Kleisli $ Base.bitraverse f pure
+instance (Base.Bitraversable p, Monad m) => Cat.QFunctor p (Kleisli m) (Kleisli m) where
+ second (Kleisli g) = Kleisli $ Base.bitraverse pure g
+instance (Base.Bitraversable p, Monad m) => Cat.Bifunctor p (Kleisli m) (Kleisli m) (Kleisli m) where
+ bimap (Kleisli f) (Kleisli g) = Kleisli $ Base.bitraverse f g
+instance (Cat.Associative (->) p, Base.Bitraversable p, Monad m) => Cat.Associative (Kleisli m) p where
+ associate = Kleisli $ pure . Cat.associate
+ disassociate = Kleisli $ pure . Cat.disassociate
+instance (Base.Bitraversable p, Cat.Associative (->) p, Cat.Braided (->) p, Monad m) => Cat.Braided (Kleisli m) p where
+ braid = Kleisli $ pure . Cat.braid
+instance (Cat.Symmetric (->) p, Base.Bitraversable p, Cat.Braided (->) p, Monad m) => Cat.Symmetric (Kleisli m) p
+instance (Cat.Monoidal (->) p, Base.Bitraversable p, Monad m) => Cat.Monoidal (Kleisli m) p where
+ type Id (Kleisli m) p = Cat.Id (->) p
+ idl = Kleisli $ pure . Cat.idl
+ idr = Kleisli $ pure . Cat.idr
+ coidl = Kleisli $ pure . Cat.coidl
+ coidr = Kleisli $ pure . Cat.coidr
+

src/Data/Vessel/Path.hs

@@ -10,6 +10,7 @@ import Control.Monad.Fix
 import qualified Data.Dependent.Map.Monoidal as MonoidalDMap
 import Data.GADT.Compare
 import Data.Map (Map)
+import Data.Functor.Identity (Identity(..))
 import qualified Data.Map as Map
 import Data.Map.Monoidal
 import Data.Semigroup (First(..))
@@ -21,6 +22,7 @@ import Data.Vessel.Map hiding (mapV)
 import Data.Vessel.Single hiding (singleV)
 import Data.Vessel.SubVessel hiding (subVessel)
 import Data.Vessel.Vessel hiding (vessel)
+import Data.Vessel.ViewMorphism (ViewMorphism(..), ViewHalfMorphism(..), ViewQueryResult)
 import Reflex
 
 -- | A (Path v w w' v') consists of maps in opposite directions:
@@ -162,3 +164,12 @@ singleV = Path
 -- and extracting the pair of results afterward.
 zip :: (Semigroup c) => Path a c c' a' -> Path b c c' b' -> Path (a, b) c c' (a', b')
 zip (Path to from) (Path to' from') = Path (\(x,y) -> to x <> to' y) (\c -> liftA2 (,) (from c) (from' c))
+
+-- | A ViewMorphism can be used as a Path to a ViewQueryResult
+vPath :: ViewMorphism Identity Maybe a b -> Path a b (ViewQueryResult b) (ViewQueryResult a)
+vPath = vPath' . _viewMorphism_to
+
+-- | A ViewHalfMorphism can be used as a Path to a ViewQueryResult
+vPath' :: ViewHalfMorphism Identity Maybe a b -> Path a b (ViewQueryResult b) (ViewQueryResult a)
+vPath' (ViewHalfMorphism f g) = Path (runIdentity . f) g
+

src/Data/Vessel/Single.hs

@@ -85,22 +85,22 @@ instance Selectable (SingleV a) () where
 lookupSingleV :: SingleV a Identity -> Maybe a
 lookupSingleV = getFirst . runIdentity . unSingleV
 
-type instance ViewQueryResult (SingleV a (Const g)) = SingleV a Identity
+type instance ViewQueryResult (SingleV a f) = SingleV a (ViewQueryResult f)
 
 -- Note. the result functions always return Just; a "Single" is always
 -- present in the result, only that the value it may be is possibly a Nothing.
-singleV :: (Applicative m, Applicative n) => ViewMorphism m n (Const g (Maybe a)) (SingleV a (Const g))
+singleV :: (Applicative m, Applicative n, Functor f, Functor (ViewQueryResult f), ViewQueryResult f (Maybe a) ~ ViewQueryResult (f (Maybe a))) => ViewMorphism m n (f (Maybe a)) (SingleV a f)
 singleV = ViewMorphism toSingleV fromSingleV
 
-toSingleV :: (Applicative m, Applicative n) => ViewHalfMorphism m n (Const g (Maybe a)) (SingleV a (Const g))
+toSingleV :: (Functor f, Functor (ViewQueryResult f), Applicative m, Applicative n, ViewQueryResult f (Maybe a) ~ ViewQueryResult (f (Maybe a))) => ViewHalfMorphism m n (f (Maybe a)) (SingleV a f)
 toSingleV = ViewHalfMorphism
- { _viewMorphism_mapQuery = \(Const x) -> pure . SingleV $ Const x
- , _viewMorphism_mapQueryResult = \(SingleV (Identity (First x))) -> pure (Identity x)
+ { _viewMorphism_mapQuery = \xs -> pure . SingleV $ fmap First xs
+ , _viewMorphism_mapQueryResult = \(SingleV xs) -> pure $ fmap getFirst xs
  }
 
-fromSingleV :: (Applicative m, Applicative n) => ViewHalfMorphism m n (SingleV a (Const g)) (Const g (Maybe a))
+fromSingleV :: (Functor f, Functor (ViewQueryResult f), Applicative m, Applicative n, ViewQueryResult f (Maybe a) ~ ViewQueryResult (f (Maybe a))) => ViewHalfMorphism m n (SingleV a f) (f (Maybe a))
 fromSingleV = ViewHalfMorphism
- { _viewMorphism_mapQuery = \(SingleV (Const g)) -> pure $ Const g
+ { _viewMorphism_mapQuery = \(SingleV xs) -> pure $ fmap getFirst xs
  , _viewMorphism_mapQueryResult = pure . SingleV . fmap First
  }
 -- | A gadget to "traverse" over a SingleV

src/Data/Vessel/SubVessel.hs

@@ -41,6 +41,7 @@ import Data.Patch (Group(..), Additive)
 import Reflex.Query.Class
 import qualified Data.Dependent.Map as DMap'
 import qualified Data.Dependent.Map.Monoidal as DMap
+import qualified Data.Map as Map'
 import qualified Data.Map.Monoidal as Map
 
 import Data.Vessel.Class hiding (empty)
@@ -207,6 +208,25 @@ mapMaybeWithKeySubVessel f (SubVessel xs) = SubVessel (mapMaybeWithKeyV @(SubVes
  f' :: forall x . SubVesselKey k v x -> x g -> Maybe (x g')
  f' (SubVesselKey k) = f k
 
+mapMaybeWithKeySubVesselSlow
+ :: forall k (v :: (* -> *) -> *) v' (g :: * -> *) (g' :: * -> *).
+ Ord k
+ => (k -> v g -> Maybe (v' g'))
+ -> SubVessel k v g
+ -> SubVessel k v' g'
+mapMaybeWithKeySubVesselSlow f = mkSubVessel . Map.mapMaybeWithKey f . getSubVessel
+
+traverseMaybeSubVesselSlow
+ :: (Ord k, Applicative m)
+ => (k -> v g -> m (Maybe (v' h)))
+ -> SubVessel k v g
+ -> m (SubVessel k v' h)
+traverseMaybeSubVesselSlow f =
+ fmap (mkSubVessel . Map.MonoidalMap)
+ . Map'.traverseMaybeWithKey f
+ . Map.getMonoidalMap
+ . getSubVessel
+
 
 uncurrySubVessel :: (Ord k1, Ord k2) => MonoidalMap k1 (SubVessel k2 v f) -> SubVessel (k1, k2) v f
 uncurrySubVessel xs = mkSubVessel $ uncurryMMap $ fmap getSubVessel xs

src/Data/Vessel/Vessel.hs

@@ -47,6 +47,7 @@ import Data.Align
 import qualified Data.Dependent.Map as DMap'
 import Data.Maybe (fromMaybe)
 import Data.These
+import Data.Monoid.DecidablyEmpty
 
 import Data.Vessel.Class hiding (empty)
 import Data.Vessel.DependentMap
@@ -114,6 +115,9 @@ instance (Has' Semigroup k (FlipAp g), GCompare k, Has View k) => Monoid (Vessel
  mempty = Vessel DMap.empty
  mappend = (<>)
 
+instance (Has' Semigroup k (FlipAp g), GCompare k, Has View k) => DecidablyEmpty (Vessel k g) where
+ isEmpty = nullV
+
 instance (Has' Semigroup k (FlipAp g), Has' Group k (FlipAp g), GCompare k, Has View k) => Group (Vessel k g) where
  negateG (Vessel m) = Vessel (negateG m) --TODO: Do we know that nullV can't be the result of negateG?
 

src/Data/Vessel/ViewMorphism.hs

@@ -35,19 +35,64 @@ import Reflex.Query.Class
 import Reflex.Class
 import Data.Align
 import Data.Vessel.Internal ()
+import Data.Proxy
+import Data.Void
+import Control.Arrow (Kleisli(..))
+import qualified Control.Category.Monoidal as Cat
+import qualified Control.Category.Associative as Cat
+import qualified Control.Category.Braided as Cat
+import qualified Control.Categorical.Bifunctor as Cat
+import Data.Vessel.Orphans ()
+
 
 type family ViewQueryResult (v :: k) :: k
 
 type instance ViewQueryResult (Const g x) = Identity x
 type instance ViewQueryResult (Const g) = Identity
-type instance ViewQueryResult (a, b) = These (ViewQueryResult a) (ViewQueryResult b)
-
--- a way to request partially loaded information;
+type instance ViewQueryResult (Proxy x) = Identity x
+type instance ViewQueryResult Proxy = Identity
+type instance ViewQueryResult (These a b) = These (ViewQueryResult a) (ViewQueryResult b)
+type instance ViewQueryResult Void = Void
+
+
+
+-- | a way to bundle a request of partially loaded information
+--
+-- `m` counts the number of occurrences in the query of `q` in `p`
+-- `n` counts the number of occurrences in the result of `p` in `q`
+--
+-- a ViewHalfMorphism representing the pull side, something like
+-- $ViewHalfMorphism Identity Maybe leaf root$ expresses a way to turn a leaf
+-- query into a root query, and to look up a leaf query result in a root query
+-- result, if its present.
+--
+-- respectively , a push side ViewHalfMorphism, something like
+-- $ViewHalfMorphism Maybe Identity root leaf$ is a way to look up a leaf query
+-- in a root query, if its there, and a way to turn a leaf result into a root
+-- result.
 data ViewHalfMorphism m n p q = ViewHalfMorphism
  { _viewMorphism_mapQuery :: p -> m q
  , _viewMorphism_mapQueryResult :: ViewQueryResult q -> n (ViewQueryResult p) -- TODO Loading data
  }
 
+mapViewHalfMorphism
+ :: Monad m
+ => ViewHalfMorphism f g a b
+ -> (f b -> m (ViewQueryResult b))
+ -> a
+ -> m (g (ViewQueryResult a))
+mapViewHalfMorphism v f x =
+ _viewMorphism_mapQueryResult v <$> f (_viewMorphism_mapQuery v x)
+
+traverseViewHalfMorphism
+ :: (Traversable f, Applicative m)
+ => ViewHalfMorphism f g a b
+ -> (b -> m (ViewQueryResult b))
+ -> a
+ -> m (f (g (ViewQueryResult a)))
+traverseViewHalfMorphism v f x =
+ traverse (fmap (_viewMorphism_mapQueryResult v) . f) (_viewMorphism_mapQuery v x)
+
 data ViewMorphism m n p q = ViewMorphism
  { _viewMorphism_to :: ViewHalfMorphism m n p q
  , _viewMorphism_from :: ViewHalfMorphism n m q p
@@ -91,21 +136,21 @@ zipViewMorphism
  , Semialign n
  , Applicative n
  )
- => ViewMorphism m n a c -> ViewMorphism m n b c -> ViewMorphism m n (a, b) c
+ => ViewMorphism m n a c -> ViewMorphism m n b c -> ViewMorphism m n (These a b) c
 zipViewMorphism (ViewMorphism f f') (ViewMorphism g g') = ViewMorphism (toZipViewMorphism f g) (fromZipViewMorphism f' g')
 
-toZipViewMorphism :: forall m n a b c. (Semialign n, Semigroup (m c)) => ViewHalfMorphism m n a c -> ViewHalfMorphism m n b c -> ViewHalfMorphism m n (a, b) c
+toZipViewMorphism :: forall m n a b c. (Semialign n, Semigroup (m c)) => ViewHalfMorphism m n a c -> ViewHalfMorphism m n b c -> ViewHalfMorphism m n (These a b) c
 toZipViewMorphism (ViewHalfMorphism a2c c2a' ) (ViewHalfMorphism b2c c2b' ) = ViewHalfMorphism
- { _viewMorphism_mapQuery = \(x, y) -> a2c x <> b2c y
+ { _viewMorphism_mapQuery = these a2c b2c $ \x y -> a2c x <> b2c y
  , _viewMorphism_mapQueryResult = \r -> align (c2a' r) (c2b' r)
  }
 fromZipViewMorphism
  :: forall m n a b c.
  ( Applicative m
  , Semigroup (n (ViewQueryResult c))
- ) => ViewHalfMorphism m n c a -> ViewHalfMorphism m n c b -> ViewHalfMorphism m n c (a, b)
+ ) => ViewHalfMorphism m n c a -> ViewHalfMorphism m n c b -> ViewHalfMorphism m n c (These a b)
 fromZipViewMorphism (ViewHalfMorphism c2a a2c') (ViewHalfMorphism c2b b2c') = ViewHalfMorphism
- { _viewMorphism_mapQuery = \r -> liftA2 (,) (c2a r) (c2b r)
+ { _viewMorphism_mapQuery = \r -> liftA2 These (c2a r) (c2b r)
  , _viewMorphism_mapQueryResult = these id id ((<>)) . bimap a2c' b2c'
  }
 
@@ -120,3 +165,39 @@ queryViewMorphism x q = do
  v :: Dynamic t (QueryResult q) <- queryDyn $ (\(ViewMorphism (ViewHalfMorphism f _) _) -> runIdentity $ f x) <$> q
  return $ (\v' (ViewMorphism (ViewHalfMorphism _ g) _) -> g v') <$> v <*> q
 
+
+type instance ViewQueryResult (These a b) = These (ViewQueryResult a) (ViewQueryResult b)
+
+type instance ViewQueryResult Void = Void
+
+instance (Monad f, Monad g) => Cat.PFunctor These (ViewHalfMorphism f g) (ViewHalfMorphism f g) where
+ first (ViewHalfMorphism f g) = ViewHalfMorphism
+ (runKleisli $ Cat.first $ Kleisli f)
+ (runKleisli $ Cat.first $ Kleisli g)
+
+instance (Monad f, Monad g) => Cat.QFunctor These (ViewHalfMorphism f g) (ViewHalfMorphism f g) where
+ second (ViewHalfMorphism f g) = ViewHalfMorphism
+ (runKleisli $ Cat.second $ Kleisli f)
+ (runKleisli $ Cat.second $ Kleisli g)
+
+instance (Monad f, Monad g) => Cat.Bifunctor These (ViewHalfMorphism f g) (ViewHalfMorphism f g) (ViewHalfMorphism f g) where
+ bimap (ViewHalfMorphism f g) (ViewHalfMorphism f' g') = ViewHalfMorphism
+ (runKleisli $ Cat.bimap (Kleisli f) (Kleisli f'))
+ (runKleisli $ Cat.bimap (Kleisli g) (Kleisli g'))
+instance (Monad f, Monad g) => Cat.Associative (ViewHalfMorphism f g) These where
+ associate = ViewHalfMorphism (runKleisli Cat.associate) (runKleisli Cat.disassociate)
+ disassociate = ViewHalfMorphism (runKleisli Cat.disassociate) (runKleisli Cat.associate)
+
+instance (Monad f, Monad g) => Cat.Braided (ViewHalfMorphism f g) These where
+ braid = ViewHalfMorphism (runKleisli Cat.braid) (runKleisli Cat.braid)
+
+instance (Monad f, Monad g) => Cat.Symmetric (ViewHalfMorphism f g) These where
+
+instance (Monad f, Monad g) => Cat.Monoidal (ViewHalfMorphism f g) These where
+ type Id (ViewHalfMorphism f g) These = Cat.Id (Kleisli Identity) These
+ idl = ViewHalfMorphism (runKleisli Cat.idl) (runKleisli Cat.coidl)
+ idr = ViewHalfMorphism (runKleisli Cat.idr) (runKleisli Cat.coidr)
+ coidl = ViewHalfMorphism (runKleisli Cat.coidl) (runKleisli Cat.idl)
+ coidr = ViewHalfMorphism (runKleisli Cat.coidr) (runKleisli Cat.idr)
+
+