{-# LANGUAGE TupleSections #-}
module Fresnel.Profunctor.Star1
( -- * Star1 profunctor
  Star1(..)
) where

import Data.Functor.Apply
import Data.Functor.Contravariant (Contravariant(..))
import Data.Profunctor
import Fresnel.Bifunctor.Contravariant (Bicontravariant(..))
import Fresnel.Profunctor.Traversing1

-- | Just like 'Data.Profunctor.Star', but with some instances defined in terms of 'Data.Functor.Apply' instead of 'Applicative'. Used by 'Fresnel.Traversal1.Traversal1' & 'Fresnel.Fold1.Fold1'.
newtype Star1 f a b = Star1 { forall (f :: * -> *) a b. Star1 f a b -> a -> f b
runStar1 :: a -> f b }

instance Functor f => Profunctor (Star1 f) where
  dimap :: forall a b c d. (a -> b) -> (c -> d) -> Star1 f b c -> Star1 f a d
dimap a -> b
f c -> d
g (Star1 b -> f c
h) = (a -> f d) -> Star1 f a d
forall (f :: * -> *) a b. (a -> f b) -> Star1 f a b
Star1 ((c -> d) -> f c -> f d
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g (f c -> f d) -> (a -> f c) -> a -> f d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> f c
h (b -> f c) -> (a -> b) -> a -> f c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Functor f => Strong (Star1 f) where
  first' :: forall a b c. Star1 f a b -> Star1 f (a, c) (b, c)
first'  (Star1 a -> f b
h) = ((a, c) -> f (b, c)) -> Star1 f (a, c) (b, c)
forall (f :: * -> *) a b. (a -> f b) -> Star1 f a b
Star1 (\ (a
a, c
c) -> (,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
h a
a)
  second' :: forall a b c. Star1 f a b -> Star1 f (c, a) (c, b)
second' (Star1 a -> f b
h) = ((c, a) -> f (c, b)) -> Star1 f (c, a) (c, b)
forall (f :: * -> *) a b. (a -> f b) -> Star1 f a b
Star1 (\ (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
h a
a)

instance Traversable f => Cochoice (Star1 f) where
  unright :: forall d a b. Star1 f (Either d a) (Either d b) -> Star1 f a b
unright (Star1 Either d a -> f (Either d b)
h) = (a -> f b) -> Star1 f a b
forall (f :: * -> *) a b. (a -> f b) -> Star1 f a b
Star1 (Either d a -> f b
go (Either d a -> f b) -> (a -> Either d a) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either d a
forall a b. b -> Either a b
Right)
    where
    go :: Either d a -> f b
go = (d -> f b) -> (f b -> f b) -> Either d (f b) -> f b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either d a -> f b
go (Either d a -> f b) -> (d -> Either d a) -> d -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Either d a
forall a b. a -> Either a b
Left) f b -> f b
forall a. a -> a
id (Either d (f b) -> f b)
-> (Either d a -> Either d (f b)) -> Either d a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Either d b) -> Either d (f b)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => f (m a) -> m (f a)
sequence (f (Either d b) -> Either d (f b))
-> (Either d a -> f (Either d b)) -> Either d a -> Either d (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either d a -> f (Either d b)
h

instance Apply f => Traversing1 (Star1 f) where
  wander1 :: forall a b s t.
(forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t)
-> Star1 f a b -> Star1 f s t
wander1 forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f (Star1 a -> f b
h) = (s -> f t) -> Star1 f s t
forall (f :: * -> *) a b. (a -> f b) -> Star1 f a b
Star1 ((a -> f b) -> s -> f t
forall (f :: * -> *). Apply f => (a -> f b) -> s -> f t
f a -> f b
h)

instance Contravariant f => Bicontravariant (Star1 f) where
  contrabimap :: forall a' a b' b.
(a' -> a) -> (b' -> b) -> Star1 f a b -> Star1 f a' b'
contrabimap a' -> a
f b' -> b
g (Star1 a -> f b
h) = (a' -> f b') -> Star1 f a' b'
forall (f :: * -> *) a b. (a -> f b) -> Star1 f a b
Star1 ((b' -> b) -> f b -> f b'
forall a' a. (a' -> a) -> f a -> f a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap 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
h (a -> f b) -> (a' -> a) -> a' -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)