{-# LANGUAGE CPP #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2011-2015 Edward Kmett,
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- For a good explanation of profunctors in Haskell see Dan Piponi's article:
--
-- <http://blog.sigfpe.com/2011/07/profunctors-in-haskell.html>
--
-- For more information on strength and costrength, see:
--
-- <http://comonad.com/reader/2008/deriving-strength-from-laziness/>
----------------------------------------------------------------------------
module Data.Profunctor.Types
  ( Profunctor(dimap, lmap, rmap)
  , Star(..)
  , Costar(..)
  , WrappedArrow(..)
  , Forget(..)
  , (:->)
  ) where

import Control.Applicative hiding (WrappedArrow(..))
import Control.Arrow
import Control.Category
import Control.Comonad
import Control.Monad (MonadPlus(..), (>=>))
import Data.Coerce (Coercible, coerce)
import Data.Distributive
import Data.Foldable
import Data.Functor.Contravariant
import Data.Profunctor.Unsafe
import Data.Traversable
import Prelude hiding (id,(.))

#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid (Monoid(..))
#endif

#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup (Semigroup(..))
#endif

infixr 0 :->

-- | (':->') has a polymorphic kind since @5.6@.

-- (:->) :: forall k1 k2. (k1 -> k2 -> Type) -> (k1 -> k2 -> Type) -> Type
type p :-> q = forall a b. p a b -> q a b

------------------------------------------------------------------------------
-- Star
------------------------------------------------------------------------------

-- | Lift a 'Functor' into a 'Profunctor' (forwards).
--
-- 'Star' has a polymorphic kind since @5.6@.

-- Star :: (k -> Type) -> (Type -> k -> Type)
newtype Star f d c = Star { forall {k} (f :: k -> *) d (c :: k). Star f d c -> d -> f c
runStar :: d -> f c }

instance Functor f => Profunctor (Star f) where
  dimap :: forall a b c d. (a -> b) -> (c -> d) -> Star f b c -> Star f a d
dimap a -> b
ab c -> d
cd (Star b -> f c
bfc) = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
cd forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> f c
bfc forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b
ab)
  {-# INLINE dimap #-}
  lmap :: forall a b c. (a -> b) -> Star f b c -> Star f a c
lmap a -> b
k (Star b -> f c
f) = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star (b -> f c
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b
k)
  {-# INLINE lmap #-}
  rmap :: forall b c a. (b -> c) -> Star f a b -> Star f a c
rmap b -> c
k (Star a -> f b
f) = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> c
k forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> f b
f)
  {-# INLINE rmap #-}
  -- We cannot safely overload (#.) because we didn't write the 'Functor'.
  Star f b c
p .# :: forall a b c (q :: * -> * -> *).
Coercible b a =>
Star f b c -> q a b -> Star f a c
.# q a b
_ = coerce :: forall a b. Coercible a b => a -> b
coerce Star f b c
p
  {-# INLINE (.#) #-}

instance Functor f => Functor (Star f a) where
  fmap :: forall a b. (a -> b) -> Star f a a -> Star f a b
fmap = forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap
  {-# INLINE fmap #-}

instance Applicative f => Applicative (Star f a) where
  pure :: forall a. a -> Star f a a
pure a
a = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ \a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  Star a -> f (a -> b)
ff <*> :: forall a b. Star f a (a -> b) -> Star f a a -> Star f a b
<*> Star a -> f a
fx = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ \a
a -> a -> f (a -> b)
ff a
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> f a
fx a
a
  Star a -> f a
ff  *> :: forall a b. Star f a a -> Star f a b -> Star f a b
*> Star a -> f b
fx = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ \a
a -> a -> f a
ff a
a  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> a -> f b
fx a
a
  Star a -> f a
ff <* :: forall a b. Star f a a -> Star f a b -> Star f a a
<*  Star a -> f b
fx = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ \a
a -> a -> f a
ff a
a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  a -> f b
fx a
a

instance Alternative f => Alternative (Star f a) where
  empty :: forall a. Star f a a
empty = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ \a
_ -> forall (f :: * -> *) a. Alternative f => f a
empty
  Star a -> f a
f <|> :: forall a. Star f a a -> Star f a a -> Star f a a
<|> Star a -> f a
g = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ \a
a -> a -> f a
f a
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> f a
g a
a

instance Monad f => Monad (Star f a) where
#if __GLASGOW_HASKELL__ < 710
  return a = Star $ \_ -> return a
#endif
  Star a -> f a
m >>= :: forall a b. Star f a a -> (a -> Star f a b) -> Star f a b
>>= a -> Star f a b
f = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ \ a
e -> do
    a
a <- a -> f a
m a
e
    forall {k} (f :: k -> *) d (c :: k). Star f d c -> d -> f c
runStar (a -> Star f a b
f a
a) a
e

instance MonadPlus f => MonadPlus (Star f a) where
  mzero :: forall a. Star f a a
mzero = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ \a
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
  Star a -> f a
f mplus :: forall a. Star f a a -> Star f a a -> Star f a a
`mplus` Star a -> f a
g = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ \a
a -> a -> f a
f a
a forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` a -> f a
g a
a

instance Distributive f => Distributive (Star f a) where
  distribute :: forall (f :: * -> *) a.
Functor f =>
f (Star f a a) -> Star f a (f a)
distribute f (Star f a a)
fs = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ \a
a -> forall (g :: * -> *) (f :: * -> *) a b.
(Distributive g, Functor f) =>
(a -> g b) -> f a -> g (f b)
collect ((forall a b. (a -> b) -> a -> b
$ a
a) forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# forall {k} (f :: k -> *) d (c :: k). Star f d c -> d -> f c
runStar) f (Star f a a)
fs

instance Monad f => Category (Star f) where
  id :: forall a. Star f a a
id = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall (m :: * -> *) a. Monad m => a -> m a
return
  Star b -> f c
f . :: forall b c a. Star f b c -> Star f a b -> Star f a c
. Star a -> f b
g = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall a b. (a -> b) -> a -> b
$ a -> f b
g forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> b -> f c
f

instance Contravariant f => Contravariant (Star f a) where
  contramap :: forall a' a. (a' -> a) -> Star f a a -> Star f a a'
contramap a' -> a
f (Star a -> f a
g) = forall {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> f a
g)
  {-# INLINE contramap #-}

------------------------------------------------------------------------------
-- Costar
------------------------------------------------------------------------------

-- | Lift a 'Functor' into a 'Profunctor' (backwards).
--
-- 'Costar' has a polymorphic kind since @5.6@.

-- Costar :: (k -> Type) -> k -> Type -> Type
newtype Costar f d c = Costar { forall {k} (f :: k -> *) (d :: k) c. Costar f d c -> f d -> c
runCostar :: f d -> c }

instance Functor f => Profunctor (Costar f) where
  dimap :: forall a b c d.
(a -> b) -> (c -> d) -> Costar f b c -> Costar f a d
dimap a -> b
ab c -> d
cd (Costar f b -> c
fbc) = forall {k} (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar (c -> d
cd forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f b -> c
fbc forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
ab)
  {-# INLINE dimap #-}
  lmap :: forall a b c. (a -> b) -> Costar f b c -> Costar f a c
lmap a -> b
k (Costar f b -> c
f) = forall {k} (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar (f b -> c
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
k)
  {-# INLINE lmap #-}
  rmap :: forall b c a. (b -> c) -> Costar f a b -> Costar f a c
rmap b -> c
k (Costar f a -> b
f) = forall {k} (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar (b -> c
k forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f a -> b
f)
  {-# INLINE rmap #-}
  #. :: forall a b c (q :: * -> * -> *).
Coercible c b =>
q b c -> Costar f a b -> Costar f a c
(#.) q b c
_ = coerce :: forall a b. Coercible a b => a -> b
coerce (\b
x -> b
x :: b) :: forall a b. Coercible b a => a -> b
  {-# INLINE (#.) #-}
  -- We cannot overload (.#) because we didn't write the 'Functor'.

instance Distributive (Costar f d) where
  distribute :: forall (f :: * -> *) a.
Functor f =>
f (Costar f d a) -> Costar f d (f a)
distribute f (Costar f d a)
fs = forall {k} (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar forall a b. (a -> b) -> a -> b
$ \f d
gd -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a b. (a -> b) -> a -> b
$ f d
gd) forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# forall {k} (f :: k -> *) (d :: k) c. Costar f d c -> f d -> c
runCostar) f (Costar f d a)
fs

instance Functor (Costar f a) where
  fmap :: forall a b. (a -> b) -> Costar f a a -> Costar f a b
fmap a -> b
k (Costar f a -> a
f) = forall {k} (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar (a -> b
k forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. f a -> a
f)
  {-# INLINE fmap #-}
  a
a <$ :: forall a b. a -> Costar f a b -> Costar f a a
<$ Costar f a b
_ = forall {k} (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar forall a b. (a -> b) -> a -> b
$ \f a
_ -> a
a
  {-# INLINE (<$) #-}

instance Applicative (Costar f a) where
  pure :: forall a. a -> Costar f a a
pure a
a = forall {k} (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar forall a b. (a -> b) -> a -> b
$ \f a
_ -> a
a
  Costar f a -> a -> b
ff <*> :: forall a b. Costar f a (a -> b) -> Costar f a a -> Costar f a b
<*> Costar f a -> a
fx = forall {k} (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar forall a b. (a -> b) -> a -> b
$ \f a
a -> f a -> a -> b
ff f a
a (f a -> a
fx f a
a)
  Costar f a a
_ *> :: forall a b. Costar f a a -> Costar f a b -> Costar f a b
*> Costar f a b
m = Costar f a b
m
  Costar f a a
m <* :: forall a b. Costar f a a -> Costar f a b -> Costar f a a
<* Costar f a b
_ = Costar f a a
m

instance Monad (Costar f a) where
  return :: forall a. a -> Costar f a a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Costar f a -> a
m >>= :: forall a b. Costar f a a -> (a -> Costar f a b) -> Costar f a b
>>= a -> Costar f a b
f = forall {k} (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar forall a b. (a -> b) -> a -> b
$ \ f a
x -> forall {k} (f :: k -> *) (d :: k) c. Costar f d c -> f d -> c
runCostar (a -> Costar f a b
f (f a -> a
m f a
x)) f a
x

------------------------------------------------------------------------------
-- Wrapped Profunctors
------------------------------------------------------------------------------

-- | Wrap an arrow for use as a 'Profunctor'.
--
-- 'WrappedArrow' has a polymorphic kind since @5.6@.

-- WrappedArrow :: (k1 -> k2 -> Type) -> (k1 -> k2 -> Type)
newtype WrappedArrow p a b = WrapArrow { forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
WrappedArrow p a b -> p a b
unwrapArrow :: p a b }

instance Category p => Category (WrappedArrow p) where
  WrapArrow p b c
f . :: forall (b :: k) (c :: k) (a :: k).
WrappedArrow p b c -> WrappedArrow p a b -> WrappedArrow p a c
. WrapArrow p a b
g = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow (p b c
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. p a b
g)
  {-# INLINE (.) #-}
  id :: forall (a :: k). WrappedArrow p a a
id = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
  {-# INLINE id #-}

instance Arrow p => Arrow (WrappedArrow p) where
  arr :: forall b c. (b -> c) -> WrappedArrow p b c
arr = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr
  {-# INLINE arr #-}
  first :: forall b c d. WrappedArrow p b c -> WrappedArrow p (b, d) (c, d)
first = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
WrappedArrow p a b -> p a b
unwrapArrow
  {-# INLINE first #-}
  second :: forall b c d. WrappedArrow p b c -> WrappedArrow p (d, b) (d, c)
second = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
WrappedArrow p a b -> p a b
unwrapArrow
  {-# INLINE second #-}
  WrapArrow p b c
a *** :: forall b c b' c'.
WrappedArrow p b c
-> WrappedArrow p b' c' -> WrappedArrow p (b, b') (c, c')
*** WrapArrow p b' c'
b = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow (p b c
a forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** p b' c'
b)
  {-# INLINE (***) #-}
  WrapArrow p b c
a &&& :: forall b c c'.
WrappedArrow p b c
-> WrappedArrow p b c' -> WrappedArrow p b (c, c')
&&& WrapArrow p b c'
b = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow (p b c
a forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& p b c'
b)
  {-# INLINE (&&&) #-}

instance ArrowZero p => ArrowZero (WrappedArrow p) where
  zeroArrow :: forall b c. WrappedArrow p b c
zeroArrow = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
  {-# INLINE zeroArrow #-}

instance ArrowChoice p => ArrowChoice (WrappedArrow p) where
  left :: forall b c d.
WrappedArrow p b c -> WrappedArrow p (Either b d) (Either c d)
left = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
WrappedArrow p a b -> p a b
unwrapArrow
  {-# INLINE left #-}
  right :: forall b c d.
WrappedArrow p b c -> WrappedArrow p (Either d b) (Either d c)
right = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
WrappedArrow p a b -> p a b
unwrapArrow
  {-# INLINE right #-}
  WrapArrow p b c
a +++ :: forall b c b' c'.
WrappedArrow p b c
-> WrappedArrow p b' c'
-> WrappedArrow p (Either b b') (Either c c')
+++ WrapArrow p b' c'
b = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow (p b c
a forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
+++ p b' c'
b)
  {-# INLINE (+++) #-}
  WrapArrow p b d
a ||| :: forall b d c.
WrappedArrow p b d
-> WrappedArrow p c d -> WrappedArrow p (Either b c) d
||| WrapArrow p c d
b = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow (p b d
a forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| p c d
b)
  {-# INLINE (|||) #-}

instance ArrowApply p => ArrowApply (WrappedArrow p) where
  app :: forall b c. WrappedArrow p (WrappedArrow p b c, b) c
app = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
WrappedArrow p a b -> p a b
unwrapArrow)
  {-# INLINE app #-}

instance ArrowLoop p => ArrowLoop (WrappedArrow p) where
  loop :: forall b d c. WrappedArrow p (b, d) (c, d) -> WrappedArrow p b c
loop = forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b d c.
ArrowLoop a =>
a (b, d) (c, d) -> a b c
loop forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} {k} (p :: k -> k -> *) (a :: k) (b :: k).
WrappedArrow p a b -> p a b
unwrapArrow
  {-# INLINE loop #-}

instance Arrow p => Profunctor (WrappedArrow p) where
  lmap :: forall a b c. (a -> b) -> WrappedArrow p b c -> WrappedArrow p a c
lmap = forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
(^>>)
  {-# INLINE lmap #-}
  rmap :: forall b c a. (b -> c) -> WrappedArrow p a b -> WrappedArrow p a c
rmap = forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
(^<<)
  {-# INLINE rmap #-}
  -- We cannot safely overload (#.) or (.#) because we didn't write the 'Arrow'.

------------------------------------------------------------------------------
-- Forget
------------------------------------------------------------------------------

-- | 'Forget' has a polymorphic kind since @5.6@.

-- Forget :: Type -> Type -> k -> Type
newtype Forget r a b = Forget { forall {k} r a (b :: k). Forget r a b -> a -> r
runForget :: a -> r }

instance Profunctor (Forget r) where
  dimap :: forall a b c d.
(a -> b) -> (c -> d) -> Forget r b c -> Forget r a d
dimap a -> b
f c -> d
_ (Forget b -> r
k) = forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget (b -> r
k forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b
f)
  {-# INLINE dimap #-}
  lmap :: forall a b c. (a -> b) -> Forget r b c -> Forget r a c
lmap a -> b
f (Forget b -> r
k) = forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget (b -> r
k forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b
f)
  {-# INLINE lmap #-}
  rmap :: forall b c a. (b -> c) -> Forget r a b -> Forget r a c
rmap b -> c
_ (Forget a -> r
k) = forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget a -> r
k
  {-# INLINE rmap #-}

instance Functor (Forget r a) where
  fmap :: forall a b. (a -> b) -> Forget r a a -> Forget r a b
fmap a -> b
_ (Forget a -> r
k) = forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget a -> r
k
  {-# INLINE fmap #-}

instance Foldable (Forget r a) where
  foldMap :: forall m a. Monoid m => (a -> m) -> Forget r a a -> m
foldMap a -> m
_ Forget r a a
_ = forall a. Monoid a => a
mempty
  {-# INLINE foldMap #-}

instance Traversable (Forget r a) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Forget r a a -> f (Forget r a b)
traverse a -> f b
_ (Forget a -> r
k) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget a -> r
k)
  {-# INLINE traverse #-}

instance Contravariant (Forget r a) where
  contramap :: forall a' a. (a' -> a) -> Forget r a a -> Forget r a a'
contramap a' -> a
_ (Forget a -> r
k) = forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget a -> r
k
  {-# INLINE contramap #-}

-- | Via @Semigroup r => (a -> r)@
--
-- @since 5.6.2
instance Semigroup r => Semigroup (Forget r a b) where
  Forget a -> r
f <> :: Forget r a b -> Forget r a b -> Forget r a b
<> Forget a -> r
g = forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget (a -> r
f forall a. Semigroup a => a -> a -> a
<> a -> r
g)
  {-# INLINE (<>) #-}

-- | Via @Monoid r => (a -> r)@
--
-- @since 5.6.2
instance Monoid r => Monoid (Forget r a b) where
  mempty :: Forget r a b
mempty = forall {k} r a (b :: k). (a -> r) -> Forget r a b
Forget forall a. Monoid a => a
mempty
  {-# INLINE mempty #-}
#if !(MIN_VERSION_base(4,11,0))
  mappend (Forget f) (Forget g) = Forget (mappend f g)
  {-# INLINE mappend #-}
#endif