ViewMorphism.hs

{-# 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 Control.Applicative
import Control.Category
import Control.Monad
import Data.Align
import Data.Bifunctor
import Data.Functor.Identity
import Data.Kind (Type)
import Data.These
import Data.Vessel.Internal ()
import Prelude hiding ((.), id)
import Reflex.Class
import Reflex.Query.Class

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
  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
  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 :: Type) (q :: Type) 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