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

-- Profunctor experiments on continuations

import Data.Profunctor
import Data.Profunctor.Rep
import Data.Profunctor.Sieve
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Class
import Data.Foldable
import Data.Traversable
import Data.Monoid
import Control.Applicative

-- ContT r m a :: (a -> m r) -> m r
-- shiftT :: ((a -> m r) -> ContT r m r) -> ContT r m a
-- shiftT :: ((a -> m r) -> (r -> m r) -> m r) -> (a -> m r) -> m r

import Data.Functor.Identity


helper :: (a -> Bool) -> [a] -> ContT r f (Maybe a)
helper :: (a -> Bool) -> [a] -> ContT r f (Maybe a)
helper predicate :: a -> Bool
predicate xs :: [a]
xs = do
    ((Maybe a -> ContT r f (Maybe a)) -> ContT r f (Maybe a))
-> ContT r f (Maybe a)
forall k a (r :: k) (m :: k -> *) b.
((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC (((Maybe a -> ContT r f (Maybe a)) -> ContT r f (Maybe a))
 -> ContT r f (Maybe a))
-> ((Maybe a -> ContT r f (Maybe a)) -> ContT r f (Maybe a))
-> ContT r f (Maybe a)
forall a b. (a -> b) -> a -> b
$ \cc :: Maybe a -> ContT r f (Maybe a)
cc -> do
        case (a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find a -> Bool
predicate [a]
xs of
          Just i :: a
i -> Maybe a -> ContT r f (Maybe a)
cc (a -> Maybe a
forall a. a -> Maybe a
Just a
i)
          Nothing -> Maybe a -> ContT r f (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

helper' :: (Monad m, Monoid r) => (a -> Bool) -> [a] -> ContT r m a
helper' :: (a -> Bool) -> [a] -> ContT r m a
helper' predicate :: a -> Bool
predicate xs :: [a]
xs = do
    ((a -> m r) -> ContT r m r) -> ContT r m a
forall (m :: * -> *) a r.
Monad m =>
((a -> m r) -> ContT r m r) -> ContT r m a
shiftT (((a -> m r) -> ContT r m r) -> ContT r m a)
-> ((a -> m r) -> ContT r m r) -> ContT r m a
forall a b. (a -> b) -> a -> b
$ \cc :: a -> m r
cc -> do
        Ap (ContT r m) r -> ContT r m r
forall k (f :: k -> *) (a :: k). Ap f a -> f a
getAp (Ap (ContT r m) r -> ContT r m r)
-> Ap (ContT r m) r -> ContT r m r
forall a b. (a -> b) -> a -> b
$ ((a -> Ap (ContT r m) r) -> [a] -> Ap (ContT r m) r)
-> [a] -> (a -> Ap (ContT r m) r) -> Ap (ContT r m) r
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> Ap (ContT r m) r) -> [a] -> Ap (ContT r m) r
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [a]
xs ((a -> Ap (ContT r m) r) -> Ap (ContT r m) r)
-> (a -> Ap (ContT r m) r) -> Ap (ContT r m) r
forall a b. (a -> b) -> a -> b
$ \x :: a
x ->
                    ContT r m r -> Ap (ContT r m) r
forall k (f :: k -> *) (a :: k). f a -> Ap f a
Ap (ContT r m r -> Ap (ContT r m) r)
-> ContT r m r -> Ap (ContT r m) r
forall a b. (a -> b) -> a -> b
$ if a -> Bool
predicate a
x
                            then m r -> ContT r m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (a -> m r
cc a
x)
                            else r -> ContT r m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
forall a. Monoid a => a
mempty

helper'' :: (Monad m, Monoid r) => (r -> Bool) -> [r] -> ContT r m r
helper'' :: (r -> Bool) -> [r] -> ContT r m r
helper'' predicate :: r -> Bool
predicate xs :: [r]
xs = do
    ((r -> ContT r m r) -> ContT r m r) -> ContT r m r
forall k a (r :: k) (m :: k -> *) b.
((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC (((r -> ContT r m r) -> ContT r m r) -> ContT r m r)
-> ((r -> ContT r m r) -> ContT r m r) -> ContT r m r
forall a b. (a -> b) -> a -> b
$ \outer :: r -> ContT r m r
outer -> do
        ((r -> m r) -> ContT r m r) -> ContT r m r
forall (m :: * -> *) a r.
Monad m =>
((a -> m r) -> ContT r m r) -> ContT r m a
shiftT (((r -> m r) -> ContT r m r) -> ContT r m r)
-> ((r -> m r) -> ContT r m r) -> ContT r m r
forall a b. (a -> b) -> a -> b
$ \inner :: r -> m r
inner -> do
            (ContT r m r -> r -> ContT r m r)
-> ContT r m r -> [r] -> ContT r m r
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((r -> m r) -> (r -> ContT r m r) -> ContT r m r -> r -> ContT r m r
go r -> m r
inner r -> ContT r m r
outer) (r -> ContT r m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
forall a. Monoid a => a
mempty) [r]
xs
            -- getAp $ flip foldMap xs $ \x ->
            --             Ap $ if predicate x
            --                     then outer _
            --                     else lift $ inner x
  where
    go :: (r -> m r) -> (r -> ContT r m r) -> ContT r m r -> r -> ContT r m r
go inner :: r -> m r
inner outer :: r -> ContT r m r
outer mr :: ContT r m r
mr a :: r
a 
      | r -> Bool
predicate r
a = ContT r m r
mr ContT r m r -> (r -> ContT r m r) -> ContT r m r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= r -> ContT r m r
outer
      | Bool
otherwise = (r -> r -> r) -> ContT r m r -> ContT r m r -> ContT r m r
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 r -> r -> r
forall a. Semigroup a => a -> a -> a
(<>) ContT r m r
mr (m r -> ContT r m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m r -> ContT r m r) -> m r -> ContT r m r
forall a b. (a -> b) -> a -> b
$ r -> m r
inner r
a)

stopWhen :: (Representable p, Rep p ~ f) => p (Maybe Int) r -> p [Int] r
stopWhen :: p (Maybe Int) r -> p [Int] r
stopWhen = ([Int] -> ContT r f (Maybe Int)) -> p (Maybe Int) r -> p [Int] r
forall (p :: * -> * -> *) (f :: * -> *) s r a.
(Representable p, Rep p ~ f) =>
(s -> ContT r f a) -> p a r -> p s r
withCapture ((Int -> Bool) -> [Int] -> ContT r f (Maybe Int)
forall a r (f :: * -> *). (a -> Bool) -> [a] -> ContT r f (Maybe a)
helper Int -> Bool
forall a. Integral a => a -> Bool
even)

stopWhen' :: (Monoid r, Monad m, Representable p, Rep p ~ m) => p Int r -> p [Int] r
stopWhen' :: p Int r -> p [Int] r
stopWhen' = ([Int] -> ContT r m Int) -> p Int r -> p [Int] r
forall (p :: * -> * -> *) (f :: * -> *) s r a.
(Representable p, Rep p ~ f) =>
(s -> ContT r f a) -> p a r -> p s r
withCapture ((Int -> Bool) -> [Int] -> ContT r m Int
forall (m :: * -> *) r a.
(Monad m, Monoid r) =>
(a -> Bool) -> [a] -> ContT r m a
helper' Int -> Bool
forall a. Integral a => a -> Bool
even)

stopWhen'' :: (Monad m, Representable p, Rep p ~ m) => p [a] [a] -> p [[a]] [a]
stopWhen'' :: p [a] [a] -> p [[a]] [a]
stopWhen'' = ([[a]] -> ContT [a] m [a]) -> p [a] [a] -> p [[a]] [a]
forall (p :: * -> * -> *) (f :: * -> *) s r a.
(Representable p, Rep p ~ f) =>
(s -> ContT r f a) -> p a r -> p s r
withCapture (([a] -> Bool) -> [[a]] -> ContT [a] m [a]
forall (m :: * -> *) r.
(Monad m, Monoid r) =>
(r -> Bool) -> [r] -> ContT r m r
helper'' ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>3) (Int -> Bool) -> ([a] -> Int) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length))


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


tester :: [[ Int ]] -> IO [Int]
tester :: [[Int]] -> IO [Int]
tester = Star IO [[Int]] [Int] -> [[Int]] -> IO [Int]
forall (f :: * -> *) d c. Star f d c -> d -> f c
runStar (Star IO [[Int]] [Int] -> [[Int]] -> IO [Int])
-> Star IO [[Int]] [Int] -> [[Int]] -> IO [Int]
forall a b. (a -> b) -> a -> b
$ Star IO [Int] [Int] -> Star IO [[Int]] [Int]
forall (m :: * -> *) (p :: * -> * -> *) a.
(Monad m, Representable p, Rep p ~ m) =>
p [a] [a] -> p [[a]] [a]
stopWhen'' (([Int] -> IO [Int]) -> Star IO [Int] [Int]
forall (f :: * -> *) d c. (d -> f c) -> Star f d c
Star [Int] -> IO [Int]
forall b. Show b => b -> IO b
go')
  where
    go' :: b -> IO b
go' i :: b
i = b -> IO ()
forall a. Show a => a -> IO ()
print b
i IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> IO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
i
    go :: Maybe a -> IO [a]
go (Just i :: a
i) = a -> IO ()
forall a. Show a => a -> IO ()
print a
i IO () -> IO [a] -> IO [a]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> IO [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a
i]
    go Nothing = [a] -> IO [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- class Profunctor p => Capture p where