{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Profunctor.Optic.Traversal0 (
Traversal0
, Traversal0'
, Ixtraversal0
, Ixtraversal0'
, ATraversal0
, ATraversal0'
, traversal0
, traversal0'
, ixtraversal0
, ixtraversal0'
, traversal0Vl
, ixtraversal0Vl
, Traversal0Rep(..)
, withTraversal0
, nulled
, inserted
, selected
, predicated
, is
, isnt
, matches
) where
import Data.Bifunctor (first, second)
import Data.Bitraversable
import Data.List.Index
import Data.Map as Map
import Data.Semigroup.Bitraversable
import Data.Profunctor.Optic.Lens hiding (first, second, unit)
import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Prism (prism)
import Data.Profunctor.Optic.Grate
import Data.Profunctor.Optic.Type
import Data.Semiring
import Control.Monad.Trans.State
import Data.Profunctor.Optic.Iso
import qualified Data.Bifunctor as B
type ATraversal0 s t a b = Optic (Traversal0Rep a b) s t a b
type ATraversal0' s a = ATraversal0 s s a a
traversal0 :: (s -> t + a) -> (s -> b -> t) -> Traversal0 s t a b
traversal0 sta sbt = dimap (\s -> (s,) <$> sta s) (id ||| uncurry sbt) . right' . second'
traversal0' :: (s -> Maybe a) -> (s -> a -> s) -> Traversal0' s a
traversal0' sa sas = flip traversal0 sas $ \s -> maybe (Left s) Right (sa s)
ixtraversal0 :: (s -> t + (i , a)) -> (s -> b -> t) -> Ixtraversal0 i s t a b
ixtraversal0 stia sbt = ixtraversal0Vl $ \point f s -> either point (fmap (sbt s) . uncurry f) (stia s)
ixtraversal0' :: (s -> Maybe (i , a)) -> (s -> a -> s) -> Ixtraversal0' i s a
ixtraversal0' sia = ixtraversal0 $ \s -> maybe (Left s) Right (sia s)
traversal0Vl :: (forall f. Functor f => (forall c. c -> f c) -> (a -> f b) -> s -> f t) -> Traversal0 s t a b
traversal0Vl f = dimap (\s -> (s,) <$> eswap (sat s)) (id ||| uncurry sbt) . right' . second'
where
sat = f Right Left
sbt s b = runIdentity $ f Identity (\_ -> Identity b) s
ixtraversal0Vl :: (forall f. Functor f => (forall c. c -> f c) -> (i -> a -> f b) -> s -> f t) -> Ixtraversal0 i s t a b
ixtraversal0Vl f = traversal0Vl $ \cc iab -> f cc (curry iab) . snd
withTraversal0 :: ATraversal0 s t a b -> ((s -> t + a) -> (s -> b -> t) -> r) -> r
withTraversal0 o k = case o (Traversal0Rep Right $ const id) of Traversal0Rep x y -> k x y
nulled :: Traversal0' s a
nulled = traversal0 Left const
{-# INLINE nulled #-}
inserted :: (i -> s -> Maybe (i, a)) -> (i -> a -> s -> s) -> i -> Ixtraversal0' i s a
inserted isia iasa i = ixtraversal0Vl $ \point f s ->
case isia i s of
Nothing -> point s
Just (i', a) -> f i' a <&> \a -> iasa i' a s
{-# INLINE inserted #-}
selected :: (a -> Bool) -> Traversal0' (a, b) b
selected p = traversal0 (\kv@(k,v) -> branch p kv v k) (\kv@(k,_) v' -> if p k then (k,v') else kv)
{-# INLINE selected #-}
predicated :: (a -> Bool) -> Traversal0' a a
predicated p = traversal0 (branch' p) (flip const)
{-# INLINE predicated #-}
is :: ATraversal0 s t a b -> s -> Bool
is o = either (const False) (const True) . matches o
{-# INLINE is #-}
isnt :: ATraversal0 s t a b -> s -> Bool
isnt o = either (const True) (const False) . matches o
{-# INLINE isnt #-}
matches :: ATraversal0 s t a b -> s -> t + a
matches o = withTraversal0 o $ \sta _ -> sta
{-# INLINE matches #-}
data Traversal0Rep a b s t = Traversal0Rep (s -> t + a) (s -> b -> t)
instance Profunctor (Traversal0Rep u v) where
dimap f g (Traversal0Rep getter setter) = Traversal0Rep
(\a -> first g $ getter (f a))
(\a v -> g (setter (f a) v))
instance Strong (Traversal0Rep u v) where
first' (Traversal0Rep getter setter) = Traversal0Rep
(\(a, c) -> first (,c) $ getter a)
(\(a, c) v -> (setter a v, c))
instance Choice (Traversal0Rep u v) where
right' (Traversal0Rep getter setter) = Traversal0Rep
(\eca -> eassocl (second getter eca))
(\eca v -> second (`setter` v) eca)
instance Sieve (Traversal0Rep a b) (Index0 a b) where
sieve (Traversal0Rep sta sbt) s = Index0 (sta s) (sbt s)
instance Representable (Traversal0Rep a b) where
type Rep (Traversal0Rep a b) = Index0 a b
tabulate f = Traversal0Rep (info0 . f) (values0 . f)
data Index0 a b r = Index0 (r + a) (b -> r)
values0 :: Index0 a b r -> b -> r
values0 (Index0 _ br) = br
info0 :: Index0 a b r -> r + a
info0 (Index0 a _) = a
instance Functor (Index0 a b) where
fmap f (Index0 ra br) = Index0 (first f ra) (f . br)
{-# INLINE fmap #-}