{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BlockArguments #-}
module Data.Profunctor.Cont where

-- Profunctor experiments on continuations

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
  -- callCC :: (p a x -> p a (Either x b)) -> p a b
  -- callCC :: (p (Either a a) x -> p a x) -> p a a
  -- callCC :: (p (Either b x) x -> p a b) -> p a b
  -- callCC :: (p b x -> p a b) -> p a b
  -- callCC :: p ((a -> p q b) -> p q a, q) a
  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 -- 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


-- helper :: (a -> Bool) -> [a] -> ContT r f (Maybe a)
-- helper predicate xs = do
--     callCC $ \cc -> do
--         case find predicate xs of
--           Just i -> cc (Just i)
--           Nothing -> pure Nothing

-- helper' :: (Monad m, Monoid r) => (a -> Bool) -> [a] -> ContT r m a
-- helper' predicate xs = do
--     shiftT $ \cc -> do
--         getAp $ flip foldMap xs $ \x ->
--                     Ap $ if predicate x
--                             then lift (cc x)
--                             else pure mempty

-- helper'' :: (Monad m, Monoid r) => (r -> Bool) -> [r] -> ContT r m r
-- helper'' predicate xs = do
--     callCC $ \outer -> do
--         shiftT $ \inner -> do
--             foldl' (go inner outer) (pure mempty) xs
--             -- getAp $ flip foldMap xs $ \x ->
--             --             Ap $ if predicate x
--             --                     then outer _
--             --                     else lift $ inner x
--   where
--     go inner outer mr a
--       | predicate a = mr >>= outer
--       | otherwise = liftA2 (<>) mr (lift $ inner a)

-- stopWhen :: (Representable p, Rep p ~ f) => p (Maybe Int) r -> p [Int] r
-- stopWhen = withCapture (helper even)

-- stopWhen' :: (Monoid r, Monad m, Representable p, Rep p ~ m) => p Int r -> p [Int] r
-- stopWhen' = withCapture (helper' even)

-- stopWhen'' :: (Monad m, Representable p, Rep p ~ m) => p [a] [a] -> p [[a]] [a]
-- stopWhen'' = withCapture (helper'' ((>3) . length))


-- -- Optic s r a r =
-- withCapture :: (Representable p, Rep p ~ f) => (s -> ContT r f a) -> p a r -> p s r
-- withCapture f p =
--     tabulate $ \b ->
--         let ContT g = (f b)
--             handler = sieve p
--          in g handler


-- tester :: [[ Int ]] -> IO [Int]
-- tester = runStar $ stopWhen'' (Star go')
--   where
--     go' i = print i >> pure i
--     go (Just i) = print i >> pure [i]
--     go Nothing = pure []

-- -- class Profunctor p => Capture p where