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