{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BlockArguments #-}
module Data.Profunctor.Cont where
import Data.Profunctor
import Data.Profunctor.Arrow
import Data.Function
import qualified Control.Category as C
import Control.Category ((>>>))
import Data.Void
data ContP r a b =
ContP {ContP r a b -> a -> (b -> r) -> r
runContP :: a -> ((b -> r) -> r) }
deriving a -> ContP r a b -> ContP r a a
(a -> b) -> ContP r a a -> ContP r a b
(forall a b. (a -> b) -> ContP r a a -> ContP r a b)
-> (forall a b. a -> ContP r a b -> ContP r a a)
-> Functor (ContP r a)
forall a b. a -> ContP r a b -> ContP r a a
forall a b. (a -> b) -> ContP r a a -> ContP r a b
forall r a a b. a -> ContP r a b -> ContP r a a
forall r a a b. (a -> b) -> ContP r a a -> ContP r a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ContP r a b -> ContP r a a
$c<$ :: forall r a a b. a -> ContP r a b -> ContP r a a
fmap :: (a -> b) -> ContP r a a -> ContP r a b
$cfmap :: forall r a a b. (a -> b) -> ContP r a a -> ContP r a b
Functor
instance C.Category (ContP r) where
id :: ContP r a a
id = (a -> (a -> r) -> r) -> ContP r a a
forall r a b. (a -> (b -> r) -> r) -> ContP r a b
ContP a -> (a -> r) -> r
forall a b. a -> (a -> b) -> b
(&)
ContP bCrR :: b -> (c -> r) -> r
bCrR . :: ContP r b c -> ContP r a b -> ContP r a c
. ContP aBrR :: a -> (b -> r) -> r
aBrR = (a -> (c -> r) -> r) -> ContP r a c
forall r a b. (a -> (b -> r) -> r) -> ContP r a b
ContP ((a -> (c -> r) -> r) -> ContP r a c)
-> (a -> (c -> r) -> r) -> ContP r a c
forall a b. (a -> b) -> a -> b
$ \a :: a
a cr :: c -> r
cr ->
a -> (b -> r) -> r
aBrR a
a ((b -> r) -> r) -> (b -> r) -> r
forall a b. (a -> b) -> a -> b
$ \b :: b
b -> b -> (c -> r) -> r
bCrR b
b c -> r
cr
instance Profunctor (ContP r) where
dimap :: (a -> b) -> (c -> d) -> ContP r b c -> ContP r a d
dimap l :: a -> b
l r :: c -> d
r (ContP f :: b -> (c -> r) -> r
f) = (c -> d) -> ContP r a c -> ContP r a d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
r (ContP r a c -> ContP r a d) -> ContP r a c -> ContP r a d
forall a b. (a -> b) -> a -> b
$ (a -> (c -> r) -> r) -> ContP r a c
forall r a b. (a -> (b -> r) -> r) -> ContP r a b
ContP (\a :: a
a cr :: c -> r
cr -> b -> (c -> r) -> r
f (a -> b
l a
a) c -> r
cr)
instance ProfunctorApply (ContP r) where
app :: ContP r (ContP r a b, a) b
app = ((ContP r a b, a) -> (b -> r) -> r) -> ContP r (ContP r a b, a) b
forall r a b. (a -> (b -> r) -> r) -> ContP r a b
ContP \(ContP aBrR :: a -> (b -> r) -> r
aBrR, a :: a
a) br :: b -> r
br -> a -> (b -> r) -> r
aBrR a
a b -> r
br
class Profunctor p => ProfunctorCont p where
callCC :: (p a b -> p x a) -> p x a
instance Choice (ContP r) where
right' :: ContP r a b -> ContP r (Either c a) (Either c b)
right' (ContP f :: a -> (b -> r) -> r
f) = (Either c a -> (Either c b -> r) -> r)
-> ContP r (Either c a) (Either c b)
forall r a b. (a -> (b -> r) -> r) -> ContP r a b
ContP ((Either c a -> (Either c b -> r) -> r)
-> ContP r (Either c a) (Either c b))
-> (Either c a -> (Either c b -> r) -> r)
-> ContP r (Either c a) (Either c b)
forall a b. (a -> b) -> a -> b
$ \eCA :: Either c a
eCA eCBR :: Either c b -> r
eCBR ->
case Either c a
eCA of
Left c :: c
c -> Either c b -> r
eCBR (c -> Either c b
forall a b. a -> Either a b
Left c
c)
Right a :: a
a -> a -> (b -> r) -> r
f a
a (Either c b -> r
eCBR (Either c b -> r) -> (b -> Either c b) -> b -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either c b
forall a b. b -> Either a b
Right)
instance Strong (ContP r) where
first' :: ContP r a b -> ContP r (a, c) (b, c)
first' (ContP aBrR :: a -> (b -> r) -> r
aBrR) = ((a, c) -> ((b, c) -> r) -> r) -> ContP r (a, c) (b, c)
forall r a b. (a -> (b -> r) -> r) -> ContP r a b
ContP \(a :: a
a, c :: c
c) bcr :: (b, c) -> r
bcr -> a -> (b -> r) -> r
aBrR a
a ((b, c) -> r
bcr ((b, c) -> r) -> (b -> (b, c)) -> b -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,c
c))
instance ProfunctorCont (ContP r) where
callCC :: (ContP r a b -> ContP r x a) -> ContP r x a
callCC f :: ContP r a b -> ContP r x a
f = (x -> (a -> r) -> r) -> ContP r x a
forall r a b. (a -> (b -> r) -> r) -> ContP r a b
ContP \q :: x
q ar :: a -> r
ar ->
let ContP x :: x -> (a -> r) -> r
x = ContP r a b -> ContP r x a
f (ContP r a b -> ContP r x a) -> ContP r a b -> ContP r x a
forall a b. (a -> b) -> a -> b
$ (a -> (b -> r) -> r) -> ContP r a b
forall r a b. (a -> (b -> r) -> r) -> ContP r a b
ContP \a :: a
a _ -> a -> r
ar a
a
in x -> (a -> r) -> r
x x
q a -> r
ar
evalContP :: ContP r a r -> a -> r
evalContP :: ContP r a r -> a -> r
evalContP (ContP f :: a -> (r -> r) -> r
f) a :: a
a = a -> (r -> r) -> r
f a
a r -> r
forall a. a -> a
id
reset :: ContP r a r -> ContP r' a r
reset :: ContP r a r -> ContP r' a r
reset = (a -> r) -> ContP r' a r
forall (p :: * -> * -> *) a b.
(Profunctor p, Category p) =>
(a -> b) -> p a b
arr ((a -> r) -> ContP r' a r)
-> (ContP r a r -> a -> r) -> ContP r a r -> ContP r' a r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContP r a r -> a -> r
forall r a. ContP r a r -> a -> r
evalContP
shift :: ContP r (ContP r (a -> r) r) a
shift :: ContP r (ContP r (a -> r) r) a
shift = (ContP r (a -> r) r -> (a -> r) -> r)
-> ContP r (ContP r (a -> r) r) a
forall r a b. (a -> (b -> r) -> r) -> ContP r a b
ContP (ContP r (a -> r) r -> (a -> r) -> r
forall r a. ContP r a r -> a -> r
evalContP)
neutralize :: ContP r r x
neutralize :: ContP r r x
neutralize = (r -> (x -> r) -> r) -> ContP r r x
forall r a b. (a -> (b -> r) -> r) -> ContP r a b
ContP (\r :: r
r _ -> r
r)
testP :: ContP String Int Int
testP :: ContP String Int Int
testP = ContP String Int Int
catcher ContP String Int Int
-> ContP String Int Int -> ContP String Int Int
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Int) -> ContP String Int Int
forall (p :: * -> * -> *) a b.
(Profunctor p, Category p) =>
(a -> b) -> p a b
arr Int -> Int
forall a. Enum a => a -> a
succ ContP String Int Int
-> ContP String Int Int -> ContP String Int Int
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Int) -> ContP String Int Int
forall (p :: * -> * -> *) a b.
(Profunctor p, Category p) =>
(a -> b) -> p a b
arr Int -> Int
forall a. Enum a => a -> a
succ ContP String Int Int
-> ContP String Int Int -> ContP String Int Int
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Int) -> ContP String Int Int
forall (p :: * -> * -> *) a b.
(Profunctor p, Category p) =>
(a -> b) -> p a b
arr Int -> Int
forall a. Enum a => a -> a
succ
where
catcher :: ContP String Int Int
catcher :: ContP String Int Int
catcher = (Int -> Either Int Int)
-> (Either Void Int -> Int)
-> ContP String (Either Int Int) (Either Void Int)
-> ContP String Int Int
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (\n :: Int
n -> if Int -> Bool
forall a. Integral a => a -> Bool
even Int
n then Int -> Either Int Int
forall a b. b -> Either a b
Right Int
n else Int -> Either Int Int
forall a b. a -> Either a b
Left Int
n) ((Void -> Int) -> (Int -> Int) -> Either Void Int -> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Void -> Int
forall a. Void -> a
absurd Int -> Int
forall a. a -> a
id) ((Int -> String)
-> ContP String String Void -> ContP String Int Void
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap Int -> String
forall a. Show a => a -> String
show ContP String String Void
forall r x. ContP r r x
neutralize ContP String Int Void
-> ContP String Int Int
-> ContP String (Either Int Int) (Either Void Int)
forall (p :: * -> * -> *) b c b' c'.
(Choice p, Category p) =>
p b c -> p b' c' -> p (Either b b') (Either c c')
+++ ContP String Int Int
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
C.id)
testP'' :: ContP String Int Int
testP'' :: ContP String Int Int
testP'' = (ContP String Int Int -> ContP String Int Int)
-> ContP String Int Int
forall (p :: * -> * -> *) a b x.
ProfunctorCont p =>
(p a b -> p x a) -> p x a
callCC \cc :: ContP String Int Int
cc ->
ContP String Int Int -> ContP String Int Int
catcher ContP String Int Int
cc ContP String Int Int
-> ContP String Int Int -> ContP String Int Int
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Int) -> ContP String Int Int
forall (p :: * -> * -> *) a b.
(Profunctor p, Category p) =>
(a -> b) -> p a b
arr Int -> Int
forall a. Enum a => a -> a
succ ContP String Int Int
-> ContP String Int Int -> ContP String Int Int
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Int) -> ContP String Int Int
forall (p :: * -> * -> *) a b.
(Profunctor p, Category p) =>
(a -> b) -> p a b
arr Int -> Int
forall a. Enum a => a -> a
succ ContP String Int Int
-> ContP String Int Int -> ContP String Int Int
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Int) -> ContP String Int Int
forall (p :: * -> * -> *) a b.
(Profunctor p, Category p) =>
(a -> b) -> p a b
arr Int -> Int
forall a. Enum a => a -> a
succ
where
catcher :: ContP String Int Int -> ContP String Int Int
catcher :: ContP String Int Int -> ContP String Int Int
catcher p :: ContP String Int Int
p = (Int -> Either Int Int)
-> (Either Int Int -> Int)
-> ContP String (Either Int Int) (Either Int Int)
-> ContP String Int Int
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap ((Int -> Bool) -> Int -> Either Int Int
forall a. (a -> Bool) -> a -> Either a a
splitPred Int -> Bool
forall a. Integral a => a -> Bool
even) Either Int Int -> Int
forall a. Either a a -> a
unify (ContP String Int Int
p ContP String Int Int
-> ContP String Int Int
-> ContP String (Either Int Int) (Either Int Int)
forall (p :: * -> * -> *) b c b' c'.
(Choice p, Category p) =>
p b c -> p b' c' -> p (Either b b') (Either c c')
+++ ContP String Int Int
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
C.id)
splitPred :: (a -> Bool) -> a -> Either a a
splitPred :: (a -> Bool) -> a -> Either a a
splitPred predicate :: a -> Bool
predicate a :: a
a = (if a -> Bool
predicate a
a then a -> Either a a
forall a b. b -> Either a b
Right a
a else a -> Either a a
forall a b. a -> Either a b
Left a
a)
unify :: Either a a -> a
unify :: Either a a -> a
unify = (a -> a) -> (a -> a) -> Either a a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> a
forall a. a -> a
id a -> a
forall a. a -> a
id