module Data.Profunctor.Expansive where

import Data.Profunctor
import Control.Applicative
import Data.Foldable
import Data.Tagged
import Data.Profunctor.Cayley

-- Per Reed Mullanix this is "monadicity".
-- We induce a monoid in the structure of the profunctor to collaps our argument.
-- Apparently roughly a T-algebra over some category.
class Expansive p where
  expand :: Foldable f => p a b -> p (f a) b

instance Alternative f => Expansive (Star f) where
  expand :: Star f a b -> Star f (f a) b
expand (Star f :: a -> f b
f) = (f a -> f b) -> Star f (f a) b
forall (f :: * -> *) d c. (d -> f c) -> Star f d c
Star ([f b] -> f b
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([f b] -> f b) -> (f a -> [f b]) -> f a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> [a] -> [f b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> f b
f ([a] -> [f b]) -> (f a -> [a]) -> f a -> [f b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)

instance Monoid r => Expansive (Forget r) where
  expand :: Forget r a b -> Forget r (f a) b
expand (Forget f :: a -> r
f) = (f a -> r) -> Forget r (f a) b
forall r a b. (a -> r) -> Forget r a b
Forget ((a -> r) -> f a -> r
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> r
f)

instance Expansive Tagged where
  expand :: Tagged a b -> Tagged (f a) b
expand (Tagged b :: b
b) = b -> Tagged (f a) b
forall k (s :: k) b. b -> Tagged s b
Tagged b
b

instance (Functor f, Expansive p) => Expansive (Cayley f p) where
  expand :: Cayley f p a b -> Cayley f p (f a) b
expand (Cayley pfab :: f (p a b)
pfab) = f (p (f a) b) -> Cayley f p (f a) b
forall (f :: * -> *) (p :: * -> * -> *) a b.
f (p a b) -> Cayley f p a b
Cayley ((p a b -> p (f a) b) -> f (p a b) -> f (p (f a) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap p a b -> p (f a) b
forall (p :: * -> * -> *) (f :: * -> *) a b.
(Expansive p, Foldable f) =>
p a b -> p (f a) b
expand f (p a b)
pfab)