{-# 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
  { ViewHalfMorphism m n p q -> p -> m q
_viewMorphism_mapQuery :: p -> m q
  , ViewHalfMorphism m n p q
-> ViewQueryResult q -> n (ViewQueryResult p)
_viewMorphism_mapQueryResult :: ViewQueryResult q -> n (ViewQueryResult p) -- TODO Loading data
  }

data ViewMorphism m n p q = ViewMorphism
  { ViewMorphism m n p q -> ViewHalfMorphism m n p q
_viewMorphism_to ::   ViewHalfMorphism m n p q
  , ViewMorphism m n p q -> ViewHalfMorphism n m q p
_viewMorphism_from :: ViewHalfMorphism n m q p
  }

type ViewMorphismSimple = ViewMorphism Identity Maybe

instance (Monad m, Monad n) => Category (ViewHalfMorphism n m) where
  id :: ViewHalfMorphism n m a a
id = (a -> n a)
-> (ViewQueryResult a -> m (ViewQueryResult a))
-> ViewHalfMorphism n m a a
forall (m :: * -> *) (n :: * -> *) p q.
(p -> m q)
-> (ViewQueryResult q -> n (ViewQueryResult p))
-> ViewHalfMorphism m n p q
ViewHalfMorphism a -> n a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ViewQueryResult a -> m (ViewQueryResult a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ViewHalfMorphism b -> n c
f ViewQueryResult c -> m (ViewQueryResult b)
f' . :: ViewHalfMorphism n m b c
-> ViewHalfMorphism n m a b -> ViewHalfMorphism n m a c
. ViewHalfMorphism a -> n b
g ViewQueryResult b -> m (ViewQueryResult a)
g' = (a -> n c)
-> (ViewQueryResult c -> m (ViewQueryResult a))
-> ViewHalfMorphism n m a c
forall (m :: * -> *) (n :: * -> *) p q.
(p -> m q)
-> (ViewQueryResult q -> n (ViewQueryResult p))
-> ViewHalfMorphism m n p q
ViewHalfMorphism (b -> n c
f (b -> n c) -> (a -> n b) -> a -> n c
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< a -> n b
g) (ViewQueryResult c -> m (ViewQueryResult b)
f' (ViewQueryResult c -> m (ViewQueryResult b))
-> (ViewQueryResult b -> m (ViewQueryResult a))
-> ViewQueryResult c
-> m (ViewQueryResult a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ViewQueryResult b -> m (ViewQueryResult a)
g')

instance (Monad m, Monad n) => Category (ViewMorphism m n) where
  id :: ViewMorphism m n a a
id = ViewHalfMorphism m n a a
-> ViewHalfMorphism n m a a -> ViewMorphism m n a a
forall (m :: * -> *) (n :: * -> *) p q.
ViewHalfMorphism m n p q
-> ViewHalfMorphism n m q p -> ViewMorphism m n p q
ViewMorphism ViewHalfMorphism m n a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id ViewHalfMorphism n m a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
  ViewMorphism ViewHalfMorphism m n b c
f ViewHalfMorphism n m c b
f' . :: ViewMorphism m n b c
-> ViewMorphism m n a b -> ViewMorphism m n a c
. ViewMorphism ViewHalfMorphism m n a b
g ViewHalfMorphism n m b a
g' = ViewHalfMorphism m n a c
-> ViewHalfMorphism n m c a -> ViewMorphism m n a c
forall (m :: * -> *) (n :: * -> *) p q.
ViewHalfMorphism m n p q
-> ViewHalfMorphism n m q p -> ViewMorphism m n p q
ViewMorphism (ViewHalfMorphism m n b c
f ViewHalfMorphism m n b c
-> ViewHalfMorphism m n a b -> ViewHalfMorphism m n a c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ViewHalfMorphism m n a b
g) (ViewHalfMorphism n m b a
g' ViewHalfMorphism n m b a
-> ViewHalfMorphism n m c b -> ViewHalfMorphism n m c a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ViewHalfMorphism n m c b
f')

instance (Semigroup (m b) , Semigroup (n (ViewQueryResult a))) => Semigroup (ViewHalfMorphism m n a b) where
  ViewHalfMorphism a -> m b
f ViewQueryResult b -> n (ViewQueryResult a)
f' <> :: ViewHalfMorphism m n a b
-> ViewHalfMorphism m n a b -> ViewHalfMorphism m n a b
<> ViewHalfMorphism a -> m b
g ViewQueryResult b -> n (ViewQueryResult a)
g' = (a -> m b)
-> (ViewQueryResult b -> n (ViewQueryResult a))
-> ViewHalfMorphism m n a b
forall (m :: * -> *) (n :: * -> *) p q.
(p -> m q)
-> (ViewQueryResult q -> n (ViewQueryResult p))
-> ViewHalfMorphism m n p q
ViewHalfMorphism (a -> m b
f (a -> m b) -> (a -> m b) -> a -> m b
forall a. Semigroup a => a -> a -> a
<> a -> m b
g) (ViewQueryResult b -> n (ViewQueryResult a)
f' (ViewQueryResult b -> n (ViewQueryResult a))
-> (ViewQueryResult b -> n (ViewQueryResult a))
-> ViewQueryResult b
-> n (ViewQueryResult a)
forall a. Semigroup a => a -> a -> a
<> ViewQueryResult b -> n (ViewQueryResult a)
g')

instance (Monoid (m b) , Monoid (n (ViewQueryResult a))) => Monoid (ViewHalfMorphism m n a b) where
  mappend :: ViewHalfMorphism m n a b
-> ViewHalfMorphism m n a b -> ViewHalfMorphism m n a b
mappend = ViewHalfMorphism m n a b
-> ViewHalfMorphism m n a b -> ViewHalfMorphism m n a b
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: ViewHalfMorphism m n a b
mempty = (a -> m b)
-> (ViewQueryResult b -> n (ViewQueryResult a))
-> ViewHalfMorphism m n a b
forall (m :: * -> *) (n :: * -> *) p q.
(p -> m q)
-> (ViewQueryResult q -> n (ViewQueryResult p))
-> ViewHalfMorphism m n p q
ViewHalfMorphism a -> m b
forall a. Monoid a => a
mempty ViewQueryResult b -> n (ViewQueryResult a)
forall a. Monoid a => a
mempty

instance
    ( Semigroup (m b), Semigroup (m (ViewQueryResult b))
    , Semigroup (n a), Semigroup (n (ViewQueryResult a))
    ) => Semigroup (ViewMorphism m n a b) where
  ViewMorphism ViewHalfMorphism m n a b
f ViewHalfMorphism n m b a
f' <> :: ViewMorphism m n a b
-> ViewMorphism m n a b -> ViewMorphism m n a b
<> ViewMorphism ViewHalfMorphism m n a b
g ViewHalfMorphism n m b a
g' = ViewHalfMorphism m n a b
-> ViewHalfMorphism n m b a -> ViewMorphism m n a b
forall (m :: * -> *) (n :: * -> *) p q.
ViewHalfMorphism m n p q
-> ViewHalfMorphism n m q p -> ViewMorphism m n p q
ViewMorphism (ViewHalfMorphism m n a b
f ViewHalfMorphism m n a b
-> ViewHalfMorphism m n a b -> ViewHalfMorphism m n a b
forall a. Semigroup a => a -> a -> a
<> ViewHalfMorphism m n a b
g) (ViewHalfMorphism n m b a
f' ViewHalfMorphism n m b a
-> ViewHalfMorphism n m b a -> ViewHalfMorphism n m b a
forall a. Semigroup a => a -> a -> a
<> ViewHalfMorphism n m b a
g')

instance
    ( Monoid (m b), Monoid (m (ViewQueryResult b))
    , Monoid (n a), Monoid (n (ViewQueryResult a))
    )  => Monoid (ViewMorphism m n a b) where
  mappend :: ViewMorphism m n a b
-> ViewMorphism m n a b -> ViewMorphism m n a b
mappend = ViewMorphism m n a b
-> ViewMorphism m n a b -> ViewMorphism m n a b
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: ViewMorphism m n a b
mempty = ViewHalfMorphism m n a b
-> ViewHalfMorphism n m b a -> ViewMorphism m n a b
forall (m :: * -> *) (n :: * -> *) p q.
ViewHalfMorphism m n p q
-> ViewHalfMorphism n m q p -> ViewMorphism m n p q
ViewMorphism ViewHalfMorphism m n a b
forall a. Monoid a => a
mempty ViewHalfMorphism n m b a
forall a. Monoid a => a
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 m n a c
-> ViewMorphism m n b c -> ViewMorphism m n (a, b) c
zipViewMorphism (ViewMorphism ViewHalfMorphism m n a c
f ViewHalfMorphism n m c a
f') (ViewMorphism ViewHalfMorphism m n b c
g ViewHalfMorphism n m c b
g') = ViewHalfMorphism m n (a, b) c
-> ViewHalfMorphism n m c (a, b) -> ViewMorphism m n (a, b) c
forall (m :: * -> *) (n :: * -> *) p q.
ViewHalfMorphism m n p q
-> ViewHalfMorphism n m q p -> ViewMorphism m n p q
ViewMorphism (ViewHalfMorphism m n a c
-> ViewHalfMorphism m n b c -> ViewHalfMorphism m n (a, b) c
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 m n a c
f ViewHalfMorphism m n b c
g) (ViewHalfMorphism n m c a
-> ViewHalfMorphism n m c b -> ViewHalfMorphism n m c (a, b)
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 n m c a
f' ViewHalfMorphism n m c b
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 m n a c
-> ViewHalfMorphism m n b c -> ViewHalfMorphism m n (a, b) c
toZipViewMorphism (ViewHalfMorphism a -> m c
a2c ViewQueryResult c -> n (ViewQueryResult a)
c2a' ) (ViewHalfMorphism b -> m c
b2c ViewQueryResult c -> n (ViewQueryResult b)
c2b' ) = ViewHalfMorphism :: forall (m :: * -> *) (n :: * -> *) p q.
(p -> m q)
-> (ViewQueryResult q -> n (ViewQueryResult p))
-> ViewHalfMorphism m n p q
ViewHalfMorphism
    { _viewMorphism_mapQuery :: (a, b) -> m c
_viewMorphism_mapQuery = \(a
x, b
y) -> a -> m c
a2c a
x m c -> m c -> m c
forall a. Semigroup a => a -> a -> a
<> b -> m c
b2c b
y
    , _viewMorphism_mapQueryResult :: ViewQueryResult c -> n (ViewQueryResult (a, b))
_viewMorphism_mapQueryResult = \ViewQueryResult c
r -> n (ViewQueryResult a)
-> n (ViewQueryResult b)
-> n (These (ViewQueryResult a) (ViewQueryResult b))
forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
align (ViewQueryResult c -> n (ViewQueryResult a)
c2a' ViewQueryResult c
r) (ViewQueryResult c -> n (ViewQueryResult b)
c2b' ViewQueryResult c
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 m n c a
-> ViewHalfMorphism m n c b -> ViewHalfMorphism m n c (a, b)
fromZipViewMorphism (ViewHalfMorphism c -> m a
c2a ViewQueryResult a -> n (ViewQueryResult c)
a2c') (ViewHalfMorphism c -> m b
c2b ViewQueryResult b -> n (ViewQueryResult c)
b2c') = ViewHalfMorphism :: forall (m :: * -> *) (n :: * -> *) p q.
(p -> m q)
-> (ViewQueryResult q -> n (ViewQueryResult p))
-> ViewHalfMorphism m n p q
ViewHalfMorphism
    { _viewMorphism_mapQuery :: c -> m (a, b)
_viewMorphism_mapQuery = \c
r -> (a -> b -> (a, b)) -> m a -> m b -> m (a, b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (c -> m a
c2a c
r) (c -> m b
c2b c
r)
    , _viewMorphism_mapQueryResult :: ViewQueryResult (a, b) -> n (ViewQueryResult c)
_viewMorphism_mapQueryResult = (n (ViewQueryResult c) -> n (ViewQueryResult c))
-> (n (ViewQueryResult c) -> n (ViewQueryResult c))
-> (n (ViewQueryResult c)
    -> n (ViewQueryResult c) -> n (ViewQueryResult c))
-> These (n (ViewQueryResult c)) (n (ViewQueryResult c))
-> n (ViewQueryResult c)
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these n (ViewQueryResult c) -> n (ViewQueryResult c)
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id n (ViewQueryResult c) -> n (ViewQueryResult c)
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (n (ViewQueryResult c)
-> n (ViewQueryResult c) -> n (ViewQueryResult c)
forall a. Semigroup a => a -> a -> a
(<>)) (These (n (ViewQueryResult c)) (n (ViewQueryResult c))
 -> n (ViewQueryResult c))
-> (These (ViewQueryResult a) (ViewQueryResult b)
    -> These (n (ViewQueryResult c)) (n (ViewQueryResult c)))
-> These (ViewQueryResult a) (ViewQueryResult b)
-> n (ViewQueryResult c)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ViewQueryResult a -> n (ViewQueryResult c))
-> (ViewQueryResult b -> n (ViewQueryResult c))
-> These (ViewQueryResult a) (ViewQueryResult b)
-> These (n (ViewQueryResult c)) (n (ViewQueryResult c))
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ViewQueryResult a -> n (ViewQueryResult c)
a2c' ViewQueryResult b -> n (ViewQueryResult c)
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 :: p
-> Dynamic t (ViewMorphism Identity partial p q)
-> m (Dynamic t (partial (ViewQueryResult p)))
queryViewMorphism p
x Dynamic t (ViewMorphism Identity partial p q)
q = do
  v :: Dynamic t (QueryResult q) <- Dynamic t q -> m (Dynamic t (QueryResult q))
forall t q (m :: * -> *).
(Reflex t, MonadQuery t q m) =>
Dynamic t q -> m (Dynamic t (QueryResult q))
queryDyn (Dynamic t q -> m (Dynamic t (QueryResult q)))
-> Dynamic t q -> m (Dynamic t (QueryResult q))
forall a b. (a -> b) -> a -> b
$ (\(ViewMorphism (ViewHalfMorphism p -> Identity q
f ViewQueryResult q -> partial (ViewQueryResult p)
_) ViewHalfMorphism partial Identity q p
_) -> Identity q -> q
forall a. Identity a -> a
runIdentity (Identity q -> q) -> Identity q -> q
forall a b. (a -> b) -> a -> b
$ p -> Identity q
f p
x) (ViewMorphism Identity partial p q -> q)
-> Dynamic t (ViewMorphism Identity partial p q) -> Dynamic t q
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t (ViewMorphism Identity partial p q)
q
  Dynamic t (partial (ViewQueryResult p))
-> m (Dynamic t (partial (ViewQueryResult p)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Dynamic t (partial (ViewQueryResult p))
 -> m (Dynamic t (partial (ViewQueryResult p))))
-> Dynamic t (partial (ViewQueryResult p))
-> m (Dynamic t (partial (ViewQueryResult p)))
forall a b. (a -> b) -> a -> b
$ (\ViewQueryResult q
v' (ViewMorphism  (ViewHalfMorphism p -> Identity q
_ ViewQueryResult q -> partial (ViewQueryResult p)
g) ViewHalfMorphism partial Identity q p
_) -> ViewQueryResult q -> partial (ViewQueryResult p)
g ViewQueryResult q
v') (ViewQueryResult q
 -> ViewMorphism Identity partial p q
 -> partial (ViewQueryResult p))
-> Dynamic t (ViewQueryResult q)
-> Dynamic
     t
     (ViewMorphism Identity partial p q -> partial (ViewQueryResult p))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t (QueryResult q)
Dynamic t (ViewQueryResult q)
v Dynamic
  t
  (ViewMorphism Identity partial p q -> partial (ViewQueryResult p))
-> Dynamic t (ViewMorphism Identity partial p q)
-> Dynamic t (partial (ViewQueryResult p))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t (ViewMorphism Identity partial p q)
q