packages feed

vessel (empty) → 0.1.0.0

raw patch · 18 files changed

+2770/−0 lines, 18 filesdep +aesondep +aeson-gadt-thdep +base

Dependencies added: aeson, aeson-gadt-th, base, bifunctors, constraints, constraints-extras, containers, dependent-map, dependent-monoidal-map, dependent-sum, dependent-sum-aeson-orphans, dependent-sum-template, lens, markdown-unlit, monoidal-containers, mtl, patch, reflex, semialign, text, these, vessel, witherable

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for vessel++## 0.1.0.0++* Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Obsidian Systems LLC++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Cale Gibbard, Obsidian Systems LLC nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,10 @@+# vessel: functor-parametric containers+[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/vessel.svg)](https://hackage.haskell.org/package/vessel) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/vessel/badge)](https://matrix.hackage.haskell.org/#/package/vessel) [![Github CI](https://github.com/obsidiansystems/vessel/workflows/github-action/badge.svg)](https://github.com/obsidiansystems/vessel/actions) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/obsidiansystems/vessel/blob/master/LICENSE)++See the [tutorial](tutorial/Tutorial.md) for a worked example of how to use this library.+++***++[![Obsidian Systems](https://obsidian.systems/static/images/ObsidianSystemsLogo.svg)](https://obsidian.systems)+
+ src/Data/Vessel.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE PolyKinds #-}++module Data.Vessel+  ( Vessel(..)+  , View(..)+  , EmptyView(..)+  , Selectable(..)+  , FlipAp(..)+  , IdentityV(..)+  , SingleV(..)+  , MapV(..)+  , DMapV(..)+  , singletonV+  , lookupV+  , buildV+  , subtractV+  , mapMaybeWithKeyV+  , traverseWithKeyV+  , traverseWithKeyV_+  , intersectionWithKeyV+  , mapDecomposedV+  , alignWithMV+  , collapseNullV+  , VSum (..)+  , toListV+  , fromListV+  , module Data.Proxy+  , module Data.Functor.Identity+  , module Data.Functor.Const+  , module Data.Functor.Compose+  , transposeView+  , Disperse(..)+  , SubVessel(..)+  , traverseSubVessel+  , singletonSubVessel+  , lookupSubVessel+  ) where++import Data.Functor.Compose+import Data.Functor.Const+import Data.Functor.Identity+import Data.Proxy++import Data.Vessel.Class as X+import Data.Vessel.Disperse as X+import Data.Vessel.Selectable as X+import Data.Vessel.Vessel as X+import Data.Vessel.DependentMap as X+import Data.Vessel.Identity as X+import Data.Vessel.Internal as X+import Data.Vessel.Map as X+import Data.Vessel.Single as X+import Data.Vessel.SubVessel as X+import Data.Vessel.ViewMorphism as X
+ src/Data/Vessel/Class.hs view
@@ -0,0 +1,372 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.Vessel.Class where++import Control.Arrow ((***))+import Control.Monad.Writer.Strict (Writer, execWriter, tell)+import Data.Align+import Data.Foldable+import Data.Functor.Compose+import Data.Witherable+import GHC.Generics+import Data.Semigroup+import Data.These+import Data.Maybe (fromMaybe)+import Data.Functor.Identity+import Reflex.Query.Class+import Data.Proxy+import Data.Map.Monoidal (MonoidalMap (..))+import Data.Dependent.Map.Monoidal (MonoidalDMap (..))+import Data.GADT.Compare+import qualified Data.Dependent.Map.Monoidal as DMap+import qualified Data.Dependent.Map as DMap'++import Data.Vessel.Internal++------- The View Class -------++-- | Our containers are parameterised by a choice of functor to apply at the leaves of their+-- structure. By applying them to Identity, we obtain ordinary containers for data, called "views".+-- By applying them to Proxy, we obtain what are effectively blank forms to be filled in, called+-- "queries" or "view selectors". By using a functor such as Map k, information about many queries+-- or their results may be aggregated together into a single container.+--+-- This class codifies the operations we need to be able to perform on these container types in+-- order to transpose various Map-like structures into and out of them.+--+-- This is done for the purposes of, on the one hand collecting many users' view selectors into a+-- single aggregated selector containing information about who is interested in each part (condenseV),+-- and on the other hand, taking the resulting aggregated views and splitting them into a Map of+-- views for each user (disperseV).+--+-- It also specifies the cropV operation which restricts a view to a particular selection, as well+-- as operations for mapping functions over all the leaves of the container.+class View (v :: (* -> *) -> *) where+  -- | Transpose a sufficiently-Map-like structure into a container, effectively aggregating+  -- many structures into a single one containing information about which keys each part of it+  -- came from originally.+  condenseV :: (Foldable t, Filterable t, Functor t) => t (v g) -> v (Compose t g)+  default condenseV :: GCondenseView t g v => t (v g) -> v (Compose t g)+  condenseV tvg = to $ condenseView $ from <$> tvg++  -- | Transpose a sufficiently-Map-like structure out of a container, the inverse of condenseV.+  disperseV :: (Align t) => v (Compose t g) -> t (v g)+  default disperseV :: GDisperseView t g v => v (Compose t g) -> t (v g)+  disperseV vtg = to <$> disperseView (from vtg)++  -- TODO: Decide whether mapV and traverseV are actually a good idea to provide.+  -- They may actually help people write operations which are inefficient.++  -- | Given a structure specifying a query, and a structure representing a view of data,+  -- restrict the view to only those parts which satisfy the query. (Essentially intersection of Maps.)+  cropV :: (forall a. s a -> i a -> r a) -> v s -> v i -> Maybe (v r)+  default cropV :: forall s i r. GZipView s i r v => (forall a. s a -> i a -> r a) -> v s -> v i -> Maybe (v r)+  cropV f vi vs = maybeEmptyView $ to $ zipView z (from vi) (from vs)+    where z :: forall v'. (View v', EmptyView v') => v' s -> v' i -> v' r+          z v'i v's = fromMaybe emptyV $ cropV f v'i v's++  -- | We also want a way to determine if the container is empty, because shipping empty containers+  -- around is a bad idea.+  nullV :: v i -> Bool+  default nullV :: forall i. GMapView i i v => v i -> Bool+  nullV v = getAll $ execWriter $+              mapViewM @i @i @(Rep (v i)) @(Rep (v i)) f (from v)+    where f :: View v' => v' i -> Writer All (v' i) -- TODO: strict writer is not strict enough,  use State or Writer.CPS+          f v' = tell (All $ nullV v') *> pure v'++  -- | Map a natural transformation over all the leaves of a container, changing the functor which+  -- has been applied.+  mapV :: (forall a. f a -> g a) -> v f -> v g+  default mapV :: GMapView f g v => (forall a. f a -> g a) -> v f -> v g+  mapV f vf = to $ mapView (mapV f) $ from vf++  -- | Traverse over the leaves of a container.+  traverseV :: (Applicative m) => (forall a. f a -> m (g a)) -> v f -> m (v g)+  default traverseV :: (GMapView f g v, Applicative m) => (forall a. f a -> m (g a)) -> v f -> m (v g)+  traverseV f vf = to <$> mapViewM (traverseV f) (from vf)++  -- | Map over all the leaves of a container, keeping only the 'Just' results+  -- and returing 'Nothing' if no leaves are kept.+  mapMaybeV :: (forall a. f a -> Maybe (g a)) -> v f -> Maybe (v g)+  default mapMaybeV :: forall f g. GMapView f g v => (forall a. f a -> Maybe (g a)) -> v f -> Maybe (v g)+  mapMaybeV f vf = maybeEmptyView $ to $ mapView z $ from vf+    where z :: forall v'. (View v', EmptyView v') => v' f -> v' g+          z v'f = fromMaybe emptyV $ mapMaybeV f v'f++  -- | Map over all the leaves of two containers, combining the leaves with the+  -- provided function, keeping only the 'Just' results and returing 'Nothing'+  -- if no leaves are kept.+  alignWithMaybeV :: (forall a. These (f a) (g a) -> Maybe (h a)) -> v f -> v g -> Maybe (v h)+  default alignWithMaybeV :: forall f g h. GZipView f g h v => (forall a. These (f a) (g a) -> Maybe (h a)) -> v f -> v g -> Maybe (v h)+  alignWithMaybeV f vf vg = maybeEmptyView $ to $ zipView z (from vf) (from vg)+    where z :: forall v'. (View v', EmptyView v') => v' f -> v' g -> v' h+          z v'f v'g = fromMaybe emptyV $ alignWithMaybeV f v'f v'g++  -- | Map over all the leaves of two containers, combining the leaves with the+  -- provided function+  alignWithV :: (forall a. These (f a) (g a) -> h a) -> v f -> v g -> v h+  default alignWithV :: GZipView f g h v => (forall a. These (f a) (g a) -> h a) -> v f -> v g -> v h+  alignWithV f vf vg = to $ zipView (alignWithV f) (from vf) (from vg)++-- | A type `v` supports EmptyView iff it is able to contain no information.+class View v => EmptyView v where+  -- Law: nullV emptyV == True+  --TODO: More laws+  emptyV :: v f++maybeEmptyView :: View v => v f -> Maybe (v f)+maybeEmptyView v = if nullV v then Nothing else Just v++------ Classes and Generic instances for Generic View instance ------++class Empty1 a where+  empty :: a p++instance Empty1 U1 where+  empty = U1++instance EmptyView v => Empty1 (K1 i (v f)) where+  empty = K1 emptyV++instance Empty1 a => Empty1 (M1 i t a) where+  empty = M1 empty++instance (Empty1 a, Empty1 b) => Empty1 (a :*: b) where+  empty = empty :*: empty++type GCondenseView t f v =+  ( Generic (v f)+  , Generic (v (Compose t f))+  , CondenseView t (Rep (v f)) (Rep (v (Compose t f)))+  )++class (Foldable t, Filterable t, Functor t) => CondenseView t vf vtf where+  condenseView :: t (vf p) -> vtf p++instance (Foldable t, Filterable t, Functor t) => CondenseView t U1 U1 where+  condenseView _ = U1++instance (View v, Foldable t, Filterable t, Functor t) => CondenseView t (K1 i (v f)) (K1 i (v (Compose t f))) where+  condenseView tvf = K1 $ condenseV $ unK1 <$> tvf++instance CondenseView t vf vtf => CondenseView t (M1 i t' vf) (M1 i t' vtf) where+  condenseView tvf = M1 $ condenseView $ unM1 <$> tvf++instance (CondenseView t avf avtf, CondenseView t bvf bvtf, Empty1 avf, Empty1 bvf) => CondenseView t (avf :*: bvf) (avtf :*: bvtf) where+  condenseView tvf = condenseView (getA <$> tvf) :*: condenseView (getB <$> tvf)+    where getA (a :*: _) = a+          getB (_ :*: b) = b++type GDisperseView t f v =+  ( Generic (v f)+  , Generic (v (Compose t f))+  , DisperseView t (Rep (v f)) (Rep (v (Compose t f)))+  )++class Align t => DisperseView t vf vtf where+  disperseView :: vtf p -> t (vf p)++instance Align t => DisperseView t U1 U1 where+  disperseView _ = nil++instance (View v, Align t) => DisperseView t (K1 i (v f)) (K1 i (v (Compose t f))) where+  disperseView (K1 vtf) = K1 <$> disperseV vtf++instance DisperseView t vf vtf => DisperseView t (M1 i t' vf) (M1 i t' vtf) where+  disperseView (M1 vf) = M1 <$> disperseView vf++instance (DisperseView t avf avtf, DisperseView t bvf bvtf, Empty1 avf, Empty1 bvf) => DisperseView t (avf :*: bvf) (avtf :*: bvtf) where+  disperseView (avtf :*: bvtf) = alignWith f (disperseView avtf) (disperseView bvtf)+    where f :: These (avf p) (bvf p) -> (avf :*: bvf) p+          f = \case+            This a -> a :*: empty+            That b -> empty :*: b+            These a b -> a :*: b++type GMapView f g v =+  ( Generic (v f)+  , Generic (v g)+  , MapView f g (Rep (v f)) (Rep (v g))+  )++class MapView f g vf vg where+  mapViewM+    :: Applicative m+    => (forall v'. (View v', EmptyView v') => v' f -> m (v' g))+    -> vf p+    -> m (vg p)++instance MapView f g V1 V1 where+  mapViewM _ = \case++instance MapView f g U1 U1 where+  mapViewM _ U1 = pure U1++instance (View v, EmptyView v) => MapView f g (K1 i (v f)) (K1 i (v g)) where+  mapViewM f (K1 vf) = K1 <$> f vf++instance MapView f g vf vg => MapView f g (M1 i t vf) (M1 i t vg) where+  mapViewM f (M1 vf) = M1 <$> mapViewM f vf++instance (MapView f g avf avg, MapView f g bvf bvg) => MapView f g (avf :*: bvf) (avg :*: bvg) where+  mapViewM f (avf :*: bvf) = (:*:)+    <$> mapViewM f avf+    <*> mapViewM f bvf++mapView+  :: MapView f g vf vg+  => (forall v'. (View v', EmptyView v') => v' f -> v' g)+  -> vf p+  -> vg p+mapView f vf = runIdentity $ mapViewM (\v'f -> Identity $ f v'f) vf++type GZipView f g h v =+  ( Generic (v f)+  , Generic (v g)+  , Generic (v h)+  , ZipView f g h (Rep (v f)) (Rep (v g)) (Rep (v h))+  )++class ZipView f g h vf vg vh where+  zipViewM+    :: Applicative m+    => (forall v'. (View v', EmptyView v') => v' f -> v' g -> m (v' h))+    -> vf p+    -> vg p+    -> m (vh p)++instance ZipView f g h V1 V1 V1 where+  zipViewM _ = \case++instance ZipView f g h U1 U1 U1 where+  zipViewM _ U1 U1 = pure U1++instance (View v, EmptyView v) => ZipView f g h (K1 i (v f)) (K1 i (v g)) (K1 i (v h)) where+  zipViewM f (K1 vf) (K1 vg) = K1 <$> f vf vg++instance ZipView f g h vf vg vh => ZipView f g h (M1 i t vf) (M1 i t vg) (M1 i t vh) where+  zipViewM f (M1 vf) (M1 vg) = M1 <$> zipViewM f vf vg++instance (ZipView f g h avf avg avh, ZipView f g h bvf bvg bvh) => ZipView f g h (avf :*: bvf) (avg :*: bvg) (avh :*: bvh) where+  zipViewM f (avf :*: bvf) (avg :*: bvg) = (:*:)+    <$> zipViewM f avf avg+    <*> zipViewM f bvf bvg++zipView+  :: ZipView f g h vf vg vh+  => (forall v'. (View v', EmptyView v') => v' f -> v' g -> v' h)+  -> vf p+  -> vg p+  -> vh p+zipView f vf vg = runIdentity $ zipViewM (\v'f v'g -> Identity $ f v'f v'g) vf vg++collapseNullV :: View v => v f -> Maybe (v f)+collapseNullV v = if nullV v+  then Nothing+  else Just v+++subtractV :: View v => v f -> v g -> Maybe (v f)+subtractV = alignWithMaybeV (\case This x -> Just x; _ -> Nothing)++alignWithMV+  :: forall m v f g h+  .  (View v, Applicative m)+  => (forall a. These (f a) (g a) -> m (h a))+  -> v f+  -> v g+  -> m (Maybe (v h))+alignWithMV f a b = traverse (traverseV getCompose) $ alignWithMaybeV g a b+  where g :: forall a. These (f a) (g a) -> Maybe (Compose m h a)+        g = Just . Compose . f++-- | A main point of the View class is to be able to produce this QueryMorphism.+transposeView+  :: ( View v+     , Foldable t+     , Filterable t+     , Functor t+     , Align t+     , QueryResult (t (v g)) ~ (t (v g'))+     , QueryResult (v (Compose t g)) ~ v (Compose t g')+     , Monoid (v g)+     , Monoid (v (Compose t g))+     )+  => QueryMorphism (t (v g)) (v (Compose t g))+transposeView = QueryMorphism+  { _queryMorphism_mapQuery = condenseV -- aggregate queries.+  , _queryMorphism_mapQueryResult = disperseV -- individualise results.+  }++mapDecomposedV+  :: (Functor m, View v)+  => (v Proxy -> m (v Identity))+  -> v (Compose (MonoidalMap c) g)+  -> m (Maybe (v (Compose (MonoidalMap c) Identity)))+mapDecomposedV f v = cropV recompose v <$> (f $ mapV (\_ -> Proxy) v)+  where+    recompose :: Compose (MonoidalMap c) g a -> Identity a -> Compose (MonoidalMap c) Identity a+    recompose (Compose s) i = Compose $ i <$ s++------- The View instance for MonoidalDMap -------+instance (GCompare k) => View (MonoidalDMap k) where+  cropV :: (forall a. s a -> i a -> r a) -> MonoidalDMap k s -> MonoidalDMap k i -> Maybe (MonoidalDMap k r)+  cropV f a b = collapseNullV $ DMap.intersectionWithKey (\_ s i -> f s i) a b++  nullV :: MonoidalDMap k s -> Bool+  nullV m = DMap.null m++  condenseV :: forall col g. ( Foldable col, Filterable col, Functor col )+            => col (MonoidalDMap k g)+            -> MonoidalDMap k (Compose col g)+  condenseV col = condenseD' (fold (fmap unMonoidalDMap col)) col++  disperseV :: forall col g. (Align col)+           => MonoidalDMap k (Compose col g)+           -> col (MonoidalDMap k g)+  disperseV row = case findPivotD (unMonoidalDMap row) of+    NoneD -> nil+    OneD k (Compose v) -> fmap (DMap.singleton k) v+    SplitD pivot _l _r -> uncurry (alignWith (mergeThese unionDistinctAscD)) $+      disperseV *** disperseV $ splitLTD pivot row++  mapV :: (forall a. f a -> g a) -> MonoidalDMap k f -> MonoidalDMap k g+  mapV f m = DMap.map f m++  traverseV :: (Applicative m) => (forall a. f a -> m (g a)) -> MonoidalDMap k f -> m (MonoidalDMap k g)+  traverseV f m = DMap.traverseWithKey (\_ v -> f v) m++  mapMaybeV f (MonoidalDMap m) = collapseNullV $ MonoidalDMap $+    DMap'.mapMaybe f m++  alignWithV f a b = alignWithKeyMonoidalDMap (\_ x -> f x) a b++  alignWithMaybeV f a b = collapseNullV $ alignWithKeyMaybeMonoidalDMap (\_ x -> f x) a b++instance (GCompare k) => EmptyView (MonoidalDMap k) where+  emptyV = DMap.empty++filterV :: View v => (forall a. f a -> Bool) -> v f -> Maybe (v f)+filterV f = mapMaybeV (\x -> if f x then Just x else Nothing)++-- | a completely empty view.+instance View Proxy+
+ src/Data/Vessel/DependentMap.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Vessel.DependentMap where++import Data.Aeson+import Data.Bifunctor+import Data.Constraint.Extras+import Data.Constraint.Forall+import Data.Dependent.Map.Monoidal (MonoidalDMap(..))+import Data.Functor.Compose+import Data.GADT.Compare+import Data.Some (Some(Some))+import GHC.Generics+import Data.Functor.Identity+import Data.Dependent.Sum+import Data.Dependent.Sum.Orphans ()+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Patch (Group(..), Additive)+import qualified Data.Dependent.Map as DMap'+import qualified Data.Dependent.Map.Monoidal as DMap++import Data.Vessel.Class+import Data.Vessel.Selectable+import Data.Vessel.Internal++-- | A functor-indexed container corrresponding to DMap k v.+newtype DMapV (k :: * -> *) (v :: * -> *) g = DMapV { unDMapV :: MonoidalDMap k (Compose g v) }+  deriving (Generic)++deriving instance (GCompare k, Has' Eq k (Compose g v)) => Eq (DMapV k v g)+deriving instance (GCompare k, Has' Eq k (Compose g v), Has' Ord k (Compose g v)) => Ord (DMapV k v g)+deriving instance (GCompare k, Has' Semigroup k (Compose g v)) => Semigroup (DMapV k v g)+deriving instance (GCompare k, Has' Semigroup k (Compose g v), Has' Monoid k (Compose g v)) => Monoid (DMapV k v g)+deriving instance (GCompare k, Has' Semigroup k (Compose g v), Has' Monoid k (Compose g v), Has' Group k (Compose g v)) => Group (DMapV k v g)+deriving instance (GCompare k, Has' Semigroup k (Compose g v), Has' Monoid k (Compose g v), Has' Group k (Compose g v), Has' Additive k (Compose g v)) => Additive (DMapV k v g)++instance (Has' ToJSON k (Compose g v), ForallF ToJSON k) => ToJSON (DMapV k v g)++instance (Has' FromJSON k (Compose g v), FromJSON (Some k), GCompare k) => FromJSON (DMapV k v g)++deriving instance (ForallF Show k, Has' Show k (Compose g v)) => Show (DMapV k v g)++instance (GCompare k) => View (DMapV k v) where+  cropV f (DMapV s) (DMapV i) = collapseNullV $ DMapV (DMap.intersectionWithKey (\_ (Compose x) (Compose y) -> Compose $ f x y) s i)+  nullV (DMapV m) = DMap.null m+  condenseV m = DMapV . DMap.map assocLCompose . condenseV . fmap unDMapV $ m+  disperseV (DMapV m) = fmap DMapV . disperseV . DMap.map assocRCompose $ m+  mapV f (DMapV m) = DMapV $ DMap.map (\(Compose x) -> Compose (f x)) m+  traverseV f (DMapV m) = DMapV <$> DMap.traverseWithKey (\_ (Compose x) -> Compose <$> f x) m+  mapMaybeV f (DMapV (MonoidalDMap m)) = collapseNullV $ DMapV $ MonoidalDMap $+    DMap'.mapMaybe (fmap Compose . f . getCompose) m+  alignWithV f (DMapV a) (DMapV b) = DMapV (alignWithKeyMonoidalDMap (\_ x -> Compose . f $ bimap getCompose getCompose x) a b)+  alignWithMaybeV f (DMapV a) (DMapV b) = collapseNullV . DMapV $+     alignWithKeyMaybeMonoidalDMap (\_ x -> fmap Compose $ f (bimap getCompose getCompose x)) a b++instance (GCompare k) => EmptyView (DMapV k v) where+  emptyV = DMapV DMap.empty++instance (GCompare k) => Selectable (DMapV k v) (Set (Some k)) where+  type Selection (DMapV k v) (Set (Some k)) = MonoidalDMap k v+  selector p s = DMapV . DMap.fromListWithKey (\_ x _ -> x) $+    fmap (\(Some k) -> k :=> Compose p) (Set.toList s)+  selection _ (DMapV m) = DMap.map (\(Compose (Identity v)) -> v) m+
+ src/Data/Vessel/Disperse.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.Vessel.Disperse where++import Control.Arrow ((***))+import Data.Witherable+import Data.Align+import Data.Map.Monoidal (MonoidalMap (..))+import qualified Data.Map.Monoidal as Map+import Data.These+import Data.Foldable hiding (null)++import Data.Vessel.Internal++-- | Disperse is a simplified version of View for ordinary containers. This is used as a stepping stone to obtain the View instance for MapV.+class Disperse row where+  disperse :: (Foldable col, Filterable col, Functor col) => col (row a) -> row (col a)+  condense :: (Align col) => row (col a) -> col (row a)++instance Ord k => Disperse (MonoidalMap k) where+  disperse :: forall col a. (Foldable col, Filterable col, Functor col)+           => col (MonoidalMap k a)+           -> MonoidalMap k (col a)+  disperse col = disperse' (Map.MonoidalMap (fold (fmap Map.getMonoidalMap col))) col+    where+      disperse'+        :: MonoidalMap k a+        -> col (MonoidalMap k a)+        -> MonoidalMap k (col a)+      disperse' folded col' = case findPivot folded of+        None -> Map.MonoidalMap mempty+        One k _ -> Map.singleton k (mapMaybe (Map.lookup k) col')+        Split pivot l r -> uncurry unionDistinctAsc $ (disperse' l *** disperse' r) $ split pivot col'+      split+        :: (Ord k, Filterable col)+        => k -> col (MonoidalMap k a)+        -> (col (MonoidalMap k a), col (MonoidalMap k a))+      split pivot col' = unalignProperly $ mapMaybe (splitOne pivot) col'+      splitOne+        :: Ord k+        => k+        -> MonoidalMap k a+        -> Maybe (These (MonoidalMap k a) (MonoidalMap k a))+      splitOne pivot m =+        let (l, r) = splitLT pivot m+        in case (Map.null l, Map.null r) of+          (True, True) -> Nothing+          (False, True) -> Just $ This l+          (True, False) -> Just $ That r+          (False, False) -> Just $ These l r++  condense :: forall col a. (Align col)+           => MonoidalMap k (col a)+           -> col (MonoidalMap k a)+  condense row = case findPivot row of+    None -> nil+    One k v -> fmap (Map.singleton k) v+    Split pivot _l _r -> uncurry (alignWith (mergeThese unionDistinctAsc)) $ condense *** condense $ splitLT pivot row+
+ src/Data/Vessel/Identity.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.Vessel.Identity where++import Data.Aeson+import Data.Patch (Group(..), Additive)+import GHC.Generics+import Data.Functor.Compose+import Data.Functor.Const+import Data.Functor.Identity+import Data.These++import Data.Vessel.Class+import Data.Vessel.Selectable+import Data.Vessel.ViewMorphism++-- | A functor-indexed container corresponding to Identity. (i.e. a single non-deletable item)+newtype IdentityV (a :: *) (g :: * -> *) = IdentityV { unIdentityV :: g a }+  deriving (Eq, Ord, Show, Read, Semigroup, Monoid, Group, Additive, Generic, ToJSON, FromJSON)++instance View (IdentityV a) where+  cropV f (IdentityV s) (IdentityV x) = Just $ IdentityV $ f s x+  nullV _ = False+  condenseV m = IdentityV (Compose (fmap unIdentityV m))+  disperseV (IdentityV (Compose m)) = fmap IdentityV m+  mapV f (IdentityV x) = IdentityV (f x)+  traverseV f (IdentityV x) = IdentityV <$> f x+  mapMaybeV f (IdentityV x) = IdentityV <$> f x+  alignWithMaybeV f (IdentityV x) (IdentityV y) = IdentityV <$> f (These x y)+  alignWithV f (IdentityV x) (IdentityV y) = IdentityV $ f $ These x y++instance Selectable (IdentityV a) () where+  type Selection (IdentityV a) () = a+  selector p () = IdentityV p+  selection () (IdentityV (Identity a)) = a++lookupIdentityV :: IdentityV a Identity -> a+lookupIdentityV = runIdentity . unIdentityV++type instance ViewQueryResult (IdentityV a (Const g)) = IdentityV a Identity++identityV :: (Applicative m, Applicative n) => ViewMorphism m n (Const g a) (IdentityV a (Const g))+identityV = ViewMorphism toIdentityV fromIdentityV++toIdentityV :: (Applicative m, Applicative n) => ViewHalfMorphism m n (Const g a) (IdentityV a (Const g))+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 = ViewHalfMorphism+  { _viewMorphism_mapQuery = pure . unIdentityV+  , _viewMorphism_mapQueryResult = pure . IdentityV+  }++-- | A gadget to "traverse" over an IdentityV+handleIdentityVSelector+  :: forall a f g m. Functor m+  => (forall x. x -> f x -> g x)+  -> m a+  ->    IdentityV a f+  -> m (IdentityV a g)+handleIdentityVSelector k f (IdentityV xs) = (\y -> IdentityV $ k y xs) <$> f++-- | Non-existentialized map; since the contained value is known+mapIdentityV :: (f a -> g a) -> IdentityV a f -> IdentityV a g+mapIdentityV f (IdentityV xs) = IdentityV (f xs)++
+ src/Data/Vessel/Internal.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Data.Vessel.Internal where++import Control.Arrow ((***))+import Data.Aeson+import Data.Constraint.Extras+import Data.Constraint.Forall+import Data.Dependent.Map.Internal (DMap (..))+import qualified Data.Dependent.Map as DMap'+import Data.Dependent.Map.Monoidal (MonoidalDMap(..))+import Data.Functor.Compose+import Data.Functor.Const+import Data.GADT.Compare+import Data.Some (Some(Some))+import Data.Map.Monoidal (MonoidalMap (..))+import qualified Data.Map.Monoidal as Map+import Data.These+import Data.Patch (Group(..), Additive)+import Data.Coerce+import Data.Set (Set)+import Data.Witherable+import qualified Data.Map as Map'+import qualified Data.Map.Merge.Strict as Map'++import qualified Data.Dependent.Map.Monoidal as DMap+-- import qualified Data.Dependent.Map as DMap'++newtype FlipAp (g :: k) (v :: k -> *) = FlipAp { unFlipAp :: v g }+  deriving (Eq, Ord, Show)++------- Instances for FlipAp -------++instance Semigroup (v g) => Semigroup (FlipAp g v) where+  FlipAp x <> FlipAp y = FlipAp (x <> y)++instance Monoid (v g) => Monoid (FlipAp g v) where+  mempty = FlipAp mempty+  mappend (FlipAp x) (FlipAp y) = FlipAp (mappend x y)++instance Group (v g) => Group (FlipAp g v) where+  negateG (FlipAp x) = FlipAp (negateG x)++instance Additive (v g) => Additive (FlipAp g v)+++-- A single Vessel key/value pair, essentially a choice of container type, together with a corresponding container.+data VSum (k :: ((* -> *) -> *) -> *) (g :: * -> *) = forall v. k v :~> v g++------- Serialisation -------++instance (ForallF ToJSON k, HasV ToJSON k g) => ToJSON (VSum k g) where+  toJSON ((k :: k v) :~> (v :: v g)) =+    toJSON ( whichever @ToJSON @k @v (toJSON k)+           , hasV @ToJSON @g k (toJSON v))++instance forall k g. (FromJSON (Some k), HasV FromJSON k g) => FromJSON (VSum k g) where+  parseJSON x = do+    (jk, jv) <- parseJSON x+    (Some k) <- parseJSON jk+    v <- hasV @FromJSON @g k (parseJSON jv)+    return (k :~> v)+--+------ TODO: Orphans that need a good home -------++instance (Has' Group f g, Has' Semigroup f g, GCompare f) => Group (MonoidalDMap f g) where+  negateG (MonoidalDMap m) = MonoidalDMap (DMap'.mapWithKey (\k v -> has' @Group @g k (negateG v)) m)++instance (Has' Group f g, Has' Semigroup f g, GCompare f) => Additive (MonoidalDMap f g)++instance (Semigroup (f (g a))) => Semigroup (Compose f g a) where+  (Compose x) <> (Compose y) = Compose (x <> y)++instance (Monoid (f (g a))) => Monoid (Compose f g a) where+  mempty = Compose mempty+  mappend (Compose x) (Compose y) = Compose (mappend x y)++------- Miscellaneous stuff to be moved elsewhere -------++-- TODO: These belong in Data.Functor.Compose -- good luck to anyone who wants to upstream them into base though.+-- Perhaps we could start a small module filled with basic coherences like this.+assocLCompose :: (Functor f) => Compose f (Compose g h) x -> Compose (Compose f g) h x+assocLCompose (Compose x) = Compose (Compose (fmap getCompose x))++assocRCompose :: (Functor f) => Compose (Compose f g) h x -> Compose f (Compose g h) x+assocRCompose (Compose (Compose x)) = Compose (fmap Compose x)++alignWithKeyMaybeDMap :: GCompare k => (forall a. k a -> These (f a) (g a) -> Maybe (h a)) -> DMap k f -> DMap k g -> DMap k h+alignWithKeyMaybeDMap f a b = DMap'.mapMaybeWithKey (\k t -> f k $ dtheseToThese t) $ DMap'.unionWithKey (\_ (DThis x) (DThat y) -> DThese x y) (DMap'.map DThis a) (DMap'.map DThat b)++alignWithKeyDMap :: GCompare k => (forall a. k a -> These (f a) (g a) -> h a) -> DMap k f -> DMap k g -> DMap k h+alignWithKeyDMap f a b = DMap'.mapWithKey (\k t -> f k $ dtheseToThese t) $ DMap'.unionWithKey (\_ (DThis x) (DThat y) -> DThese x y) (DMap'.map DThis a) (DMap'.map DThat b)++data DThese f g a = DThis (f a) | DThat (g a) | DThese (f a) (g a)++dtheseToThese :: DThese f g a -> These (f a) (g a)+dtheseToThese = \case+  DThis a -> This a+  DThat b -> That b+  DThese a b -> These a b++theseToDThese :: These (f a) (g a) -> DThese f g a+theseToDThese = \case+  This a -> DThis a+  That b -> DThat b+  These a b -> DThese a b++-- TODO: Contribute this to the 'these' package and/or sort out its generalisation.+unalignProperly :: (Filterable f) => f (These a b) -> (f a, f b)+unalignProperly f = (mapMaybe leftThese f, mapMaybe rightThese f)+  where+    leftThese :: These a b -> Maybe a+    leftThese = these (\x -> Just x) (\_ -> Nothing) (\x _ -> Just x)+    rightThese :: These a b -> Maybe b+    rightThese = these (\_ -> Nothing) (\y -> Just y) (\_ y -> Just y)++data Pivot k a = None | One k a | Split k (MonoidalMap k a) (MonoidalMap k a)+  deriving (Eq, Ord, Show)++findPivot :: Ord k => MonoidalMap k a -> Pivot k a+findPivot m = case Map.splitRoot m of+  [] -> None+  [l,xm,r] -> case Map.toList xm of+      [(k,v)] | Map.null l && Map.null r -> One k v+              | otherwise -> Split k (Map.insert k v l) r+      _ -> errorMsg+  _ -> errorMsg+  where errorMsg = error "Data.Vessel.findPivot: unexpected result from Data.MonoidalMap.splitRoot (wrong version of monoidal-containers?)"++unionDistinctAsc :: (Ord k) => MonoidalMap k a -> MonoidalMap k a -> MonoidalMap k a+unionDistinctAsc = Map.unionWith (\x _ -> x)++splitLT :: Ord k => k -> MonoidalMap k a -> (MonoidalMap k a, MonoidalMap k a)+splitLT k m = case Map.splitLookup k m of+  (l, Just v, r) -> (Map.insert k v l, r)+  (l, Nothing, r) -> (l, r)++data PivotD (k :: l -> *) (g :: l -> *) = NoneD | forall v. OneD (k v) (g v) | forall v. SplitD (k v) (DMap k g) (DMap k g)++condenseD' :: (GCompare k, Foldable t, Filterable t)+           => DMap k g+           -> t (MonoidalDMap k g)+           -> MonoidalDMap k (Compose t g)+condenseD' folded col = case findPivotD folded of+  NoneD -> DMap.empty+  OneD k _ -> DMap.singleton k (Compose $ mapMaybe (DMap.lookup k) col)+  SplitD pivot l r -> uncurry unionDistinctAscD $ (condenseD' l *** condenseD' r) $ splitD pivot col++findPivotD :: (GCompare k) => DMap k g -> PivotD k g+findPivotD m = case m of+  Tip -> NoneD+  Bin _ k v l r+    | DMap'.null l && DMap'.null r -> OneD k v+    | otherwise -> SplitD k (DMap'.insert k v l) r++unionDistinctAscD :: (GCompare k) => MonoidalDMap k g -> MonoidalDMap k g -> MonoidalDMap k g+unionDistinctAscD = DMap.unionWithKey (\_ x _ -> x)++splitLTD :: GCompare k => k v -> MonoidalDMap k g -> (MonoidalDMap k g, MonoidalDMap k g)+splitLTD k m = case DMap.splitLookup k m of+  (l, Just v, r) -> (DMap.insert k v l, r)+  (l, Nothing, r) -> (l, r)++alignWithKeyMonoidalDMap :: GCompare k => (forall a. k a -> These (f a) (g a) -> h a) -> MonoidalDMap k f -> MonoidalDMap k g -> MonoidalDMap k h+alignWithKeyMonoidalDMap f (MonoidalDMap a) (MonoidalDMap b) = MonoidalDMap $ alignWithKeyDMap f a b+++alignWithKeyMaybeMonoidalDMap :: GCompare k => (forall a. k a -> These (f a) (g a) -> Maybe (h a)) -> MonoidalDMap k f -> MonoidalDMap k g -> MonoidalDMap k h+alignWithKeyMaybeMonoidalDMap f (MonoidalDMap a) (MonoidalDMap b) = MonoidalDMap $ alignWithKeyMaybeDMap f a b++splitD :: (GCompare k, Filterable t)+       => k x -> t (MonoidalDMap k g) -> (t (MonoidalDMap k g), t (MonoidalDMap k g))+splitD pivot col = unalignProperly $ mapMaybe (splitOneD pivot) col++splitOneD :: (GCompare k) => k v -> MonoidalDMap k g -> Maybe (These (MonoidalDMap k g) (MonoidalDMap k g))+splitOneD pivot m =+  let (l, r) = splitLTD pivot m+  in case (DMap.null l, DMap.null r) of+    (True, True) -> Nothing+    (False, True) -> Just $ This l+    (True, False) -> Just $ That r+    (False, False) -> Just $ These l r++instance Group (f (g x)) => Group (Compose f g x) where+  negateG (Compose fgx) = Compose (negateG fgx)+  Compose fgx ~~ Compose fgy = Compose (fgx ~~ fgy)++curryMMap :: (Ord a, Ord b) => MonoidalMap (a,b) c -> MonoidalMap a (MonoidalMap b c)+curryMMap m = Map.fromListWith (Map.unionWith (error "overlap")) $+  [ (a, (Map.singleton b c))+  | ((a,b), c) <- Map.toList m+  ]++uncurryMMap :: (Ord a, Ord b) => MonoidalMap a (MonoidalMap b c) -> MonoidalMap (a,b) c+uncurryMMap m = Map.fromListWith (error "overlap") $+  [ ((a, b), c)+  | (a, bc) <- Map.toList m+  , (b, c) <- Map.toList bc+  ]++leftOuterJoin :: Ord k => (a -> c) -> (a -> b -> c) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k c+leftOuterJoin =+  (coerce :: ((a -> c) -> (a -> b -> c) -> Map'.Map k a -> Map'.Map k b -> Map'.Map k c)+          -> ((a -> c) -> (a -> b -> c) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k c)+  ) leftOuterJoin'++leftOuterJoin' :: Ord k => (a -> c) -> (a -> b -> c) -> Map'.Map k a -> Map'.Map k b -> Map'.Map k c+leftOuterJoin' a2c ab2c = Map'.merge+    (Map'.mapMissing $ \_ -> a2c)+    Map'.dropMissing+    (Map'.zipWithMatched $ \_ -> ab2c)++leftOuterJoin_ :: Ord k => a -> Set k -> MonoidalMap k a -> MonoidalMap k a+leftOuterJoin_ x = leftOuterJoin id const . Map.fromSet (const x)
+ src/Data/Vessel/Map.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.Vessel.Map where++import Control.Applicative+import Data.Aeson+import Data.Align+import Data.Foldable+import Data.Functor.Identity+import Data.Functor.Compose+import Data.Map.Monoidal (MonoidalMap (..))+import Data.Patch (Group(..), Additive)+import GHC.Generics+import qualified Data.Map.Monoidal as Map+import qualified Data.Map as Map'+import qualified Data.Map.Merge.Strict as Map'+import Data.Set (Set)++import Data.Vessel.Class hiding (empty)+import Data.Vessel.Selectable+import Data.Vessel.Disperse+import Data.Vessel.ViewMorphism++-- | A functor-indexed container corresponding to Map k v.+newtype MapV k v g = MapV { unMapV :: MonoidalMap k (g v) }+  deriving (Eq, Ord, Show, Read, Generic)++deriving instance (Semigroup v, Ord k) => Semigroup (MapV k v Identity)+deriving instance (Semigroup v, Ord k) => Monoid (MapV k v Identity)+deriving instance (Ord k1, Ord k2, Semigroup v) => Semigroup (MapV k1 v (Compose (MonoidalMap k2) Identity))++instance (Ord k, Eq g, Monoid g) => Semigroup (MapV k v (Const g)) where+  MapV (MonoidalMap xs) <> MapV (MonoidalMap ys) = MapV $ MonoidalMap $ Map'.merge Map'.preserveMissing Map'.preserveMissing (Map'.zipWithMaybeMatched $ \_ (Const x) (Const y) -> f x y) xs ys+    where+      f :: g -> g -> Maybe (Const g v)+      f x y = if xy == mempty then Nothing else Just (Const xy)+        where+          xy = x <> y++instance (Ord k, Eq g, Monoid g) => Monoid (MapV k v (Const g)) where+  mappend = (<>)+  mempty = MapV Map.empty++instance (Ord k, Eq g, Group g) => Group (MapV k v (Const g)) where+  negateG (MapV (MonoidalMap xs)) = MapV $ MonoidalMap $ fmap negateG xs+instance (Ord k, Eq g, Group g, Additive g) => Additive (MapV k v (Const g))++instance (Ord k1, Ord k2, Monoid g, Eq g) => Semigroup (MapV k1 v (Compose (MonoidalMap k2) (Const g))) where+  MapV (MonoidalMap xs) <> MapV (MonoidalMap ys) = MapV $ MonoidalMap $ Map'.merge Map'.preserveMissing Map'.preserveMissing (Map'.zipWithMaybeMatched $ \_ (Compose (MonoidalMap x)) (Compose (MonoidalMap y)) -> fmap Compose $ nothingOnNull $ MonoidalMap $ mergeMapSemigroup x y) xs ys+    where+      nothingOnNull :: Foldable f => f a -> Maybe (f a)+      nothingOnNull f = if null f then Nothing else Just f++      mergeMapSemigroup :: forall k g. (Ord k, Monoid g, Eq g) => Map'.Map k g -> Map'.Map k g -> Map'.Map k g+      mergeMapSemigroup = Map'.merge Map'.preserveMissing Map'.preserveMissing (Map'.zipWithMaybeMatched $ const f)+          where+            f :: g -> g -> Maybe g+            f x y = if xy == mempty then Nothing else Just xy+              where+                xy = x <> y++instance (Ord k1, Ord k2, Monoid g, Eq g) => Monoid (MapV k1 v (Compose (MonoidalMap k2) (Const g))) where+  mappend = (<>)+  mempty = MapV Map.empty++instance (Ord k1, Ord k2, Group g, Eq g) => Group (MapV k1 v (Compose (MonoidalMap k2) (Const g))) where+  negateG (MapV xs) = MapV $ fmap negateG xs+instance (Ord k1, Ord k2, Additive g, Group g, Eq g) => Additive (MapV k1 v (Compose (MonoidalMap k2) (Const g)))++instance (Ord k) => View (MapV k v) where+  cropV f (MapV s) (MapV i) = collapseNullV $ MapV (Map.intersectionWithKey (\_ x y -> f x y) s i)+  nullV (MapV m) = Map.null m+  condenseV m = MapV . fmap Compose . disperse . fmap unMapV $ m+  disperseV (MapV m) = fmap MapV . condense . fmap getCompose $ m+  mapV f (MapV m) = MapV $ Map.map f m+  traverseV f (MapV m) = MapV <$> traverse f m+  mapMaybeV f (MapV m) = collapseNullV $ MapV $ Map.mapMaybe f m+  alignWithMaybeV f (MapV (MonoidalMap a)) (MapV (MonoidalMap b)) = collapseNullV $ MapV $ MonoidalMap $ Map'.mapMaybe id $ alignWith f a b+  alignWithV f (MapV (MonoidalMap a)) (MapV (MonoidalMap b)) = MapV $ MonoidalMap $ alignWith f a b++instance (Ord k) => EmptyView (MapV k v) where+  emptyV = MapV Map.empty++deriving instance (ToJSONKey k, ToJSON (g v), Ord k) => ToJSON (MapV k v g)+deriving instance (FromJSONKey k, FromJSON (g v), Ord k) => FromJSON (MapV k v g)++instance (Ord k) => Selectable (MapV k v) (Set k) where+  type Selection (MapV k v) (Set k) = MonoidalMap k v+  selector p s = MapV (Map.fromSet (const p) s)+  selection _ (MapV m) = fmap (\(Identity a) -> a) m++instance Ord k => Selectable (MapV k v) (Identity k) where+  type Selection (MapV k v) (Identity k) = Maybe v+  selector p (Identity k) = MapV (Map.singleton k p)+  selection (Identity k) (MapV m) = Map.lookup k $ fmap (\(Identity a) -> a) m++singletonMapV :: k -> g v -> MapV k v g+singletonMapV k v = MapV $ Map.singleton k v++lookupMapV :: Ord k => k -> MapV k v g -> Maybe (g v)+lookupMapV k (MapV xs) = Map.lookup k xs++type instance ViewQueryResult (MapV k v g) = MapV k v (ViewQueryResult g)++mapVMorphism+  :: ( Ord k , ViewQueryResult (g v) ~ ViewQueryResult g v, Alternative n, Applicative m)+  => k -> ViewMorphism m n (g v) (MapV k v g)+mapVMorphism k = ViewMorphism (toMapVMorphism k) (fromMapVMorphism k)++toMapVMorphism+  :: ( Ord k , ViewQueryResult (g v) ~ ViewQueryResult g v, Alternative n, Applicative m)+  => k -> ViewHalfMorphism m n (g v) (MapV k v g)+toMapVMorphism k = ViewHalfMorphism+  { _viewMorphism_mapQuery = pure . singletonMapV k+  , _viewMorphism_mapQueryResult = maybe empty pure . lookupMapV k+  }+fromMapVMorphism+  :: ( Alternative m, Applicative n, Ord k , ViewQueryResult (g v) ~ ViewQueryResult g v)+  => k -> ViewHalfMorphism m n (MapV k v g) (g v)+fromMapVMorphism k = ViewHalfMorphism+  { _viewMorphism_mapQuery = maybe empty pure . lookupMapV k+  , _viewMorphism_mapQueryResult = pure . singletonMapV k+  }++mapVSetMorphism+  :: ( Ord k , ViewQueryResult (g v) ~ ViewQueryResult g v, Monoid (ViewQueryResult g v), Monoid (g v), Alternative n, Applicative m)+  => Set k -> ViewMorphism m n (g v) (MapV k v g)+mapVSetMorphism k = ViewMorphism (toMapVSetMorphism k) (fromMapVSetMorphism k)++toMapVSetMorphism+  :: ( Ord k , ViewQueryResult (g v) ~ ViewQueryResult g v, Applicative n, Applicative m, Monoid (ViewQueryResult g v))+  => Set k -> ViewHalfMorphism m n (g v) (MapV k v g)+toMapVSetMorphism k = ViewHalfMorphism+  { _viewMorphism_mapQuery = pure . MapV . flip Map.fromSet k . const+  , _viewMorphism_mapQueryResult = pure . fold . flip Map'.restrictKeys k . getMonoidalMap . unMapV+  }+fromMapVSetMorphism+  :: ( Alternative m, Applicative n, Ord k , ViewQueryResult (g v) ~ ViewQueryResult g v, Monoid (g v))+  => Set k -> ViewHalfMorphism m n (MapV k v g) (g v)+fromMapVSetMorphism k = ViewHalfMorphism+  { _viewMorphism_mapQuery = pure . fold . flip Map'.restrictKeys k . getMonoidalMap . unMapV+  , _viewMorphism_mapQueryResult = pure . MapV . flip Map.fromSet k . const+  }++-- | Match whatever's present in the View, insert nothing.+mapVWildcardMorphism+  :: (Semigroup (g v), Semigroup (ViewQueryResult g v), ViewQueryResult (g v) ~ ViewQueryResult g v, Alternative n, Applicative m)+  => ViewMorphism m n (g v) (MapV k v g)+mapVWildcardMorphism = ViewMorphism toMapVWildcardMorphism fromMapVWildcardMorphism++toMapVWildcardMorphism+  :: (Applicative m, Alternative n, Semigroup (ViewQueryResult g v), ViewQueryResult (g v) ~ ViewQueryResult g v)+  => ViewHalfMorphism m n (g v) (MapV k v g)+toMapVWildcardMorphism = ViewHalfMorphism+  { _viewMorphism_mapQuery = const $ pure $ MapV Map.empty+  , _viewMorphism_mapQueryResult = maybe empty pure . foldMap Just . unMapV+  }++fromMapVWildcardMorphism+  :: (Alternative m, Applicative n, Semigroup (g v))+  => ViewHalfMorphism m n (MapV k v g) (g v)+fromMapVWildcardMorphism = ViewHalfMorphism+  { _viewMorphism_mapQuery = maybe empty pure . foldMap Just . unMapV+  , _viewMorphism_mapQueryResult = const $ pure $ MapV Map.empty+  }++-- | A gadget to "traverse" over all of the keys in a MapV in one step+handleMapVSelector+  :: forall a f g k m.+  ( Ord k, Functor m )+  => (forall x. x -> f x -> g x)+  -> (Set k -> m (MonoidalMap k a))+  ->    MapV k a f+  -> m (MapV k a g)+handleMapVSelector k f (MapV xs) = (\ys -> MapV $ Map.intersectionWith k ys xs) <$> f (Map.keysSet xs)++-- | Non-existentialized mapV; since the contained value is known+mapMapWithKeyV :: (k -> f a -> g a) -> MapV k a f -> MapV k a g+mapMapWithKeyV f (MapV xs) = MapV (Map.mapWithKey f xs)
+ src/Data/Vessel/Selectable.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.Vessel.Selectable where+------- Selectable convenience class -------++import Data.Functor.Identity++-- A convenience class for producing and consuming functor-indexed containers.+class Selectable v k where+  -- | A more convenient type to use for extracting results.+  type Selection v k+  -- | Build a query given a suitable value for specifying what we're asking for.+  -- 'p' will typically be Proxy or Const SelectedCount.+  selector :: (forall a. p a) -> k -> v p+  -- | From a view, extract a more convenient type of value to use.+  selection :: k -> v Identity -> Selection v k+
+ src/Data/Vessel/Single.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Vessel.Single where++import Data.These+import Data.Patch (Group(..), Additive)+import Data.Semigroup+import Data.Functor.Identity+import Data.Witherable+import Data.Functor.Compose+import Data.Functor.Const+import Data.Align+import Data.Aeson+import GHC.Generics (Generic)++import Data.Vessel.Class+import Data.Vessel.Selectable+import Data.Vessel.ViewMorphism++------- Simple structure components -------++-- | A functor-indexed container for a single deletable item.+newtype SingleV (a :: *) (g :: * -> *) = SingleV { unSingleV :: g (First (Maybe a)) }+  deriving (Generic)++deriving instance (Eq (g (First (Maybe a)))) => Eq (SingleV a g)+deriving instance (Ord (g (First (Maybe a)))) => Ord (SingleV a g)+deriving instance (Show (g (First (Maybe a)))) => Show (SingleV a g)+deriving instance (Read (g (First (Maybe a)))) => Read (SingleV a g)++instance (Semigroup (g (First (Maybe a)))) => Semigroup (SingleV a g) where+  (SingleV x) <> (SingleV y) = SingleV (x <> y)++instance (Monoid (g (First (Maybe a)))) => Monoid (SingleV a g) where+  mempty = SingleV mempty+  mappend (SingleV x) (SingleV y) = SingleV (mappend x y)++instance (Group (g (First (Maybe a)))) => Group (SingleV a g) where+  negateG (SingleV x) = SingleV (negateG x)++instance (Additive (g (First (Maybe a)))) => Additive (SingleV a g)++instance View (SingleV a) where+  cropV f (SingleV s) (SingleV i) = Just $ SingleV $ f s i+  nullV (SingleV _) = False+  condenseV :: (Foldable t, Filterable t, Functor t) => t (SingleV a g) -> SingleV a (Compose t g)+  condenseV m = SingleV . Compose $ fmap unSingleV m+  disperseV :: (Align t) => SingleV a (Compose t g) -> t (SingleV a g)+  disperseV (SingleV (Compose x)) = fmap SingleV x+  mapV :: (forall x. f x -> g x) -> SingleV a f -> SingleV a g+  mapV f (SingleV x) = SingleV $ f x+  traverseV :: (Applicative m) => (forall x. f x -> m (g x)) -> SingleV a f -> m (SingleV a g)+  traverseV f (SingleV x) = SingleV <$> f x+  mapMaybeV f (SingleV x) = SingleV <$> f x+  alignWithMaybeV f (SingleV x) (SingleV y) = SingleV <$> f (These x y)+  alignWithV f (SingleV x) (SingleV y) = SingleV $ f $ These x y++deriving instance ToJSON (g (First (Maybe a))) => ToJSON (SingleV a g)++deriving instance FromJSON (g (First (Maybe a))) => FromJSON (SingleV a g)++instance Selectable (SingleV a) () where+  type Selection (SingleV a) () = Maybe a+  selector p () = SingleV p+  selection () (SingleV x) = getFirst . runIdentity $ x++lookupSingleV :: SingleV a Identity -> Maybe a+lookupSingleV = getFirst . runIdentity . unSingleV++type instance ViewQueryResult (SingleV a (Const g)) = SingleV a Identity++-- 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 = ViewMorphism toSingleV fromSingleV++toSingleV :: (Applicative m, Applicative n) => ViewHalfMorphism m n (Const g (Maybe a)) (SingleV a (Const g))+toSingleV = ViewHalfMorphism+  { _viewMorphism_mapQuery = \(Const x) -> pure . SingleV $ Const x+  , _viewMorphism_mapQueryResult = \(SingleV (Identity (First x))) -> pure (Identity x)+  }++fromSingleV :: (Applicative m, Applicative n) => ViewHalfMorphism m n (SingleV a (Const g)) (Const g (Maybe a))+fromSingleV = ViewHalfMorphism+  { _viewMorphism_mapQuery = \(SingleV (Const g)) -> pure $ Const g+  , _viewMorphism_mapQueryResult = pure . SingleV . fmap First+  }+-- | A gadget to "traverse" over a SingleV+handleSingleVSelector+  :: forall a f g m. Functor m+  => (forall x. x -> f x -> g x)+  -> m (First (Maybe a))+  ->    SingleV a f+  -> m (SingleV a g)+handleSingleVSelector k f (SingleV xs) = (\y -> SingleV $ k y xs) <$> f++-- | Non-existentialized mapV; since the contained value is known+mapSingleV :: (f (First (Maybe a)) -> g (First (Maybe a))) -> SingleV a f -> SingleV a g+mapSingleV f (SingleV xs) = SingleV (f xs)
+ src/Data/Vessel/SubVessel.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Vessel.SubVessel where++import Control.Applicative+import Data.Aeson+import Data.Constraint+import Data.Constraint.Extras+import Data.Dependent.Map.Monoidal (MonoidalDMap(..))+import Data.Dependent.Sum (DSum(..))+import Data.Foldable+import Data.Functor.Compose+import Data.Functor.Identity+import Data.GADT.Compare+import Data.GADT.Show+import Data.Map.Monoidal (MonoidalMap(..))+import Data.Proxy+import Data.Set (Set)+import Data.Some (Some(Some))+import Data.Type.Equality+import GHC.Generics+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.Monoidal as Map++import Data.Vessel.Class hiding (empty)+import Data.Vessel.Vessel+import Data.Vessel.Internal+import Data.Vessel.ViewMorphism++data SubVesselKey k (f :: (* -> *) -> *) (g :: (* -> *) -> *) where+  SubVesselKey :: k -> SubVesselKey k f f+deriving instance Show k => Show (SubVesselKey k f g)+instance Show k => GShow (SubVesselKey k f) where gshowsPrec = showsPrec++instance FromJSON k => FromJSON (Some (SubVesselKey k v)) where parseJSON v = Some . SubVesselKey <$> parseJSON v+instance ToJSON k => ToJSON (SubVesselKey k f g) where toJSON (SubVesselKey k) = toJSON k++instance ArgDict c (SubVesselKey k f) where+  type ConstraintsFor (SubVesselKey k f) c = c f+  argDict (SubVesselKey _) = Dict++instance Eq k => GEq (SubVesselKey k v) where+  geq (SubVesselKey x) (SubVesselKey y) = case x == y of+    True -> Just Refl+    False -> Nothing++instance Ord k => GCompare (SubVesselKey k v) where+  gcompare (SubVesselKey x) (SubVesselKey y) = case compare x y of+    LT -> GLT+    EQ -> GEQ+    GT -> GGT++-- | Something between MapV and Vessel, where the keys are simple values, but the values are full views.+--+-- TODO: this representation has the advantage that all of it's instances come "free", but the mostly "right" representation is probably+-- ... Vessel v (Compose (MonoidalMap k) f)+newtype SubVessel (k :: *)  (v :: (* -> *) -> *) (f :: * -> *) = SubVessel { unSubVessel :: Vessel (SubVesselKey k v) f }+  deriving (FromJSON, ToJSON, Semigroup, Monoid, Generic, Group, Additive, Eq)++deriving instance (Show k, Show (v f)) => Show (SubVessel k v f)++-- slightly nicer unwrapper compared to unSubVessel+getSubVessel :: Ord k => SubVessel k v f -> MonoidalMap k (v f)+getSubVessel = Map.fromListWith (error "getSubVessel:collision") . fmap (\(SubVesselKey k :~> v) -> (k, v)) . toListV . unSubVessel++mkSubVessel :: Ord k => MonoidalMap k (v f) -> SubVessel k v f+mkSubVessel = SubVessel . Vessel . MonoidalDMap . DMap'.fromList . fmap (\(k, v) -> (SubVesselKey k :=> FlipAp v)) . Map.toList+++instance (Ord k, View v) => View (SubVessel k v)++instance (Ord k, Semigroup (v Identity), View v) => Query (SubVessel k v (Const x)) where+  type QueryResult (SubVessel k v (Const x)) = SubVessel k v Identity+  crop (SubVessel q) (SubVessel r) = SubVessel (crop q r)++instance (Ord k, Semigroup (v Identity), View v ) => Query (SubVessel k v Proxy) where+  type QueryResult (SubVessel k v Proxy) = SubVessel k v Identity+  crop (SubVessel q) (SubVessel r) = SubVessel (crop q r)++instance+    ( Ord k+    , View v+    , Query (Vessel (SubVesselKey k v) g)+    , Semigroup (v (Compose c (VesselLeafWrapper (QueryResult (Vessel (SubVesselKey k v) g)))))+    )+    => Query (SubVessel k v (Compose c (g :: * -> *))) where+  type QueryResult (SubVessel k v (Compose c g)) = SubVessel k v+    (Compose c (VesselLeafWrapper (QueryResult (Vessel (SubVesselKey k v) g))))+  crop (SubVessel q) (SubVessel r) = SubVessel (crop q r)+++traverseSubVessel :: (Ord k, View v, Applicative m) => (k -> v g -> m (v h)) -> SubVessel k v g -> m (SubVessel k v h)+traverseSubVessel f (SubVessel x) = SubVessel <$> traverseWithKeyV (\(SubVesselKey k) -> f k) x++singletonSubVessel :: forall k f v . View v => k -> v f -> SubVessel k v f+singletonSubVessel k f = SubVessel $ singletonV @v @(SubVesselKey k v) (SubVesselKey k :: SubVesselKey k v v ) f++lookupSubVessel :: (Ord k) => k -> SubVessel k v f -> Maybe (v f)+lookupSubVessel k = lookupV (SubVesselKey k) . unSubVessel++subVesselFromKeys :: (Ord k, View v) => (k -> v f) -> Set k -> SubVessel k v f+subVesselFromKeys f ks = SubVessel $ fromListV $ fmap (\k -> SubVesselKey k :~> f k) $ toList ks++type instance ViewQueryResult (SubVessel k v g) = SubVessel k v (ViewQueryResult g)++subVessel :: (Ord k, View v, ViewQueryResult (v g) ~ v (ViewQueryResult g), Alternative n, Applicative m) => k -> ViewMorphism m n (v g) (SubVessel k v g)+subVessel k = ViewMorphism (toSubVessel k) (fromSubVessel k)++toSubVessel :: (Ord k, Applicative m, Alternative n, View v, ViewQueryResult (v g) ~ v (ViewQueryResult g)) => k -> ViewHalfMorphism m n (v g) (SubVessel k v g)+toSubVessel k = ViewHalfMorphism+  { _viewMorphism_mapQuery = pure . singletonSubVessel k+  , _viewMorphism_mapQueryResult = maybe empty pure . lookupSubVessel k+  }++fromSubVessel :: (Ord k, Alternative m, Applicative n, View v, ViewQueryResult (v g) ~ v (ViewQueryResult g)) => k -> ViewHalfMorphism m n (SubVessel k v g) (v g)+fromSubVessel k = ViewHalfMorphism+  { _viewMorphism_mapQuery = maybe empty pure . lookupSubVessel k+  , _viewMorphism_mapQueryResult = pure . singletonSubVessel k+  }+++subVesselWildcard+  ::+  ( Ord k+  , View v, ViewQueryResult (v g) ~ v (ViewQueryResult g)+  , Semigroup (v g), Semigroup (v (ViewQueryResult g))+  , Alternative n+  , Applicative m+  ) => ViewMorphism m n (v g) (SubVessel k v g)+subVesselWildcard = ViewMorphism toSubVesselWildcard fromSubVesselWildcard++toSubVesselWildcard+  ::+  ( Ord k+  , Applicative m, Alternative n+  , View v, ViewQueryResult (v g) ~ v (ViewQueryResult g)+  , Semigroup (v (ViewQueryResult g))+  ) => ViewHalfMorphism m n (v g) (SubVessel k v g)+toSubVesselWildcard = ViewHalfMorphism+  { _viewMorphism_mapQuery = const $ pure $ SubVessel $ Vessel $ DMap.empty+  , _viewMorphism_mapQueryResult = maybe empty pure . foldMap Just . getSubVessel+  }++fromSubVesselWildcard+  ::+  ( Ord k+  , Alternative m, Applicative n+  , Semigroup (v g)+  ) => ViewHalfMorphism m n (SubVessel k v g) (v g)+fromSubVesselWildcard = ViewHalfMorphism+  { _viewMorphism_mapQuery = maybe empty pure . foldMap Just . getSubVessel+  , _viewMorphism_mapQueryResult = const $ pure $ SubVessel $ Vessel $ DMap.empty+  }++subVessels ::+  ( Ord k, Applicative m, View v , Alternative n+  , ViewQueryResult (v g) ~ v (ViewQueryResult g)+  , Monoid (n (v g)) , Monoid (n (v (ViewQueryResult g)))+  ) => Set k -> ViewMorphism m n (v g) (SubVessel k v g)+subVessels k = ViewMorphism (toSubVessels k) (fromSubVessels k)++toSubVessels ::+  ( Ord k, Applicative m, View v , Alternative n+  , ViewQueryResult (v g) ~ v (ViewQueryResult g)+  , Monoid (n (v (ViewQueryResult g)))+  ) => Set k -> ViewHalfMorphism m n (v g) (SubVessel k v g)+toSubVessels k = ViewHalfMorphism+  { _viewMorphism_mapQuery = pure . flip subVesselFromKeys k . const+  , _viewMorphism_mapQueryResult = fold . leftOuterJoin_ empty k . fmap pure . getSubVessel+  }++fromSubVessels ::+  ( Ord k, Applicative m, View v , Alternative n+  , ViewQueryResult (v g) ~ v (ViewQueryResult g)+  , Monoid (n (v g))+  ) => Set k -> ViewHalfMorphism n m (SubVessel k v g) (v g)+fromSubVessels k = ViewHalfMorphism+  { _viewMorphism_mapQuery = fold . leftOuterJoin_ empty k . fmap pure . getSubVessel+  , _viewMorphism_mapQueryResult = pure . flip subVesselFromKeys k . const+  }+++mapMaybeWithKeySubVessel :: forall k v (g :: * -> *) (g' :: * -> *) . (View v, Ord k) => (k -> v g -> Maybe (v g')) -> SubVessel k v g -> SubVessel k v g'+mapMaybeWithKeySubVessel f (SubVessel xs) = SubVessel (mapMaybeWithKeyV @(SubVesselKey k v) f' xs)+  where+    f' :: forall x . SubVesselKey k v x -> x g -> Maybe (x g')+    f' (SubVesselKey k) = f k+++uncurrySubVessel :: (Ord k1, Ord k2) => MonoidalMap k1 (SubVessel k2 v f) -> SubVessel (k1, k2) v f+uncurrySubVessel xs = mkSubVessel $ uncurryMMap $ fmap getSubVessel xs++currySubVessel :: (Ord k1, Ord k2) => SubVessel (k1, k2) v f -> MonoidalMap k1 (SubVessel k2 v f)+currySubVessel xs = fmap mkSubVessel $ curryMMap $ getSubVessel xs++-- | the instance for Filterable (MonoidalMap k) is not defined anyplace conveninent, this sidesteps it for this particular case.+condenseVMMap :: forall k v g. View v => MonoidalMap k (v g) -> v (Compose (MonoidalMap k) g)+condenseVMMap = mapV (Compose . MonoidalMap . getCompose) . condenseV . getMonoidalMap++-- | A gadget to "traverse" over all of the keys in a SubVessel in one step+handleSubVesselSelector+  ::  forall k m tag (f :: * -> *) (g :: * -> *).+  ( Ord k, Applicative m, Has View tag, GCompare tag )+  => (forall v.  tag v+             ->    MonoidalMap k (v f)+             -> m (MonoidalMap k (v g)))+  ->    SubVessel k (Vessel tag) f+  -> m (SubVessel k (Vessel tag) g)+handleSubVesselSelector f xs = (\y -> mkSubVessel $ disperseV y) <$> traverseWithKeyV f' (condenseVMMap $ getSubVessel xs)+  where+    f' :: forall v.  tag v+       ->    v (Compose (MonoidalMap k) f)+       -> m (v (Compose (MonoidalMap k) g))+    f' tag xs' = has @View tag $ condenseVMMap <$> f tag (disperseV xs')++-- | A gadget to "traverse" over all of the keys in a SubVessel, aligned to the keys nested inside a deeper Map, in one step+handleSubSubVesselSelector+  :: (Ord k1, Ord k2, Applicative m, Has View tag, GCompare tag)+  => (forall v. tag v -> MonoidalMap (k1, k2) (v f) -> m (MonoidalMap (k1, k2) (v g)))+  ->    MonoidalMap k1 (SubVessel k2 (Vessel tag) f)+  -> m (MonoidalMap k1 (SubVessel k2 (Vessel tag) g))+handleSubSubVesselSelector f xs = currySubVessel <$> handleSubVesselSelector f (uncurrySubVessel xs)++instance (Ord k, View v) => EmptyView (SubVessel k v) where+  emptyV = SubVessel emptyV+
+ src/Data/Vessel/Vessel.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Vessel.Vessel where++import Control.Applicative+import Control.Arrow ((***))+import Control.Monad+import Data.Aeson+import Data.Some (Some)+import Data.Constraint.Extras+import Data.Functor.Identity+import Data.Proxy+import Data.Dependent.Sum+import Data.Dependent.Sum.Orphans ()+import Data.Constraint.Forall+import Data.Dependent.Map.Monoidal (MonoidalDMap(..))+import Data.Dependent.Map.Internal (DMap (..))+import Data.Foldable hiding (null)+import qualified Data.Dependent.Map.Monoidal as DMap+import Data.GADT.Compare+import Data.GADT.Show+import Data.Witherable+import Data.Vessel.Internal+import GHC.Generics+import Reflex.Query.Class+import Data.Patch (Group(..), Additive)+import Data.Functor.Compose+import Data.Align+import qualified Data.Dependent.Map as DMap'+import Data.Maybe (fromMaybe)+import Data.These++import Data.Vessel.Class hiding (empty)+import Data.Vessel.DependentMap+import Data.Vessel.ViewMorphism++------- Vessel -------++-- | This type is a container for storing an arbitrary collection of functor-parametric container types of the sort+-- discussed above, keyed by a GADT whose index will specify which sort of container goes in each position.+--+-- Ordinary types with values have kind *+-- Functors have kind * -> *+-- Containers taking a functor as a parameter then have kind (* -> *) -> *+-- The keys of a vessel are indexed by a functor-parametric container type, so they have kind ((* -> *) -> *) -> *+-- Vessel itself, for any such key type, produces a functor-parametric container, so it has kind+-- (((* -> *) -> *) -> *) -> (* -> *) -> *+-- Law: None of the items in the Vessel's MonoidalDMap are nullV+newtype Vessel (k :: ((* -> *) -> *) -> *) (g :: * -> *) = Vessel { unVessel :: MonoidalDMap k (FlipAp g) }+  deriving (Generic)++deriving instance (GCompare k, Has' Eq k (FlipAp g)) => Eq (Vessel k g)++deriving instance (ForallF Show k, GShow k, Has' Show k (FlipAp g)) => Show (Vessel k g)++-- TODO: Ord, Read, Show++instance (Has View k, GCompare k, Has' Semigroup k (FlipAp Identity)) => Query (Vessel k (Const x)) where+  type QueryResult (Vessel k (Const x)) = Vessel k Identity+  crop q r = fromMaybe emptyV $ cropV (\_ a -> a) q r --TODO++instance (Has View k, GCompare k, Has' Semigroup k (FlipAp Identity)) => Query (Vessel k Proxy) where+  type QueryResult (Vessel k Proxy) = Vessel k Identity+  crop q r = fromMaybe emptyV $ cropV (\_ a -> a) q r --TODO+++instance (GCompare k, ForallF ToJSON k, HasV ToJSON k g) => ToJSON (Vessel k g) where+  toJSON v = toJSON (toListV v)++instance (GCompare k, FromJSON (Some k), HasV FromJSON k g, Has View k) => FromJSON (Vessel k g) where+  parseJSON x = fmap fromListV (parseJSON x)++-- TODO: figure out how to write a single instance for the case of Compose which depends on a Query instance for the right hand+-- composed functor... and/or let's replace Query with something more appropriate since it's pretty uniform what we want the crop+-- function to be all the time now.++type family VesselLeafWrapper v where+  VesselLeafWrapper (Vessel k g) = g++instance ( Has View k+         , GCompare k+         , Has' Semigroup k (FlipAp (Compose c (VesselLeafWrapper (QueryResult (Vessel k g)))))+         , Query (Vessel k g) )+        => Query (Vessel k (Compose c g)) where+  type QueryResult (Vessel k (Compose c g)) = Vessel k (Compose c (VesselLeafWrapper (QueryResult (Vessel k g))))+  crop q r = fromMaybe emptyV $ cropV (\_ a -> a) q r++instance (Has' Semigroup k (FlipAp g), GCompare k, Has View k) => Semigroup (Vessel k g) where+  Vessel m <> Vessel n = Vessel $ filterNullFlipAps $ m <> n++instance (Has' Semigroup k (FlipAp g), GCompare k, Has View k) => Monoid (Vessel k g) where+  mempty = Vessel DMap.empty+  mappend = (<>)++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?++instance (Has' Additive k (FlipAp g), Has' Semigroup k (FlipAp g), GCompare k, Has View k) => Additive (Vessel k g)++------- The View instance for Vessel itself --------++instance (Has View k, GCompare k) => View (Vessel k) where+  cropV :: (forall a. s a -> i a -> r a) -> Vessel k s -> Vessel k i -> Maybe (Vessel k r)+  cropV f sv iv = collapseNullV $ intersectionMaybeWithKeyV (\k s i -> has @View k (cropV f s i)) sv iv+  nullV :: Vessel k i -> Bool+  nullV (Vessel m) = DMap.null m+  mapV :: (forall a. f a -> g a) -> Vessel k f -> Vessel k g+  mapV f (Vessel m) = Vessel (DMap.mapWithKey (\k (FlipAp v) -> has @View k $ FlipAp (mapV f v)) m)+  traverseV :: (Applicative m) => (forall a. f a -> m (g a)) -> Vessel k f -> m (Vessel k g)+  traverseV f m = traverseWithKeyV (\k v -> has @View k $ traverseV f v) m+  condenseV :: (Foldable t, Filterable t, Functor t)+            => t (Vessel k g)+            -> Vessel k (Compose t g)+  condenseV col = condenseV' folded col+    where folded = fold $ fmap (unMonoidalDMap . unVessel) col+  disperseV :: (Align t) => Vessel k (Compose t g) -> t (Vessel k g)+  disperseV row = case findPivotD (unMonoidalDMap (unVessel row)) of+    NoneD -> nil+    OneD k (FlipAp v) -> has @View k $ fmap (singletonV k) (disperseV v)+    SplitD pivot _l _r -> uncurry (alignWith (mergeThese unionDistinctAscV)) $+      disperseV *** disperseV $ has @View pivot $ splitLTV pivot row+  mapMaybeV f (Vessel (MonoidalDMap m)) = collapseNullV $ Vessel $ MonoidalDMap $+    DMap'.mapMaybeWithKey (\k (FlipAp v) -> has @View k $ FlipAp <$> mapMaybeV f v) m+  alignWithMaybeV (f :: forall a. These (f a) (g a) -> Maybe (h a)) (Vessel as) (Vessel bs) = collapseNullV $ Vessel $+    let g :: forall v. k v -> These (FlipAp f v) (FlipAp g v) -> Maybe (FlipAp h v)+        g k = has @View k $ fmap FlipAp . \case+          This (FlipAp a) -> mapMaybeV (f . This) a+          That (FlipAp b) -> mapMaybeV (f . That) b+          These (FlipAp a) (FlipAp b) -> alignWithMaybeV f a b+    in alignWithKeyMaybeMonoidalDMap g as bs+  alignWithV (f :: forall a. These (f a) (g a) -> h a) (Vessel as) (Vessel bs) = Vessel $+    let g :: forall v. k v -> These (FlipAp f v) (FlipAp g v) -> FlipAp h v+        g k = has @View k $ FlipAp . \case+          This (FlipAp a) -> mapV (f . This) a+          That (FlipAp b) -> mapV (f . That) b+          These (FlipAp a) (FlipAp b) -> alignWithV f a b+    in alignWithKeyMonoidalDMap g as bs++instance (Has View k, GCompare k) => EmptyView (Vessel k) where+  emptyV = Vessel DMap.empty++toListV :: Vessel k g -> [VSum k g]+toListV (Vessel m) = fmap (\(k :=> FlipAp v) -> k :~> v) (DMap.toList m)++fromListV :: (GCompare k, Has View k) => [VSum k g] -> Vessel k g+fromListV vs = Vessel $+  DMap.fromListWithKey (\_ _ v -> v) $+  mapMaybe (\(k :~> v) -> has @View k $ if nullV v then Nothing else Just $ k :=> FlipAp v) vs++intersectionMaybeWithKeyV :: (GCompare k, Has View k) => (forall v. View v => k v -> v g -> v g' -> Maybe (v h)) -> Vessel k g -> Vessel k g' -> Vessel k h+intersectionMaybeWithKeyV f (Vessel m) (Vessel m') = Vessel $+  filterNullFlipAps $+  intersectionDMapMaybeWithKey (\k (FlipAp x) (FlipAp y) -> has @View k $ FlipAp <$> f k x y) m m'++traverseWithKeyV :: (GCompare k, Has View k, Applicative m) => (forall v. View v => k v -> v g -> m (v h)) -> Vessel k g -> m (Vessel k h)+traverseWithKeyV f (Vessel x) = Vessel . filterNullFlipAps <$> DMap.traverseWithKey (\k (FlipAp v) -> has @View k $ FlipAp <$> f k v) x++traverseWithKeyV_ :: (GCompare k, Has View k, Applicative m) => (forall v. View v => k v -> v g -> m ()) -> Vessel k g -> m ()+traverseWithKeyV_ f (Vessel x) = void $ DMap.traverseWithKey (\k (FlipAp v) -> has @View k $ Const () <$ f k v) x++buildV :: (GCompare k, Has View k, Applicative m) => Vessel k g -> (forall v. k v -> v g -> m (v h)) -> m (Vessel k h)+buildV v f = traverseWithKeyV f v++intersectionWithKeyV :: (GCompare k, Has View k) => (forall v. View v => k v -> v g -> v g' -> v h) -> Vessel k g -> Vessel k g' -> Vessel k h+intersectionWithKeyV f (Vessel m) (Vessel m') = Vessel $+  filterNullFlipAps $+  DMap.intersectionWithKey (\k (FlipAp x) (FlipAp y) -> has @View k $ FlipAp (f k x y)) m m'++------- Operations on Vessel -------++singletonV :: View v => k v -> v g -> Vessel k g+singletonV k v = Vessel $ if nullV v then DMap.empty else DMap.singleton k (FlipAp v)++lookupV :: (GCompare k) => k v -> Vessel k g -> Maybe (v g)+lookupV k (Vessel m) = unFlipAp <$> DMap.lookup k m++mapMaybeWithKeyV :: (GCompare k, Has View k) => (forall v. View v => k v -> v g -> Maybe (v g')) -> Vessel k g -> Vessel k g'+mapMaybeWithKeyV f (Vessel m) = Vessel $ DMap.mapMaybeWithKey (\k (FlipAp x) -> has @View k $ FlipAp <$> (collapseNullV =<< f k x)) m++--TODO: Upstream+intersectionDMapMaybeWithKey :: GCompare k => (forall x. k x -> a x -> b x -> Maybe (c x)) -> MonoidalDMap k a -> MonoidalDMap k b -> MonoidalDMap k c+intersectionDMapMaybeWithKey f a b = DMap.mapMaybeWithKey (\_ -> getCompose) $ DMap.intersectionWithKey (\k x y -> Compose $ f k x y) a b++------- Instances for Vessel -------+condenseV' :: forall k t g.+              ( Has View k, GCompare k, Foldable t, Filterable t, Functor t)+           => DMap k (FlipAp g)+           -> t (Vessel k g)+           -> Vessel k (Compose t g)+condenseV' folded col =+  case findPivotD folded of+    NoneD -> emptyV+    OneD (k :: k v) _ -> has @View k $ singletonV k (condenseV $ mapMaybe (lookupV k) col)+    SplitD pivot l r -> uncurry unionDistinctAscV $ (condenseV' l *** condenseV' r) $ has @View pivot $ splitV pivot col++unionDistinctAscV :: (GCompare k) => Vessel k g -> Vessel k g -> Vessel k g+unionDistinctAscV (Vessel l) (Vessel r) = Vessel $ DMap.unionWithKey (\_ x _ -> x) l r++splitV :: forall k t g v. (GCompare k, View v, Filterable t)+       => k v -> t (Vessel k g) -> (t (Vessel k g), t (Vessel k g))+splitV pivot col = unalignProperly $ mapMaybe (splitOneV pivot) col++splitOneV :: (GCompare k, View v) => k v -> Vessel k g -> Maybe (These (Vessel k g) (Vessel k g))+splitOneV pivot m =+  let (l@(Vessel l'), r@(Vessel r')) = splitLTV pivot m+  in case (DMap.null l', DMap.null r') of+    (True, True) -> Nothing+    (False, True) -> Just $ This l+    (True, False) -> Just $ That r+    (False, False) -> Just $ These l r++splitLTV :: (GCompare k, View v) => k v -> Vessel k g -> (Vessel k g, Vessel k g)+splitLTV k (Vessel m) = case DMap.splitLookup k m of+  (l, Just (FlipAp v), r) | not $ nullV v -> (Vessel (DMap.insert k (FlipAp v) l), Vessel r)+  (l, _, r) -> (Vessel l, Vessel r)++type instance ViewQueryResult (Vessel v g) = Vessel v (ViewQueryResult g)++vessel :: (GCompare k, ViewQueryResult (v g) ~ v (ViewQueryResult g), View v, Alternative n, Applicative m) => k v -> ViewMorphism m n (v g) (Vessel k g)+vessel k = ViewMorphism (toVessel k) (fromVessel k)++toVessel :: (Applicative m, Alternative n, GCompare k, ViewQueryResult (v g) ~ v (ViewQueryResult g), View v) => k v -> ViewHalfMorphism m n (v g) (Vessel k g)+toVessel k = ViewHalfMorphism+  { _viewMorphism_mapQuery = pure . singletonV k+  , _viewMorphism_mapQueryResult = maybe empty pure . lookupV k+  }++fromVessel:: (Alternative m, Applicative n, GCompare k, ViewQueryResult (v g) ~ v (ViewQueryResult g), View v) => k v -> ViewHalfMorphism m n (Vessel k g) (v g)+fromVessel k = ViewHalfMorphism+  { _viewMorphism_mapQuery = maybe empty pure . lookupV k+  , _viewMorphism_mapQueryResult = pure . singletonV k+  }++filterNullFlipAps :: (GCompare k, Has View k) => MonoidalDMap k (FlipAp f) -> MonoidalDMap k (FlipAp f)+filterNullFlipAps = DMap.mapMaybeWithKey (\k (FlipAp v) -> has @View k $ FlipAp <$> collapseNullV v)
+ src/Data/Vessel/ViewMorphism.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-# LANGUAGE UndecidableInstances #-}++module Data.Vessel.ViewMorphism where+------- Selectable convenience class -------++import Prelude hiding (id, (.))+import Control.Monad+import Control.Applicative+import Control.Category+import Data.Bifunctor+import Data.Functor.Identity+import Data.These+import Reflex.Query.Class+import Reflex.Class+import Data.Align+import Data.Vessel.Internal ()++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;+data ViewHalfMorphism m n p q = ViewHalfMorphism+  { _viewMorphism_mapQuery :: p -> m q+  , _viewMorphism_mapQueryResult :: ViewQueryResult q -> n (ViewQueryResult p) -- TODO Loading data+  }++data ViewMorphism m n p q = ViewMorphism+  { _viewMorphism_to ::   ViewHalfMorphism m n p q+  , _viewMorphism_from :: ViewHalfMorphism n m q p+  }++type ViewMorphismSimple = ViewMorphism Identity Maybe++instance (Monad m, Monad n) => Category (ViewHalfMorphism n m) where+  id = ViewHalfMorphism pure pure+  ViewHalfMorphism f f' . ViewHalfMorphism g g' = ViewHalfMorphism (f <=< g) (f' >=> g')++instance (Monad m, Monad n) => Category (ViewMorphism m n) where+  id = ViewMorphism id id+  ViewMorphism f f' . ViewMorphism g g' = ViewMorphism (f . g) (g' . f')++instance (Semigroup (m b) , Semigroup (n (ViewQueryResult a))) => Semigroup (ViewHalfMorphism m n a b) where+  ViewHalfMorphism f f' <> ViewHalfMorphism g g' = ViewHalfMorphism (f <> g) (f' <> g')++instance (Monoid (m b) , Monoid (n (ViewQueryResult a))) => Monoid (ViewHalfMorphism m n a b) where+  mappend = (<>)+  mempty = ViewHalfMorphism mempty mempty++instance+    ( Semigroup (m b), Semigroup (m (ViewQueryResult b))+    , Semigroup (n a), Semigroup (n (ViewQueryResult a))+    ) => Semigroup (ViewMorphism m n a b) where+  ViewMorphism f f' <> ViewMorphism g g' = ViewMorphism (f <> g) (f' <> g')++instance+    ( Monoid (m b), Monoid (m (ViewQueryResult b))+    , Monoid (n a), Monoid (n (ViewQueryResult a))+    )  => Monoid (ViewMorphism m n a b) where+  mappend = (<>)+  mempty = ViewMorphism mempty mempty++-- | query for two things simultaneously, return as much result as is available.+zipViewMorphism+  ::+  ( Semigroup (m c)+  , Semigroup (m (ViewQueryResult c))+  , Semialign n+  , Applicative n+  )+  => ViewMorphism m n a c -> ViewMorphism m n b c -> ViewMorphism m n (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 (ViewHalfMorphism a2c c2a' ) (ViewHalfMorphism b2c c2b' ) = ViewHalfMorphism+    { _viewMorphism_mapQuery = \(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)+fromZipViewMorphism (ViewHalfMorphism c2a a2c') (ViewHalfMorphism c2b b2c') = ViewHalfMorphism+    { _viewMorphism_mapQuery = \r -> liftA2 (,) (c2a r) (c2b r)+    , _viewMorphism_mapQueryResult = these id id ((<>)) . bimap a2c' b2c'+    }++queryViewMorphism :: forall t (p :: *) (q :: *) m partial.+  ( Reflex t+  , MonadQuery t q m+  , Monad m+  , QueryResult q ~ ViewQueryResult q+  )+  => p -> Dynamic t (ViewMorphism Identity partial p q) -> m (Dynamic t (partial (ViewQueryResult p)))+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+
+ tutorial/Tutorial.lhs view
@@ -0,0 +1,365 @@+# A tutorial introduction to vessel++In this example, we're going to sketch out a blog application using vessel.++First, some preliminaries:++```haskell++module Tutorial where++import Prelude hiding (id, (.), filter)++import Control.Category+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Fix+import Data.Aeson (FromJSON(..), ToJSON(..))+import Data.Aeson.GADT.TH (deriveJSONGADT)+import Data.Align+import Data.Proxy+import Data.Map (Map)+import Data.Map.Monoidal (MonoidalMap(..))+import Data.Semigroup (First(..), Max(..))+import Data.Dependent.Map (DMap)+import Data.Text (Text)+import Reflex+import Reflex.Network+import qualified Data.Map as Map+import qualified Data.Map.Merge.Strict as Map++import Data.Vessel+import Data.Vessel.ViewMorphism+import Data.Vessel.Vessel+import Data.Vessel.Map+import Data.Vessel.Identity++import Data.GADT.Compare.TH+import Data.GADT.Show.TH+import Data.Constraint.Extras.TH++type PostId = Int+type Post = Text++```++Next we'll define "query" type, which captures the kinds of queries we can have...++```haskell++data Qsimple g = Qsimple+  { _q_posts :: GrpMap PostId g -- ^ a map from post ID's to refcounts, represents querying for that post+  , _q_latestPostId :: GrpMap () g -- ^ morally a "bool"; for if the maxPost Id is being requested.+  } deriving (Eq, Ord, Show, Read)++```++And the corresponding result type.  Note that we have the same set of fields occur in both.++```haskell++data Rsimple = Rsimple+  { _r_posts :: MonoidalMap PostId (First (Maybe Post)) -- ^ posts+  , _r_latestPostId :: MonoidalMap () (Max (Maybe PostId)) -- ^ the max post id;+  } deriving (Eq, Ord, Show, Read)++```+Now we end up needing to produce some boilerplate instances for our queries;+QueryT (the only "real" instance for MonadQuery) requires that the query type+be a Group.  It does this for essentially performance reasons.  If 100 widgets+have queries, and one of them "goes away", then we can either add the remaining+99 queries **or** subtract the removed query from the total for all 100 we already+have.  The latter is almost always quicker.++```haskell++instance (Eq g, Monoid g) => Semigroup (Qsimple g) where Qsimple x y <> Qsimple x' y' = Qsimple (x <> x') (y <> y')+instance (Eq g, Monoid g) => Monoid (Qsimple g) where mempty = Qsimple mempty mempty+instance (Eq g, Group g) => Group (Qsimple g) where negateG (Qsimple x y) = Qsimple (negateG x) (negateG y)+instance (Eq g, Monoid g, Additive g) => Additive (Qsimple g)+instance GrpFunctor Qsimple where mapG f (Qsimple x y) = Qsimple (mapG f x) (mapG f y)++```++MonadQuery Also requires that QueryResult be a monoid;  this reflects the idea+that the result can be updated as new data is sent to the frontend; with+"updates" being appended to the left.  That's the reason for the First and Max+values above.++Those are also the reason for the Maybe wrappers in both cases,  it's+necessary to distinguish the two states of "the data is absent because it+doesn't exist in the backend" from "the data is absent because you haven't+received it yet".++```haskell++instance Semigroup Rsimple where Rsimple posts maxId <> Rsimple posts' maxId' = Rsimple (posts <> posts') (maxId <> maxId')+instance Monoid Rsimple where { mempty = Rsimple mempty mempty }++```++We associate the two types, query and response, with Query;  which is also+essentially boilerplate code.  The single method for Query; crop, should+restrict the query result to only that which matches the query.  Crop has two+essential duties.  It's used in query handlers that call runQueryT.++```haskell++instance Query (Qsimple g) where+  type QueryResult (Qsimple g) = Rsimple+  crop (Qsimple postsQ maxIdQ) (Rsimple postsR maxIdR) = Rsimple (cropMap postsQ postsR) (cropMap maxIdQ maxIdR)+    where cropMap q r = MonoidalMap $ Map.intersection (getMonoidalMap r) (unGrpMap q)++```++We now can write code that "queries" for posts.  Note that the distinction+between "not yet loaded" and "doesnt exist at all" is reflected in two+different Maybe's.  Resist the urge to "join" the two together.  That's a sure+recipe for annoying glitches which flash "deleted" right before showing the+user their data.++Once again we see some amount of boilerplate; we construct the query by+building up from the given field; and then need to tear down the query result+by examining the corresponding field.++```haskell++watchPost +  :: ( MonadQuery t (Qsimple SelectedCount) m+     , QueryResult (Qsimple SelectedCount) ~ Rsimple+     , Reflex t+     , Monad m+     )+  => Dynamic t PostId -> m (Dynamic t (Maybe (Maybe Post)))+watchPost postIds = do+  queryResult <- queryDyn $ ffor postIds $ \postId -> mempty { _q_posts = GrpMap (Map.singleton postId 1) }+  return $ ffor2 postIds queryResult $ \postId r -> getFirst <$> view (at postId) (_r_posts r)++watchLatestPostId+  :: ( MonadQuery t (Qsimple SelectedCount) m+     , QueryResult (Qsimple SelectedCount) ~ Rsimple+     , Reflex t+     , Monad m+     )+  => m (Dynamic t (Maybe (Maybe PostId)))+watchLatestPostId = do+  queryResult <- queryDyn $ constDyn $  mempty { _q_latestPostId = GrpMap (Map.singleton () 1) }+  return $ ffor queryResult $ \r -> getMax <$> view (at ()) (_r_latestPostId r)++displayLatestPost+  :: ( MonadHold t m+     , MonadFix m+     , MonadQuery t (Qsimple SelectedCount) m+     , QueryResult (Qsimple SelectedCount) ~ Rsimple+     , Reflex t+     , PostBuild t m+     , Widget t m+     )+  => m ()+displayLatestPost = do+  mdmId <- maybeDyn =<< watchLatestPostId+  dyn_ $ ffor mdmId $ \case+    Nothing -> text "Loading ..."+    Just dmId -> do+      mdId <- maybeDyn dmId+      dyn_ $ ffor mdId $ \case+        Nothing -> text "No posts found"+        Just dId -> displayPost dId++displayPost+  :: ( MonadQuery t (Qsimple SelectedCount) m+     , QueryResult (Qsimple SelectedCount) ~ Rsimple+     , PostBuild t m+     , MonadHold t m+     , MonadFix m+     , Widget t m+     )+  => Dynamic t PostId -> m ()+displayPost postId = do+  mdmPost <- maybeDyn =<< watchPost postId+  dyn_ $ ffor mdmPost $ \case+    Nothing -> text "Loading post ..."+    Just dmPost -> do+      mdPost <- maybeDyn dmPost+      dyn_ $ ffor mdPost $ \case+        Nothing -> text "Post Not Found"+        Just dPost -> dynText dPost++```++We can try to improve the situation in essentially all of+these cases above by factoring out the common parts using+something resembling the HKD Pattern; when we need to+associate a group with each query; we can use `Const g`; and+for the result which demands only the result data for that+key, we can use Identity. A downside is boilerplate+instances, even ones that can normally be derived.++```haskell++data Qhkd (f :: * -> *) = Qhkd+  { _qhkd_posts :: MonoidalMap PostId (f (First (Maybe Post))) -- ^ posts+  , _qhkd_latestPostId :: MonoidalMap () (f (Max (Maybe PostId))) -- ^ the max post id;+  }++type Qhkd_query g = Qhkd (Const g)+type Qhkd_response = Qhkd Identity++```++We can instead observe the pattern that "most" of the shape of a record of+queries/responses can be  decomposed into products of maps.  Another way of+expressing the same concept is with a DMap.  with this approach:++```haskell++data Qtag (a :: *) where+  Qtag_Posts        :: PostId -> Qtag (First (Maybe Post))+  Qtag_LatestPostId :: Qtag (Max (Maybe PostId))++type Qtag_query g = DMap Qtag (Const g)+type Qtag_response = DMap Qtag Identity++```++Vessel takes this idea a bit further; where the above approach uses parameters+as values, vessel makes it "recursive";  the GADTs used have "functor"+parameters, and most of the applied types are also functor parametric.++```haskell++data Qvessel (v :: (* -> *) -> *) where+  Posts        :: Qvessel (MapV PostId (First (Maybe Post)))+  LatestPostId :: Qvessel (IdentityV (Max (Maybe PostId)))++```+Using this sort of construction allows us to eliminate nearly all of the+boilerplate; there's a small amount of TH to derive GCompare and all of the+remaining instances follow from the view types in vessel:++```haskell++viewPost :: (MonadQuery t (Vessel Qvessel (Const SelectedCount)) m, Reflex t, Monad m)+  => Dynamic t PostId -> m (Dynamic t (Maybe (Maybe Post)))+viewPost postIds = (fmap.fmap.fmap) (getFirst . runIdentity) $ queryViewMorphism 1 $ ffor postIds $ \pid -> vessel Posts . mapVMorphism pid++viewLatestPostId :: (MonadQuery t (Vessel Qvessel (Const SelectedCount)) m, Reflex t, Monad m)+  => m (Dynamic t (Maybe (Maybe PostId)))+viewLatestPostId = (fmap.fmap.fmap) (getMax . runIdentity) $ queryViewMorphism 1 $ constDyn $ vessel LatestPostId . identityV++```+Feel free to ignore everything below this line; this is just to force me to get+other types "right".++***++```haskell++-- To avoid requiring reflex-dom, we stub out a few functions that you'd normally get from reflex-dom-core.+type Widget t m = (NotReady t m, Adjustable t m, PostBuild t m)++dyn_ :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m ()+dyn_ = void . networkView++text :: Monad m => Text -> m ()+text _ = pure ()++dynText :: Monad m => Dynamic t Text -> m ()+dynText _ = pure ()++positive :: forall x. (Monoid x, Ord x) => x -> SelectedCount+positive x+  | x > mempty = 1+  | otherwise = 0+++dischargeMonadQuery :: forall v t m a.+  ( Additive (v SelectedCount), Group (v SelectedCount), PerformEvent t m, GrpFunctor v, Eq (v SelectedCount)+  , Monoid (QueryResult (v SelectedCount)), PostBuild t m, MonadHold t m, MonadFix m, Widget t m+  , Query (v SelectedCount)+  )+  => (v SelectedCount -> Performable m (QueryResult (v SelectedCount)))+  -> (forall m'. (PostBuild t m', MonadHold t m', Widget t m', MonadFix m', MonadQuery t (v SelectedCount) m') => m' a)+  -> m a+dischargeMonadQuery getQueryResult widget = mdo++  ( result+    , iVS :: Incremental t (AdditivePatch (v SelectedCount))+    ) <- runQueryT widget v_t+  let+    vs_t :: Dynamic t (v SelectedCount) = incrementalToDynamic iVS+    dvs :: Event t (v SelectedCount) = attach (current vs_t) (updated vs_t) <&> \(vs_n, vs_n1) -> mapG positive $ mapG positive vs_n ~~ mapG positive vs_n1++  pb <- getPostBuild+  let vs_0 = tag (current vs_t) pb++  v_t <- foldDyn (<>) mempty v_n1++  v_n1 :: Event t (QueryResult (v SelectedCount))+    <- performEvent $ salign vs_0 dvs <&> \dvs' -> if dvs' /= mempty then return mempty else getQueryResult dvs'++  return result++++readShowLatestPost+  :: ( MonadIO (Performable m)+     , PerformEvent t m+     , PostBuild t m+     , MonadHold t m+     , MonadFix m+     , Query (Qsimple SelectedCount)+     , QueryResult (Qsimple SelectedCount) ~ Rsimple+     , Widget t m+     )+  => m ()+readShowLatestPost = dischargeMonadQuery promtForIt displayLatestPost+  where+    promtForIt q = liftIO $ do+      print q+      readLn++-- annoying stuff that needs to exist but doesn't.+newtype GrpMap k v = GrpMap { unGrpMap :: Map k v } deriving (Eq, Ord, Show, Read)+type role GrpMap nominal nominal++liftNonZero :: (Monoid a, Eq a) => (a -> a -> a) -> a -> a -> Maybe a+liftNonZero f x y = if (xy /= mempty)+  then Just x+  else Nothing+  where xy = f x y++instance (Monoid g, Eq g, Ord k) => Semigroup (GrpMap k g) where+  GrpMap xs <> GrpMap ys = GrpMap $ Map.merge id id (Map.zipWithMaybeMatched $ const $ liftNonZero (<>)) xs ys++instance (Monoid g, Eq g, Ord k) => Monoid (GrpMap k g) where+  mempty = GrpMap Map.empty+  mappend = (<>)++instance (Group g, Eq g, Ord k) => Group (GrpMap k g) where+  negateG (GrpMap xs) = GrpMap $ fmap negateG xs+  GrpMap xs ~~ GrpMap ys = GrpMap $ Map.merge id (Map.mapMissing $ const $ negateG) (Map.zipWithMaybeMatched $ const $ liftNonZero (~~)) xs ys++class (forall g. (Eq g, Group g) => Group (f g)) => GrpFunctor f where+  mapG :: (Eq b, Group b) => (a -> b) -> f a -> f b++-- distributive functors can still be groups.+instance GrpFunctor ((->) r) where mapG = fmap+instance GrpFunctor Proxy where mapG = fmap+instance GrpFunctor Identity where mapG = fmap++instance Ord k => GrpFunctor (GrpMap k) where+  mapG f (GrpMap xs) = GrpMap $ Map.mapMaybe (\x ->+    let fx = f x+    in if fx /= mempty+    then Just fx+    else Nothing) xs++deriveArgDict ''Qvessel+deriveJSONGADT ''Qvessel+deriveGEq ''Qvessel+deriveGCompare ''Qvessel+deriveGShow ''Qvessel++```
+ tutorial/Tutorial.md view
@@ -0,0 +1,365 @@+# A tutorial introduction to vessel++In this example, we're going to sketch out a blog application using vessel.++First, some preliminaries:++```haskell++module Tutorial where++import Prelude hiding (id, (.), filter)++import Control.Category+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Fix+import Data.Aeson (FromJSON(..), ToJSON(..))+import Data.Aeson.GADT.TH (deriveJSONGADT)+import Data.Align+import Data.Proxy+import Data.Map (Map)+import Data.Map.Monoidal (MonoidalMap(..))+import Data.Semigroup (First(..), Max(..))+import Data.Dependent.Map (DMap)+import Data.Text (Text)+import Reflex+import Reflex.Network+import qualified Data.Map as Map+import qualified Data.Map.Merge.Strict as Map++import Data.Vessel+import Data.Vessel.ViewMorphism+import Data.Vessel.Vessel+import Data.Vessel.Map+import Data.Vessel.Identity++import Data.GADT.Compare.TH+import Data.GADT.Show.TH+import Data.Constraint.Extras.TH++type PostId = Int+type Post = Text++```++Next we'll define "query" type, which captures the kinds of queries we can have...++```haskell++data Qsimple g = Qsimple+  { _q_posts :: GrpMap PostId g -- ^ a map from post ID's to refcounts, represents querying for that post+  , _q_latestPostId :: GrpMap () g -- ^ morally a "bool"; for if the maxPost Id is being requested.+  } deriving (Eq, Ord, Show, Read)++```++And the corresponding result type.  Note that we have the same set of fields occur in both.++```haskell++data Rsimple = Rsimple+  { _r_posts :: MonoidalMap PostId (First (Maybe Post)) -- ^ posts+  , _r_latestPostId :: MonoidalMap () (Max (Maybe PostId)) -- ^ the max post id;+  } deriving (Eq, Ord, Show, Read)++```+Now we end up needing to produce some boilerplate instances for our queries;+QueryT (the only "real" instance for MonadQuery) requires that the query type+be a Group.  It does this for essentially performance reasons.  If 100 widgets+have queries, and one of them "goes away", then we can either add the remaining+99 queries **or** subtract the removed query from the total for all 100 we already+have.  The latter is almost always quicker.++```haskell++instance (Eq g, Monoid g) => Semigroup (Qsimple g) where Qsimple x y <> Qsimple x' y' = Qsimple (x <> x') (y <> y')+instance (Eq g, Monoid g) => Monoid (Qsimple g) where mempty = Qsimple mempty mempty+instance (Eq g, Group g) => Group (Qsimple g) where negateG (Qsimple x y) = Qsimple (negateG x) (negateG y)+instance (Eq g, Monoid g, Additive g) => Additive (Qsimple g)+instance GrpFunctor Qsimple where mapG f (Qsimple x y) = Qsimple (mapG f x) (mapG f y)++```++MonadQuery Also requires that QueryResult be a monoid;  this reflects the idea+that the result can be updated as new data is sent to the frontend; with+"updates" being appended to the left.  That's the reason for the First and Max+values above.++Those are also the reason for the Maybe wrappers in both cases,  it's+necessary to distinguish the two states of "the data is absent because it+doesn't exist in the backend" from "the data is absent because you haven't+received it yet".++```haskell++instance Semigroup Rsimple where Rsimple posts maxId <> Rsimple posts' maxId' = Rsimple (posts <> posts') (maxId <> maxId')+instance Monoid Rsimple where { mempty = Rsimple mempty mempty }++```++We associate the two types, query and response, with Query;  which is also+essentially boilerplate code.  The single method for Query; crop, should+restrict the query result to only that which matches the query.  Crop has two+essential duties.  It's used in query handlers that call runQueryT.++```haskell++instance Query (Qsimple g) where+  type QueryResult (Qsimple g) = Rsimple+  crop (Qsimple postsQ maxIdQ) (Rsimple postsR maxIdR) = Rsimple (cropMap postsQ postsR) (cropMap maxIdQ maxIdR)+    where cropMap q r = MonoidalMap $ Map.intersection (getMonoidalMap r) (unGrpMap q)++```++We now can write code that "queries" for posts.  Note that the distinction+between "not yet loaded" and "doesnt exist at all" is reflected in two+different Maybe's.  Resist the urge to "join" the two together.  That's a sure+recipe for annoying glitches which flash "deleted" right before showing the+user their data.++Once again we see some amount of boilerplate; we construct the query by+building up from the given field; and then need to tear down the query result+by examining the corresponding field.++```haskell++watchPost +  :: ( MonadQuery t (Qsimple SelectedCount) m+     , QueryResult (Qsimple SelectedCount) ~ Rsimple+     , Reflex t+     , Monad m+     )+  => Dynamic t PostId -> m (Dynamic t (Maybe (Maybe Post)))+watchPost postIds = do+  queryResult <- queryDyn $ ffor postIds $ \postId -> mempty { _q_posts = GrpMap (Map.singleton postId 1) }+  return $ ffor2 postIds queryResult $ \postId r -> getFirst <$> view (at postId) (_r_posts r)++watchLatestPostId+  :: ( MonadQuery t (Qsimple SelectedCount) m+     , QueryResult (Qsimple SelectedCount) ~ Rsimple+     , Reflex t+     , Monad m+     )+  => m (Dynamic t (Maybe (Maybe PostId)))+watchLatestPostId = do+  queryResult <- queryDyn $ constDyn $  mempty { _q_latestPostId = GrpMap (Map.singleton () 1) }+  return $ ffor queryResult $ \r -> getMax <$> view (at ()) (_r_latestPostId r)++displayLatestPost+  :: ( MonadHold t m+     , MonadFix m+     , MonadQuery t (Qsimple SelectedCount) m+     , QueryResult (Qsimple SelectedCount) ~ Rsimple+     , Reflex t+     , PostBuild t m+     , Widget t m+     )+  => m ()+displayLatestPost = do+  mdmId <- maybeDyn =<< watchLatestPostId+  dyn_ $ ffor mdmId $ \case+    Nothing -> text "Loading ..."+    Just dmId -> do+      mdId <- maybeDyn dmId+      dyn_ $ ffor mdId $ \case+        Nothing -> text "No posts found"+        Just dId -> displayPost dId++displayPost+  :: ( MonadQuery t (Qsimple SelectedCount) m+     , QueryResult (Qsimple SelectedCount) ~ Rsimple+     , PostBuild t m+     , MonadHold t m+     , MonadFix m+     , Widget t m+     )+  => Dynamic t PostId -> m ()+displayPost postId = do+  mdmPost <- maybeDyn =<< watchPost postId+  dyn_ $ ffor mdmPost $ \case+    Nothing -> text "Loading post ..."+    Just dmPost -> do+      mdPost <- maybeDyn dmPost+      dyn_ $ ffor mdPost $ \case+        Nothing -> text "Post Not Found"+        Just dPost -> dynText dPost++```++We can try to improve the situation in essentially all of+these cases above by factoring out the common parts using+something resembling the HKD Pattern; when we need to+associate a group with each query; we can use `Const g`; and+for the result which demands only the result data for that+key, we can use Identity. A downside is boilerplate+instances, even ones that can normally be derived.++```haskell++data Qhkd (f :: * -> *) = Qhkd+  { _qhkd_posts :: MonoidalMap PostId (f (First (Maybe Post))) -- ^ posts+  , _qhkd_latestPostId :: MonoidalMap () (f (Max (Maybe PostId))) -- ^ the max post id;+  }++type Qhkd_query g = Qhkd (Const g)+type Qhkd_response = Qhkd Identity++```++We can instead observe the pattern that "most" of the shape of a record of+queries/responses can be  decomposed into products of maps.  Another way of+expressing the same concept is with a DMap.  with this approach:++```haskell++data Qtag (a :: *) where+  Qtag_Posts        :: PostId -> Qtag (First (Maybe Post))+  Qtag_LatestPostId :: Qtag (Max (Maybe PostId))++type Qtag_query g = DMap Qtag (Const g)+type Qtag_response = DMap Qtag Identity++```++Vessel takes this idea a bit further; where the above approach uses parameters+as values, vessel makes it "recursive";  the GADTs used have "functor"+parameters, and most of the applied types are also functor parametric.++```haskell++data Qvessel (v :: (* -> *) -> *) where+  Posts        :: Qvessel (MapV PostId (First (Maybe Post)))+  LatestPostId :: Qvessel (IdentityV (Max (Maybe PostId)))++```+Using this sort of construction allows us to eliminate nearly all of the+boilerplate; there's a small amount of TH to derive GCompare and all of the+remaining instances follow from the view types in vessel:++```haskell++viewPost :: (MonadQuery t (Vessel Qvessel (Const SelectedCount)) m, Reflex t, Monad m)+  => Dynamic t PostId -> m (Dynamic t (Maybe (Maybe Post)))+viewPost postIds = (fmap.fmap.fmap) (getFirst . runIdentity) $ queryViewMorphism 1 $ ffor postIds $ \pid -> vessel Posts . mapVMorphism pid++viewLatestPostId :: (MonadQuery t (Vessel Qvessel (Const SelectedCount)) m, Reflex t, Monad m)+  => m (Dynamic t (Maybe (Maybe PostId)))+viewLatestPostId = (fmap.fmap.fmap) (getMax . runIdentity) $ queryViewMorphism 1 $ constDyn $ vessel LatestPostId . identityV++```+Feel free to ignore everything below this line; this is just to force me to get+other types "right".++***++```haskell++-- To avoid requiring reflex-dom, we stub out a few functions that you'd normally get from reflex-dom-core.+type Widget t m = (NotReady t m, Adjustable t m, PostBuild t m)++dyn_ :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m ()+dyn_ = void . networkView++text :: Monad m => Text -> m ()+text _ = pure ()++dynText :: Monad m => Dynamic t Text -> m ()+dynText _ = pure ()++positive :: forall x. (Monoid x, Ord x) => x -> SelectedCount+positive x+  | x > mempty = 1+  | otherwise = 0+++dischargeMonadQuery :: forall v t m a.+  ( Additive (v SelectedCount), Group (v SelectedCount), PerformEvent t m, GrpFunctor v, Eq (v SelectedCount)+  , Monoid (QueryResult (v SelectedCount)), PostBuild t m, MonadHold t m, MonadFix m, Widget t m+  , Query (v SelectedCount)+  )+  => (v SelectedCount -> Performable m (QueryResult (v SelectedCount)))+  -> (forall m'. (PostBuild t m', MonadHold t m', Widget t m', MonadFix m', MonadQuery t (v SelectedCount) m') => m' a)+  -> m a+dischargeMonadQuery getQueryResult widget = mdo++  ( result+    , iVS :: Incremental t (AdditivePatch (v SelectedCount))+    ) <- runQueryT widget v_t+  let+    vs_t :: Dynamic t (v SelectedCount) = incrementalToDynamic iVS+    dvs :: Event t (v SelectedCount) = attach (current vs_t) (updated vs_t) <&> \(vs_n, vs_n1) -> mapG positive $ mapG positive vs_n ~~ mapG positive vs_n1++  pb <- getPostBuild+  let vs_0 = tag (current vs_t) pb++  v_t <- foldDyn (<>) mempty v_n1++  v_n1 :: Event t (QueryResult (v SelectedCount))+    <- performEvent $ salign vs_0 dvs <&> \dvs' -> if dvs' /= mempty then return mempty else getQueryResult dvs'++  return result++++readShowLatestPost+  :: ( MonadIO (Performable m)+     , PerformEvent t m+     , PostBuild t m+     , MonadHold t m+     , MonadFix m+     , Query (Qsimple SelectedCount)+     , QueryResult (Qsimple SelectedCount) ~ Rsimple+     , Widget t m+     )+  => m ()+readShowLatestPost = dischargeMonadQuery promtForIt displayLatestPost+  where+    promtForIt q = liftIO $ do+      print q+      readLn++-- annoying stuff that needs to exist but doesn't.+newtype GrpMap k v = GrpMap { unGrpMap :: Map k v } deriving (Eq, Ord, Show, Read)+type role GrpMap nominal nominal++liftNonZero :: (Monoid a, Eq a) => (a -> a -> a) -> a -> a -> Maybe a+liftNonZero f x y = if (xy /= mempty)+  then Just x+  else Nothing+  where xy = f x y++instance (Monoid g, Eq g, Ord k) => Semigroup (GrpMap k g) where+  GrpMap xs <> GrpMap ys = GrpMap $ Map.merge id id (Map.zipWithMaybeMatched $ const $ liftNonZero (<>)) xs ys++instance (Monoid g, Eq g, Ord k) => Monoid (GrpMap k g) where+  mempty = GrpMap Map.empty+  mappend = (<>)++instance (Group g, Eq g, Ord k) => Group (GrpMap k g) where+  negateG (GrpMap xs) = GrpMap $ fmap negateG xs+  GrpMap xs ~~ GrpMap ys = GrpMap $ Map.merge id (Map.mapMissing $ const $ negateG) (Map.zipWithMaybeMatched $ const $ liftNonZero (~~)) xs ys++class (forall g. (Eq g, Group g) => Group (f g)) => GrpFunctor f where+  mapG :: (Eq b, Group b) => (a -> b) -> f a -> f b++-- distributive functors can still be groups.+instance GrpFunctor ((->) r) where mapG = fmap+instance GrpFunctor Proxy where mapG = fmap+instance GrpFunctor Identity where mapG = fmap++instance Ord k => GrpFunctor (GrpMap k) where+  mapG f (GrpMap xs) = GrpMap $ Map.mapMaybe (\x ->+    let fx = f x+    in if fx /= mempty+    then Just fx+    else Nothing) xs++deriveArgDict ''Qvessel+deriveJSONGADT ''Qvessel+deriveGEq ''Qvessel+deriveGCompare ''Qvessel+deriveGShow ''Qvessel++```
+ vessel.cabal view
@@ -0,0 +1,119 @@+name:               vessel+version:            0.1.0.0+description:+  A dependently-typed key-value data structure that allows for storage of both "queries", (wherein keys are stored along with reasons for selecting the items or counts of the number of times something has been selected), as well as the responses to those queries, in which the type of the key additionally determines the type of the response++license:            BSD3+license-file:       LICENSE+author:             Obsidian Systems LLC+maintainer:         maintainer@obsidian.systems+copyright:          Obsidian Systems LLC+build-type:         Simple+extra-source-files:+  ChangeLog.md+  README.md+  tutorial/Tutorial.md++cabal-version:      2.0+category:           Data+synopsis:           Functor-parametric containers+tested-with:        GHC ==8.6.5 || ==8.8.4 || ==8.10.2++library+  exposed-modules:+    Data.Vessel+    Data.Vessel.Class+    Data.Vessel.DependentMap+    Data.Vessel.Disperse+    Data.Vessel.Identity+    Data.Vessel.Internal+    Data.Vessel.Map+    Data.Vessel.Selectable+    Data.Vessel.Single+    Data.Vessel.SubVessel+    Data.Vessel.Vessel+    Data.Vessel.ViewMorphism++  other-extensions:+    FlexibleInstances+    GeneralizedNewtypeDeriving+    RankNTypes+    ScopedTypeVariables+    StandaloneDeriving+    TypeFamilies+    UndecidableInstances++  build-depends:+      aeson                        >=1.4     && <1.6+    , base                         >=4.9     && <4.15+    , bifunctors                   >=5.5     && <5.6+    , constraints                  >=0.10    && <0.15+    , constraints-extras           >=0.3     && <0.4+    , containers                   >=0.6     && <0.7+    , dependent-map                >=0.4     && <0.5+    , dependent-monoidal-map       >=0.1.1.0 && <0.2+    , dependent-sum                >=0.7     && <0.8+    , dependent-sum-aeson-orphans  >=0.3     && <0.4+    , monoidal-containers          >=0.6     && <0.7+    , mtl                          >=2.2     && <2.3+    , patch                        >=0.0.4.0 && <0.1+    , reflex                       >=0.6.4   && <0.9+    , semialign                    >=1+    , these                        >=1       && <1.1+    , witherable                   >=0.2     && <=0.3.2++  hs-source-dirs:   src+  default-language: Haskell2010++library vessel-tutorial+  if impl(ghcjs)+    buildable: False+  hs-source-dirs:   tutorial+  exposed-modules:  Tutorial+  default-language: Haskell2010+  default-extensions:+    ConstraintKinds+    FlexibleContexts+    FlexibleInstances+    GADTs+    GeneralizedNewtypeDeriving+    LambdaCase+    MultiParamTypeClasses+    OverloadedStrings+    QuantifiedConstraints+    RankNTypes+    RecursiveDo+    RoleAnnotations+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TypeFamilies+    UndecidableInstances+  ghc-options:      -Wall  -pgmL markdown-unlit+  build-tool-depends: markdown-unlit:markdown-unlit+  build-depends:+      aeson+    , aeson-gadt-th+    , base+    , constraints+    , constraints-extras+    , containers+    , dependent-map+    , dependent-monoidal-map+    , dependent-sum+    , dependent-sum-aeson-orphans+    , dependent-sum-template+    , lens+    , markdown-unlit+    , monoidal-containers+    , mtl+    , reflex+    , semialign+    , text+    , these+    , vessel+    , witherable++source-repository head+  type:     git+  location: https://github.com/obsidiansystems/vessel