module Data.Profunctor.Fun.Internal
( -- * CPS functions
  Fun(..)
  -- ** Mixfix syntax
, type (~~)
, type (~>)
  -- ** Construction
, fun
) where

import           Control.Arrow
import qualified Control.Category as Cat
import           Data.Bifunctor.Disjunction
import           Data.Functor.Continuation
import           Data.Profunctor
import           Data.Profunctor.Traversing

-- CPS functions

newtype Fun r a b = Fun { Fun r a b -> (r ! b) -> r ! a
(#) :: r ! b -> r ! a }

infixl 7 #

instance Cat.Category (Fun r) where
  id :: Fun r a a
id = ((r ! a) -> r ! a) -> Fun r a a
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun (r ! a) -> r ! a
forall a. a -> a
id
  Fun r b c
f . :: Fun r b c -> Fun r a b -> Fun r a c
. Fun r a b
g = ((r ! c) -> r ! a) -> Fun r a c
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun ((Fun r a b
g Fun r a b -> (r ! b) -> r ! a
forall r a b. Fun r a b -> (r ! b) -> r ! a
#) ((r ! b) -> r ! a) -> ((r ! c) -> r ! b) -> (r ! c) -> r ! a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fun r b c
f Fun r b c -> (r ! c) -> r ! b
forall r a b. Fun r a b -> (r ! b) -> r ! a
#))

instance Profunctor (Fun r) where
  dimap :: (a -> b) -> (c -> d) -> Fun r b c -> Fun r a d
dimap a -> b
f c -> d
g = ((r ! d) -> r ! a) -> Fun r a d
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun (((r ! d) -> r ! a) -> Fun r a d)
-> (Fun r b c -> (r ! d) -> r ! a) -> Fun r b c -> Fun r a d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((r ! d) -> r ! c)
-> ((r ! b) -> r ! a) -> ((r ! c) -> r ! b) -> (r ! d) -> r ! a
forall (p :: Type -> Type -> Type) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap ((c -> d) -> (r ! d) -> r ! c
forall (f :: Type -> Type) a b.
Contravariant f =>
(a -> b) -> f b -> f a
contramap c -> d
g) ((a -> b) -> (r ! b) -> r ! a
forall (f :: Type -> Type) a b.
Contravariant f =>
(a -> b) -> f b -> f a
contramap a -> b
f) (((r ! c) -> r ! b) -> (r ! d) -> r ! a)
-> (Fun r b c -> (r ! c) -> r ! b) -> Fun r b c -> (r ! d) -> r ! a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fun r b c -> (r ! c) -> r ! b
forall r a b. Fun r a b -> (r ! b) -> r ! a
(#)
  lmap :: (a -> b) -> Fun r b c -> Fun r a c
lmap a -> b
f = ((r ! c) -> r ! a) -> Fun r a c
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun (((r ! c) -> r ! a) -> Fun r a c)
-> (Fun r b c -> (r ! c) -> r ! a) -> Fun r b c -> Fun r a c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((r ! b) -> r ! a) -> ((r ! c) -> r ! b) -> (r ! c) -> r ! a
forall (p :: Type -> Type -> Type) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap ((a -> b) -> (r ! b) -> r ! a
forall (f :: Type -> Type) a b.
Contravariant f =>
(a -> b) -> f b -> f a
contramap a -> b
f) (((r ! c) -> r ! b) -> (r ! c) -> r ! a)
-> (Fun r b c -> (r ! c) -> r ! b) -> Fun r b c -> (r ! c) -> r ! a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fun r b c -> (r ! c) -> r ! b
forall r a b. Fun r a b -> (r ! b) -> r ! a
(#)
  rmap :: (b -> c) -> Fun r a b -> Fun r a c
rmap b -> c
g = ((r ! c) -> r ! a) -> Fun r a c
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun (((r ! c) -> r ! a) -> Fun r a c)
-> (Fun r a b -> (r ! c) -> r ! a) -> Fun r a b -> Fun r a c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((r ! c) -> r ! b) -> ((r ! b) -> r ! a) -> (r ! c) -> r ! a
forall (p :: Type -> Type -> Type) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap ((b -> c) -> (r ! c) -> r ! b
forall (f :: Type -> Type) a b.
Contravariant f =>
(a -> b) -> f b -> f a
contramap b -> c
g) (((r ! b) -> r ! a) -> (r ! c) -> r ! a)
-> (Fun r a b -> (r ! b) -> r ! a) -> Fun r a b -> (r ! c) -> r ! a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fun r a b -> (r ! b) -> r ! a
forall r a b. Fun r a b -> (r ! b) -> r ! a
(#)

instance Choice (Fun r) where
  left' :: Fun r a b -> Fun r (Either a c) (Either b c)
left'  Fun r a b
f = ((r ! Either b c) -> r ! Either a c)
-> Fun r (Either a c) (Either b c)
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun (\ r ! Either b c
k -> (Fun r a b
f Fun r a b -> (r ! b) -> r ! a
forall r a b. Fun r a b -> (r ! b) -> r ! a
# (r ! Either b c) -> r ! b
forall (k :: Type -> Type) (d :: Type -> Type -> Type) a b.
(Contravariant k, Disj d) =>
k (d a b) -> k a
inlK r ! Either b c
k) (r ! a) -> (r ! c) -> r ! Either a c
forall (d :: Type -> Type -> Type) (k :: Type -> Type) a b.
(Disj d, Representable k) =>
k a -> k b -> k (d a b)
<!!> (r ! Either b c) -> r ! c
forall (k :: Type -> Type) (d :: Type -> Type -> Type) a b.
(Contravariant k, Disj d) =>
k (d a b) -> k b
inrK r ! Either b c
k)
  right' :: Fun r a b -> Fun r (Either c a) (Either c b)
right' Fun r a b
f = ((r ! Either c b) -> r ! Either c a)
-> Fun r (Either c a) (Either c b)
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun (\ r ! Either c b
k -> (r ! Either c b) -> r ! c
forall (k :: Type -> Type) (d :: Type -> Type -> Type) a b.
(Contravariant k, Disj d) =>
k (d a b) -> k a
inlK r ! Either c b
k (r ! c) -> (r ! a) -> r ! Either c a
forall (d :: Type -> Type -> Type) (k :: Type -> Type) a b.
(Disj d, Representable k) =>
k a -> k b -> k (d a b)
<!!> (Fun r a b
f Fun r a b -> (r ! b) -> r ! a
forall r a b. Fun r a b -> (r ! b) -> r ! a
# (r ! Either c b) -> r ! b
forall (k :: Type -> Type) (d :: Type -> Type -> Type) a b.
(Contravariant k, Disj d) =>
k (d a b) -> k b
inrK r ! Either c b
k))

instance Cochoice (Fun r) where
  unleft :: Fun r (Either a d) (Either b d) -> Fun r a b
unleft  Fun r (Either a d) (Either b d)
f = ((r ! b) -> r ! a) -> Fun r a b
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun (\ r ! b
k -> let f' :: r ! Either a d
f' = Fun r (Either a d) (Either b d)
f Fun r (Either a d) (Either b d)
-> (r ! Either b d) -> r ! Either a d
forall r a b. Fun r a b -> (r ! b) -> r ! a
# (r ! b
k (r ! b) -> (r ! d) -> r ! Either b d
forall (d :: Type -> Type -> Type) (k :: Type -> Type) a b.
(Disj d, Representable k) =>
k a -> k b -> k (d a b)
<!!> (r ! Either a d) -> r ! d
forall (k :: Type -> Type) (d :: Type -> Type -> Type) a b.
(Contravariant k, Disj d) =>
k (d a b) -> k b
inrK r ! Either a d
f') in (r ! Either a d) -> r ! a
forall (k :: Type -> Type) (d :: Type -> Type -> Type) a b.
(Contravariant k, Disj d) =>
k (d a b) -> k a
inlK r ! Either a d
f')
  unright :: Fun r (Either d a) (Either d b) -> Fun r a b
unright Fun r (Either d a) (Either d b)
f = ((r ! b) -> r ! a) -> Fun r a b
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun (\ r ! b
k -> let f' :: r ! Either d a
f' = Fun r (Either d a) (Either d b)
f Fun r (Either d a) (Either d b)
-> (r ! Either d b) -> r ! Either d a
forall r a b. Fun r a b -> (r ! b) -> r ! a
# ((r ! Either d a) -> r ! d
forall (k :: Type -> Type) (d :: Type -> Type -> Type) a b.
(Contravariant k, Disj d) =>
k (d a b) -> k a
inlK r ! Either d a
f' (r ! d) -> (r ! b) -> r ! Either d b
forall (d :: Type -> Type -> Type) (k :: Type -> Type) a b.
(Disj d, Representable k) =>
k a -> k b -> k (d a b)
<!!> r ! b
k) in (r ! Either d a) -> r ! a
forall (k :: Type -> Type) (d :: Type -> Type -> Type) a b.
(Contravariant k, Disj d) =>
k (d a b) -> k b
inrK r ! Either d a
f')

instance Strong (Fun r) where
  first' :: Fun r a b -> Fun r (a, c) (b, c)
first'  Fun r a b
f = ((r ! (b, c)) -> (a, c) -> r) -> Fun r (a, c) (b, c)
forall r b a. ((r ! b) -> a -> r) -> (a ~~ r) ~> b
fun (\ r ! (b, c)
k (a
a, c
c) -> Fun r a b
f Fun r a b -> (r ! b) -> r ! a
forall r a b. Fun r a b -> (r ! b) -> r ! a
# (b -> (b, c)) -> (r ! (b, c)) -> r ! b
forall (f :: Type -> Type) a b.
Contravariant f =>
(a -> b) -> f b -> f a
contramap (,c
c) r ! (b, c)
k (r ! a) -> a -> r
forall r a. (r ! a) -> a -> r
! a
a)
  second' :: Fun r a b -> Fun r (c, a) (c, b)
second' Fun r a b
f = ((r ! (c, b)) -> (c, a) -> r) -> Fun r (c, a) (c, b)
forall r b a. ((r ! b) -> a -> r) -> (a ~~ r) ~> b
fun (\ r ! (c, b)
k (c
c, a
a) -> Fun r a b
f Fun r a b -> (r ! b) -> r ! a
forall r a b. Fun r a b -> (r ! b) -> r ! a
# (b -> (c, b)) -> (r ! (c, b)) -> r ! b
forall (f :: Type -> Type) a b.
Contravariant f =>
(a -> b) -> f b -> f a
contramap (c
c,) r ! (c, b)
k (r ! a) -> a -> r
forall r a. (r ! a) -> a -> r
! a
a)

instance Traversing (Fun r) where
  wander :: (forall (f :: Type -> Type).
 Applicative f =>
 (a -> f b) -> s -> f t)
-> Fun r a b -> Fun r s t
wander forall (f :: Type -> Type). Applicative f => (a -> f b) -> s -> f t
traverse Fun r a b
f = ((r ! t) -> s -> r) -> Fun r s t
forall r b a. ((r ! b) -> a -> r) -> (a ~~ r) ~> b
fun (\ r ! t
b s
a -> (a -> Fun r () b) -> s -> Fun r () t
forall (f :: Type -> Type). Applicative f => (a -> f b) -> s -> f t
traverse (\ a
a -> ((r ! b) -> () -> r) -> Fun r () b
forall r b a. ((r ! b) -> a -> r) -> (a ~~ r) ~> b
fun (\ r ! b
k ()
_ -> Fun r a b
f Fun r a b -> (r ! b) -> r ! a
forall r a b. Fun r a b -> (r ! b) -> r ! a
# r ! b
k (r ! a) -> a -> r
forall r a. (r ! a) -> a -> r
! a
a)) s
a Fun r () t -> (r ! t) -> r ! ()
forall r a b. Fun r a b -> (r ! b) -> r ! a
# r ! t
b (r ! ()) -> () -> r
forall r a. (r ! a) -> a -> r
! ())

instance Functor (Fun r a) where
  fmap :: (a -> b) -> Fun r a a -> Fun r a b
fmap = (a -> b) -> Fun r a a -> Fun r a b
forall (p :: Type -> Type -> Type) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap
  <$ :: a -> Fun r a b -> Fun r a a
(<$) = (b -> a) -> Fun r a b -> Fun r a a
forall (p :: Type -> Type -> Type) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap ((b -> a) -> Fun r a b -> Fun r a a)
-> (a -> b -> a) -> a -> Fun r a b -> Fun r a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> a
forall a b. a -> b -> a
const

instance Applicative (Fun r x) where
  pure :: a -> Fun r x a
pure = ((r ! a) -> r ! x) -> Fun r x a
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun (((r ! a) -> r ! x) -> Fun r x a)
-> (a -> (r ! a) -> r ! x) -> a -> Fun r x a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (r ! a) -> r ! x
forall (f :: Type -> Type) b a. Contravariant f => b -> f b -> f a
(>$)
  Fun r x (a -> b)
f <*> :: Fun r x (a -> b) -> Fun r x a -> Fun r x b
<*> Fun r x a
a = ((r ! b) -> x -> r) -> Fun r x b
forall r b a. ((r ! b) -> a -> r) -> (a ~~ r) ~> b
fun (\ r ! b
k x
x -> Fun r x (a -> b)
f Fun r x (a -> b) -> (r ! (a -> b)) -> r ! x
forall r a b. Fun r a b -> (r ! b) -> r ! a
# ((a -> b) -> r) -> r ! (a -> b)
forall r a. (a -> r) -> r ! a
K (\ a -> b
f -> Fun r x a
a Fun r x a -> (r ! a) -> r ! x
forall r a b. Fun r a b -> (r ! b) -> r ! a
# (a -> b) -> (r ! b) -> r ! a
forall (f :: Type -> Type) a b.
Contravariant f =>
(a -> b) -> f b -> f a
contramap a -> b
f r ! b
k (r ! x) -> x -> r
forall r a. (r ! a) -> a -> r
! x
x) (r ! x) -> x -> r
forall r a. (r ! a) -> a -> r
! x
x)

instance Monad (Fun r a) where
  Fun r a a
m >>= :: Fun r a a -> (a -> Fun r a b) -> Fun r a b
>>= a -> Fun r a b
f = ((r ! b) -> a -> r) -> Fun r a b
forall r b a. ((r ! b) -> a -> r) -> (a ~~ r) ~> b
fun (\ r ! b
k a
x -> Fun r a a
m Fun r a a -> (r ! a) -> r ! a
forall r a b. Fun r a b -> (r ! b) -> r ! a
# (a -> r) -> r ! a
forall r a. (a -> r) -> r ! a
K (\ a
a -> a -> Fun r a b
f a
a Fun r a b -> (r ! b) -> r ! a
forall r a b. Fun r a b -> (r ! b) -> r ! a
# r ! b
k (r ! a) -> a -> r
forall r a. (r ! a) -> a -> r
! a
x) (r ! a) -> a -> r
forall r a. (r ! a) -> a -> r
! a
x)

instance Arrow (Fun r) where
  arr :: (b -> c) -> Fun r b c
arr = ((r ! c) -> r ! b) -> Fun r b c
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun (((r ! c) -> r ! b) -> Fun r b c)
-> ((b -> c) -> (r ! c) -> r ! b) -> (b -> c) -> Fun r b c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> c) -> (r ! c) -> r ! b
forall (f :: Type -> Type) a b.
Contravariant f =>
(a -> b) -> f b -> f a
contramap
  first :: Fun r b c -> Fun r (b, d) (c, d)
first = Fun r b c -> Fun r (b, d) (c, d)
forall (p :: Type -> Type -> Type) a b c.
Strong p =>
p a b -> p (a, c) (b, c)
first'
  second :: Fun r b c -> Fun r (d, b) (d, c)
second = Fun r b c -> Fun r (d, b) (d, c)
forall (p :: Type -> Type -> Type) a b c.
Strong p =>
p a b -> p (c, a) (c, b)
second'

instance ArrowChoice (Fun r) where
  left :: Fun r b c -> Fun r (Either b d) (Either c d)
left = Fun r b c -> Fun r (Either b d) (Either c d)
forall (p :: Type -> Type -> Type) a b c.
Choice p =>
p a b -> p (Either a c) (Either b c)
left'
  right :: Fun r b c -> Fun r (Either d b) (Either d c)
right = Fun r b c -> Fun r (Either d b) (Either d c)
forall (p :: Type -> Type -> Type) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'

instance ArrowApply (Fun r) where
  app :: Fun r (Fun r b c, b) c
app = ((r ! c) -> (Fun r b c, b) -> r) -> Fun r (Fun r b c, b) c
forall r b a. ((r ! b) -> a -> r) -> (a ~~ r) ~> b
fun (\ r ! c
k (Fun r b c
f, b
a) -> Fun r b c
f Fun r b c -> (r ! c) -> r ! b
forall r a b. Fun r a b -> (r ! b) -> r ! a
# r ! c
k (r ! b) -> b -> r
forall r a. (r ! a) -> a -> r
! b
a)


-- Mixfix syntax

type a ~~r = Fun r a
type r~> b = r b

infixr 1 ~~
infixr 0 ~>


-- Construction

fun :: (r ! b -> a -> r) -> a ~~r~> b
fun :: ((r ! b) -> a -> r) -> (a ~~ r) ~> b
fun = ((r ! b) -> r ! a) -> (a ~~ r) ~> b
forall r a b. ((r ! b) -> r ! a) -> Fun r a b
Fun (((r ! b) -> r ! a) -> (a ~~ r) ~> b)
-> (((r ! b) -> a -> r) -> (r ! b) -> r ! a)
-> ((r ! b) -> a -> r)
-> (a ~~ r) ~> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> r) -> r ! a) -> ((r ! b) -> a -> r) -> (r ! b) -> r ! a
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> r) -> r ! a
forall r a. (a -> r) -> r ! a
K