{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
module Fresnel.Profunctor.OptionalStar
( -- * Optional star profunctors
  OptionalStar(..)
  -- * Construction
, optionalStar
  -- * Elimination
, runOptionalStar
  -- * Computation
, mapOptionalStar
) where

import Data.Coerce
import Data.Functor.Contravariant
import Data.Profunctor
import Data.Profunctor.Unsafe
import Fresnel.Bifunctor.Contravariant

-- Optional star profunctors

newtype OptionalStar f a b = OptionalStar { OptionalStar f a b
-> forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r
withOptionalStar :: forall r . ((forall x . x -> f x) -> (a -> f b) -> r) -> r }

instance Functor f => Profunctor (OptionalStar f) where
  dimap :: (a -> b) -> (c -> d) -> OptionalStar f b c -> OptionalStar f a d
dimap a -> b
f c -> d
g = ((b -> f c) -> a -> f d)
-> OptionalStar f b c -> OptionalStar f a d
forall a (f :: * -> *) b c d.
((a -> f b) -> c -> f d)
-> OptionalStar f a b -> OptionalStar f c d
mapOptionalStar ((a -> b) -> (f c -> f d) -> (b -> f c) -> a -> f d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap a -> b
f ((c -> d) -> f c -> f d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g))
  lmap :: (a -> b) -> OptionalStar f b c -> OptionalStar f a c
lmap a -> b
f = ((b -> f c) -> a -> f c)
-> OptionalStar f b c -> OptionalStar f a c
forall a (f :: * -> *) b c d.
((a -> f b) -> c -> f d)
-> OptionalStar f a b -> OptionalStar f c d
mapOptionalStar ((a -> b) -> (b -> f c) -> a -> f c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap a -> b
f)
  rmap :: (b -> c) -> OptionalStar f a b -> OptionalStar f a c
rmap b -> c
g = ((a -> f b) -> a -> f c)
-> OptionalStar f a b -> OptionalStar f a c
forall a (f :: * -> *) b c d.
((a -> f b) -> c -> f d)
-> OptionalStar f a b -> OptionalStar f c d
mapOptionalStar ((f b -> f c) -> (a -> f b) -> a -> f c
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap ((b -> c) -> f b -> f c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> c
g))
  .# :: OptionalStar f b c -> q a b -> OptionalStar f a c
(.#) = (OptionalStar f b c -> OptionalStar f a c)
-> (q a b -> OptionalStar f b c) -> q a b -> OptionalStar f a c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OptionalStar f b c -> OptionalStar f a c
coerce ((q a b -> OptionalStar f b c) -> q a b -> OptionalStar f a c)
-> (OptionalStar f b c -> q a b -> OptionalStar f b c)
-> OptionalStar f b c
-> q a b
-> OptionalStar f a c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptionalStar f b c -> q a b -> OptionalStar f b c
forall a b. a -> b -> a
const

instance Functor f => Choice (OptionalStar f) where
  left' :: OptionalStar f a b -> OptionalStar f (Either a c) (Either b c)
left'  (OptionalStar forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r
r) = (forall r.
 ((forall x. x -> f x) -> (Either a c -> f (Either b c)) -> r) -> r)
-> OptionalStar f (Either a c) (Either b c)
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) -> (Either a c -> f (Either b c)) -> r
k -> ((forall x. x -> f x) -> (a -> f b) -> r) -> r
forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r
r (\ forall x. x -> f x
point a -> f b
f -> (forall x. x -> f x) -> (Either a c -> f (Either b c)) -> r
k forall x. x -> f x
point ((a -> f (Either b c))
-> (c -> f (Either b c)) -> Either a c -> f (Either b c)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((b -> Either b c) -> f b -> f (Either b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either b c
forall a b. a -> Either a b
Left (f b -> f (Either b c)) -> (a -> f b) -> a -> f (Either b c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f) ((c -> Either b c) -> f c -> f (Either b c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> Either b c
forall a b. b -> Either a b
Right (f c -> f (Either b c)) -> (c -> f c) -> c -> f (Either b c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> f c
forall x. x -> f x
point))))
  right' :: OptionalStar f a b -> OptionalStar f (Either c a) (Either c b)
right' (OptionalStar forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r
r) = (forall r.
 ((forall x. x -> f x) -> (Either c a -> f (Either c b)) -> r) -> r)
-> OptionalStar f (Either c a) (Either c b)
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) -> (Either c a -> f (Either c b)) -> r
k -> ((forall x. x -> f x) -> (a -> f b) -> r) -> r
forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r
r (\ forall x. x -> f x
point a -> f b
f -> (forall x. x -> f x) -> (Either c a -> f (Either c b)) -> r
k forall x. x -> f x
point ((c -> f (Either c b))
-> (a -> f (Either c b)) -> Either c a -> f (Either c b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((c -> Either c b) -> f c -> f (Either c b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> Either c b
forall a b. a -> Either a b
Left (f c -> f (Either c b)) -> (c -> f c) -> c -> f (Either c b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> f c
forall x. x -> f x
point) ((b -> Either c b) -> f b -> f (Either c b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either c b
forall a b. b -> Either a b
Right (f b -> f (Either c b)) -> (a -> f b) -> a -> f (Either c b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f))))

instance Traversable f => Cochoice (OptionalStar f) where
  unright :: OptionalStar f (Either d a) (Either d b) -> OptionalStar f a b
unright OptionalStar f (Either d a) (Either d b)
r = OptionalStar f (Either d a) (Either d b)
-> forall r.
   ((forall x. x -> f x) -> (Either d a -> f (Either d b)) -> r) -> r
forall (f :: * -> *) a b.
OptionalStar f a b
-> forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r
withOptionalStar OptionalStar f (Either d a) (Either d b)
r (((forall x. x -> f x)
  -> (Either d a -> f (Either d b)) -> OptionalStar f a b)
 -> OptionalStar f a b)
-> ((forall x. x -> f x)
    -> (Either d a -> f (Either d b)) -> OptionalStar f a b)
-> OptionalStar f a b
forall a b. (a -> b) -> a -> b
$ \ forall x. x -> f x
point Either d a -> f (Either d b)
f -> let 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 :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (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)
f in (forall x. x -> f x) -> (a -> f b) -> OptionalStar f a b
forall (f :: * -> *) a b.
(forall x. x -> f x) -> (a -> f b) -> OptionalStar f a b
optionalStar forall x. x -> f x
point (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)

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

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


-- Construction

optionalStar :: (forall x . x -> f x) -> (a -> f b) -> OptionalStar f a b
optionalStar :: (forall x. x -> f x) -> (a -> f b) -> OptionalStar f a b
optionalStar forall x. x -> f x
point a -> f b
f = (forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r)
-> OptionalStar f a b
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) -> (a -> f b) -> r
k -> (forall x. x -> f x) -> (a -> f b) -> r
k forall x. x -> f x
point a -> f b
f)


-- Elimination

runOptionalStar :: OptionalStar f a b -> (a -> f b)
runOptionalStar :: OptionalStar f a b -> a -> f b
runOptionalStar OptionalStar f a b
a = OptionalStar f a b
-> ((forall x. x -> f x) -> (a -> f b) -> a -> f b) -> a -> f b
forall (f :: * -> *) a b.
OptionalStar f a b
-> forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r
withOptionalStar OptionalStar f a b
a (\ forall x. x -> f x
_ a -> f b
f -> a -> f b
f)


-- Computation

mapOptionalStar :: ((a -> f b) -> (c -> f d)) -> (OptionalStar f a b -> OptionalStar f c d)
mapOptionalStar :: ((a -> f b) -> c -> f d)
-> OptionalStar f a b -> OptionalStar f c d
mapOptionalStar (a -> f b) -> c -> f d
f (OptionalStar forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r
r) = (forall r. ((forall x. x -> f x) -> (c -> f d) -> r) -> r)
-> OptionalStar f c d
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) -> (c -> f d) -> r
k -> ((forall x. x -> f x) -> (a -> f b) -> r) -> r
forall r. ((forall x. x -> f x) -> (a -> f b) -> r) -> r
r (\ forall x. x -> f x
point -> (forall x. x -> f x) -> (c -> f d) -> r
k forall x. x -> f x
point ((c -> f d) -> r) -> ((a -> f b) -> c -> f d) -> (a -> f b) -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> c -> f d
f))