{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Profunctor.Optic.Grate (
Closed(..)
, Grate
, Grate'
, Cxgrate
, Cxgrate'
, AGrate
, AGrate'
, grate
, cxgrate
, grateVl
, cxgrateVl
, inverting
, cloneGrate
, GrateRep(..)
, withGrate
, constOf
, zipWithOf
, zipWith3Of
, zipWith4Of
, zipWithFOf
, cxclosed
, cxfirst
, cxsecond
, distributed
, connected
, forwarded
, continued
, unlifted
, toEnvironment
, toClosure
) where
import Control.Monad.Reader
import Control.Monad.Cont
import Control.Monad.IO.Unlift
import Data.Distributive
import Data.Connection (Conn(..))
import Data.Profunctor.Closed
import Data.Profunctor.Optic.Iso
import Data.Profunctor.Optic.Type
import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Index
import Data.Profunctor.Rep (unfirstCorep)
grate :: (((s -> a) -> b) -> t) -> Grate s t a b
grate sabt = dimap (flip ($)) sabt . closed
cxgrate :: (((s -> a) -> k -> b) -> t) -> Cxgrate k s t a b
cxgrate f = grate $ \sakb _ -> f sakb
grateVl :: (forall f. Functor f => (f a -> b) -> f s -> t) -> Grate s t a b
grateVl o = dimap (curry eval) ((o trivial) . Coindex) . closed
cxgrateVl :: (forall f. Functor f => (k -> f a -> b) -> f s -> t) -> Cxgrate k s t a b
cxgrateVl f = grateVl $ \kab -> const . f (flip kab)
inverting :: (s -> a) -> (b -> t) -> Grate s t a b
inverting sa bt = grate $ \sab -> bt (sab sa)
cloneGrate :: AGrate s t a b -> Grate s t a b
cloneGrate k = withGrate k grate
newtype GrateRep a b s t = GrateRep { unGrateRep :: ((s -> a) -> b) -> t }
type AGrate s t a b = Optic (GrateRep a b) s t a b
type AGrate' s a = AGrate s s a a
instance Profunctor (GrateRep a b) where
dimap f g (GrateRep z) = GrateRep $ \d -> g (z $ \k -> d (k . f))
instance Closed (GrateRep a b) where
closed (GrateRep sabt) = GrateRep $ \xsab x -> sabt $ \sa -> xsab $ \xs -> sa (xs x)
instance Costrong (GrateRep a b) where
unfirst = unfirstCorep
instance Cosieve (GrateRep a b) (Coindex a b) where
cosieve (GrateRep f) (Coindex g) = f g
instance Corepresentable (GrateRep a b) where
type Corep (GrateRep a b) = Coindex a b
cotabulate f = GrateRep $ f . Coindex
withGrate :: AGrate s t a b -> ((((s -> a) -> b) -> t) -> r) -> r
withGrate o k = case o (GrateRep $ \f -> f id) of GrateRep sabt -> k sabt
constOf :: AGrate s t a b -> b -> t
constOf o b = withGrate o $ \sabt -> sabt (const b)
zipWithOf :: AGrate s t a b -> (a -> a -> b) -> s -> s -> t
zipWithOf o comb s1 s2 = withGrate o $ \sabt -> sabt $ \get -> comb (get s1) (get s2)
zipWith3Of :: AGrate s t a b -> (a -> a -> a -> b) -> (s -> s -> s -> t)
zipWith3Of o comb s1 s2 s3 = withGrate o $ \sabt -> sabt $ \get -> comb (get s1) (get s2) (get s3)
zipWith4Of :: AGrate s t a b -> (a -> a -> a -> a -> b) -> (s -> s -> s -> s -> t)
zipWith4Of o comb s1 s2 s3 s4 = withGrate o $ \sabt -> sabt $ \get -> comb (get s1) (get s2) (get s3) (get s4)
zipWithFOf :: Functor f => AGrate s t a b -> (f a -> b) -> f s -> t
zipWithFOf o comb fs = withGrate o $ \sabt -> sabt $ \get -> comb (fmap get fs)
distributed :: Distributive f => Grate (f a) (f b) a b
distributed = grate (`cotraverse` id)
{-# INLINE distributed #-}
connected :: Conn s a -> Grate' s a
connected (Conn f g) = inverting f g
{-# INLINE connected #-}
forwarded :: Distributive m => MonadReader r m => Grate (m a) (m b) a b
forwarded = distributed
{-# INLINE forwarded #-}
continued :: Grate a (Cont r a) r r
continued = grate cont
{-# INLINE continued #-}
unlifted :: MonadUnliftIO m => Grate (m a) (m b) (IO a) (IO b)
unlifted = grate withRunInIO
{-# INLINE unlifted #-}
cxclosed :: Cxgrate k (c -> a) (c -> b) a b
cxclosed = rmap flip . closed
{-# INLINE cxclosed #-}
cxfirst :: Cxgrate k a b (a , c) (b , c)
cxfirst = rmap (unfirst . uncurry . flip) . curry'
{-# INLINE cxfirst #-}
cxsecond :: Cxgrate k a b (c , a) (c , b)
cxsecond = rmap (unsecond . uncurry) . curry' . lmap swap
{-# INLINE cxsecond #-}
toEnvironment :: Closed p => AGrate s t a b -> p a b -> Environment p s t
toEnvironment o p = withGrate o $ \sabt -> Environment sabt p (curry eval)
{-# INLINE toEnvironment #-}
toClosure :: Closed p => AGrate s t a b -> p a b -> Closure p s t
toClosure o p = withGrate o $ \sabt -> Closure (closed . grate sabt $ p)
{-# INLINE toClosure #-}