{-# LANGUAGE InstanceSigs #-}
module Data.Profunctor.DoubleStar where

import Data.Profunctor
import Data.Profunctor.Traversing
import Data.Profunctor.MStrong
import Data.Distributive

data DoubleStar f g a b = DoubleStar (f a -> g b)

instance (Functor f, Functor g) => Profunctor (DoubleStar f g) where
  dimap :: (a -> b) -> (c -> d) -> DoubleStar f g b c -> DoubleStar f g a d
dimap l :: a -> b
l r :: c -> d
r (DoubleStar p :: f b -> g c
p) = (f a -> g d) -> DoubleStar f g a d
forall (f :: * -> *) (g :: * -> *) a b.
(f a -> g b) -> DoubleStar f g a b
DoubleStar ((f a -> f b) -> (g c -> g d) -> (f b -> g c) -> f a -> g d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
l) ((c -> d) -> g c -> g d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
r) f b -> g c
p)

instance (Traversable f, Distributive g) => MStrong (DoubleStar f g) where
  msecond' :: forall m a b. Monoid m => DoubleStar f g a b -> DoubleStar f g (m, a) (m, b)
  msecond' :: DoubleStar f g a b -> DoubleStar f g (m, a) (m, b)
msecond' (DoubleStar p :: f a -> g b
p) = (f (m, a) -> g (m, b)) -> DoubleStar f g (m, a) (m, b)
forall (f :: * -> *) (g :: * -> *) a b.
(f a -> g b) -> DoubleStar f g a b
DoubleStar ((f a -> g b) -> f (m, a) -> g (m, b)
go f a -> g b
p)
    where
      go :: (f a -> g b) -> f (m, a) -> g (m, b)
      go :: (f a -> g b) -> f (m, a) -> g (m, b)
go f :: f a -> g b
f fam :: f (m, a)
fam = (m, g b) -> g (m, b)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive g, Functor f) =>
f (g a) -> g (f a)
distribute ((m, g b) -> g (m, b))
-> (f (m, a) -> (m, g b)) -> f (m, a) -> g (m, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a -> g b) -> (m, f a) -> (m, g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> g b
f ((m, f a) -> (m, g b))
-> (f (m, a) -> (m, f a)) -> f (m, a) -> (m, g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (m, a) -> (m, f a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (f (m, a) -> g (m, b)) -> f (m, a) -> g (m, b)
forall a b. (a -> b) -> a -> b
$ f (m, a)
fam


instance (Traversable f, Distributive g) => Choice (DoubleStar f g) where
  right' :: forall c a b. DoubleStar f g a b -> DoubleStar f g (Either c a) (Either c b)
  right' :: DoubleStar f g a b -> DoubleStar f g (Either c a) (Either c b)
right' (DoubleStar p :: f a -> g b
p) = (f (Either c a) -> g (Either c b))
-> DoubleStar f g (Either c a) (Either c b)
forall (f :: * -> *) (g :: * -> *) a b.
(f a -> g b) -> DoubleStar f g a b
DoubleStar f (Either c a) -> g (Either c b)
go
    where
      go :: f (Either c a) -> g (Either c b)
      go :: f (Either c a) -> g (Either c b)
go = Either c (g b) -> g (Either c b)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive g, Functor f) =>
f (g a) -> g (f a)
distribute (Either c (g b) -> g (Either c b))
-> (f (Either c a) -> Either c (g b))
-> f (Either c a)
-> g (Either c b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a -> g b) -> Either c (f a) -> Either c (g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> g b
p (Either c (f a) -> Either c (g b))
-> (f (Either c a) -> Either c (f a))
-> f (Either c a)
-> Either c (g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Either c a) -> Either c (f a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA

-- instance (Functor f, Applicative g) => Traversing (DoubleStar f g) where
--   -- traverse' :: Traversable t => p a b -> p (t a) (t b)
--   -- traverse' (DoubleStar p) = DoubleStar (traverse m)
--   wander :: forall s t a b h. Applicative h =>( (a -> h b) -> s -> h t) -> DoubleStar f g a b -> DoubleStar f g s t
--   wander f (DoubleStar p) = DoubleStar go
--     where
--       go :: f s -> g t
--       go fs = _ . fmap (f _p') $ fs