{-# 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 t (v g)
tvg = Rep (v (Compose t g)) Any -> v (Compose t g)
forall a x. Generic a => Rep a x -> a
to (Rep (v (Compose t g)) Any -> v (Compose t g))
-> Rep (v (Compose t g)) Any -> v (Compose t g)
forall a b. (a -> b) -> a -> b
$ t (Rep (v g) Any) -> Rep (v (Compose t g)) Any
forall k (t :: * -> *) (vf :: k -> *) (vtf :: k -> *) (p :: k).
CondenseView t vf vtf =>
t (vf p) -> vtf p
condenseView (t (Rep (v g) Any) -> Rep (v (Compose t g)) Any)
-> t (Rep (v g) Any) -> Rep (v (Compose t g)) Any
forall a b. (a -> b) -> a -> b
$ v g -> Rep (v g) Any
forall a x. Generic a => a -> Rep a x
from (v g -> Rep (v g) Any) -> t (v g) -> t (Rep (v g) Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (v g)
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 v (Compose t g)
vtg = Rep (v g) Any -> v g
forall a x. Generic a => Rep a x -> a
to (Rep (v g) Any -> v g) -> t (Rep (v g) Any) -> t (v g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rep (v (Compose t g)) Any -> t (Rep (v g) Any)
forall k (t :: * -> *) (vf :: k -> *) (vtf :: k -> *) (p :: k).
DisperseView t vf vtf =>
vtf p -> t (vf p)
disperseView (v (Compose t g) -> Rep (v (Compose t g)) Any
forall a x. Generic a => a -> Rep a x
from v (Compose t g)
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 forall a. s a -> i a -> r a
f v s
vi v i
vs = v r -> Maybe (v r)
forall (v :: (* -> *) -> *) (f :: * -> *).
View v =>
v f -> Maybe (v f)
maybeEmptyView (v r -> Maybe (v r)) -> v r -> Maybe (v r)
forall a b. (a -> b) -> a -> b
$ Rep (v r) Any -> v r
forall a x. Generic a => Rep a x -> a
to (Rep (v r) Any -> v r) -> Rep (v r) Any -> v r
forall a b. (a -> b) -> a -> b
$ (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' s -> v' i -> v' r)
-> Rep (v s) Any -> Rep (v i) Any -> Rep (v r) Any
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) (vf :: * -> *)
       (vg :: * -> *) (vh :: * -> *) p.
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 forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' s -> v' i -> v' r
z (v s -> Rep (v s) Any
forall a x. Generic a => a -> Rep a x
from v s
vi) (v i -> Rep (v i) Any
forall a x. Generic a => a -> Rep a x
from v i
vs)
    where z :: forall v'. (View v', EmptyView v') => v' s -> v' i -> v' r
          z :: v' s -> v' i -> v' r
z v' s
v'i v' i
v's = v' r -> Maybe (v' r) -> v' r
forall a. a -> Maybe a -> a
fromMaybe v' r
forall (v :: (* -> *) -> *) (f :: * -> *). EmptyView v => v f
emptyV (Maybe (v' r) -> v' r) -> Maybe (v' r) -> v' r
forall a b. (a -> b) -> a -> b
$ (forall a. s a -> i a -> r a) -> v' s -> v' i -> Maybe (v' r)
forall (v :: (* -> *) -> *) (s :: * -> *) (i :: * -> *)
       (r :: * -> *).
View v =>
(forall a. s a -> i a -> r a) -> v s -> v i -> Maybe (v r)
cropV forall a. s a -> i a -> r a
f v' s
v'i 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 i
v = All -> Bool
getAll (All -> Bool) -> All -> Bool
forall a b. (a -> b) -> a -> b
$ Writer All (Rep (v i) Any) -> All
forall w a. Writer w a -> w
execWriter (Writer All (Rep (v i) Any) -> All)
-> Writer All (Rep (v i) Any) -> All
forall a b. (a -> b) -> a -> b
$
              (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' i -> WriterT All Identity (v' i))
-> Rep (v i) Any -> Writer All (Rep (v i) Any)
forall (f :: * -> *) (g :: * -> *) (vf :: * -> *) (vg :: * -> *)
       (m :: * -> *) p.
(MapView f g vf vg, Applicative m) =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> vf p -> m (vg p)
mapViewM @i @i @(Rep (v i)) @(Rep (v i)) forall (v' :: (* -> *) -> *). View v' => v' i -> Writer All (v' i)
forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' i -> WriterT All Identity (v' i)
f (v i -> Rep (v i) Any
forall a x. Generic a => a -> Rep a x
from v i
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' i -> Writer All (v' i)
f v' i
v' = All -> WriterT All Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Bool -> All
All (Bool -> All) -> Bool -> All
forall a b. (a -> b) -> a -> b
$ v' i -> Bool
forall (v :: (* -> *) -> *) (i :: * -> *). View v => v i -> Bool
nullV v' i
v') WriterT All Identity () -> Writer All (v' i) -> Writer All (v' i)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> v' i -> Writer All (v' i)
forall (f :: * -> *) a. Applicative f => a -> f a
pure v' i
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 forall a. f a -> g a
f v f
vf = Rep (v g) Any -> v g
forall a x. Generic a => Rep a x -> a
to (Rep (v g) Any -> v g) -> Rep (v g) Any -> v g
forall a b. (a -> b) -> a -> b
$ (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g)
-> Rep (v f) Any -> Rep (v g) Any
forall (f :: * -> *) (g :: * -> *) (vf :: * -> *) (vg :: * -> *) p.
MapView f g vf vg =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g)
-> vf p -> vg p
mapView ((forall a. f a -> g a) -> v' f -> v' g
forall (v :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
View v =>
(forall a. f a -> g a) -> v f -> v g
mapV forall a. f a -> g a
f) (Rep (v f) Any -> Rep (v g) Any) -> Rep (v f) Any -> Rep (v g) Any
forall a b. (a -> b) -> a -> b
$ v f -> Rep (v f) Any
forall a x. Generic a => a -> Rep a x
from v f
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 forall a. f a -> m (g a)
f v f
vf = Rep (v g) Any -> v g
forall a x. Generic a => Rep a x -> a
to (Rep (v g) Any -> v g) -> m (Rep (v g) Any) -> m (v g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> Rep (v f) Any -> m (Rep (v g) Any)
forall (f :: * -> *) (g :: * -> *) (vf :: * -> *) (vg :: * -> *)
       (m :: * -> *) p.
(MapView f g vf vg, Applicative m) =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> vf p -> m (vg p)
mapViewM ((forall a. f a -> m (g a)) -> v' f -> m (v' g)
forall (v :: (* -> *) -> *) (m :: * -> *) (f :: * -> *)
       (g :: * -> *).
(View v, Applicative m) =>
(forall a. f a -> m (g a)) -> v f -> m (v g)
traverseV forall a. f a -> m (g a)
f) (v f -> Rep (v f) Any
forall a x. Generic a => a -> Rep a x
from v f
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 forall a. f a -> Maybe (g a)
f v f
vf = v g -> Maybe (v g)
forall (v :: (* -> *) -> *) (f :: * -> *).
View v =>
v f -> Maybe (v f)
maybeEmptyView (v g -> Maybe (v g)) -> v g -> Maybe (v g)
forall a b. (a -> b) -> a -> b
$ Rep (v g) Any -> v g
forall a x. Generic a => Rep a x -> a
to (Rep (v g) Any -> v g) -> Rep (v g) Any -> v g
forall a b. (a -> b) -> a -> b
$ (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g)
-> Rep (v f) Any -> Rep (v g) Any
forall (f :: * -> *) (g :: * -> *) (vf :: * -> *) (vg :: * -> *) p.
MapView f g vf vg =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g)
-> vf p -> vg p
mapView forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g
z (Rep (v f) Any -> Rep (v g) Any) -> Rep (v f) Any -> Rep (v g) Any
forall a b. (a -> b) -> a -> b
$ v f -> Rep (v f) Any
forall a x. Generic a => a -> Rep a x
from v f
vf
    where z :: forall v'. (View v', EmptyView v') => v' f -> v' g
          z :: v' f -> v' g
z v' f
v'f = v' g -> Maybe (v' g) -> v' g
forall a. a -> Maybe a -> a
fromMaybe v' g
forall (v :: (* -> *) -> *) (f :: * -> *). EmptyView v => v f
emptyV (Maybe (v' g) -> v' g) -> Maybe (v' g) -> v' g
forall a b. (a -> b) -> a -> b
$ (forall a. f a -> Maybe (g a)) -> v' f -> Maybe (v' g)
forall (v :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
View v =>
(forall a. f a -> Maybe (g a)) -> v f -> Maybe (v g)
mapMaybeV forall a. f a -> Maybe (g a)
f v' 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 forall a. These (f a) (g a) -> Maybe (h a)
f v f
vf v g
vg = v h -> Maybe (v h)
forall (v :: (* -> *) -> *) (f :: * -> *).
View v =>
v f -> Maybe (v f)
maybeEmptyView (v h -> Maybe (v h)) -> v h -> Maybe (v h)
forall a b. (a -> b) -> a -> b
$ Rep (v h) Any -> v h
forall a x. Generic a => Rep a x -> a
to (Rep (v h) Any -> v h) -> Rep (v h) Any -> v h
forall a b. (a -> b) -> a -> b
$ (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> v' h)
-> Rep (v f) Any -> Rep (v g) Any -> Rep (v h) Any
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) (vf :: * -> *)
       (vg :: * -> *) (vh :: * -> *) p.
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 forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> v' h
z (v f -> Rep (v f) Any
forall a x. Generic a => a -> Rep a x
from v f
vf) (v g -> Rep (v g) Any
forall a x. Generic a => a -> Rep a x
from v g
vg)
    where z :: forall v'. (View v', EmptyView v') => v' f -> v' g -> v' h
          z :: v' f -> v' g -> v' h
z v' f
v'f v' g
v'g = v' h -> Maybe (v' h) -> v' h
forall a. a -> Maybe a -> a
fromMaybe v' h
forall (v :: (* -> *) -> *) (f :: * -> *). EmptyView v => v f
emptyV (Maybe (v' h) -> v' h) -> Maybe (v' h) -> v' h
forall a b. (a -> b) -> a -> b
$ (forall a. These (f a) (g a) -> Maybe (h a))
-> v' f -> v' g -> Maybe (v' h)
forall (v :: (* -> *) -> *) (f :: * -> *) (g :: * -> *)
       (h :: * -> *).
View v =>
(forall a. These (f a) (g a) -> Maybe (h a))
-> v f -> v g -> Maybe (v h)
alignWithMaybeV forall a. These (f a) (g a) -> Maybe (h a)
f v' f
v'f v' g
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 forall a. These (f a) (g a) -> h a
f v f
vf v g
vg = Rep (v h) Any -> v h
forall a x. Generic a => Rep a x -> a
to (Rep (v h) Any -> v h) -> Rep (v h) Any -> v h
forall a b. (a -> b) -> a -> b
$ (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> v' h)
-> Rep (v f) Any -> Rep (v g) Any -> Rep (v h) Any
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) (vf :: * -> *)
       (vg :: * -> *) (vh :: * -> *) p.
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 ((forall a. These (f a) (g a) -> h a) -> v' f -> v' g -> v' h
forall (v :: (* -> *) -> *) (f :: * -> *) (g :: * -> *)
       (h :: * -> *).
View v =>
(forall a. These (f a) (g a) -> h a) -> v f -> v g -> v h
alignWithV forall a. These (f a) (g a) -> h a
f) (v f -> Rep (v f) Any
forall a x. Generic a => a -> Rep a x
from v f
vf) (v g -> Rep (v g) Any
forall a x. Generic a => a -> Rep a x
from v g
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 f -> Maybe (v f)
maybeEmptyView v f
v = if v f -> Bool
forall (v :: (* -> *) -> *) (i :: * -> *). View v => v i -> Bool
nullV v f
v then Maybe (v f)
forall a. Maybe a
Nothing else v f -> Maybe (v f)
forall a. a -> Maybe a
Just v f
v

------ Classes and Generic instances for Generic View instance ------

class Empty1 a where
  empty :: a p

instance Empty1 U1 where
  empty :: U1 p
empty = U1 p
forall k (p :: k). U1 p
U1

instance EmptyView v => Empty1 (K1 i (v f)) where
  empty :: K1 i (v f) p
empty = v f -> K1 i (v f) p
forall k i c (p :: k). c -> K1 i c p
K1 v f
forall (v :: (* -> *) -> *) (f :: * -> *). EmptyView v => v f
emptyV

instance Empty1 a => Empty1 (M1 i t a) where
  empty :: M1 i t a p
empty = a p -> M1 i t a p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 a p
forall k (a :: k -> *) (p :: k). Empty1 a => a p
empty

instance (Empty1 a, Empty1 b) => Empty1 (a :*: b) where
  empty :: (:*:) a b p
empty = a p
forall k (a :: k -> *) (p :: k). Empty1 a => a p
empty a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b p
forall k (a :: k -> *) (p :: k). Empty1 a => a p
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 :: t (U1 p) -> U1 p
condenseView t (U1 p)
_ = U1 p
forall k (p :: k). U1 p
U1

instance (View v, Foldable t, Filterable t, Functor t) => CondenseView t (K1 i (v f)) (K1 i (v (Compose t f))) where
  condenseView :: t (K1 i (v f) p) -> K1 i (v (Compose t f)) p
condenseView t (K1 i (v f) p)
tvf = v (Compose t f) -> K1 i (v (Compose t f)) p
forall k i c (p :: k). c -> K1 i c p
K1 (v (Compose t f) -> K1 i (v (Compose t f)) p)
-> v (Compose t f) -> K1 i (v (Compose t f)) p
forall a b. (a -> b) -> a -> b
$ t (v f) -> v (Compose t f)
forall (v :: (* -> *) -> *) (t :: * -> *) (g :: * -> *).
(View v, Foldable t, Filterable t, Functor t) =>
t (v g) -> v (Compose t g)
condenseV (t (v f) -> v (Compose t f)) -> t (v f) -> v (Compose t f)
forall a b. (a -> b) -> a -> b
$ K1 i (v f) p -> v f
forall i c k (p :: k). K1 i c p -> c
unK1 (K1 i (v f) p -> v f) -> t (K1 i (v f) p) -> t (v f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (K1 i (v f) p)
tvf

instance CondenseView t vf vtf => CondenseView t (M1 i t' vf) (M1 i t' vtf) where
  condenseView :: t (M1 i t' vf p) -> M1 i t' vtf p
condenseView t (M1 i t' vf p)
tvf = vtf p -> M1 i t' vtf p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (vtf p -> M1 i t' vtf p) -> vtf p -> M1 i t' vtf p
forall a b. (a -> b) -> a -> b
$ t (vf p) -> vtf p
forall k (t :: * -> *) (vf :: k -> *) (vtf :: k -> *) (p :: k).
CondenseView t vf vtf =>
t (vf p) -> vtf p
condenseView (t (vf p) -> vtf p) -> t (vf p) -> vtf p
forall a b. (a -> b) -> a -> b
$ M1 i t' vf p -> vf p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 (M1 i t' vf p -> vf p) -> t (M1 i t' vf p) -> t (vf p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (M1 i t' vf p)
tvf

instance (CondenseView t avf avtf, CondenseView t bvf bvtf, Empty1 avf, Empty1 bvf) => CondenseView t (avf :*: bvf) (avtf :*: bvtf) where
  condenseView :: t ((:*:) avf bvf p) -> (:*:) avtf bvtf p
condenseView t ((:*:) avf bvf p)
tvf = t (avf p) -> avtf p
forall k (t :: * -> *) (vf :: k -> *) (vtf :: k -> *) (p :: k).
CondenseView t vf vtf =>
t (vf p) -> vtf p
condenseView ((:*:) avf bvf p -> avf p
forall k (f :: k -> *) (g :: k -> *) (p :: k). (:*:) f g p -> f p
getA ((:*:) avf bvf p -> avf p) -> t ((:*:) avf bvf p) -> t (avf p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t ((:*:) avf bvf p)
tvf) avtf p -> bvtf p -> (:*:) avtf bvtf p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: t (bvf p) -> bvtf p
forall k (t :: * -> *) (vf :: k -> *) (vtf :: k -> *) (p :: k).
CondenseView t vf vtf =>
t (vf p) -> vtf p
condenseView ((:*:) avf bvf p -> bvf p
forall k (f :: k -> *) (g :: k -> *) (p :: k). (:*:) f g p -> g p
getB ((:*:) avf bvf p -> bvf p) -> t ((:*:) avf bvf p) -> t (bvf p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t ((:*:) avf bvf p)
tvf)
    where getA :: (:*:) f g p -> f p
getA (f p
a :*: g p
_) = f p
a
          getB :: (:*:) f g p -> g p
getB (f p
_ :*: g p
b) = g p
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 :: U1 p -> t (U1 p)
disperseView U1 p
_ = t (U1 p)
forall (f :: * -> *) a. Align f => f a
nil

instance (View v, Align t) => DisperseView t (K1 i (v f)) (K1 i (v (Compose t f))) where
  disperseView :: K1 i (v (Compose t f)) p -> t (K1 i (v f) p)
disperseView (K1 v (Compose t f)
vtf) = v f -> K1 i (v f) p
forall k i c (p :: k). c -> K1 i c p
K1 (v f -> K1 i (v f) p) -> t (v f) -> t (K1 i (v f) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v (Compose t f) -> t (v f)
forall (v :: (* -> *) -> *) (t :: * -> *) (g :: * -> *).
(View v, Align t) =>
v (Compose t g) -> t (v g)
disperseV v (Compose t f)
vtf

instance DisperseView t vf vtf => DisperseView t (M1 i t' vf) (M1 i t' vtf) where
  disperseView :: M1 i t' vtf p -> t (M1 i t' vf p)
disperseView (M1 vtf p
vf) = vf p -> M1 i t' vf p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (vf p -> M1 i t' vf p) -> t (vf p) -> t (M1 i t' vf p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> vtf p -> t (vf p)
forall k (t :: * -> *) (vf :: k -> *) (vtf :: k -> *) (p :: k).
DisperseView t vf vtf =>
vtf p -> t (vf p)
disperseView vtf p
vf

instance (DisperseView t avf avtf, DisperseView t bvf bvtf, Empty1 avf, Empty1 bvf) => DisperseView t (avf :*: bvf) (avtf :*: bvtf) where
  disperseView :: (:*:) avtf bvtf p -> t ((:*:) avf bvf p)
disperseView (avtf p
avtf :*: bvtf p
bvtf) = (These (avf p) (bvf p) -> (:*:) avf bvf p)
-> t (avf p) -> t (bvf p) -> t ((:*:) avf bvf p)
forall (f :: * -> *) a b c.
Semialign f =>
(These a b -> c) -> f a -> f b -> f c
alignWith These (avf p) (bvf p) -> (:*:) avf bvf p
forall (p :: k). These (avf p) (bvf p) -> (:*:) avf bvf p
f (avtf p -> t (avf p)
forall k (t :: * -> *) (vf :: k -> *) (vtf :: k -> *) (p :: k).
DisperseView t vf vtf =>
vtf p -> t (vf p)
disperseView avtf p
avtf) (bvtf p -> t (bvf p)
forall k (t :: * -> *) (vf :: k -> *) (vtf :: k -> *) (p :: k).
DisperseView t vf vtf =>
vtf p -> t (vf p)
disperseView bvtf p
bvtf)
    where f :: These (avf p) (bvf p) -> (avf :*: bvf) p
          f :: These (avf p) (bvf p) -> (:*:) avf bvf p
f = \case
            This avf p
a -> avf p
a avf p -> bvf p -> (:*:) avf bvf p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: bvf p
forall k (a :: k -> *) (p :: k). Empty1 a => a p
empty
            That bvf p
b -> avf p
forall k (a :: k -> *) (p :: k). Empty1 a => a p
empty avf p -> bvf p -> (:*:) avf bvf p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: bvf p
b
            These avf p
a bvf p
b -> avf p
a avf p -> bvf p -> (:*:) avf bvf p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: bvf p
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 :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> V1 p -> m (V1 p)
mapViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> m (v' g)
_ = V1 p -> m (V1 p)
\case

instance MapView f g U1 U1 where
  mapViewM :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> U1 p -> m (U1 p)
mapViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> m (v' g)
_ U1 p
U1 = U1 p -> m (U1 p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 p
forall k (p :: k). U1 p
U1

instance (View v, EmptyView v) => MapView f g (K1 i (v f)) (K1 i (v g)) where
  mapViewM :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> K1 i (v f) p -> m (K1 i (v g) p)
mapViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> m (v' g)
f (K1 v f
vf) = v g -> K1 i (v g) p
forall k i c (p :: k). c -> K1 i c p
K1 (v g -> K1 i (v g) p) -> m (v g) -> m (K1 i (v g) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v f -> m (v g)
forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> m (v' g)
f v f
vf

instance MapView f g vf vg => MapView f g (M1 i t vf) (M1 i t vg) where
  mapViewM :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> M1 i t vf p -> m (M1 i t vg p)
mapViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> m (v' g)
f (M1 vf p
vf) = vg p -> M1 i t vg p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (vg p -> M1 i t vg p) -> m (vg p) -> m (M1 i t vg p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> vf p -> m (vg p)
forall (f :: * -> *) (g :: * -> *) (vf :: * -> *) (vg :: * -> *)
       (m :: * -> *) p.
(MapView f g vf vg, Applicative m) =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> vf p -> m (vg p)
mapViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> m (v' g)
f vf p
vf

instance (MapView f g avf avg, MapView f g bvf bvg) => MapView f g (avf :*: bvf) (avg :*: bvg) where
  mapViewM :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> (:*:) avf bvf p -> m ((:*:) avg bvg p)
mapViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> m (v' g)
f (avf p
avf :*: bvf p
bvf) = avg p -> bvg p -> (:*:) avg bvg p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
    (avg p -> bvg p -> (:*:) avg bvg p)
-> m (avg p) -> m (bvg p -> (:*:) avg bvg p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> avf p -> m (avg p)
forall (f :: * -> *) (g :: * -> *) (vf :: * -> *) (vg :: * -> *)
       (m :: * -> *) p.
(MapView f g vf vg, Applicative m) =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> vf p -> m (vg p)
mapViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> m (v' g)
f avf p
avf
    m (bvg p -> (:*:) avg bvg p) -> m (bvg p) -> m ((:*:) avg bvg p)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> bvf p -> m (bvg p)
forall (f :: * -> *) (g :: * -> *) (vf :: * -> *) (vg :: * -> *)
       (m :: * -> *) p.
(MapView f g vf vg, Applicative m) =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> vf p -> m (vg p)
mapViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> m (v' g)
f bvf p
bvf

mapView
  :: MapView f g vf vg
  => (forall v'. (View v', EmptyView v') => v' f -> v' g)
  -> vf p
  -> vg p
mapView :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g)
-> vf p -> vg p
mapView forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g
f vf p
vf = Identity (vg p) -> vg p
forall a. Identity a -> a
runIdentity (Identity (vg p) -> vg p) -> Identity (vg p) -> vg p
forall a b. (a -> b) -> a -> b
$ (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> Identity (v' g))
-> vf p -> Identity (vg p)
forall (f :: * -> *) (g :: * -> *) (vf :: * -> *) (vg :: * -> *)
       (m :: * -> *) p.
(MapView f g vf vg, Applicative m) =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> m (v' g))
-> vf p -> m (vg p)
mapViewM (\v' f
v'f -> v' g -> Identity (v' g)
forall a. a -> Identity a
Identity (v' g -> Identity (v' g)) -> v' g -> Identity (v' g)
forall a b. (a -> b) -> a -> b
$ v' f -> v' g
forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g
f v' f
v'f) vf p
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 :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> V1 p -> V1 p -> m (V1 p)
zipViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> m (v' h)
_ = V1 p -> V1 p -> m (V1 p)
\case

instance ZipView f g h U1 U1 U1 where
  zipViewM :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> U1 p -> U1 p -> m (U1 p)
zipViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> m (v' h)
_ U1 p
U1 U1 p
U1 = U1 p -> m (U1 p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 p
forall k (p :: k). U1 p
U1

instance (View v, EmptyView v) => ZipView f g h (K1 i (v f)) (K1 i (v g)) (K1 i (v h)) where
  zipViewM :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> K1 i (v f) p -> K1 i (v g) p -> m (K1 i (v h) p)
zipViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> m (v' h)
f (K1 v f
vf) (K1 v g
vg) = v h -> K1 i (v h) p
forall k i c (p :: k). c -> K1 i c p
K1 (v h -> K1 i (v h) p) -> m (v h) -> m (K1 i (v h) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> v f -> v g -> m (v h)
forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> m (v' h)
f v f
vf v g
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 :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> M1 i t vf p -> M1 i t vg p -> m (M1 i t vh p)
zipViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> m (v' h)
f (M1 vf p
vf) (M1 vg p
vg) = vh p -> M1 i t vh p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (vh p -> M1 i t vh p) -> m (vh p) -> m (M1 i t vh p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> vf p -> vg p -> m (vh p)
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) (vf :: * -> *)
       (vg :: * -> *) (vh :: * -> *) (m :: * -> *) p.
(ZipView f g h vf vg vh, Applicative m) =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> vf p -> vg p -> m (vh p)
zipViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> m (v' h)
f vf p
vf vg p
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 :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> (:*:) avf bvf p -> (:*:) avg bvg p -> m ((:*:) avh bvh p)
zipViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> m (v' h)
f (avf p
avf :*: bvf p
bvf) (avg p
avg :*: bvg p
bvg) = avh p -> bvh p -> (:*:) avh bvh p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
    (avh p -> bvh p -> (:*:) avh bvh p)
-> m (avh p) -> m (bvh p -> (:*:) avh bvh p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> avf p -> avg p -> m (avh p)
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) (vf :: * -> *)
       (vg :: * -> *) (vh :: * -> *) (m :: * -> *) p.
(ZipView f g h vf vg vh, Applicative m) =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> vf p -> vg p -> m (vh p)
zipViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> m (v' h)
f avf p
avf avg p
avg
    m (bvh p -> (:*:) avh bvh p) -> m (bvh p) -> m ((:*:) avh bvh p)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> bvf p -> bvg p -> m (bvh p)
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) (vf :: * -> *)
       (vg :: * -> *) (vh :: * -> *) (m :: * -> *) p.
(ZipView f g h vf vg vh, Applicative m) =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> vf p -> vg p -> m (vh p)
zipViewM forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> m (v' h)
f bvf p
bvf bvg p
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 :: (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> v' h)
-> vf p -> vg p -> vh p
zipView forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> v' h
f vf p
vf vg p
vg = Identity (vh p) -> vh p
forall a. Identity a -> a
runIdentity (Identity (vh p) -> vh p) -> Identity (vh p) -> vh p
forall a b. (a -> b) -> a -> b
$ (forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> Identity (v' h))
-> vf p -> vg p -> Identity (vh p)
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) (vf :: * -> *)
       (vg :: * -> *) (vh :: * -> *) (m :: * -> *) p.
(ZipView f g h vf vg vh, Applicative m) =>
(forall (v' :: (* -> *) -> *).
 (View v', EmptyView v') =>
 v' f -> v' g -> m (v' h))
-> vf p -> vg p -> m (vh p)
zipViewM (\v' f
v'f v' g
v'g -> v' h -> Identity (v' h)
forall a. a -> Identity a
Identity (v' h -> Identity (v' h)) -> v' h -> Identity (v' h)
forall a b. (a -> b) -> a -> b
$ v' f -> v' g -> v' h
forall (v' :: (* -> *) -> *).
(View v', EmptyView v') =>
v' f -> v' g -> v' h
f v' f
v'f v' g
v'g) vf p
vf vg p
vg

collapseNullV :: View v => v f -> Maybe (v f)
collapseNullV :: v f -> Maybe (v f)
collapseNullV v f
v = if v f -> Bool
forall (v :: (* -> *) -> *) (i :: * -> *). View v => v i -> Bool
nullV v f
v
  then Maybe (v f)
forall a. Maybe a
Nothing
  else v f -> Maybe (v f)
forall a. a -> Maybe a
Just v f
v


subtractV :: View v => v f -> v g -> Maybe (v f)
subtractV :: v f -> v g -> Maybe (v f)
subtractV = (forall a. These (f a) (g a) -> Maybe (f a))
-> v f -> v g -> Maybe (v f)
forall (v :: (* -> *) -> *) (f :: * -> *) (g :: * -> *)
       (h :: * -> *).
View v =>
(forall a. These (f a) (g a) -> Maybe (h a))
-> v f -> v g -> Maybe (v h)
alignWithMaybeV (\case This f a
x -> f a -> Maybe (f a)
forall a. a -> Maybe a
Just f a
x; These (f a) (g a)
_ -> Maybe (f a)
forall a. Maybe a
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 :: (forall a. These (f a) (g a) -> m (h a))
-> v f -> v g -> m (Maybe (v h))
alignWithMV forall a. These (f a) (g a) -> m (h a)
f v f
a v g
b = (v (Compose m h) -> m (v h))
-> Maybe (v (Compose m h)) -> m (Maybe (v h))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((forall a. Compose m h a -> m (h a)) -> v (Compose m h) -> m (v h)
forall (v :: (* -> *) -> *) (m :: * -> *) (f :: * -> *)
       (g :: * -> *).
(View v, Applicative m) =>
(forall a. f a -> m (g a)) -> v f -> m (v g)
traverseV forall a. Compose m h a -> m (h a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose) (Maybe (v (Compose m h)) -> m (Maybe (v h)))
-> Maybe (v (Compose m h)) -> m (Maybe (v h))
forall a b. (a -> b) -> a -> b
$ (forall a. These (f a) (g a) -> Maybe (Compose m h a))
-> v f -> v g -> Maybe (v (Compose m h))
forall (v :: (* -> *) -> *) (f :: * -> *) (g :: * -> *)
       (h :: * -> *).
View v =>
(forall a. These (f a) (g a) -> Maybe (h a))
-> v f -> v g -> Maybe (v h)
alignWithMaybeV forall a. These (f a) (g a) -> Maybe (Compose m h a)
g v f
a v g
b
  where g :: forall a. These (f a) (g a) -> Maybe (Compose m h a)
        g :: These (f a) (g a) -> Maybe (Compose m h a)
g = Compose m h a -> Maybe (Compose m h a)
forall a. a -> Maybe a
Just (Compose m h a -> Maybe (Compose m h a))
-> (These (f a) (g a) -> Compose m h a)
-> These (f a) (g a)
-> Maybe (Compose m h a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (h a) -> Compose m h a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (m (h a) -> Compose m h a)
-> (These (f a) (g a) -> m (h a))
-> These (f a) (g a)
-> Compose m h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. These (f a) (g a) -> m (h a)
forall a. These (f a) (g a) -> m (h a)
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 (t (v g)) (v (Compose t g))
transposeView = QueryMorphism :: forall q q'.
(q -> q')
-> (QueryResult q' -> QueryResult q) -> QueryMorphism q q'
QueryMorphism
  { _queryMorphism_mapQuery :: t (v g) -> v (Compose t g)
_queryMorphism_mapQuery = t (v g) -> v (Compose t g)
forall (v :: (* -> *) -> *) (t :: * -> *) (g :: * -> *).
(View v, Foldable t, Filterable t, Functor t) =>
t (v g) -> v (Compose t g)
condenseV -- aggregate queries.
  , _queryMorphism_mapQueryResult :: QueryResult (v (Compose t g)) -> QueryResult (t (v g))
_queryMorphism_mapQueryResult = QueryResult (v (Compose t g)) -> QueryResult (t (v g))
forall (v :: (* -> *) -> *) (t :: * -> *) (g :: * -> *).
(View v, Align t) =>
v (Compose t g) -> t (v g)
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 :: (v Proxy -> m (v Identity))
-> v (Compose (MonoidalMap c) g)
-> m (Maybe (v (Compose (MonoidalMap c) Identity)))
mapDecomposedV v Proxy -> m (v Identity)
f v (Compose (MonoidalMap c) g)
v = (forall a.
 Compose (MonoidalMap c) g a
 -> Identity a -> Compose (MonoidalMap c) Identity a)
-> v (Compose (MonoidalMap c) g)
-> v Identity
-> Maybe (v (Compose (MonoidalMap c) Identity))
forall (v :: (* -> *) -> *) (s :: * -> *) (i :: * -> *)
       (r :: * -> *).
View v =>
(forall a. s a -> i a -> r a) -> v s -> v i -> Maybe (v r)
cropV forall a.
Compose (MonoidalMap c) g a
-> Identity a -> Compose (MonoidalMap c) Identity a
forall c (g :: * -> *) a.
Compose (MonoidalMap c) g a
-> Identity a -> Compose (MonoidalMap c) Identity a
recompose v (Compose (MonoidalMap c) g)
v (v Identity -> Maybe (v (Compose (MonoidalMap c) Identity)))
-> m (v Identity)
-> m (Maybe (v (Compose (MonoidalMap c) Identity)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (v Proxy -> m (v Identity)
f (v Proxy -> m (v Identity)) -> v Proxy -> m (v Identity)
forall a b. (a -> b) -> a -> b
$ (forall a. Compose (MonoidalMap c) g a -> Proxy a)
-> v (Compose (MonoidalMap c) g) -> v Proxy
forall (v :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
View v =>
(forall a. f a -> g a) -> v f -> v g
mapV (\Compose (MonoidalMap c) g a
_ -> Proxy a
forall k (t :: k). Proxy t
Proxy) v (Compose (MonoidalMap c) g)
v)
  where
    recompose :: Compose (MonoidalMap c) g a -> Identity a -> Compose (MonoidalMap c) Identity a
    recompose :: Compose (MonoidalMap c) g a
-> Identity a -> Compose (MonoidalMap c) Identity a
recompose (Compose MonoidalMap c (g a)
s) Identity a
i = MonoidalMap c (Identity a) -> Compose (MonoidalMap c) Identity a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (MonoidalMap c (Identity a) -> Compose (MonoidalMap c) Identity a)
-> MonoidalMap c (Identity a) -> Compose (MonoidalMap c) Identity a
forall a b. (a -> b) -> a -> b
$ Identity a
i Identity a -> MonoidalMap c (g a) -> MonoidalMap c (Identity a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ MonoidalMap c (g a)
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 :: (forall a. s a -> i a -> r a)
-> MonoidalDMap k s -> MonoidalDMap k i -> Maybe (MonoidalDMap k r)
cropV forall a. s a -> i a -> r a
f MonoidalDMap k s
a MonoidalDMap k i
b = MonoidalDMap k r -> Maybe (MonoidalDMap k r)
forall (v :: (* -> *) -> *) (f :: * -> *).
View v =>
v f -> Maybe (v f)
collapseNullV (MonoidalDMap k r -> Maybe (MonoidalDMap k r))
-> MonoidalDMap k r -> Maybe (MonoidalDMap k r)
forall a b. (a -> b) -> a -> b
$ (forall v. k v -> s v -> i v -> r v)
-> MonoidalDMap k s -> MonoidalDMap k i -> MonoidalDMap k r
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (g :: k1 -> *)
       (h :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). k2 v -> f v -> g v -> h v)
-> MonoidalDMap k2 f -> MonoidalDMap k2 g -> MonoidalDMap k2 h
DMap.intersectionWithKey (\k v
_ s v
s i v
i -> s v -> i v -> r v
forall a. s a -> i a -> r a
f s v
s i v
i) MonoidalDMap k s
a MonoidalDMap k i
b

  nullV :: MonoidalDMap k s -> Bool
  nullV :: MonoidalDMap k s -> Bool
nullV MonoidalDMap k s
m = MonoidalDMap k s -> Bool
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). MonoidalDMap k2 f -> Bool
DMap.null MonoidalDMap k s
m

  condenseV :: forall col g. ( Foldable col, Filterable col, Functor col )
            => col (MonoidalDMap k g)
            -> MonoidalDMap k (Compose col g)
  condenseV :: col (MonoidalDMap k g) -> MonoidalDMap k (Compose col g)
condenseV col (MonoidalDMap k g)
col = DMap k g
-> col (MonoidalDMap k g) -> MonoidalDMap k (Compose col g)
forall k1 (k :: k1 -> *) (t :: * -> *) (g :: k1 -> *).
(GCompare k, Foldable t, Filterable t) =>
DMap k g -> t (MonoidalDMap k g) -> MonoidalDMap k (Compose t g)
condenseD' (col (DMap k g) -> DMap k g
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ((MonoidalDMap k g -> DMap k g)
-> col (MonoidalDMap k g) -> col (DMap k g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MonoidalDMap k g -> DMap k g
forall k (f :: k -> *) (g :: k -> *). MonoidalDMap f g -> DMap f g
unMonoidalDMap col (MonoidalDMap k g)
col)) col (MonoidalDMap k g)
col

  disperseV :: forall col g. (Align col)
           => MonoidalDMap k (Compose col g)
           -> col (MonoidalDMap k g)
  disperseV :: MonoidalDMap k (Compose col g) -> col (MonoidalDMap k g)
disperseV MonoidalDMap k (Compose col g)
row = case DMap k (Compose col g) -> PivotD k (Compose col g)
forall l (k :: l -> *) (g :: l -> *).
GCompare k =>
DMap k g -> PivotD k g
findPivotD (MonoidalDMap k (Compose col g) -> DMap k (Compose col g)
forall k (f :: k -> *) (g :: k -> *). MonoidalDMap f g -> DMap f g
unMonoidalDMap MonoidalDMap k (Compose col g)
row) of
    PivotD k (Compose col g)
NoneD -> col (MonoidalDMap k g)
forall (f :: * -> *) a. Align f => f a
nil
    OneD k v
k (Compose col (g v)
v) -> (g v -> MonoidalDMap k g) -> col (g v) -> col (MonoidalDMap k g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (k v -> g v -> MonoidalDMap k g
forall k1 (k2 :: k1 -> *) (v :: k1) (f :: k1 -> *).
k2 v -> f v -> MonoidalDMap k2 f
DMap.singleton k v
k) col (g v)
v
    SplitD k v
pivot DMap k (Compose col g)
_l DMap k (Compose col g)
_r -> (col (MonoidalDMap k g)
 -> col (MonoidalDMap k g) -> col (MonoidalDMap k g))
-> (col (MonoidalDMap k g), col (MonoidalDMap k g))
-> col (MonoidalDMap k g)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((These (MonoidalDMap k g) (MonoidalDMap k g) -> MonoidalDMap k g)
-> col (MonoidalDMap k g)
-> col (MonoidalDMap k g)
-> col (MonoidalDMap k g)
forall (f :: * -> *) a b c.
Semialign f =>
(These a b -> c) -> f a -> f b -> f c
alignWith ((MonoidalDMap k g -> MonoidalDMap k g -> MonoidalDMap k g)
-> These (MonoidalDMap k g) (MonoidalDMap k g) -> MonoidalDMap k g
forall a. (a -> a -> a) -> These a a -> a
mergeThese MonoidalDMap k g -> MonoidalDMap k g -> MonoidalDMap k g
forall k1 (k2 :: k1 -> *) (g :: k1 -> *).
GCompare k2 =>
MonoidalDMap k2 g -> MonoidalDMap k2 g -> MonoidalDMap k2 g
unionDistinctAscD)) ((col (MonoidalDMap k g), col (MonoidalDMap k g))
 -> col (MonoidalDMap k g))
-> (col (MonoidalDMap k g), col (MonoidalDMap k g))
-> col (MonoidalDMap k g)
forall a b. (a -> b) -> a -> b
$
      MonoidalDMap k (Compose col g) -> col (MonoidalDMap k g)
forall (v :: (* -> *) -> *) (t :: * -> *) (g :: * -> *).
(View v, Align t) =>
v (Compose t g) -> t (v g)
disperseV (MonoidalDMap k (Compose col g) -> col (MonoidalDMap k g))
-> (MonoidalDMap k (Compose col g) -> col (MonoidalDMap k g))
-> (MonoidalDMap k (Compose col g), MonoidalDMap k (Compose col g))
-> (col (MonoidalDMap k g), col (MonoidalDMap k g))
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** MonoidalDMap k (Compose col g) -> col (MonoidalDMap k g)
forall (v :: (* -> *) -> *) (t :: * -> *) (g :: * -> *).
(View v, Align t) =>
v (Compose t g) -> t (v g)
disperseV ((MonoidalDMap k (Compose col g), MonoidalDMap k (Compose col g))
 -> (col (MonoidalDMap k g), col (MonoidalDMap k g)))
-> (MonoidalDMap k (Compose col g), MonoidalDMap k (Compose col g))
-> (col (MonoidalDMap k g), col (MonoidalDMap k g))
forall a b. (a -> b) -> a -> b
$ k v
-> MonoidalDMap k (Compose col g)
-> (MonoidalDMap k (Compose col g), MonoidalDMap k (Compose col g))
forall k1 (k2 :: k1 -> *) (v :: k1) (g :: k1 -> *).
GCompare k2 =>
k2 v -> MonoidalDMap k2 g -> (MonoidalDMap k2 g, MonoidalDMap k2 g)
splitLTD k v
pivot MonoidalDMap k (Compose col g)
row

  mapV :: (forall a. f a -> g a) -> MonoidalDMap k f -> MonoidalDMap k g
  mapV :: (forall a. f a -> g a) -> MonoidalDMap k f -> MonoidalDMap k g
mapV forall a. f a -> g a
f MonoidalDMap k f
m = (forall a. f a -> g a) -> MonoidalDMap k f -> MonoidalDMap k g
forall k1 (f :: k1 -> *) (g :: k1 -> *) (k2 :: k1 -> *).
(forall (v :: k1). f v -> g v)
-> MonoidalDMap k2 f -> MonoidalDMap k2 g
DMap.map forall a. f a -> g a
f MonoidalDMap k f
m

  traverseV :: (Applicative m) => (forall a. f a -> m (g a)) -> MonoidalDMap k f -> m (MonoidalDMap k g)
  traverseV :: (forall a. f a -> m (g a))
-> MonoidalDMap k f -> m (MonoidalDMap k g)
traverseV forall a. f a -> m (g a)
f MonoidalDMap k f
m = (forall v. k v -> f v -> m (g v))
-> MonoidalDMap k f -> m (MonoidalDMap k g)
forall k1 (t :: * -> *) (k2 :: k1 -> *) (f :: k1 -> *)
       (g :: k1 -> *).
Applicative t =>
(forall (v :: k1). k2 v -> f v -> t (g v))
-> MonoidalDMap k2 f -> t (MonoidalDMap k2 g)
DMap.traverseWithKey (\k v
_ f v
v -> f v -> m (g v)
forall a. f a -> m (g a)
f f v
v) MonoidalDMap k f
m

  mapMaybeV :: (forall a. f a -> Maybe (g a))
-> MonoidalDMap k f -> Maybe (MonoidalDMap k g)
mapMaybeV forall a. f a -> Maybe (g a)
f (MonoidalDMap DMap k f
m) = MonoidalDMap k g -> Maybe (MonoidalDMap k g)
forall (v :: (* -> *) -> *) (f :: * -> *).
View v =>
v f -> Maybe (v f)
collapseNullV (MonoidalDMap k g -> Maybe (MonoidalDMap k g))
-> MonoidalDMap k g -> Maybe (MonoidalDMap k g)
forall a b. (a -> b) -> a -> b
$ DMap k g -> MonoidalDMap k g
forall k (f :: k -> *) (g :: k -> *). DMap f g -> MonoidalDMap f g
MonoidalDMap (DMap k g -> MonoidalDMap k g) -> DMap k g -> MonoidalDMap k g
forall a b. (a -> b) -> a -> b
$
    (forall a. f a -> Maybe (g a)) -> DMap k f -> DMap k g
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (g :: k1 -> *).
GCompare k2 =>
(forall (v :: k1). f v -> Maybe (g v)) -> DMap k2 f -> DMap k2 g
DMap'.mapMaybe forall a. f a -> Maybe (g a)
f DMap k f
m

  alignWithV :: (forall a. These (f a) (g a) -> h a)
-> MonoidalDMap k f -> MonoidalDMap k g -> MonoidalDMap k h
alignWithV forall a. These (f a) (g a) -> h a
f MonoidalDMap k f
a MonoidalDMap k g
b = (forall a. k a -> These (f a) (g a) -> h a)
-> MonoidalDMap k f -> MonoidalDMap k g -> MonoidalDMap k h
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (g :: k1 -> *)
       (h :: k1 -> *).
GCompare k2 =>
(forall (a :: k1). k2 a -> These (f a) (g a) -> h a)
-> MonoidalDMap k2 f -> MonoidalDMap k2 g -> MonoidalDMap k2 h
alignWithKeyMonoidalDMap (\k a
_ These (f a) (g a)
x -> These (f a) (g a) -> h a
forall a. These (f a) (g a) -> h a
f These (f a) (g a)
x) MonoidalDMap k f
a MonoidalDMap k g
b

  alignWithMaybeV :: (forall a. These (f a) (g a) -> Maybe (h a))
-> MonoidalDMap k f -> MonoidalDMap k g -> Maybe (MonoidalDMap k h)
alignWithMaybeV forall a. These (f a) (g a) -> Maybe (h a)
f MonoidalDMap k f
a MonoidalDMap k g
b = MonoidalDMap k h -> Maybe (MonoidalDMap k h)
forall (v :: (* -> *) -> *) (f :: * -> *).
View v =>
v f -> Maybe (v f)
collapseNullV (MonoidalDMap k h -> Maybe (MonoidalDMap k h))
-> MonoidalDMap k h -> Maybe (MonoidalDMap k h)
forall a b. (a -> b) -> a -> b
$ (forall a. k a -> These (f a) (g a) -> Maybe (h a))
-> MonoidalDMap k f -> MonoidalDMap k g -> MonoidalDMap k h
forall k1 (k2 :: k1 -> *) (f :: k1 -> *) (g :: k1 -> *)
       (h :: k1 -> *).
GCompare k2 =>
(forall (a :: k1). k2 a -> These (f a) (g a) -> Maybe (h a))
-> MonoidalDMap k2 f -> MonoidalDMap k2 g -> MonoidalDMap k2 h
alignWithKeyMaybeMonoidalDMap (\k a
_ These (f a) (g a)
x -> These (f a) (g a) -> Maybe (h a)
forall a. These (f a) (g a) -> Maybe (h a)
f These (f a) (g a)
x) MonoidalDMap k f
a MonoidalDMap k g
b

instance (GCompare k) => EmptyView (MonoidalDMap k) where
  emptyV :: MonoidalDMap k f
emptyV = MonoidalDMap k f
forall k1 (k2 :: k1 -> *) (f :: k1 -> *). MonoidalDMap k2 f
DMap.empty

filterV :: View v => (forall a. f a -> Bool) -> v f -> Maybe (v f)
filterV :: (forall a. f a -> Bool) -> v f -> Maybe (v f)
filterV forall a. f a -> Bool
f = (forall a. f a -> Maybe (f a)) -> v f -> Maybe (v f)
forall (v :: (* -> *) -> *) (f :: * -> *) (g :: * -> *).
View v =>
(forall a. f a -> Maybe (g a)) -> v f -> Maybe (v g)
mapMaybeV (\f a
x -> if f a -> Bool
forall a. f a -> Bool
f f a
x then f a -> Maybe (f a)
forall a. a -> Maybe a
Just f a
x else Maybe (f a)
forall a. Maybe a
Nothing)

-- | a completely empty view.
instance View Proxy