{-# LANGUAGE RankNTypes #-}
module Fresnel.Profunctor.Traversing1
( Traversing1(..)
  -- ** Profunctor from Traversing1
, dimapTraversing1
, lmapTraversing1
, rmapTraversing1
  -- ** Strong from Traversing1
, firstTraversing1
, secondTraversing1
) where

import Control.Arrow (Kleisli(..))
import Data.Functor.Apply
import Data.Functor.Const
import Data.Functor.Identity
import Data.Profunctor (Forget(..), Star(..), Strong)
import Data.Profunctor.Unsafe ((#.))
import Fresnel.Profunctor.OptionalStar (OptionalStar(..))

class Strong p => Traversing1 p where
  wander1 :: (forall f . Apply f => (a -> f b) -> (s -> f t)) -> (p a b -> p s t)

instance Traversing1 (->) where
  wander1 :: forall a b s t.
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> (a -> b) -> s -> t
wander1 forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f a -> b
g = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> (s -> Identity t) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity b) -> s -> Identity t
forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f (b -> Identity b
forall a. a -> Identity a
Identity (b -> Identity b) -> (a -> b) -> a -> Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
g)

instance Monad m => Traversing1 (Kleisli m) where
  wander1 :: forall a b s t.
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> Kleisli m a b -> Kleisli m s t
wander1 forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f (Kleisli a -> m b
k) = (s -> m t) -> Kleisli m s t
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (WrappedApplicative m t -> m t
forall (f :: * -> *) a. WrappedApplicative f a -> f a
unwrapApplicative (WrappedApplicative m t -> m t)
-> (s -> WrappedApplicative m t) -> s -> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> WrappedApplicative m b) -> s -> WrappedApplicative m t
forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f (m b -> WrappedApplicative m b
forall (f :: * -> *) a. f a -> WrappedApplicative f a
WrapApplicative (m b -> WrappedApplicative m b)
-> (a -> m b) -> a -> WrappedApplicative m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
k))

instance Semigroup r => Traversing1 (Forget r) where
  wander1 :: forall a b s t.
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> Forget r a b -> Forget r s t
wander1 forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f (Forget a -> r
k) = (s -> r) -> Forget r s t
forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget (Const r t -> r
forall {k} a (b :: k). Const a b -> a
getConst (Const r t -> r) -> (s -> Const r t) -> s -> r
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> (a -> b) -> a -> c
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. (a -> Const r b) -> s -> Const r t
forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f (r -> Const r b
forall {k} a (b :: k). a -> Const a b
Const (r -> Const r b) -> (a -> r) -> a -> Const r b
forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> (a -> b) -> a -> c
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> r
k))

instance Applicative f => Traversing1 (Star f) where
  wander1 :: forall a b s t.
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> Star f a b -> Star f s t
wander1 forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f (Star a -> f b
k) = (s -> f t) -> Star f s t
forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star (WrappedApplicative f t -> f t
forall (f :: * -> *) a. WrappedApplicative f a -> f a
unwrapApplicative (WrappedApplicative f t -> f t)
-> (s -> WrappedApplicative f t) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> WrappedApplicative f b) -> s -> WrappedApplicative f t
forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f (f b -> WrappedApplicative f b
forall (f :: * -> *) a. f a -> WrappedApplicative f a
WrapApplicative (f b -> WrappedApplicative f b)
-> (a -> f b) -> a -> WrappedApplicative f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
k))

instance Apply f => Traversing1 (OptionalStar f) where
  wander1 :: forall a b s t.
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> OptionalStar f a b -> OptionalStar f s t
wander1 forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f (OptionalStar forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r
k) = (forall r. ((forall x. x -> f x) -> (s -> f t) -> r) -> r)
-> OptionalStar f s t
forall (f :: * -> *) a b.
(forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r)
-> OptionalStar f a b
OptionalStar (\ (forall x. x -> f x) -> (s -> f t) -> r
k' -> ((forall x. x -> f x) -> (a -> f b) -> r) -> r
forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r
k (\ forall x. x -> f x
p -> (forall x. x -> f x) -> (s -> f t) -> r
k' x -> f x
forall x. x -> f x
p ((s -> f t) -> r) -> ((a -> f b) -> s -> f t) -> (a -> f b) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> s -> f t
forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f))


-- Profunctor from Traversing1

dimapTraversing1 :: Traversing1 p => (a' -> a) -> (b -> b') -> (p a b -> p a' b')
dimapTraversing1 :: forall (p :: * -> * -> *) a' a b b'.
Traversing1 p =>
(a' -> a) -> (b -> b') -> p a b -> p a' b'
dimapTraversing1 a' -> a
f b -> b'
g = (forall (f :: * -> *). Apply f => (a -> f b) -> a' -> f b')
-> p a b -> p a' b'
forall a b s t.
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> p a b -> p s t
forall (p :: * -> * -> *) a b s t.
Traversing1 p =>
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander1 (\ a -> f b
k -> (b -> b') -> f b -> f b'
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> b'
g (f b -> f b') -> (a' -> f b) -> a' -> f b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
k (a -> f b) -> (a' -> a) -> a' -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)

lmapTraversing1 :: Traversing1 p => (a' -> a) -> (p a b -> p a' b)
lmapTraversing1 :: forall (p :: * -> * -> *) a' a b.
Traversing1 p =>
(a' -> a) -> p a b -> p a' b
lmapTraversing1 a' -> a
f = (forall (f :: * -> *). Apply f => (a -> f b) -> a' -> f b)
-> p a b -> p a' b
forall a b s t.
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> p a b -> p s t
forall (p :: * -> * -> *) a b s t.
Traversing1 p =>
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander1 ((a -> f b) -> (a' -> a) -> a' -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)

rmapTraversing1 :: Traversing1 p => (b -> b') -> (p a b -> p a b')
rmapTraversing1 :: forall (p :: * -> * -> *) b b' a.
Traversing1 p =>
(b -> b') -> p a b -> p a b'
rmapTraversing1 b -> b'
f = (forall (f :: * -> *). Apply f => (a -> f b) -> a -> f b')
-> p a b -> p a b'
forall a b s t.
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> p a b -> p s t
forall (p :: * -> * -> *) a b s t.
Traversing1 p =>
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander1 ((b -> b') -> f b -> f b'
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> b'
f (f b -> f b') -> (a -> f b) -> a -> f b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)


-- Strong from Traversing1


firstTraversing1 :: Traversing1 p => p a b -> p (a, c) (b, c)
firstTraversing1 :: forall (p :: * -> * -> *) a b c.
Traversing1 p =>
p a b -> p (a, c) (b, c)
firstTraversing1 = (forall (f :: * -> *). Apply f => (a -> f b) -> (a, c) -> f (b, c))
-> p a b -> p (a, c) (b, c)
forall a b s t.
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> p a b -> p s t
forall (p :: * -> * -> *) a b s t.
Traversing1 p =>
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander1 (\ a -> f b
k (a
a, c
c) -> (b -> c -> (b, c)) -> c -> b -> (b, c)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) c
c (b -> (b, c)) -> f b -> f (b, c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
k a
a)

secondTraversing1 :: Traversing1 p => p a b -> p (c, a) (c, b)
secondTraversing1 :: forall (p :: * -> * -> *) a b c.
Traversing1 p =>
p a b -> p (c, a) (c, b)
secondTraversing1 = (forall (f :: * -> *). Apply f => (a -> f b) -> (c, a) -> f (c, b))
-> p a b -> p (c, a) (c, b)
forall a b s t.
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> p a b -> p s t
forall (p :: * -> * -> *) a b s t.
Traversing1 p =>
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander1 (\ a -> f b
k (c
c, a
a) -> (,) c
c (b -> (c, b)) -> f b -> f (c, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
k a
a)