{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-}
module Data.Profunctor.Optic.Index (
(%)
, ixinit
, ixlast
, reix
, ixmap
, withIxrepn
, (#)
, cxinit
, cxlast
, recx
, cxmap
, cxed
, cxjoin
, cxreturn
, type Cx'
, cxunit
, cxpastro
, cxfirst'
, withCxrepn
, Index(..)
, values
, info
, Coindex(..)
, trivial
, noindex
, coindex
, (##)
) where
import Data.Bifunctor as B
import Data.Foldable
import Data.Semigroup
import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Type
import Data.Profunctor.Strong
import GHC.Generics (Generic)
infixr 8 %
(%) :: Semigroup i => Representable p => IndexedOptic p i b1 b2 a1 a2 -> IndexedOptic p i c1 c2 b1 b2 -> IndexedOptic p i c1 c2 a1 a2
f % g = repn $ \ia1a2 (ic,c1) ->
withIxrepn g ic c1 $ \ib b1 ->
withIxrepn f ib b1 $ \ia a1 -> ia1a2 (ib <> ia, a1)
{-# INLINE (%) #-}
ixinit :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (First i) s t a b
ixinit = reix First getFirst
ixlast :: Profunctor p => IndexedOptic p i s t a b -> IndexedOptic p (Last i) s t a b
ixlast = reix Last getLast
reix :: Profunctor p => (i -> j) -> (j -> i) -> IndexedOptic p i s t a b -> IndexedOptic p j s t a b
reix ij ji = (. lmap (first' ij)) . (lmap (first' ji) .)
ixmap :: Profunctor p => (s -> a) -> (b -> t) -> IndexedOptic p i s t a b
ixmap sa bt = dimap (fmap sa) bt
withIxrepn :: Representable p => IndexedOptic p i s t a b -> i -> s -> (i -> a -> Rep p b) -> Rep p t
withIxrepn abst i s iab = (sieve . abst . tabulate $ uncurry iab) (i, s)
infixr 8 #
(#) :: Semigroup k => Corepresentable p => CoindexedOptic p k b1 b2 a1 a2 -> CoindexedOptic p k c1 c2 b1 b2 -> CoindexedOptic p k c1 c2 a1 a2
f # g = corepn $ \a1ka2 c1 kc ->
withCxrepn g c1 kc $ \b1 kb ->
withCxrepn f b1 kb $ \a1 ka -> a1ka2 a1 (kb <> ka)
{-# INLINE (#) #-}
cxinit :: Profunctor p => CoindexedOptic p k s t a b -> CoindexedOptic p (First k) s t a b
cxinit = recx First getFirst
cxlast :: Profunctor p => CoindexedOptic p k s t a b -> CoindexedOptic p (Last k) s t a b
cxlast = recx Last getLast
recx :: Profunctor p => (k -> l) -> (l -> k) -> CoindexedOptic p k s t a b -> CoindexedOptic p l s t a b
recx kl lk = (. rmap (. kl)) . (rmap (. lk) .)
cxmap :: Profunctor p => (s -> a) -> (b -> t) -> CoindexedOptic p k s t a b
cxmap sa bt = dimap sa (fmap bt)
type Cx p k a b = p a (k -> b)
type Cx' p a b = Cx p a a b
cxed :: Strong p => Iso (Cx p s s t) (Cx p k a b) (p s t) (p a b)
cxed = dimap cxjoin cxreturn
cxjoin :: Strong p => Cx p a a b -> p a b
cxjoin = peval
cxreturn :: Profunctor p => p a b -> Cx p k a b
cxreturn = rmap const
cxunit :: Strong p => Cx' p :-> p
cxunit p = dimap fork apply (first' p)
cxpastro :: Profunctor p => Iso (Cx' p a b) (Cx' p c d) (Pastro p a b) (Pastro p c d)
cxpastro = dimap (\p -> Pastro apply p fork) (\(Pastro l m r) -> dimap (fst . r) (\y a -> l (y, (snd (r a)))) m)
cxfirst' :: Profunctor p => Cx' p a b -> Cx' p (a, c) (b, c)
cxfirst' = dimap fst (B.first @(,))
withCxrepn :: Corepresentable p => CoindexedOptic p k s t a b -> Corep p s -> k -> (Corep p a -> k -> b) -> t
withCxrepn abst s k akb = (cosieve . abst $ cotabulate akb) s k
data Index a b r = Index a (b -> r)
values :: Index a b r -> b -> r
values (Index _ br) = br
{-# INLINE values #-}
info :: Index a b r -> a
info (Index a _) = a
{-# INLINE info #-}
instance Functor (Index a b) where
fmap f (Index a br) = Index a (f . br)
{-# INLINE fmap #-}
instance Profunctor (Index a) where
dimap f g (Index a br) = Index a (g . br . f)
{-# INLINE dimap #-}
instance a ~ b => Foldable (Index a b) where
foldMap f (Index b br) = f . br $ b
newtype Coindex a b k = Coindex { runCoindex :: (k -> a) -> b } deriving Generic
instance Functor (Coindex a b) where
fmap kl (Coindex abk) = Coindex $ \la -> abk (la . kl)
instance a ~ b => Apply (Coindex a b) where
(Coindex klab) <.> (Coindex abk) = Coindex $ \la -> klab $ \kl -> abk (la . kl)
instance a ~ b => Applicative (Coindex a b) where
pure k = Coindex ($k)
(<*>) = (<.>)
trivial :: Coindex a b a -> b
trivial (Coindex f) = f id
{-# INLINE trivial #-}
noindex :: Monoid k => (a -> b) -> Coindex a b k
noindex f = Coindex $ \a -> f (a mempty)
coindex :: Functor f => k -> (a -> b) -> Coindex (f a) (f b) k
coindex k ab = Coindex $ \kfa -> fmap ab (kfa k)
{-# INLINE coindex #-}
infixr 9 ##
(##) :: Semigroup k => Coindex b c k -> Coindex a b k -> Coindex a c k
Coindex f ## Coindex g = Coindex $ \b -> f $ \k1 -> g $ \k2 -> b (k1 <> k2)