{- |
  Combinators for monadic profunctors.
 -}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleContexts #-}

module Profunctor.Monad.Combinators where

import Control.Applicative
import Profunctor.Monad.Core
import Profunctor.Monad.Profunctor

-- * Basic combinators

-- | Instantiate a constraint @'ForallF' cc p@ at type @x@,
-- yielding @cc (p x)@.
--
-- === Usage
--
-- In some context with a constraint @'ForallF' 'Monad' p@ available:
--
-- @
-- 'with' \@'Monad' \@p @x '$' do
--   (...) :: p x a
-- @
--
with :: forall cc p x a. ForallF cc p => (cc (p x) => a) -> a
with :: (cc (p x) => a) -> a
with cc (p x) => a
a = case ForallF cc p :- cc (p x)
forall k2 k1 (p :: k2 -> Constraint) (f :: k1 -> k2) (a :: k1).
ForallF p f :- p (f a)
instF @cc @p @x of Sub ForallF cc p => Dict (cc (p x))
Dict -> a
cc (p x) => a
a

-- | A specialization of 'with' which deduces @p@ and @x@ from its argument.
--
-- === Usage
--
-- In some context with a constraint @'ForallF' 'Monad' p@ available:
--
-- @
-- 'with'' \@'Monad' '$' do
--   (...) :: p x a
-- @
with' :: forall cc p x a. ForallF cc p => (cc (p x) => p x a) -> p x a
with' :: (cc (p x) => p x a) -> p x a
with' = forall a. ForallF cc p => (cc (p x) => a) -> a
forall k2 k1 (cc :: k2 -> Constraint) (p :: k1 -> k2) (x :: k1) a.
ForallF cc p =>
(cc (p x) => a) -> a
with @cc @p @x

-- | A specialization of 'with'' for 'Functor', to avoid @TypeApplications@
-- where this is possible.
--
-- === Usage
--
-- In some context with a constraint @'ForallF' 'Functor' p@ available:
--
-- @
-- 'withFunctor' '$'
--   (...) '<$>' (...)
-- @
withFunctor :: ForallF Functor p => (Functor (p x) => p x a) -> p x a
withFunctor :: (Functor (p x) => p x a) -> p x a
withFunctor = forall k k1 (cc :: (k -> *) -> Constraint) (p :: k1 -> k -> *)
       (x :: k1) (a :: k).
ForallF cc p =>
(cc (p x) => p x a) -> p x a
forall (p :: k1 -> * -> *) (x :: k1) a.
ForallF Functor p =>
(Functor (p x) => p x a) -> p x a
with' @Functor

-- | A specialization of 'with'' for 'Applicative', to avoid @TypeApplications@
-- where this is possible.
--
-- === Usage
--
-- In some context with a constraint @'ForallF' 'Applicative' p@ available:
--
-- @
-- 'withApplicative' '$'
--   (...) '<$>' (...) '<*>' (...)
-- @
withApplicative
  :: ForallF Applicative p => (Applicative (p x) => p x a) -> p x a
withApplicative :: (Applicative (p x) => p x a) -> p x a
withApplicative = forall k k1 (cc :: (k -> *) -> Constraint) (p :: k1 -> k -> *)
       (x :: k1) (a :: k).
ForallF cc p =>
(cc (p x) => p x a) -> p x a
forall (p :: k1 -> * -> *) (x :: k1) a.
ForallF Applicative p =>
(Applicative (p x) => p x a) -> p x a
with' @Applicative

-- | A specialization of 'with'' for 'Alternative', to avoid @TypeApplications@
-- where this is possible.
--
-- === Usage
--
-- In some context with a constraint @'ForallF' 'Alternative' p@ available:
--
-- @
-- 'withAlternative' '$'
--   (...) '<|>' (...)
-- @
withAlternative
  :: ForallF Alternative p => (Alternative (p x) => p x a) -> p x a
withAlternative :: (Alternative (p x) => p x a) -> p x a
withAlternative = forall k k1 (cc :: (k -> *) -> Constraint) (p :: k1 -> k -> *)
       (x :: k1) (a :: k).
ForallF cc p =>
(cc (p x) => p x a) -> p x a
forall (p :: k1 -> * -> *) (x :: k1) a.
ForallF Alternative p =>
(Alternative (p x) => p x a) -> p x a
with' @Alternative

-- | A specialization of 'with'' for 'Monad', to avoid @TypeApplications@ where
-- this is possible.
--
-- === Usage
--
-- In some context with a constraint @'ForallF' 'Alternative' p@ available:
--
-- @
-- 'withMonad' '$' do
--   (...)
-- @
withMonad :: ForallF Monad p => (Monad (p x) => p x a) -> p x a
withMonad :: (Monad (p x) => p x a) -> p x a
withMonad = forall k k1 (cc :: (k -> *) -> Constraint) (p :: k1 -> k -> *)
       (x :: k1) (a :: k).
ForallF cc p =>
(cc (p x) => p x a) -> p x a
forall (p :: k1 -> * -> *) (x :: k1) a.
ForallF Monad p =>
(Monad (p x) => p x a) -> p x a
with' @Monad

-- | Bidirectional generalization of 'Control.Monad.replicateM'.
replicateP
  :: forall p x a
  .  (Profunctor p, ForallF Applicative p)
  => Int -> p x a -> p [x] [a]
replicateP :: Int -> p x a -> p [x] [a]
replicateP = (Applicative (p [x]) => Int -> p x a -> p [x] [a])
-> Int -> p x a -> p [x] [a]
forall k2 k1 (cc :: k2 -> Constraint) (p :: k1 -> k2) (x :: k1) a.
ForallF cc p =>
(cc (p x) => a) -> a
with @Applicative @p @[x] Applicative (p [x]) => Int -> p x a -> p [x] [a]
forall (p :: * -> * -> *) x a.
(Profunctor p, Applicative (p [x])) =>
Int -> p x a -> p [x] [a]
replicateP_

replicateP_
  :: (Profunctor p, Applicative (p [x]))
  => Int -> p x a -> p [x] [a]
replicateP_ :: Int -> p x a -> p [x] [a]
replicateP_ Int
0 p x a
_ = [a] -> p [x] [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
replicateP_ Int
n p x a
p = (:)
  (a -> [a] -> [a]) -> p [x] a -> p [x] ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [x] -> x
forall a. [a] -> a
head ([x] -> x) -> p x a -> p [x] a
forall (p :: * -> * -> *) y x a.
Profunctor p =>
(y -> x) -> p x a -> p y a
=. p x a
p
  p [x] ([a] -> [a]) -> p [x] [a] -> p [x] [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [x] -> [x]
forall a. [a] -> [a]
tail ([x] -> [x]) -> p [x] [a] -> p [x] [a]
forall (p :: * -> * -> *) y x a.
Profunctor p =>
(y -> x) -> p x a -> p y a
=. Int -> p x a -> p [x] [a]
forall (p :: * -> * -> *) x a.
(Profunctor p, Applicative (p [x])) =>
Int -> p x a -> p [x] [a]
replicateP_ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) p x a
p

manyP
  :: forall p x a
  .  (Profunctor p, ForallF Alternative p)
  => (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
manyP :: (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
manyP = (Alternative (p [x]) =>
 (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a])
-> (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
forall k2 k1 (cc :: k2 -> Constraint) (p :: k1 -> k2) (x :: k1) a.
ForallF cc p =>
(cc (p x) => a) -> a
with @Alternative @p @[x] Alternative (p [x]) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
forall (p :: * -> * -> *) x a.
(Profunctor p, Alternative (p [x])) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
manyP_

manyP_
  :: (Profunctor p, Alternative (p [x]))
  => (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
manyP_ :: (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
manyP_ ([x] -> Bool) -> p [x] ()
assert p x a
p = (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
forall (p :: * -> * -> *) x a.
(Profunctor p, Alternative (p [x])) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
someP_ ([x] -> Bool) -> p [x] ()
assert p x a
p p [x] [a] -> p [x] [a] -> p [x] [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> p [x] [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

someP
  :: forall p x a
  .  (Profunctor p, ForallF Alternative p)
  => (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
someP :: (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
someP = (Alternative (p [x]) =>
 (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a])
-> (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
forall k2 k1 (cc :: k2 -> Constraint) (p :: k1 -> k2) (x :: k1) a.
ForallF cc p =>
(cc (p x) => a) -> a
with @Alternative @p @[x] Alternative (p [x]) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
forall (p :: * -> * -> *) x a.
(Profunctor p, Alternative (p [x])) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
someP_

someP_
  :: (Profunctor p, Alternative (p [x]))
  => (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
someP_ :: (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
someP_ ([x] -> Bool) -> p [x] ()
assert p x a
p =
  ([x] -> Bool) -> p [x] ()
assert (Bool -> Bool
not (Bool -> Bool) -> ([x] -> Bool) -> [x] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [x] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) p [x] () -> p [x] [a] -> p [x] [a]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> [a] -> [a]) -> p [x] a -> p [x] [a] -> p [x] [a]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) ([x] -> x
forall a. [a] -> a
head ([x] -> x) -> p x a -> p [x] a
forall (p :: * -> * -> *) y x a.
Profunctor p =>
(y -> x) -> p x a -> p y a
=. p x a
p) ([x] -> [x]
forall a. [a] -> [a]
tail ([x] -> [x]) -> p [x] [a] -> p [x] [a]
forall (p :: * -> * -> *) y x a.
Profunctor p =>
(y -> x) -> p x a -> p y a
=. (([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
forall (p :: * -> * -> *) x a.
(Profunctor p, Alternative (p [x])) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p [x] [a]
manyP_ ([x] -> Bool) -> p [x] ()
assert p x a
p)

sepByP
  :: forall p x a b
  .  (Profunctor p, ForallF Alternative p)
  => (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepByP :: (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepByP = (Alternative (p [x]) =>
 (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a])
-> (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
forall k2 k1 (cc :: k2 -> Constraint) (p :: k1 -> k2) (x :: k1) a.
ForallF cc p =>
(cc (p x) => a) -> a
with @Alternative @p @[x] Alternative (p [x]) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
forall (p :: * -> * -> *) x a b.
(Profunctor p, Alternative (p [x])) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepByP_

sepByP_
  :: (Profunctor p, Alternative (p [x]))
  => (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepByP_ :: (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepByP_ ([x] -> Bool) -> p [x] ()
assert p x a
p p () b
s =
  (([x] -> Bool) -> p [x] ()
assert (Bool -> Bool
not (Bool -> Bool) -> ([x] -> Bool) -> [x] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [x] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) p [x] () -> p [x] [a] -> p [x] [a]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
forall (p :: * -> * -> *) x a b.
(Profunctor p, Alternative (p [x])) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepBy1P_ ([x] -> Bool) -> p [x] ()
assert p x a
p p () b
s) p [x] [a] -> p [x] [a] -> p [x] [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> p [x] [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

sepBy1P
  :: forall p x a b
  .  (Profunctor p, ForallF Alternative p)
  => (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepBy1P :: (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepBy1P = (Alternative (p [x]) =>
 (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a])
-> (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
forall k2 k1 (cc :: k2 -> Constraint) (p :: k1 -> k2) (x :: k1) a.
ForallF cc p =>
(cc (p x) => a) -> a
with @Alternative @p @[x] Alternative (p [x]) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
forall (p :: * -> * -> *) x a b.
(Profunctor p, Alternative (p [x])) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepBy1P_

sepBy1P_
  :: (Profunctor p, Alternative (p [x]))
  => (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepBy1P_ :: (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepBy1P_ ([x] -> Bool) -> p [x] ()
assert p x a
p p () b
s = (a -> [a] -> [a]) -> p [x] a -> p [x] [a] -> p [x] [a]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) ([x] -> x
forall a. [a] -> a
head ([x] -> x) -> p x a -> p [x] a
forall (p :: * -> * -> *) y x a.
Profunctor p =>
(y -> x) -> p x a -> p y a
=. p x a
p) ([x] -> [x]
forall a. [a] -> [a]
tail ([x] -> [x]) -> p [x] [a] -> p [x] [a]
forall (p :: * -> * -> *) y x a.
Profunctor p =>
(y -> x) -> p x a -> p y a
=. (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
forall (p :: * -> * -> *) x a b.
(Profunctor p, Alternative (p [x])) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
preByP_ ([x] -> Bool) -> p [x] ()
assert p x a
p p () b
s)

preByP
  :: forall p x a b
  .  (Profunctor p, ForallF Alternative p)
  => (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
preByP :: (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
preByP = (Alternative (p [x]) =>
 (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a])
-> (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
forall k2 k1 (cc :: k2 -> Constraint) (p :: k1 -> k2) (x :: k1) a.
ForallF cc p =>
(cc (p x) => a) -> a
with @Alternative @p @[x] Alternative (p [x]) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
forall (p :: * -> * -> *) x a b.
(Profunctor p, Alternative (p [x])) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
preByP_

preByP_
  :: (Profunctor p, Alternative (p [x]))
  => (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
preByP_ :: (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
preByP_ ([x] -> Bool) -> p [x] ()
assert p x a
p p () b
s =
  (([x] -> Bool) -> p [x] ()
assert (Bool -> Bool
not (Bool -> Bool) -> ([x] -> Bool) -> [x] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [x] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) p [x] () -> p [x] b -> p [x] b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> () -> [x] -> ()
forall a b. a -> b -> a
const () ([x] -> ()) -> p () b -> p [x] b
forall (p :: * -> * -> *) y x a.
Profunctor p =>
(y -> x) -> p x a -> p y a
=. p () b
s p [x] b -> p [x] [a] -> p [x] [a]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
forall (p :: * -> * -> *) x a b.
(Profunctor p, Alternative (p [x])) =>
(([x] -> Bool) -> p [x] ()) -> p x a -> p () b -> p [x] [a]
sepBy1P_ ([x] -> Bool) -> p [x] ()
assert p x a
p p () b
s) p [x] [a] -> p [x] [a] -> p [x] [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> p [x] [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []