{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DefaultSignatures #-}
module Data.Profunctor.Coindexed where

import Data.Profunctor
import Data.Void
import Control.Applicative
import Control.Monad
import Data.Tagged

class (Profunctor p, Profunctor q) => Coindexable e p q | q -> p where
    coindexed :: p a (Either e b) -> q a b
    default coindexed :: (e ~ Void, p ~ q) => p a (Either e b) -> q a b
    coindexed = (Either Void b -> b) -> q a (Either Void b) -> q a b
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap ((Void -> b) -> (b -> b) -> Either Void b -> b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Void -> b
forall a. Void -> a
absurd b -> b
forall a. a -> a
id)

data Coindexed e p a b = Coindexed {Coindexed e p a b -> p a (Either e b)
runCoindexed :: (p a (Either e b))}

instance Profunctor p => Profunctor (Coindexed e p) where
  dimap :: (a -> b) -> (c -> d) -> Coindexed e p b c -> Coindexed e p a d
dimap f :: a -> b
f g :: c -> d
g (Coindexed p :: p b (Either e c)
p) = p a (Either e d) -> Coindexed e p a d
forall e (p :: * -> * -> *) a b.
p a (Either e b) -> Coindexed e p a b
Coindexed ((a -> b)
-> (Either e c -> Either e d)
-> p b (Either e c)
-> p a (Either e 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) -> Either e c -> Either e d
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' c -> d
g) p b (Either e c)
p)

instance Choice p => Choice (Coindexed i p) where
  right' :: Coindexed i p a b -> Coindexed i p (Either c a) (Either c b)
right' (Coindexed p :: p a (Either i b)
p) = p (Either c a) (Either i (Either c b))
-> Coindexed i p (Either c a) (Either c b)
forall e (p :: * -> * -> *) a b.
p a (Either e b) -> Coindexed e p a b
Coindexed ((Either c a -> Either c a)
-> (Either c (Either i b) -> Either i (Either c b))
-> p (Either c a) (Either c (Either i b))
-> p (Either c a) (Either i (Either c b))
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap Either c a -> Either c a
forall a. a -> a
id Either c (Either i b) -> Either i (Either c b)
forall a a b. Either a (Either a b) -> Either a (Either a b)
reassoc (p (Either c a) (Either c (Either i b))
 -> p (Either c a) (Either i (Either c b)))
-> p (Either c a) (Either c (Either i b))
-> p (Either c a) (Either i (Either c b))
forall a b. (a -> b) -> a -> b
$ p a (Either i b) -> p (Either c a) (Either c (Either i b))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' p a (Either i b)
p)
    where
      reassoc :: Either a (Either a b) -> Either a (Either a b)
reassoc (Left c :: a
c) = Either a b -> Either a (Either a b)
forall a b. b -> Either a b
Right (a -> Either a b
forall a b. a -> Either a b
Left a
c)
      reassoc (Right (Left i :: a
i)) = a -> Either a (Either a b)
forall a b. a -> Either a b
Left a
i
      reassoc (Right (Right b :: b
b)) = Either a b -> Either a (Either a b)
forall a b. b -> Either a b
Right (b -> Either a b
forall a b. b -> Either a b
Right b
b)

instance Profunctor p => Coindexable i p (Coindexed i p) where
  coindexed :: p a (Either i b) -> Coindexed i p a b
coindexed p :: p a (Either i b)
p = p a (Either i b) -> Coindexed i p a b
forall e (p :: * -> * -> *) a b.
p a (Either e b) -> Coindexed e p a b
Coindexed p a (Either i b)
p

instance Coindexable e (Forget r) (Forget r) where
  coindexed :: Forget r a (Either e b) -> Forget r a b
coindexed (Forget f :: a -> r
f) = ((a -> r) -> Forget r a b
forall r a b. (a -> r) -> Forget r a b
Forget a -> r
f)

instance Coindexable Void (->) (->)

instance {-# OVERLAPPING #-} Functor f => Coindexable Void (Star f) (Star f) where
-- Could use selective applicative here instead.
instance (Alternative f, Monad f) => Coindexable e (Star f) (Star f) where
  coindexed :: Star f a (Either e b) -> Star f a b
coindexed (Star f :: a -> f (Either e b)
f) = (a -> f b) -> Star f a b
forall (f :: * -> *) d c. (d -> f c) -> Star f d c
Star ((a -> f b) -> Star f a b) -> (a -> f b) -> Star f a b
forall a b. (a -> b) -> a -> b
$ a -> f (Either e b)
f (a -> f (Either e b)) -> (Either e b -> f b) -> a -> f b
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (e -> f b) -> (b -> f b) -> Either e b -> f b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (f b -> e -> f b
forall a b. a -> b -> a
const f b
forall (f :: * -> *) a. Alternative f => f a
empty) b -> f b
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance Functor f => Coindexable Void (Costar f) (Costar f) where
instance Coindexable Void Tagged Tagged where