{-# LANGUAGE TupleSections #-}
{-# LANGUAGE QuantifiedConstraints #-}
module Proton.Traversal where

import Control.Applicative
import Control.Monad.State
import Data.Bitraversable
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Profunctor.Sieve
import Data.Profunctor.Traversing
import Proton.Fold
import Proton.Lens
import Proton.Setter
import Proton.Types

type Traversal s t a b = forall p. (Traversing p) => p a b -> p s t
type Traversal' s a = forall p. Traversing p => p a a -> p s s

traversed :: Traversable f => Traversal (f a) (f b) a b
traversed :: Traversal (f a) (f b) a b
traversed = p a b -> p (f a) (f b)
forall (p :: * -> * -> *) (f :: * -> *) a b.
(Traversing p, Traversable f) =>
p a b -> p (f a) (f b)
traverse'

filtered :: (a -> Bool) -> Traversal' a a
filtered :: (a -> Bool) -> Traversal' a a
filtered predicate :: a -> Bool
predicate = (a -> Either a a)
-> (Either a a -> a) -> p (Either a a) (Either a a) -> p a a
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> Either a a
partition ((a -> a) -> (a -> a) -> Either a a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> a
forall a. a -> a
id a -> a
forall a. a -> a
id) (p (Either a a) (Either a a) -> p a a)
-> (p a a -> p (Either a a) (Either a a)) -> p a a -> p a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a a -> p (Either a a) (Either a a)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either a c) (Either b c)
left'
  where
    partition :: a -> Either a a
partition a :: a
a
        | a -> Bool
predicate a
a = a -> Either a a
forall a b. a -> Either a b
Left a
a
        | Bool
otherwise = a -> Either a a
forall a b. b -> Either a b
Right a
a

traverseOf :: Optic (Star f) s t a b -> (a -> f b) -> s -> f t
traverseOf :: Optic (Star f) s t a b -> (a -> f b) -> s -> f t
traverseOf t :: Optic (Star f) s t a b
t = Star f s t -> s -> f t
forall (f :: * -> *) d c. Star f d c -> d -> f c
runStar (Star f s t -> s -> f t)
-> ((a -> f b) -> Star f s t) -> (a -> f b) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic (Star f) s t a b
t Optic (Star f) s t a b
-> ((a -> f b) -> Star f a b) -> (a -> f b) -> Star f s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> Star f a b
forall (f :: * -> *) d c. (d -> f c) -> Star f d c
Star

infixr 4 %%~
(%%~) :: Optic (Star f) s t a b -> (a -> f b) -> s -> f t
%%~ :: Optic (Star f) s t a b -> (a -> f b) -> s -> f t
(%%~) = Optic (Star f) s t a b -> (a -> f b) -> s -> f t
forall (f :: * -> *) s t a b.
Optic (Star f) s t a b -> (a -> f b) -> s -> f t
traverseOf

beside :: forall s t a b s' t' p r. (Representable p, Bitraversable r, Applicative (Rep p)) => Optic p s t a b -> Optic p s' t' a b -> Optic p (r s s') (r t t') a b
beside :: Optic p s t a b
-> Optic p s' t' a b -> Optic p (r s s') (r t t') a b
beside t1 :: Optic p s t a b
t1 t2 :: Optic p s' t' a b
t2 p :: p a b
p = (r s s' -> Rep p (r t t')) -> p (r s s') (r t t')
forall (p :: * -> * -> *) d c.
Representable p =>
(d -> Rep p c) -> p d c
tabulate r s s' -> Rep p (r t t')
go
  where
    go :: r s s' -> Rep p (r t t')
    go :: r s s' -> Rep p (r t t')
go rss :: r s s'
rss = (s -> Rep p t) -> (s' -> Rep p t') -> r s s' -> Rep p (r t t')
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse (p s t -> s -> Rep p t
forall (p :: * -> * -> *) (f :: * -> *) a b.
Sieve p f =>
p a b -> a -> f b
sieve (p s t -> s -> Rep p t) -> p s t -> s -> Rep p t
forall a b. (a -> b) -> a -> b
$ Optic p s t a b
t1 p a b
p) (p s' t' -> s' -> Rep p t'
forall (p :: * -> * -> *) (f :: * -> *) a b.
Sieve p f =>
p a b -> a -> f b
sieve (p s' t' -> s' -> Rep p t') -> p s' t' -> s' -> Rep p t'
forall a b. (a -> b) -> a -> b
$ Optic p s' t' a b
t2 p a b
p) r s s'
rss


unsafePartsOf :: forall s t a b. (forall p. Traversing p => p a b -> p s t) -> Lens s t [a] [b]
unsafePartsOf :: (forall (p :: * -> * -> *). Traversing p => p a b -> p s t)
-> Lens s t [a] [b]
unsafePartsOf t :: forall (p :: * -> * -> *). Traversing p => p a b -> p s t
t = (s -> [a]) -> (s -> [b] -> t) -> Lens s t [a] [b]
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens s -> [a]
getter s -> [b] -> t
setter'
  where
    getter :: s -> [a]
    getter :: s -> [a]
getter = Optic (Forget [a]) s t a b -> s -> [a]
forall a s t b. Optic (Forget [a]) s t a b -> s -> [a]
toListOf Optic (Forget [a]) s t a b
forall (p :: * -> * -> *). Traversing p => p a b -> p s t
t
    setter' :: s -> [b] -> t
    setter' :: s -> [b] -> t
setter' s :: s
s bs :: [b]
bs = (State [b] t -> [b] -> t) -> [b] -> State [b] t -> t
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [b] t -> [b] -> t
forall s a. State s a -> s -> a
evalState [b]
bs (State [b] t -> t) -> State [b] t -> t
forall a b. (a -> b) -> a -> b
$ Optic (Star (StateT [b] Identity)) s t a b
-> (a -> StateT [b] Identity b) -> s -> State [b] t
forall (f :: * -> *) s t a b.
Optic (Star f) s t a b -> (a -> f b) -> s -> f t
traverseOf Optic (Star (StateT [b] Identity)) s t a b
forall (p :: * -> * -> *). Traversing p => p a b -> p s t
t a -> StateT [b] Identity b
forall x. x -> StateT [b] Identity b
insert s
s
    insert :: x -> State [b] b
    insert :: x -> StateT [b] Identity b
insert _ = ([b] -> b) -> StateT [b] Identity b
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets [b] -> b
forall a. [a] -> a
head StateT [b] Identity b
-> StateT [b] Identity () -> StateT [b] Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ([b] -> [b]) -> StateT [b] Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify [b] -> [b]
forall a. [a] -> [a]
tail

partsOf :: forall s a. (forall p. Traversing p => p a a -> p s s) -> Lens' s [a]
partsOf :: (forall (p :: * -> * -> *). Traversing p => p a a -> p s s)
-> Lens' s [a]
partsOf t :: forall (p :: * -> * -> *). Traversing p => p a a -> p s s
t = (s -> [a]) -> (s -> [a] -> s) -> Lens' s [a]
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens s -> [a]
getter s -> [a] -> s
setter'
  where
    getter :: s -> [a]
    getter :: s -> [a]
getter = Optic (Forget [a]) s s a a -> s -> [a]
forall a s t b. Optic (Forget [a]) s t a b -> s -> [a]
toListOf Optic (Forget [a]) s s a a
forall (p :: * -> * -> *). Traversing p => p a a -> p s s
t
    setter' :: s -> [a] -> s
    setter' :: s -> [a] -> s
setter' s :: s
s as :: [a]
as =
        Setter s s [a] [a] -> s -> [a] -> s
forall s t a b. Setter s t a b -> s -> b -> t
set ((forall (p :: * -> * -> *). Traversing p => p a a -> p s s)
-> Lens' s [a]
forall s t a b.
(forall (p :: * -> * -> *). Traversing p => p a b -> p s t)
-> Lens s t [a] [b]
unsafePartsOf forall (p :: * -> * -> *). Traversing p => p a a -> p s s
t) s
s (ZipList a -> [a]
forall a. ZipList a -> [a]
getZipList ([a] -> ZipList a
forall a. [a] -> ZipList a
ZipList [a]
as ZipList a -> ZipList a -> ZipList a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> ZipList a
forall a. [a] -> ZipList a
ZipList (s -> [a]
getter s
s)))

taking :: forall q s a. Traversing q => Int -> (forall p. Traversing p => p a a -> p s s) -> Optic' q s a
taking :: Int
-> (forall (p :: * -> * -> *). Traversing p => p a a -> p s s)
-> Optic' q s a
taking n :: Int
n t :: forall (p :: * -> * -> *). Traversing p => p a a -> p s s
t = (forall (p :: * -> * -> *). Traversing p => p a a -> p s s)
-> Lens' s [a]
forall s a.
(forall (p :: * -> * -> *). Traversing p => p a a -> p s s)
-> Lens' s [a]
partsOf forall (p :: * -> * -> *). Traversing p => p a a -> p s s
t (q [a] [a] -> q s s) -> (q a a -> q [a] [a]) -> Optic' q s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *). Applicative f => (a -> f a) -> [a] -> f [a])
-> q a a -> q [a] [a]
forall (p :: * -> * -> *) a b s t.
Traversing p =>
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander forall (f :: * -> *). Applicative f => (a -> f a) -> [a] -> f [a]
forall (f :: * -> *) x. Applicative f => (x -> f x) -> [x] -> f [x]
go
  where
    go :: forall f x. Applicative f => (x -> f x) -> [x] -> f [x]
    go :: (x -> f x) -> [x] -> f [x]
go handler :: x -> f x
handler as :: [x]
as =
      case Int -> [x] -> ([x], [x])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [x]
as of
        (prefix :: [x]
prefix, suffix :: [x]
suffix) -> ([x] -> [x] -> [x]) -> f [x] -> f [x] -> f [x]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 [x] -> [x] -> [x]
forall a. Semigroup a => a -> a -> a
(<>) ((x -> f x) -> [x] -> f [x]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse x -> f x
handler [x]
prefix) ([x] -> f [x]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [x]
suffix)

dropping :: forall s a. Int -> Traversal' s a -> Traversal' s a
dropping :: Int -> Traversal' s a -> Traversal' s a
dropping n :: Int
n t :: Traversal' s a
t = Traversal' s a -> Lens' s [a]
forall s a.
(forall (p :: * -> * -> *). Traversing p => p a a -> p s s)
-> Lens' s [a]
partsOf Traversal' s a
t (p [a] [a] -> p s s) -> (p a a -> p [a] [a]) -> p a a -> p s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *). Applicative f => (a -> f a) -> [a] -> f [a])
-> p a a -> p [a] [a]
forall (p :: * -> * -> *) a b s t.
Traversing p =>
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander forall (f :: * -> *). Applicative f => (a -> f a) -> [a] -> f [a]
go
  where
    go :: Applicative f => (a -> f a) -> [a] -> f [a]
    go :: (a -> f a) -> [a] -> f [a]
go handler :: a -> f a
handler as :: [a]
as =
      case Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
as of
        (prefix :: [a]
prefix, suffix :: [a]
suffix) -> ([a] -> [a] -> [a]) -> f [a] -> f [a] -> f [a]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
(<>) ([a] -> f [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
prefix) ((a -> f a) -> [a] -> f [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f a
handler [a]
suffix)


-- failing :: (forall p. Traversing p => p a b -> p s t) -> (forall p. Traversing p => p a b -> p s t) -> (Traversing p => p a b -> p s t)
-- failing f _ pab = undefined $ foldMapOf f (const (Sum 1))
    -- _ $ traverse' @_ @[] p

-- both
-- failing ()