{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
module Control.Arrow.Profunctor where

import Data.Profunctor
import qualified Data.Profunctor.Arrow as PA
import qualified Control.Arrow as Arr
import qualified Control.Category as C
import Data.Coerce
import Data.Bifunctor

newtype WrappedProfunctor p a b = WrappedProfunctor {WrappedProfunctor p a b -> p a b
unwrapProfunctor :: p a b}
  deriving newtype WrappedProfunctor p a a
WrappedProfunctor p b c
-> WrappedProfunctor p a b -> WrappedProfunctor p a c
(forall a. WrappedProfunctor p a a)
-> (forall b c a.
    WrappedProfunctor p b c
    -> WrappedProfunctor p a b -> WrappedProfunctor p a c)
-> Category (WrappedProfunctor p)
forall a. WrappedProfunctor p a a
forall b c a.
WrappedProfunctor p b c
-> WrappedProfunctor p a b -> WrappedProfunctor p a c
forall k (cat :: k -> k -> *).
(forall (a :: k). cat a a)
-> (forall (b :: k) (c :: k) (a :: k).
    cat b c -> cat a b -> cat a c)
-> Category cat
forall (p :: * -> * -> *) a. Category p => WrappedProfunctor p a a
forall (p :: * -> * -> *) b c a.
Category p =>
WrappedProfunctor p b c
-> WrappedProfunctor p a b -> WrappedProfunctor p a c
. :: WrappedProfunctor p b c
-> WrappedProfunctor p a b -> WrappedProfunctor p a c
$c. :: forall (p :: * -> * -> *) b c a.
Category p =>
WrappedProfunctor p b c
-> WrappedProfunctor p a b -> WrappedProfunctor p a c
id :: WrappedProfunctor p a a
$cid :: forall (p :: * -> * -> *) a. Category p => WrappedProfunctor p a a
C.Category

instance (Profunctor p, C.Category p, Strong p) => Arr.Arrow (WrappedProfunctor p) where
  arr :: (b -> c) -> WrappedProfunctor p b c
arr = p b c -> WrappedProfunctor p b c
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (p b c -> WrappedProfunctor p b c)
-> ((b -> c) -> p b c) -> (b -> c) -> WrappedProfunctor p b c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> c) -> p b c
forall (p :: * -> * -> *) a b.
(Profunctor p, Category p) =>
(a -> b) -> p a b
PA.arr
  first :: WrappedProfunctor p b c -> WrappedProfunctor p (b, d) (c, d)
first (WrappedProfunctor p :: p b c
p) = p (b, d) (c, d) -> WrappedProfunctor p (b, d) (c, d)
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (p b c -> p (b, d) (c, d)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (a, c) (b, c)
first' p b c
p)
  second :: WrappedProfunctor p b c -> WrappedProfunctor p (d, b) (d, c)
second (WrappedProfunctor p :: p b c
p) = p (d, b) (d, c) -> WrappedProfunctor p (d, b) (d, c)
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (p b c -> p (d, b) (d, c)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (c, a) (c, b)
second' p b c
p)
  WrappedProfunctor l :: p b c
l *** :: WrappedProfunctor p b c
-> WrappedProfunctor p b' c' -> WrappedProfunctor p (b, b') (c, c')
*** WrappedProfunctor r :: p b' c'
r = p (b, b') (c, c') -> WrappedProfunctor p (b, b') (c, c')
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (p b c
l p b c -> p b' c' -> p (b, b') (c, c')
forall (p :: * -> * -> *) b c b' c'.
(Category p, Strong p) =>
p b c -> p b' c' -> p (b, b') (c, c')
PA.*** p b' c'
r)
  WrappedProfunctor l :: p b c
l &&& :: WrappedProfunctor p b c
-> WrappedProfunctor p b c' -> WrappedProfunctor p b (c, c')
&&& WrappedProfunctor r :: p b c'
r = p b (c, c') -> WrappedProfunctor p b (c, c')
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (p b c
l p b c -> p b c' -> p b (c, c')
forall (p :: * -> * -> *) b c c'.
(Category p, Strong p) =>
p b c -> p b c' -> p b (c, c')
PA.&&& p b c'
r)

instance (PA.ProfunctorZero p, C.Category p, Strong p) => Arr.ArrowZero (WrappedProfunctor p) where
  zeroArrow :: WrappedProfunctor p b c
zeroArrow = p b c -> WrappedProfunctor p b c
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor p b c
forall (p :: * -> * -> *) a b. ProfunctorZero p => p a b
PA.zeroProfunctor

instance (PA.ProfunctorPlus p, C.Category p, Strong p) => Arr.ArrowPlus (WrappedProfunctor p) where
  WrappedProfunctor l :: p b c
l <+> :: WrappedProfunctor p b c
-> WrappedProfunctor p b c -> WrappedProfunctor p b c
<+> WrappedProfunctor r :: p b c
r = p b c -> WrappedProfunctor p b c
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (p b c
l p b c -> p b c -> p b c
forall (p :: * -> * -> *) a b.
ProfunctorPlus p =>
p a b -> p a b -> p a b
PA.<+> p b c
r)

instance (Choice p, C.Category p, Strong p) => Arr.ArrowChoice (WrappedProfunctor p) where
  left :: WrappedProfunctor p b c
-> WrappedProfunctor p (Either b d) (Either c d)
left (WrappedProfunctor l :: p b c
l) = p (Either b d) (Either c d)
-> WrappedProfunctor p (Either b d) (Either c d)
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (p b c -> p (Either b d) (Either c d)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either a c) (Either b c)
left' p b c
l)
  right :: WrappedProfunctor p b c
-> WrappedProfunctor p (Either d b) (Either d c)
right (WrappedProfunctor l :: p b c
l) = p (Either d b) (Either d c)
-> WrappedProfunctor p (Either d b) (Either d c)
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (p b c -> p (Either d b) (Either d c)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right' p b c
l)
  WrappedProfunctor l :: p b c
l +++ :: WrappedProfunctor p b c
-> WrappedProfunctor p b' c'
-> WrappedProfunctor p (Either b b') (Either c c')
+++ WrappedProfunctor r :: p b' c'
r = p (Either b b') (Either c c')
-> WrappedProfunctor p (Either b b') (Either c c')
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (p b c
l p b c -> p b' c' -> p (Either b b') (Either c c')
forall (p :: * -> * -> *) b c b' c'.
(Choice p, Category p) =>
p b c -> p b' c' -> p (Either b b') (Either c c')
PA.+++ p b' c'
r)
  WrappedProfunctor l :: p b d
l ||| :: WrappedProfunctor p b d
-> WrappedProfunctor p c d -> WrappedProfunctor p (Either b c) d
||| WrappedProfunctor r :: p c d
r = p (Either b c) d -> WrappedProfunctor p (Either b c) d
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (p b d
l p b d -> p c d -> p (Either b c) d
forall (p :: * -> * -> *) b d c.
(Choice p, Category p) =>
p b d -> p c d -> p (Either b c) d
PA.||| p c d
r)

instance (C.Category p, Strong p, PA.ProfunctorApply p) => Arr.ArrowApply (WrappedProfunctor p) where
  app :: WrappedProfunctor p (WrappedProfunctor p b c, b) c
app  = p (WrappedProfunctor p b c, b) c
-> WrappedProfunctor p (WrappedProfunctor p b c, b) c
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (((WrappedProfunctor p b c, b) -> (p b c, b))
-> p (p b c, b) c -> p (WrappedProfunctor p b c, b) c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap ((WrappedProfunctor p b c -> p b c)
-> (WrappedProfunctor p b c, b) -> (p b c, b)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first WrappedProfunctor p b c -> p b c
forall a b. Coercible a b => a -> b
coerce) p (p b c, b) c
forall (p :: * -> * -> *) a b. ProfunctorApply p => p (p a b, a) b
PA.app)

instance (C.Category p, Strong p, Costrong p) => Arr.ArrowLoop (WrappedProfunctor p) where
  loop :: WrappedProfunctor p (b, d) (c, d) -> WrappedProfunctor p b c
loop (WrappedProfunctor p :: p (b, d) (c, d)
p) = p b c -> WrappedProfunctor p b c
forall (p :: * -> * -> *) a b. p a b -> WrappedProfunctor p a b
WrappedProfunctor (p (b, d) (c, d) -> p b c
forall (p :: * -> * -> *) a d b.
Costrong p =>
p (a, d) (b, d) -> p a b
unfirst p (b, d) (c, d)
p)