{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE DerivingVia #-}

-- | This module provides some missing classes from profunctors
--
-- BEWARE: That part of Kernmantle API is experimental and is likely to change
-- in the future.

module Data.Profunctor.EffFunctor where

import qualified Control.Applicative as App
import Control.Arrow hiding (first, second)
import Control.Category
import Data.Biapplicative (Biapplicative)
import Data.Bifunctor
import Data.Bifunctor.Functor
import Data.Bifunctor.Tannen
import Data.Profunctor hiding ((:->))
import Data.Profunctor.Cayley
import qualified Data.Profunctor as Pro

import Control.Kernmantle.Error

import Prelude hiding (id, (.))


-- | Functors over binary effects
type EffFunctor = BifunctorFunctor

-- | Maps the effect inside an 'EffFunctor'. Various names to follow the
-- @bifunctors@/@profunctors@ conventions.
effmap, effrmap, effsecond :: (EffFunctor f) => (eff :-> eff') -> f eff :-> f eff'
effmap :: (eff :-> eff') -> f eff :-> f eff'
effmap = (eff :-> eff') -> f eff a b -> f eff' a b
forall k k1 k2 k3 (t :: (k -> k1 -> *) -> k2 -> k3 -> *)
       (p :: k -> k1 -> *) (q :: k -> k1 -> *).
BifunctorFunctor t =>
(p :-> q) -> t p :-> t q
bifmap
effrmap :: (eff :-> eff') -> f eff :-> f eff'
effrmap = (eff :-> eff') -> f eff a b -> f eff' a b
forall k k1 k2 k3 (t :: (k -> k1 -> *) -> k2 -> k3 -> *)
       (p :: k -> k1 -> *) (q :: k -> k1 -> *).
BifunctorFunctor t =>
(p :-> q) -> t p :-> t q
bifmap
effsecond :: (eff :-> eff') -> f eff :-> f eff'
effsecond = (eff :-> eff') -> f eff a b -> f eff' a b
forall k k1 k2 k3 (t :: (k -> k1 -> *) -> k2 -> k3 -> *)
       (p :: k -> k1 -> *) (q :: k -> k1 -> *).
BifunctorFunctor t =>
(p :-> q) -> t p :-> t q
bifmap

-- | Pointed Functors (= functors equipped with 'pure') over binary
-- effects. Doesn't have an equivalent afaik in @bifunctors@.
class (EffFunctor f) => EffPointedFunctor f where
  effpure :: eff :-> f eff

instance (Applicative f) => EffPointedFunctor (Tannen f) where
  effpure :: eff a b -> Tannen f eff a b
effpure = f (eff a b) -> Tannen f eff a b
forall k k1 k2 (f :: k -> *) (p :: k1 -> k2 -> k) (a :: k1)
       (b :: k2).
f (p a b) -> Tannen f p a b
Tannen (f (eff a b) -> Tannen f eff a b)
-> (eff a b -> f (eff a b)) -> eff a b -> Tannen f eff a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. eff a b -> f (eff a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE effpure #-}

-- | Would be a "@BifunctorBifunctor@", but that class doesn't exist
class (forall a. (Arrow a) => (EffFunctor (p a))) => EffBifunctor p where
  effbimap :: (Arrow a) => (a :-> a') -> (b :-> b') -> p a b :-> p a' b'
  effbimap a :-> a'
f b :-> b'
g = (a :-> a') -> p a b' :-> p a' b'
forall (p :: (* -> * -> *) -> (* -> * -> *) -> * -> * -> *)
       (a :: * -> * -> *) (a' :: * -> * -> *) (b :: * -> * -> *).
(EffBifunctor p, Arrow a) =>
(a :-> a') -> p a b :-> p a' b
efffirst a :-> a'
f (p a b' a b -> p a' b' a b)
-> (p a b a b -> p a b' a b) -> p a b a b -> p a' b' a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (b :-> b') -> p a b :-> p a b'
forall (f :: (* -> * -> *) -> * -> * -> *) (eff :: * -> * -> *)
       (eff' :: * -> * -> *).
EffFunctor f =>
(eff :-> eff') -> f eff :-> f eff'
effsecond b :-> b'
g

  efffirst :: (Arrow a) => (a :-> a') -> p a b :-> p a' b
  efffirst a :-> a'
f = (a :-> a') -> (b :-> b) -> p a b :-> p a' b
forall (p :: (* -> * -> *) -> (* -> * -> *) -> * -> * -> *)
       (a :: * -> * -> *) (a' :: * -> * -> *) (b :: * -> * -> *)
       (b' :: * -> * -> *).
(EffBifunctor p, Arrow a) =>
(a :-> a') -> (b :-> b') -> p a b :-> p a' b'
effbimap a :-> a'
f b :-> b
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

-- | Would be a "@ProfunctorBifunctor@", but that class doesn't exist.
class (forall a. (EffFunctor (p a))) => EffProfunctor p where
  effdimap :: (a' :-> a) -> (b :-> b') -> p a b :-> p a' b'
  effdimap a' :-> a
f b :-> b'
g = (a' :-> a) -> p a b' :-> p a' b'
forall (p :: (* -> * -> *) -> (* -> * -> *) -> * -> * -> *)
       (a' :: * -> * -> *) (a :: * -> * -> *) (b :: * -> * -> *).
EffProfunctor p =>
(a' :-> a) -> p a b :-> p a' b
efflmap a' :-> a
f (p a b' a b -> p a' b' a b)
-> (p a b a b -> p a b' a b) -> p a b a b -> p a' b' a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (b :-> b') -> p a b :-> p a b'
forall (f :: (* -> * -> *) -> * -> * -> *) (eff :: * -> * -> *)
       (eff' :: * -> * -> *).
EffFunctor f =>
(eff :-> eff') -> f eff :-> f eff'
effrmap b :-> b'
g

  efflmap :: (a' :-> a) -> p a b :-> p a' b
  efflmap a' :-> a
f = (a' :-> a) -> (b :-> b) -> p a b :-> p a' b
forall (p :: (* -> * -> *) -> (* -> * -> *) -> * -> * -> *)
       (a' :: * -> * -> *) (a :: * -> * -> *) (b :: * -> * -> *)
       (b' :: * -> * -> *).
EffProfunctor p =>
(a' :-> a) -> (b :-> b') -> p a b :-> p a' b'
effdimap a' :-> a
f b :-> b
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id