{-# LANGUAGE InstanceSigs #-}
module Proton.Coalgebraic where

import Proton.Types
import Data.Profunctor
import Proton.Prisms
import Proton.Review

type Coalgebraic s t a b = forall p. MChoice p => Optic p s t a b
type Coalgebraic' s a = Coalgebraic s s a a

swapEither :: Either a b -> Either b a
swapEither :: Either a b -> Either b a
swapEither (Left a :: a
a) = a -> Either b a
forall a b. b -> Either a b
Right a
a
swapEither (Right a :: b
a) = b -> Either b a
forall a b. a -> Either a b
Left b
a

class Profunctor p => MChoice p where
  mleft' :: p a b -> p (Either a m) (Either b m)
  mleft' = (Either a m -> Either m a)
-> (Either m b -> Either b m)
-> p (Either m a) (Either m b)
-> p (Either a m) (Either b m)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap Either a m -> Either m a
forall a b. Either a b -> Either b a
swapEither Either m b -> Either b m
forall a b. Either a b -> Either b a
swapEither (p (Either m a) (Either m b) -> p (Either a m) (Either b m))
-> (p a b -> p (Either m a) (Either m b))
-> p a b
-> p (Either a m) (Either b m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (Either m a) (Either m b)
forall (p :: * -> * -> *) a b m.
MChoice p =>
p a b -> p (Either m a) (Either m b)
mright'
  mright' :: p a b -> p (Either m a) (Either m b)
  mright' = (Either m a -> Either a m)
-> (Either b m -> Either m b)
-> p (Either a m) (Either b m)
-> p (Either m a) (Either m b)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap Either m a -> Either a m
forall a b. Either a b -> Either b a
swapEither Either b m -> Either m b
forall a b. Either a b -> Either b a
swapEither (p (Either a m) (Either b m) -> p (Either m a) (Either m b))
-> (p a b -> p (Either a m) (Either b m))
-> p a b
-> p (Either m a) (Either m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (Either a m) (Either b m)
forall (p :: * -> * -> *) a b m.
MChoice p =>
p a b -> p (Either a m) (Either b m)
mleft'

instance MChoice (->) where
  mright' :: (a -> b) -> Either m a -> Either m b
mright' = (a -> b) -> Either m a -> Either m b
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'

instance Applicative f => MChoice (Star f) where
  mright' :: Star f a b -> Star f (Either m a) (Either m b)
mright' = Star f a b -> Star f (Either m a) (Either m b)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'

instance (Monoid r) => MChoice (Forget r) where
  mright' :: Forget r a b -> Forget r (Either m a) (Either m b)
mright' = Forget r a b -> Forget r (Either m a) (Either m b)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'

instance Traversable f => MChoice (Costar f) where
  mright' :: forall a b m. Costar f a b -> Costar f (Either m a) (Either m b)
  mright' :: Costar f a b -> Costar f (Either m a) (Either m b)
mright' (Costar f :: f a -> b
f) = ((f (Either m a) -> Either m b)
-> Costar f (Either m a) (Either m b)
forall (f :: * -> *) d c. (f d -> c) -> Costar f d c
Costar ((f a -> b) -> Either m (f a) -> Either m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> b
f (Either m (f a) -> Either m b)
-> (f (Either m a) -> Either m (f a))
-> f (Either m a)
-> Either m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Either m a) -> Either m (f a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA))

coprism :: (b -> t) -> (s -> Either t a) -> Coalgebraic s t a b
coprism :: (b -> t) -> (s -> Either t a) -> Coalgebraic s t a b
coprism rev :: b -> t
rev split :: s -> Either t a
split = (s -> Either t a)
-> (Either t b -> t) -> p (Either t a) (Either t b) -> p s t
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t a
split ((t -> t) -> (b -> t) -> Either t b -> t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> t
forall a. a -> a
id b -> t
rev) (p (Either t a) (Either t b) -> p s t)
-> (p a b -> p (Either t a) (Either t b)) -> p a b -> p s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (Either t a) (Either t b)
forall (p :: * -> * -> *) a b m.
MChoice p =>
p a b -> p (Either m a) (Either m b)
mright'

coalgPrism :: Prism s t a b -> Coalgebraic s t a b
coalgPrism :: Prism s t a b -> Coalgebraic s t a b
coalgPrism pr :: Prism s t a b
pr = (b -> t) -> (s -> Either t a) -> Coalgebraic s t a b
forall b t s a.
(b -> t) -> (s -> Either t a) -> Coalgebraic s t a b
coprism ((Tagged a b -> Tagged s t) -> b -> t
forall k1 k2 (a :: k1) b (s :: k2) t.
(Tagged a b -> Tagged s t) -> b -> t
review Tagged a b -> Tagged s t
Prism s t a b
pr) (Prism s t a b -> s -> Either t a
forall s t a b. Prism s t a b -> s -> Either t a
matching Prism s t a b
pr)

_Just' :: Coalgebraic (Maybe a) (Maybe b) a b
_Just' :: Optic p (Maybe a) (Maybe b) a b
_Just' = Prism (Maybe a) (Maybe b) a b
-> Coalgebraic (Maybe a) (Maybe b) a b
forall s t a b. Prism s t a b -> Coalgebraic s t a b
coalgPrism forall a b. Prism (Maybe a) (Maybe b) a b
Prism (Maybe a) (Maybe b) a b
_Just

_Right' :: Coalgebraic (Either e a) (Either e b) a b
_Right' :: Optic p (Either e a) (Either e b) a b
_Right' = Prism (Either e a) (Either e b) a b
-> Coalgebraic (Either e a) (Either e b) a b
forall s t a b. Prism s t a b -> Coalgebraic s t a b
coalgPrism forall a b b'. Prism (Either a b) (Either a b') b b'
Prism (Either e a) (Either e b) a b
_Right