{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Diverse.Profunctor.Many (
Itemized
, itemized
, itemizedK
, Projected
, projected
, projectedK
, MakeFrom
, MakeBoth
, makeBesides
, makeBesidesK
, thenMake
, thenMakeK
) where
import Control.Arrow
import qualified Control.Category as C
import Control.Lens
import Data.Diverse.Lens.Many
import Data.Diverse.Many
import Data.Diverse.TypeLevel
import Data.Profunctor
type Itemized a b s t =
( Had a s
, t ~ Replaced a b s
)
itemized ::
forall w a b s t.
( Profunctor w
, Strong w
, Itemized a b s t
)
=> w a b -> w s t
itemized w = dimap (\c -> (view item' c, c)) (\(b, c) -> set (item @a) b c) (first' w)
itemizedK ::
forall m a b s t.
( Monad m
, Itemized a b s t
)
=> (a -> m b) -> (s -> m t)
itemizedK f = runKleisli . itemized $ Kleisli f
type Projected a1 a2 b1 b2 =
( Select a1 a2
, Amend a1 b1 a2
, b2 ~ Replaces a1 b1 a2
)
projected :: forall w a1 a2 b1 b2.
( Strong w
, Projected a1 a2 b1 b2
)
=> w (Many a1) (Many b1) -> w (Many a2) (Many b2)
projected w = dimap (\c -> (select c, c)) (\(b, c) -> amend @a1 @b1 @a2 c b) (first' w)
projectedK :: forall m a1 a2 b1 b2.
( Monad m
, Projected a1 a2 b1 b2
)
=> (Many a1 -> m (Many b1)) -> (Many a2 -> m (Many b2))
projectedK f = runKleisli . projected $ Kleisli f
type MakeBoth b1 b2 b3 =
( b3 ~ Append b1 b2
)
type MakeFrom a1 a2 a3 =
( Select a1 a3
, Select a2 a3
, a3 ~ AppendUnique a1 a2
)
makeBesides
:: forall w a1 a2 a3 b1 b2 b3.
( C.Category w
, Strong w
, MakeFrom a1 a2 a3
, MakeBoth b1 b2 b3
)
=> w (Many a1) (Many b1)
-> w (Many a2) (Many b2)
-> w (Many a3) (Many b3)
x `makeBesides` y = rmap (uncurry (/./)) (lmap (select @a1 &&& select @a2) (first' x) C.>>> second' y)
infixr 3 `makeBesides`
makeBesidesK
:: forall m a1 a2 a3 b1 b2 b3.
( Monad m
, MakeFrom a1 a2 a3
, MakeBoth b1 b2 b3
)
=> (Many a1 -> m (Many b1))
-> (Many a2 -> m (Many b2))
-> (Many a3 -> m (Many b3))
makeBesidesK f g = runKleisli $ makeBesides (Kleisli f) (Kleisli g)
infixr 3 `makeBesidesK`
thenMake :: forall w a a2 b1 b2 b3.
( C.Category w
, Strong w
, Projected a2 b1 b2 b3
)
=> w a (Many b1)
-> w (Many a2) (Many b2)
-> w a (Many b3)
x `thenMake` y = x C.>>> projected y
infixr 3 `thenMake`
thenMakeK :: forall m a a2 b1 b2 b3.
( Monad m
, Projected a2 b1 b2 b3
)
=> (a -> m (Many b1))
-> (Many a2 -> m (Many b2))
-> (a -> m (Many b3))
thenMakeK f g = runKleisli $ thenMake (Kleisli f) (Kleisli g)
infixr 3 `thenMakeK`