{-# 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.Monoid hiding (Product)
import Data.Profunctor.Unsafe
import Data.Traversable
import Prelude hiding (id,(.))

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 { Star f d c -> d -> f c
runStar :: d -> f c }

instance Functor f => Profunctor (Star f) where
  dimap :: (a -> b) -> (c -> d) -> Star f b c -> Star f a d
dimap a -> b
ab c -> d
cd (Star b -> f c
bfc) = (a -> f d) -> Star f a d
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((c -> d) -> f c -> f d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
cd (f c -> f d) -> (a -> f c) -> a -> f d
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 (b -> f c) -> (a -> b) -> a -> f c
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 :: (a -> b) -> Star f b c -> Star f a c
lmap a -> b
k (Star b -> f c
f) = (a -> f c) -> Star f a c
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star (b -> f c
f (b -> f c) -> (a -> b) -> a -> f c
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 :: (b -> c) -> Star f a b -> Star f a c
rmap b -> c
k (Star a -> f b
f) = (a -> f c) -> Star f a c
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((b -> c) -> f b -> f c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> c
k (f b -> f c) -> (a -> f b) -> a -> f c
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 .# :: Star f b c -> q a b -> Star f a c
.# q a b
_ = Star f b c -> Star f a c
coerce Star f b c
p
  {-# INLINE (.#) #-}

instance Functor f => Functor (Star f a) where
  fmap :: (a -> b) -> Star f a a -> Star f a b
fmap = (a -> b) -> Star f a a -> Star f a b
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 :: a -> Star f a a
pure a
a = (a -> f a) -> Star f a a
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> f a) -> Star f a a) -> (a -> f a) -> Star f a a
forall a b. (a -> b) -> a -> b
$ \a
_ -> a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  Star a -> f (a -> b)
ff <*> :: Star f a (a -> b) -> Star f a a -> Star f a b
<*> Star a -> f a
fx = (a -> f b) -> Star f a b
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> f b) -> Star f a b) -> (a -> f b) -> Star f a b
forall a b. (a -> b) -> a -> b
$ \a
a -> a -> f (a -> b)
ff a
a f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> f a
fx a
a
  Star a -> f a
ff  *> :: Star f a a -> Star f a b -> Star f a b
*> Star a -> f b
fx = (a -> f b) -> Star f a b
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> f b) -> Star f a b) -> (a -> f b) -> Star f a b
forall a b. (a -> b) -> a -> b
$ \a
a -> a -> f a
ff a
a  f a -> f b -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> a -> f b
fx a
a
  Star a -> f a
ff <* :: Star f a a -> Star f a b -> Star f a a
<*  Star a -> f b
fx = (a -> f a) -> Star f a a
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> f a) -> Star f a a) -> (a -> f a) -> Star f a a
forall a b. (a -> b) -> a -> b
$ \a
a -> a -> f a
ff a
a f a -> f b -> f 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 :: Star f a a
empty = (a -> f a) -> Star f a a
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> f a) -> Star f a a) -> (a -> f a) -> Star f a a
forall a b. (a -> b) -> a -> b
$ \a
_ -> f a
forall (f :: * -> *) a. Alternative f => f a
empty
  Star a -> f a
f <|> :: Star f a a -> Star f a a -> Star f a a
<|> Star a -> f a
g = (a -> f a) -> Star f a a
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> f a) -> Star f a a) -> (a -> f a) -> Star f a a
forall a b. (a -> b) -> a -> b
$ \a
a -> a -> f a
f a
a f a -> f a -> f 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 >>= :: Star f a a -> (a -> Star f a b) -> Star f a b
>>= a -> Star f a b
f = (a -> f b) -> Star f a b
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> f b) -> Star f a b) -> (a -> f b) -> Star f a b
forall a b. (a -> b) -> a -> b
$ \ a
e -> do
    a
a <- a -> f a
m a
e
    Star f a b -> a -> f b
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 :: Star f a a
mzero = (a -> f a) -> Star f a a
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> f a) -> Star f a a) -> (a -> f a) -> Star f a a
forall a b. (a -> b) -> a -> b
$ \a
_ -> f a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  Star a -> f a
f mplus :: Star f a a -> Star f a a -> Star f a a
`mplus` Star a -> f a
g = (a -> f a) -> Star f a a
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> f a) -> Star f a a) -> (a -> f a) -> Star f a a
forall a b. (a -> b) -> a -> b
$ \a
a -> a -> f a
f a
a f a -> f a -> f 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 :: f (Star f a a) -> Star f a (f a)
distribute f (Star f a a)
fs = (a -> f (f a)) -> Star f a (f a)
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> f (f a)) -> Star f a (f a))
-> (a -> f (f a)) -> Star f a (f a)
forall a b. (a -> b) -> a -> b
$ \a
a -> (Star f a a -> f a) -> f (Star f a a) -> f (f a)
forall (g :: * -> *) (f :: * -> *) a b.
(Distributive g, Functor f) =>
(a -> g b) -> f a -> g (f b)
collect (((a -> f a) -> a -> f a
forall a b. (a -> b) -> a -> b
$ a
a) ((a -> f a) -> f a)
-> (Star f a a -> a -> f a) -> Star f a a -> f a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# Star f a a -> a -> f a
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 :: Star f a a
id = (a -> f a) -> Star f a a
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return
  Star b -> f c
f . :: Star f b c -> Star f a b -> Star f a c
. Star a -> f b
g = (a -> f c) -> Star f a c
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> f c) -> Star f a c) -> (a -> f c) -> Star f a c
forall a b. (a -> b) -> a -> b
$ a -> f b
g (a -> f b) -> (b -> f c) -> a -> f c
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 :: (a -> b) -> Star f a b -> Star f a a
contramap a -> b
f (Star a -> f b
g) = (a -> f a) -> Star f a a
forall k (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star ((a -> b) -> f b -> f a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
f (f b -> f a) -> (a -> f b) -> a -> f a
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
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 { Costar f d c -> f d -> c
runCostar :: f d -> c }

instance Functor f => Profunctor (Costar f) where
  dimap :: (a -> b) -> (c -> d) -> Costar f b c -> Costar f a d
dimap a -> b
ab c -> d
cd (Costar f b -> c
fbc) = (f a -> d) -> Costar f a d
forall k (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar (c -> d
cd (c -> d) -> (f a -> c) -> f a -> d
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 (f b -> c) -> (f a -> f b) -> f a -> c
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 a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
ab)
  {-# INLINE dimap #-}
  lmap :: (a -> b) -> Costar f b c -> Costar f a c
lmap a -> b
k (Costar f b -> c
f) = (f a -> c) -> Costar f a c
forall k (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar (f b -> c
f (f b -> c) -> (f a -> f b) -> f a -> c
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 a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
k)
  {-# INLINE lmap #-}
  rmap :: (b -> c) -> Costar f a b -> Costar f a c
rmap b -> c
k (Costar f a -> b
f) = (f a -> c) -> Costar f a c
forall k (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar (b -> c
k (b -> c) -> (f a -> b) -> f a -> c
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 #-}
  #. :: q b c -> Costar f a b -> Costar f a c
(#.) q b c
_ = (b -> 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 :: f (Costar f d a) -> Costar f d (f a)
distribute f (Costar f d a)
fs = (f d -> f a) -> Costar f d (f a)
forall k (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar ((f d -> f a) -> Costar f d (f a))
-> (f d -> f a) -> Costar f d (f a)
forall a b. (a -> b) -> a -> b
$ \f d
gd -> (Costar f d a -> a) -> f (Costar f d a) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((f d -> a) -> f d -> a
forall a b. (a -> b) -> a -> b
$ f d
gd) ((f d -> a) -> a)
-> (Costar f d a -> f d -> a) -> Costar f d a -> a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# Costar f d a -> f d -> a
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 :: (a -> b) -> Costar f a a -> Costar f a b
fmap a -> b
k (Costar f a -> a
f) = (f a -> b) -> Costar f a b
forall k (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar (a -> b
k (a -> b) -> (f a -> a) -> f a -> b
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 <$ :: a -> Costar f a b -> Costar f a a
<$ Costar f a b
_ = (f a -> a) -> Costar f a a
forall k (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar ((f a -> a) -> Costar f a a) -> (f a -> a) -> Costar f a a
forall a b. (a -> b) -> a -> b
$ \f a
_ -> a
a
  {-# INLINE (<$) #-}

instance Applicative (Costar f a) where
  pure :: a -> Costar f a a
pure a
a = (f a -> a) -> Costar f a a
forall k (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar ((f a -> a) -> Costar f a a) -> (f a -> a) -> Costar f a a
forall a b. (a -> b) -> a -> b
$ \f a
_ -> a
a
  Costar f a -> a -> b
ff <*> :: Costar f a (a -> b) -> Costar f a a -> Costar f a b
<*> Costar f a -> a
fx = (f a -> b) -> Costar f a b
forall k (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar ((f a -> b) -> Costar f a b) -> (f a -> b) -> Costar f a b
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
_ *> :: 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 <* :: 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 :: a -> Costar f a a
return = a -> Costar f a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Costar f a -> a
m >>= :: Costar f a a -> (a -> Costar f a b) -> Costar f a b
>>= a -> Costar f a b
f = (f a -> b) -> Costar f a b
forall k (f :: k -> *) (d :: k) c. (f d -> c) -> Costar f d c
Costar ((f a -> b) -> Costar f a b) -> (f a -> b) -> Costar f a b
forall a b. (a -> b) -> a -> b
$ \ f a
x -> Costar f a b -> f a -> b
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 { WrappedArrow p a b -> p a b
unwrapArrow :: p a b }

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

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

instance ArrowChoice p => ArrowChoice (WrappedArrow p) where
  left :: WrappedArrow p b c -> WrappedArrow p (Either b d) (Either c d)
left = p (Either b d) (Either c d)
-> WrappedArrow p (Either b d) (Either c d)
forall k k (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow (p (Either b d) (Either c d)
 -> WrappedArrow p (Either b d) (Either c d))
-> (WrappedArrow p b c -> p (Either b d) (Either c d))
-> WrappedArrow p b c
-> WrappedArrow p (Either b d) (Either c d)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. p b c -> p (Either b d) (Either c d)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (p b c -> p (Either b d) (Either c d))
-> (WrappedArrow p b c -> p b c)
-> WrappedArrow p b c
-> p (Either b d) (Either c d)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WrappedArrow p b c -> p b c
forall k k (p :: k -> k -> *) (a :: k) (b :: k).
WrappedArrow p a b -> p a b
unwrapArrow
  {-# INLINE left #-}
  right :: WrappedArrow p b c -> WrappedArrow p (Either d b) (Either d c)
right = p (Either d b) (Either d c)
-> WrappedArrow p (Either d b) (Either d c)
forall k k (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow (p (Either d b) (Either d c)
 -> WrappedArrow p (Either d b) (Either d c))
-> (WrappedArrow p b c -> p (Either d b) (Either d c))
-> WrappedArrow p b c
-> WrappedArrow p (Either d b) (Either d c)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. p b c -> p (Either d b) (Either d c)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right (p b c -> p (Either d b) (Either d c))
-> (WrappedArrow p b c -> p b c)
-> WrappedArrow p b c
-> p (Either d b) (Either d c)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WrappedArrow p b c -> p b 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 +++ :: WrappedArrow p b c
-> WrappedArrow p b' c'
-> WrappedArrow p (Either b b') (Either c c')
+++ WrapArrow p b' c'
b = p (Either b b') (Either c c')
-> WrappedArrow p (Either b b') (Either c c')
forall k k (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow (p b c
a p b c -> p b' c' -> p (Either b b') (Either c c')
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 ||| :: WrappedArrow p b d
-> WrappedArrow p c d -> WrappedArrow p (Either b c) d
||| WrapArrow p c d
b = p (Either b c) d -> WrappedArrow p (Either b c) d
forall k k (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow (p b d
a p b d -> p c d -> p (Either b c) d
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 :: WrappedArrow p (WrappedArrow p b c, b) c
app = p (WrappedArrow p b c, b) c
-> WrappedArrow p (WrappedArrow p b c, b) c
forall k k (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow (p (WrappedArrow p b c, b) c
 -> WrappedArrow p (WrappedArrow p b c, b) c)
-> p (WrappedArrow p b c, b) c
-> WrappedArrow p (WrappedArrow p b c, b) c
forall a b. (a -> b) -> a -> b
$ p (p b c, b) c
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app p (p b c, b) c
-> p (WrappedArrow p b c, b) (p b c, b)
-> p (WrappedArrow p b c, b) c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((WrappedArrow p b c, b) -> (p b c, b))
-> p (WrappedArrow p b c, b) (p b c, b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((WrappedArrow p b c -> p b c)
-> (WrappedArrow p b c, b) -> (p b c, b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first WrappedArrow p b c -> p b c
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 :: WrappedArrow p (b, d) (c, d) -> WrappedArrow p b c
loop = p b c -> WrappedArrow p b c
forall k k (p :: k -> k -> *) (a :: k) (b :: k).
p a b -> WrappedArrow p a b
WrapArrow (p b c -> WrappedArrow p b c)
-> (WrappedArrow p (b, d) (c, d) -> p b c)
-> WrappedArrow p (b, d) (c, d)
-> WrappedArrow p b c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. p (b, d) (c, d) -> p b c
forall (a :: * -> * -> *) b d c.
ArrowLoop a =>
a (b, d) (c, d) -> a b c
loop (p (b, d) (c, d) -> p b c)
-> (WrappedArrow p (b, d) (c, d) -> p (b, d) (c, d))
-> WrappedArrow p (b, d) (c, d)
-> p b c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WrappedArrow p (b, d) (c, d) -> p (b, d) (c, d)
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 :: (a -> b) -> WrappedArrow p b c -> WrappedArrow p a c
lmap = (a -> b) -> WrappedArrow p b c -> WrappedArrow p a c
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
(^>>)
  {-# INLINE lmap #-}
  rmap :: (b -> c) -> WrappedArrow p a b -> WrappedArrow p a c
rmap = (b -> c) -> WrappedArrow p a b -> WrappedArrow p a c
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 { Forget r a b -> a -> r
runForget :: a -> r }

instance Profunctor (Forget r) where
  dimap :: (a -> b) -> (c -> d) -> Forget r b c -> Forget r a d
dimap a -> b
f c -> d
_ (Forget b -> r
k) = (a -> r) -> Forget r a d
forall k r a (b :: k). (a -> r) -> Forget r a b
Forget (b -> r
k (b -> r) -> (a -> b) -> a -> r
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 :: (a -> b) -> Forget r b c -> Forget r a c
lmap a -> b
f (Forget b -> r
k) = (a -> r) -> Forget r a c
forall k r a (b :: k). (a -> r) -> Forget r a b
Forget (b -> r
k (b -> r) -> (a -> b) -> a -> r
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 :: (b -> c) -> Forget r a b -> Forget r a c
rmap b -> c
_ (Forget a -> r
k) = (a -> r) -> Forget r a c
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 :: (a -> b) -> Forget r a a -> Forget r a b
fmap a -> b
_ (Forget a -> r
k) = (a -> r) -> Forget r a b
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 :: (a -> m) -> Forget r a a -> m
foldMap a -> m
_ Forget r a a
_ = m
forall a. Monoid a => a
mempty
  {-# INLINE foldMap #-}

instance Traversable (Forget r a) where
  traverse :: (a -> f b) -> Forget r a a -> f (Forget r a b)
traverse a -> f b
_ (Forget a -> r
k) = Forget r a b -> f (Forget r a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> r) -> Forget r a b
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 :: (a -> b) -> Forget r a b -> Forget r a a
contramap a -> b
_ (Forget a -> r
k) = (a -> r) -> Forget r a a
forall k r a (b :: k). (a -> r) -> Forget r a b
Forget a -> r
k
  {-# INLINE contramap #-}