-- |
-- Module      : Data.HFunctor.Route
-- Copyright   : (c) Justin Le 2019
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- This module contains the useful combinators 'Pre' and 'Post', which
-- enhances a functor with a "route" to and from the outside world; even if
-- the functor itself is existentially closed in a functor combinator, the
-- route will provide line to the outside world for extraction or
-- injection.
--
-- See 'Pre' and 'Post' for more information.
--
-- @since 0.3.4.0
module Data.HFunctor.Route (
  -- * Routing Combinators
  -- ** Contravariant
    Pre(..)
  , interpretPre, getPre, retractPre
  , injectPre, mapPre
  , preDivisible, preDivise, preContravariant
  -- ** Covariant
  , Post(..)
  , interpretPost, getPost, retractPost
  , injectPost, mapPost
  , postPlus, postAlt, postFunctor
  -- * Wrapped Invariant
  -- ** Contravariant
  , PreT(..)
  , preDivisibleT, preDiviseT, preContravariantT
  -- ** Covariant
  , PostT(..)
  , postPlusT, postAltT, postFunctorT
  ) where

import           Control.Natural
import           Data.Functor.Contravariant
import           Data.Functor.Contravariant.Divise
import           Data.Functor.Contravariant.Divisible
import           Data.Functor.Invariant
import           Data.Functor.Plus
import           Data.HFunctor
import           Data.HFunctor.Interpret
import           Data.Profunctor
import           Data.Void

-- | A useful helper type to use with a covariant functor combinator that
-- allows you to tag along contravariant access to all @f@s inside the
-- combinator.
--
-- Maybe most usefully, it can be used with 'Ap'.  Remember that @'Ap' f a@
-- is a collection of @f x@s, with each x existentially wrapped.  Now, for
-- a @'Ap' (Pre a f) a@, it will be a collection of @f x@ and @a -> x@s:
-- not only each individual part, but a way to "select" that individual
-- part from the overal @a@.
--
-- So, you can imagine @'Ap' ('Pre' a f) b@ as a collection of @f x@ that
-- consumes @a@ and produces @b@.
--
-- When @a@ and @b@ are the same, @'Ap' ('Pre' a f) a@ is like the free
-- invariant sequencer.  That is, in a sense, @'Ap' ('Pre' a f) a@ contains
-- both contravariant and covariant sequences side-by-side, /consuming/
-- @a@s and also /producing/ @a@s.
--
-- You can build up these values with 'injectPre', and then use whatever
-- typeclasses your @t@ normally supports to build it up, like
-- 'Applicative' (for 'Ap').  You can then interpret it into both its
-- contravariant and covariant contexts:
--
-- @
-- -- interpret the covariant part
-- runCovariant :: 'Applicative' g => (f ~> g) -> Ap (Pre a f) a -> g a
-- runCovariant f = interpret (f . getPre)
--
-- -- interpret the contravariant part
-- runContravariant :: 'Divisible' g => (f ~> g) -> Ap (Pre a f) a -> g a
-- runContravariant = preDivisible
-- @
--
-- The 'PreT' type wraps up @'Ap' ('Pre' a f) a@ into a type @'PreT' 'Ap'
-- f a@, with nice instances/helpers.
--
-- An example of a usage of this in the real world is the /unjson/
-- library's record type constructor, to implement bidrectional
-- serializers for product types.
data Pre  a f b = (a -> b) :>$<: f b
  deriving a -> Pre a f b -> Pre a f a
(a -> b) -> Pre a f a -> Pre a f b
(forall a b. (a -> b) -> Pre a f a -> Pre a f b)
-> (forall a b. a -> Pre a f b -> Pre a f a) -> Functor (Pre a f)
forall a b. a -> Pre a f b -> Pre a f a
forall a b. (a -> b) -> Pre a f a -> Pre a f b
forall a (f :: * -> *) a b.
Functor f =>
a -> Pre a f b -> Pre a f a
forall a (f :: * -> *) a b.
Functor f =>
(a -> b) -> Pre a f a -> Pre a f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Pre a f b -> Pre a f a
$c<$ :: forall a (f :: * -> *) a b.
Functor f =>
a -> Pre a f b -> Pre a f a
fmap :: (a -> b) -> Pre a f a -> Pre a f b
$cfmap :: forall a (f :: * -> *) a b.
Functor f =>
(a -> b) -> Pre a f a -> Pre a f b
Functor


-- | A useful helper type to use with a contravariant functor combinator that
-- allows you to tag along covariant access to all @f@s inside the
-- combinator.
--
-- Maybe most usefully, it can be used with 'Dec'.  Remember that @'Dec' f a@
-- is a collection of @f x@s, with each x existentially wrapped.  Now, for
-- a @'Dec' (Post a f) a@, it will be a collection of @f x@ and @x -> a@s:
-- not only each individual part, but a way to "re-embed" that individual
-- part into overal @a@.
--
-- So, you can imagine @'Dec' ('Post' a f) b@ as a collection of @f x@ that
-- consumes @b@ and produces @a@.
--
-- When @a@ and @b@ are the same, @'Dec' ('Post' a f) a@ is like the free
-- invariant sequencer.  That is, in a sense, @'Dec' ('Post' a f) a@ contains
-- both contravariant and covariant sequences side-by-side, /consuming/
-- @a@s and also /producing/ @a@s.
--
-- You can build up these values with 'injectPre', and then use whatever
-- typeclasses your @t@ normally supports to build it up, like
-- 'Conclude' (for 'Div').  You can then interpret it into both its
-- contravariant and covariant contexts:
--
-- @
-- -- interpret the covariant part
-- runCovariant :: 'Plus' g => (f ~> g) -> Div (Post a f) a -> g a
-- runCovariant f = interpret (f . getPost)
--
-- -- interpret the contravariant part
-- runContravariant :: 'Conclude' g => (f ~> g) -> Div (Post a f) a -> g a
-- runContravariant = preDivisible
-- @
--
-- The 'PostT' type wraps up @'Dec' ('Post' a f) a@ into a type @'PostT'
-- 'Dec'
-- f a@, with nice instances/helpers.
--
-- An example of a usage of this in the real world is a possible
-- implementation of the /unjson/ library's sum type constructor, to
-- implement bidrectional serializers for sum types.
data Post a f b = (b -> a) :<$>: f b

instance Contravariant f => Contravariant (Post a f) where
    contramap :: (a -> b) -> Post a f b -> Post a f a
contramap f :: a -> b
f (g :: b -> a
g :<$>: x :: f b
x) = b -> a
g (b -> a) -> (a -> b) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> a) -> f a -> Post a f a
forall a (f :: * -> *) b. (b -> a) -> f b -> Post a f b
:<$>: (a -> b) -> f b -> f a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
f f b
x

infixl 4 :>$<:
infixl 4 :<$>:

-- | Turn the covariant functor combinator @t@ into an 'Invariant'
-- functor combinator; if @t f a@ "produces" @a@s, then @'PreT' t f a@ will
-- both consume and produce @a@s.
--
-- You can run this normally as if it were a @t f a@ by using 'interpret';
-- however, you can also interpret into covariant contexts with
-- 'preDivisibleT', 'preDiviseT', and 'preContravariantT'.
--
-- See 'Pre' for more information.
newtype PreT t f a = PreT { PreT t f a -> t (Pre a f) a
unPreT :: t (Pre a f) a }

instance (HFunctor t, forall x. Functor (t (Pre x f))) => Invariant (PreT t f) where
    invmap :: (a -> b) -> (b -> a) -> PreT t f a -> PreT t f b
invmap f :: a -> b
f g :: b -> a
g = t (Pre b f) b -> PreT t f b
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
t (Pre a f) a -> PreT t f a
PreT
               (t (Pre b f) b -> PreT t f b)
-> (PreT t f a -> t (Pre b f) b) -> PreT t f a -> PreT t f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pre a f ~> Pre b f) -> t (Pre a f) ~> t (Pre b f)
forall k k (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor t =>
(f ~> g) -> t f ~> t g
hmap ((b -> a) -> Pre a f x -> Pre b f x
forall c a (f :: * -> *) b. (c -> a) -> Pre a f b -> Pre c f b
mapPre b -> a
g)
               (t (Pre a f) b -> t (Pre b f) b)
-> (PreT t f a -> t (Pre a f) b) -> PreT t f a -> t (Pre b f) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> t (Pre a f) a -> t (Pre a f) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f
               (t (Pre a f) a -> t (Pre a f) b)
-> (PreT t f a -> t (Pre a f) a) -> PreT t f a -> t (Pre a f) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreT t f a -> t (Pre a f) a
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
PreT t f a -> t (Pre a f) a
unPreT

instance HFunctor t => HFunctor (PreT t) where
    hmap :: (f ~> g) -> PreT t f ~> PreT t g
hmap f :: f ~> g
f = t (Pre x g) x -> PreT t g x
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
t (Pre a f) a -> PreT t f a
PreT (t (Pre x g) x -> PreT t g x)
-> (PreT t f x -> t (Pre x g) x) -> PreT t f x -> PreT t g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pre x f ~> Pre x g) -> t (Pre x f) ~> t (Pre x g)
forall k k (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor t =>
(f ~> g) -> t f ~> t g
hmap ((f ~> g) -> Pre x f ~> Pre x g
forall k k (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor t =>
(f ~> g) -> t f ~> t g
hmap f ~> g
f) (t (Pre x f) x -> t (Pre x g) x)
-> (PreT t f x -> t (Pre x f) x) -> PreT t f x -> t (Pre x g) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreT t f x -> t (Pre x f) x
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
PreT t f a -> t (Pre a f) a
unPreT

instance Inject t => Inject (PreT t) where
    inject :: f x -> PreT t f x
inject = t (Pre x f) x -> PreT t f x
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
t (Pre a f) a -> PreT t f a
PreT (t (Pre x f) x -> PreT t f x)
-> (f x -> t (Pre x f) x) -> f x -> PreT t f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pre x f x -> t (Pre x f) x
forall k (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
inject (Pre x f x -> t (Pre x f) x)
-> (f x -> Pre x f x) -> f x -> t (Pre x f) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> x
forall a. a -> a
id (x -> x) -> f x -> Pre x f x
forall a (f :: * -> *) b. (a -> b) -> f b -> Pre a f b
:>$<:)

instance Interpret t f => Interpret (PreT t) f where
    interpret :: (g ~> f) -> PreT t g ~> f
interpret f :: g ~> f
f = (g ~> f) -> t g ~> f
forall k (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
Interpret t f =>
(g ~> f) -> t g ~> f
interpret g ~> f
f (t g x -> f x) -> (PreT t g x -> t g x) -> PreT t g x -> f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pre x g ~> g) -> t (Pre x g) ~> t g
forall k k (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor t =>
(f ~> g) -> t f ~> t g
hmap Pre x g ~> g
forall a (f :: * -> *) b. Pre a f b -> f b
getPre (t (Pre x g) x -> t g x)
-> (PreT t g x -> t (Pre x g) x) -> PreT t g x -> t g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreT t g x -> t (Pre x g) x
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
PreT t f a -> t (Pre a f) a
unPreT

-- | Turn the contravariant functor combinator @t@ into an 'Invariant'
-- functor combinator; if @t f a@ "consumes" @a@s, then @'PostT' t f a@ will
-- both consume and produce @a@s.
--
-- You can run this normally as if it were a @t f a@ by using 'interpret';
-- however, you can also interpret into covariant contexts with
-- 'postPlusT', 'postAltT', and 'postFunctorT'.
--
-- See 'Post' for more information.
newtype PostT t f a = PostT { PostT t f a -> t (Post a f) a
unPostT :: t (Post a f) a }

instance (HFunctor t, forall x. Contravariant (t (Post x f))) => Invariant (PostT t f) where
    invmap :: (a -> b) -> (b -> a) -> PostT t f a -> PostT t f b
invmap f :: a -> b
f g :: b -> a
g = t (Post b f) b -> PostT t f b
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
t (Post a f) a -> PostT t f a
PostT
               (t (Post b f) b -> PostT t f b)
-> (PostT t f a -> t (Post b f) b) -> PostT t f a -> PostT t f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Post a f ~> Post b f) -> t (Post a f) ~> t (Post b f)
forall k k (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor t =>
(f ~> g) -> t f ~> t g
hmap ((a -> b) -> Post a f x -> Post b f x
forall a c (f :: * -> *) b. (a -> c) -> Post a f b -> Post c f b
mapPost a -> b
f)
               (t (Post a f) b -> t (Post b f) b)
-> (PostT t f a -> t (Post a f) b) -> PostT t f a -> t (Post b f) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a) -> t (Post a f) a -> t (Post a f) b
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap b -> a
g
               (t (Post a f) a -> t (Post a f) b)
-> (PostT t f a -> t (Post a f) a) -> PostT t f a -> t (Post a f) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostT t f a -> t (Post a f) a
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
PostT t f a -> t (Post a f) a
unPostT

-- | Run a @'PreT' t@ into a contravariant 'Divisible' context.  To run it
-- in @t@s normal covariant context, use 'interpret'.
--
-- This will work for types where there are a possibly-empty collection of
-- @f@s, like:
--
-- @
-- preDivisibleT :: Divisible g => (f ~> g) -> PreT 'Ap'    f ~> g
-- preDivisibleT :: Divisible g => (f ~> g) -> PreT 'ListF' f ~> g
-- @
preDivisibleT
    :: (forall m. Monoid m => Interpret t (AltConst m), Divisible g)
    => (f ~> g)
    -> PreT t f ~> g
preDivisibleT :: (f ~> g) -> PreT t f ~> g
preDivisibleT f :: f ~> g
f = (f ~> g) -> t (Pre x f) x -> g x
forall (t :: (* -> *) -> * -> *) (g :: * -> *) (f :: * -> *) a b.
(forall m. Monoid m => Interpret t (AltConst m), Divisible g) =>
(f ~> g) -> t (Pre a f) b -> g a
preDivisible f ~> g
f (t (Pre x f) x -> g x)
-> (PreT t f x -> t (Pre x f) x) -> PreT t f x -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreT t f x -> t (Pre x f) x
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
PreT t f a -> t (Pre a f) a
unPreT

-- | Run a @'PreT' t@ into a contravariant 'Divise' context.  To run it in
-- @t@s normal covariant context, use 'interpret'.
--
-- This will work for types where there is a non-empty collection of
-- @f@s, like:
--
-- @
-- preDiviseT :: Divise g => (f ~> g) -> PreT 'Ap1'       f ~> g
-- preDiviseT :: Divise g => (f ~> g) -> PreT 'NonEmptyF' f ~> g
-- @
preDiviseT
    :: (forall m. Semigroup m => Interpret t (AltConst m), Divise g)
    => (f ~> g)
    -> PreT t f ~> g
preDiviseT :: (f ~> g) -> PreT t f ~> g
preDiviseT f :: f ~> g
f = (f ~> g) -> t (Pre x f) x -> g x
forall (t :: (* -> *) -> * -> *) (g :: * -> *) (f :: * -> *) a b.
(forall m. Semigroup m => Interpret t (AltConst m), Divise g) =>
(f ~> g) -> t (Pre a f) b -> g a
preDivise f ~> g
f (t (Pre x f) x -> g x)
-> (PreT t f x -> t (Pre x f) x) -> PreT t f x -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreT t f x -> t (Pre x f) x
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
PreT t f a -> t (Pre a f) a
unPreT

-- | Run a @'PreT' t@ into a 'Contravariant'.  To run it in
-- @t@s normal covariant context, use 'interpret'.
--
-- This will work for types where there is exactly one @f@ inside:
--
-- @
-- preContravariantT :: Contravariant g => (f ~> g) -> PreT 'Step'     f ~> g
-- preContravariantT :: Contravariant g => (f ~> g) -> PreT 'Coyoneda' f ~> g
-- @
preContravariantT
    :: (forall m. Interpret t (AltConst m), Contravariant g)
    => (f ~> g)
    -> PreT t f ~> g
preContravariantT :: (f ~> g) -> PreT t f ~> g
preContravariantT f :: f ~> g
f = (f ~> g) -> t (Pre x f) x -> g x
forall (t :: (* -> *) -> * -> *) (g :: * -> *) (f :: * -> *) a b.
(forall m. Interpret t (AltConst m), Contravariant g) =>
(f ~> g) -> t (Pre a f) b -> g a
preContravariant f ~> g
f (t (Pre x f) x -> g x)
-> (PreT t f x -> t (Pre x f) x) -> PreT t f x -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreT t f x -> t (Pre x f) x
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
PreT t f a -> t (Pre a f) a
unPreT

-- | Run a "pre-routed" @t@ into a contravariant 'Divisible' context.  To
-- run it in @t@s normal covariant context, use 'interpret' with 'getPre'.
--
-- This will work for types where there are a possibly-empty collection of
-- @f@s, like:
--
-- @
-- preDivisible :: Divisible g => (f ~> g) -> 'Ap'    ('Pre' a f) b -> g a
-- preDivisible :: Divisible g => (f ~> g) -> 'ListF' ('Pre' a f) b -> g a
-- @
preDivisible
    :: (forall m. Monoid m => Interpret t (AltConst m), Divisible g)
    => (f ~> g)
    -> t (Pre a f) b
    -> g a
preDivisible :: (f ~> g) -> t (Pre a f) b -> g a
preDivisible f :: f ~> g
f = (g a -> g a -> g a) -> g a -> [g a] -> g a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((a -> (a, a)) -> g a -> g a -> g a
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide (\x :: a
x -> (a
x,a
x))) g a
forall (f :: * -> *) a. Divisible f => f a
conquer
               ([g a] -> g a) -> (t (Pre a f) b -> [g a]) -> t (Pre a f) b -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. Pre a f x -> g a) -> t (Pre a f) b -> [g a]
forall k (t :: (k -> *) -> k -> *) (f :: k -> *) b (a :: k).
(forall m. Monoid m => Interpret t (AltConst m)) =>
(forall (x :: k). f x -> b) -> t f a -> [b]
icollect ((f ~> g) -> Pre a f x -> g a
forall (g :: * -> *) (f :: * -> *) a b.
Contravariant g =>
(f ~> g) -> Pre a f b -> g a
interpretPre f ~> g
f)

-- | Run a "pre-routed" @t@ into a contravariant 'Divise' context.  To
-- run it in @t@s normal covariant context, use 'interpret' with 'getPre'.
--
-- This will work for types where there are is a non-empty collection of
-- @f@s, like:
--
-- @
-- preDivise :: Divise g => (f ~> g) -> 'Ap1'       ('Pre' a f) b -> g a
-- preDivise :: Divise g => (f ~> g) -> 'NonEmptyF' ('Pre' a f) b -> g a
-- @
preDivise
    :: (forall m. Semigroup m => Interpret t (AltConst m), Divise g)
    => (f ~> g)
    -> t (Pre a f) b
    -> g a
preDivise :: (f ~> g) -> t (Pre a f) b -> g a
preDivise f :: f ~> g
f = (g a -> g a -> g a) -> NonEmpty (g a) -> g a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 g a -> g a -> g a
forall (f :: * -> *) a. Divise f => f a -> f a -> f a
(<:>) (NonEmpty (g a) -> g a)
-> (t (Pre a f) b -> NonEmpty (g a)) -> t (Pre a f) b -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. Pre a f x -> g a) -> t (Pre a f) b -> NonEmpty (g a)
forall k (t :: (k -> *) -> k -> *) (f :: k -> *) b (a :: k).
(forall m. Semigroup m => Interpret t (AltConst m)) =>
(forall (x :: k). f x -> b) -> t f a -> NonEmpty b
icollect1 ((f ~> g) -> Pre a f x -> g a
forall (g :: * -> *) (f :: * -> *) a b.
Contravariant g =>
(f ~> g) -> Pre a f b -> g a
interpretPre f ~> g
f)

-- | Run a "pre-routed" @t@ into a 'Contravariant'.  To run it in @t@s
-- normal covariant context, use 'interpret' with 'getPre'.
--
-- This will work for types where there is exactly one @f@ inside:
--
-- @
-- preContravariant :: Contravariant g => (f ~> g) -> 'Step'     ('Pre' a f) b -> g a
-- preContravariant :: Contravariant g => (f ~> g) -> 'Coyoneda' ('Pre' a f) b -> g a
-- @
preContravariant
    :: (forall m. Interpret t (AltConst m), Contravariant g)
    => (f ~> g)
    -> t (Pre a f) b
    -> g a
preContravariant :: (f ~> g) -> t (Pre a f) b -> g a
preContravariant f :: f ~> g
f = (forall x. Pre a f x -> g a) -> t (Pre a f) b -> g a
forall k (t :: (k -> *) -> k -> *) b (f :: k -> *) (a :: k).
Interpret t (AltConst b) =>
(forall (x :: k). f x -> b) -> t f a -> b
iget ((f ~> g) -> Pre a f x -> g a
forall (g :: * -> *) (f :: * -> *) a b.
Contravariant g =>
(f ~> g) -> Pre a f b -> g a
interpretPre f ~> g
f)

-- | Run a @'PostT' t@ into a covariant 'Plus' context.  To run it
-- in @t@s normal contravariant context, use 'interpret'.
--
-- This will work for types where there are a possibly-empty collection of
-- @f@s, like:
--
-- @
-- postPlusT :: Plus g => (f ~> g) -> PreT 'Dec' f ~> g
-- postPlusT :: Plus g => (f ~> g) -> PreT 'Div' f ~> g
-- @
postPlusT
    :: (forall m. Monoid m => Interpret t (AltConst m), Plus g)
    => (f ~> g)
    -> PostT t f ~> g
postPlusT :: (f ~> g) -> PostT t f ~> g
postPlusT f :: f ~> g
f = (f ~> g) -> t (Post x f) x -> g x
forall (t :: (* -> *) -> * -> *) (g :: * -> *) (f :: * -> *) a b.
(forall m. Monoid m => Interpret t (AltConst m), Plus g) =>
(f ~> g) -> t (Post a f) b -> g a
postPlus f ~> g
f (t (Post x f) x -> g x)
-> (PostT t f x -> t (Post x f) x) -> PostT t f x -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostT t f x -> t (Post x f) x
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
PostT t f a -> t (Post a f) a
unPostT

-- | Run a @'PostT' t@ into a covariant 'Alt' context.  To run it
-- in @t@s normal contravariant context, use 'interpret'.
--
-- This will work for types where there is a non-empty collection of
-- @f@s, like:
--
-- @
-- postAltT :: Alt g => (f ~> g) -> PreT 'Dec1' f ~> g
-- postAltT :: Alt g => (f ~> g) -> PreT 'Div1' f ~> g
-- @
postAltT
    :: (forall m. Semigroup m => Interpret t (AltConst m), Alt g)
    => (f ~> g)
    -> PostT t f ~> g
postAltT :: (f ~> g) -> PostT t f ~> g
postAltT f :: f ~> g
f = (f ~> g) -> t (Post x f) x -> g x
forall (t :: (* -> *) -> * -> *) (g :: * -> *) (f :: * -> *) a b.
(forall m. Semigroup m => Interpret t (AltConst m), Alt g) =>
(f ~> g) -> t (Post a f) b -> g a
postAlt f ~> g
f (t (Post x f) x -> g x)
-> (PostT t f x -> t (Post x f) x) -> PostT t f x -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostT t f x -> t (Post x f) x
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
PostT t f a -> t (Post a f) a
unPostT

-- | Run a @'PostT' t@ into a covariant 'Functor' context.  To run it
-- in @t@s normal contravariant context, use 'interpret'.
--
-- This will work for types where there is exactly one @f@ inside:
--
-- @
-- postFunctorT :: Functor g => (f ~> g) -> PreT 'Step' f ~> g
-- postFunctorT :: Functor g => (f ~> g) -> PreT 'CCY.Coyoneda' f ~> g
-- @
postFunctorT
    :: (forall m. Interpret t (AltConst m), Functor g)
    => (f ~> g)
    -> PostT t f ~> g
postFunctorT :: (f ~> g) -> PostT t f ~> g
postFunctorT f :: f ~> g
f = (f ~> g) -> t (Post x f) x -> g x
forall (t :: (* -> *) -> * -> *) (g :: * -> *) (f :: * -> *) a b.
(forall m. Interpret t (AltConst m), Functor g) =>
(f ~> g) -> t (Post a f) b -> g a
postFunctor f ~> g
f (t (Post x f) x -> g x)
-> (PostT t f x -> t (Post x f) x) -> PostT t f x -> g x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PostT t f x -> t (Post x f) x
forall (t :: (* -> *) -> * -> *) (f :: * -> *) a.
PostT t f a -> t (Post a f) a
unPostT

-- | Run a "post-routed" @t@ into a covariant 'Plus' context.  To run it
-- in @t@s normal contravariant context, use 'interpret'.
--
-- This will work for types where there are a possibly-empty collection of
-- @f@s, like:
--
-- @
-- postPlus :: Plus g => (f ~> g) -> 'Dec' (Post a f) b -> g a
-- postPlus :: Plus g => (f ~> g) -> 'Div' (Post a f) b -> g a
-- @
postPlus
    :: (forall m. Monoid m => Interpret t (AltConst m), Plus g)
    => (f ~> g)
    -> t (Post a f) b
    -> g a
postPlus :: (f ~> g) -> t (Post a f) b -> g a
postPlus f :: f ~> g
f = (g a -> g a -> g a) -> g a -> [g a] -> g a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr g a -> g a -> g a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
(<!>) g a
forall (f :: * -> *) a. Plus f => f a
zero ([g a] -> g a)
-> (t (Post a f) b -> [g a]) -> t (Post a f) b -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. Post a f x -> g a) -> t (Post a f) b -> [g a]
forall k (t :: (k -> *) -> k -> *) (f :: k -> *) b (a :: k).
(forall m. Monoid m => Interpret t (AltConst m)) =>
(forall (x :: k). f x -> b) -> t f a -> [b]
icollect ((f ~> g) -> Post a f x -> g a
forall (g :: * -> *) (f :: * -> *) a b.
Functor g =>
(f ~> g) -> Post a f b -> g a
interpretPost f ~> g
f)

-- | Run a "post-routed" @t@ into a covariant 'Alt' context.  To run it
-- in @t@s normal contravariant context, use 'interpret'.
--
-- This will work for types where there are is a non-empty collection of
-- @f@s, like:
--
-- @
-- postAlt :: Alt g => (f ~> g) -> 'Dec1' (Post a f) b -> g a
-- postAlt :: Alt g => (f ~> g) -> 'Div1' (Post a f) b -> g a
-- @
postAlt
    :: (forall m. Semigroup m => Interpret t (AltConst m), Alt g)
    => (f ~> g)
    -> t (Post a f) b
    -> g a
postAlt :: (f ~> g) -> t (Post a f) b -> g a
postAlt f :: f ~> g
f = (g a -> g a -> g a) -> NonEmpty (g a) -> g a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 g a -> g a -> g a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
(<!>) (NonEmpty (g a) -> g a)
-> (t (Post a f) b -> NonEmpty (g a)) -> t (Post a f) b -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. Post a f x -> g a) -> t (Post a f) b -> NonEmpty (g a)
forall k (t :: (k -> *) -> k -> *) (f :: k -> *) b (a :: k).
(forall m. Semigroup m => Interpret t (AltConst m)) =>
(forall (x :: k). f x -> b) -> t f a -> NonEmpty b
icollect1 ((f ~> g) -> Post a f x -> g a
forall (g :: * -> *) (f :: * -> *) a b.
Functor g =>
(f ~> g) -> Post a f b -> g a
interpretPost f ~> g
f)

-- | Run a "post-routed" @t@ into a covariant 'Functor' context.  To run it
-- in @t@s normal contravariant context, use 'interpret'.
--
-- This will work for types where there is exactly one @f@ inside:
--
-- @
-- postFunctor :: Functor g => (f ~> g) -> 'Step'         (Post a f) b -> g a
-- postFunctor :: Functor g => (f ~> g) -> 'CCY.Coyoneda' (Post a f) b -> g a
-- @
postFunctor
    :: (forall m. Interpret t (AltConst m), Functor g)
    => (f ~> g)
    -> t (Post a f) b
    -> g a
postFunctor :: (f ~> g) -> t (Post a f) b -> g a
postFunctor f :: f ~> g
f = (forall x. Post a f x -> g a) -> t (Post a f) b -> g a
forall k (t :: (k -> *) -> k -> *) b (f :: k -> *) (a :: k).
Interpret t (AltConst b) =>
(forall (x :: k). f x -> b) -> t f a -> b
iget ((f ~> g) -> Post a f x -> g a
forall (g :: * -> *) (f :: * -> *) a b.
Functor g =>
(f ~> g) -> Post a f b -> g a
interpretPost f ~> g
f)

-- | Contravariantly retract the @f@ out of a 'Pre', applying the
-- pre-routing function.  Not usually that useful because 'Pre' is meant to
-- be used with covariant 'Functor's.
retractPre :: Contravariant f => Pre a f b -> f a
retractPre :: Pre a f b -> f a
retractPre (f :: a -> b
f :>$<: x :: f b
x) = (a -> b) -> f b -> f a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
f f b
x

-- | Interpret a 'Pre' into a contravariant context, applying the
-- pre-routing function.
interpretPre :: Contravariant g => (f ~> g) -> Pre a f b -> g a
interpretPre :: (f ~> g) -> Pre a f b -> g a
interpretPre f :: f ~> g
f (g :: a -> b
g :>$<: x :: f b
x) = (a -> b) -> g b -> g a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
g (f b -> g b
f ~> g
f f b
x)

-- | Drop the pre-routing function and just give the original wrapped
-- value.
getPre :: Pre a f b -> f b
getPre :: Pre a f b -> f b
getPre (_ :>$<: x :: f b
x) = f b
x

-- | Pre-compose on the pre-routing function.
mapPre :: (c -> a) -> Pre a f b -> Pre c f b
mapPre :: (c -> a) -> Pre a f b -> Pre c f b
mapPre f :: c -> a
f (g :: a -> b
g :>$<: x :: f b
x) = a -> b
g (a -> b) -> (c -> a) -> c -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> a
f (c -> b) -> f b -> Pre c f b
forall a (f :: * -> *) b. (a -> b) -> f b -> Pre a f b
:>$<: f b
x

-- | Like 'inject', but allowing you to provide a pre-routing function.
injectPre :: Inject t => (a -> b) -> f b -> t (Pre a f) b
injectPre :: (a -> b) -> f b -> t (Pre a f) b
injectPre f :: a -> b
f x :: f b
x = Pre a f b -> t (Pre a f) b
forall k (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
inject (a -> b
f (a -> b) -> f b -> Pre a f b
forall a (f :: * -> *) b. (a -> b) -> f b -> Pre a f b
:>$<: f b
x)

-- | Covariantly retract the @f@ out of a 'Post', applying the
-- post-routing function.  Not usually that useful because 'Post' is meant to
-- be used with contravariant 'Functor's.
retractPost :: Functor f => Post a f b -> f a
retractPost :: Post a f b -> f a
retractPost (f :: b -> a
f :<$>: x :: f b
x) = (b -> a) -> f b -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> a
f f b
x

-- | Interpret a 'Post' into a covariant context, applying the
-- post-routing function.
interpretPost :: Functor g => (f ~> g) -> Post a f b -> g a
interpretPost :: (f ~> g) -> Post a f b -> g a
interpretPost f :: f ~> g
f (g :: b -> a
g :<$>: x :: f b
x) = (b -> a) -> g b -> g a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> a
g (f b -> g b
f ~> g
f f b
x)

-- | Drop the post-routing function and just give the original wrapped
-- value.
getPost :: Post a f b -> f b
getPost :: Post a f b -> f b
getPost (_ :<$>: x :: f b
x) = f b
x

-- | Post-compose on the post-routing function.
mapPost :: (a -> c) -> Post a f b -> Post c f b
mapPost :: (a -> c) -> Post a f b -> Post c f b
mapPost f :: a -> c
f (g :: b -> a
g :<$>: x :: f b
x) = a -> c
f  (a -> c) -> (b -> a) -> b -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
g (b -> c) -> f b -> Post c f b
forall a (f :: * -> *) b. (b -> a) -> f b -> Post a f b
:<$>: f b
x

-- | Like 'inject', but allowing you to provide a post-routing function.
injectPost :: Inject t => (b -> a) -> f b -> t (Post a f) b
injectPost :: (b -> a) -> f b -> t (Post a f) b
injectPost f :: b -> a
f x :: f b
x = Post a f b -> t (Post a f) b
forall k (t :: (k -> *) -> k -> *) (f :: k -> *).
Inject t =>
f ~> t f
inject (b -> a
f (b -> a) -> f b -> Post a f b
forall a (f :: * -> *) b. (b -> a) -> f b -> Post a f b
:<$>: f b
x)

instance Functor f => Invariant (Post a f) where
    invmap :: (a -> b) -> (b -> a) -> Post a f a -> Post a f b
invmap f :: a -> b
f g :: b -> a
g (h :: a -> a
h :<$>: x :: f a
x) = a -> a
h (a -> a) -> (b -> a) -> b -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
g (b -> a) -> f b -> Post a f b
forall a (f :: * -> *) b. (b -> a) -> f b -> Post a f b
:<$>: (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
x

instance Contravariant f => Invariant (Pre a f) where
    invmap :: (a -> b) -> (b -> a) -> Pre a f a -> Pre a f b
invmap f :: a -> b
f g :: b -> a
g (h :: a -> a
h :>$<: x :: f a
x) = a -> b
f (a -> b) -> (a -> a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
h (a -> b) -> f b -> Pre a f b
forall a (f :: * -> *) b. (a -> b) -> f b -> Pre a f b
:>$<: (b -> a) -> f a -> f b
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap b -> a
g f a
x

instance HFunctor (Post a) where
    hmap :: (f ~> g) -> Post a f ~> Post a g
hmap g :: f ~> g
g (f :: x -> a
f :<$>: x :: f x
x) = x -> a
f (x -> a) -> g x -> Post a g x
forall a (f :: * -> *) b. (b -> a) -> f b -> Post a f b
:<$>: f x -> g x
f ~> g
g f x
x

instance HFunctor (Pre a) where
    hmap :: (f ~> g) -> Pre a f ~> Pre a g
hmap g :: f ~> g
g (f :: a -> x
f :>$<: x :: f x
x) = a -> x
f (a -> x) -> g x -> Pre a g x
forall a (f :: * -> *) b. (a -> b) -> f b -> Pre a f b
:>$<: f x -> g x
f ~> g
g f x
x

instance Monoid a => Inject (Post a) where
    inject :: f x -> Post a f x
inject x :: f x
x = a -> x -> a
forall a b. a -> b -> a
const a
forall a. Monoid a => a
mempty (x -> a) -> f x -> Post a f x
forall a (f :: * -> *) b. (b -> a) -> f b -> Post a f b
:<$>: f x
x

instance Monoid a => HBind (Post a) where
    hjoin :: Post a (Post a f) x -> Post a f x
hjoin (f :: x -> a
f :<$>: (g :: x -> a
g :<$>: x :: f x
x)) = (x -> a
f (x -> a) -> (x -> a) -> x -> a
forall a. Semigroup a => a -> a -> a
<> x -> a
g) (x -> a) -> f x -> Post a f x
forall a (f :: * -> *) b. (b -> a) -> f b -> Post a f b
:<$>: f x
x

instance Monoid a => Interpret (Post a) f where
    retract :: Post a f x -> f x
retract (_ :<$>: x :: f x
x) = f x
x

-- | This instance is over-contrained (@a@ only needs to be uninhabited),
-- but there is no commonly used "uninhabited" typeclass
instance (a ~ Void) => Inject (Pre a) where
    inject :: f x -> Pre a f x
inject x :: f x
x = Void -> x
forall a. Void -> a
absurd (Void -> x) -> f x -> Pre Void f x
forall a (f :: * -> *) b. (a -> b) -> f b -> Pre a f b
:>$<: f x
x

-- | This instance is over-contrained (@a@ only needs to be uninhabited),
-- but there is no commonly used "uninhabited" typeclass
instance (a ~ Void) => HBind (Pre a) where
    hjoin :: Pre a (Pre a f) x -> Pre a f x
hjoin (_ :>$<: (_ :>$<: x :: f x
x)) = Void -> x
forall a. Void -> a
absurd (Void -> x) -> f x -> Pre Void f x
forall a (f :: * -> *) b. (a -> b) -> f b -> Pre a f b
:>$<: f x
x

instance (a ~ Void) => Interpret (Pre a) f where
    retract :: Pre a f x -> f x
retract (_ :>$<: x :: f x
x) = f x
x

-- | If @t@ is a covariant functor combinator, then you applying it to
-- @'Pre' a f@ gives you a profunctor.
newtype ProPre t f a b = ProPre { ProPre t f a b -> t (Pre a f) b
unProPre :: t (Pre a f) b }

instance (HFunctor t, forall x. Functor (t (Pre x f))) => Profunctor (ProPre t f) where
    dimap :: (a -> b) -> (c -> d) -> ProPre t f b c -> ProPre t f a d
dimap f :: a -> b
f g :: c -> d
g = t (Pre a f) d -> ProPre t f a d
forall k (t :: (* -> *) -> k -> *) (f :: * -> *) a (b :: k).
t (Pre a f) b -> ProPre t f a b
ProPre
              (t (Pre a f) d -> ProPre t f a d)
-> (ProPre t f b c -> t (Pre a f) d)
-> ProPre t f b c
-> ProPre t f a d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pre b f ~> Pre a f) -> t (Pre b f) ~> t (Pre a f)
forall k k (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor t =>
(f ~> g) -> t f ~> t g
hmap ((a -> b) -> Pre b f x -> Pre a f x
forall c a (f :: * -> *) b. (c -> a) -> Pre a f b -> Pre c f b
mapPre a -> b
f)
              (t (Pre b f) d -> t (Pre a f) d)
-> (ProPre t f b c -> t (Pre b f) d)
-> ProPre t f b c
-> t (Pre a f) d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> d) -> t (Pre b f) c -> t (Pre b f) d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g
              (t (Pre b f) c -> t (Pre b f) d)
-> (ProPre t f b c -> t (Pre b f) c)
-> ProPre t f b c
-> t (Pre b f) d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProPre t f b c -> t (Pre b f) c
forall k (t :: (* -> *) -> k -> *) (f :: * -> *) a (b :: k).
ProPre t f a b -> t (Pre a f) b
unProPre

-- | If @t@ is a contravariant functor combinator, then you applying it to
-- @'Post' a f@ gives you a profunctor.
newtype ProPost t f a b = ProPost { ProPost t f a b -> t (Post b f) a
unProPost :: t (Post b f) a }

instance (HFunctor t, forall x. Contravariant (t (Post x f))) => Profunctor (ProPost t f) where
    dimap :: (a -> b) -> (c -> d) -> ProPost t f b c -> ProPost t f a d
dimap f :: a -> b
f g :: c -> d
g = t (Post d f) a -> ProPost t f a d
forall k (t :: (* -> *) -> k -> *) (f :: * -> *) (a :: k) b.
t (Post b f) a -> ProPost t f a b
ProPost
              (t (Post d f) a -> ProPost t f a d)
-> (ProPost t f b c -> t (Post d f) a)
-> ProPost t f b c
-> ProPost t f a d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Post c f ~> Post d f) -> t (Post c f) ~> t (Post d f)
forall k k (t :: (k -> *) -> k -> *) (f :: k -> *) (g :: k -> *).
HFunctor t =>
(f ~> g) -> t f ~> t g
hmap ((c -> d) -> Post c f x -> Post d f x
forall a c (f :: * -> *) b. (a -> c) -> Post a f b -> Post c f b
mapPost c -> d
g)
              (t (Post c f) a -> t (Post d f) a)
-> (ProPost t f b c -> t (Post c f) a)
-> ProPost t f b c
-> t (Post d f) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> t (Post c f) b -> t (Post c f) a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
f
              (t (Post c f) b -> t (Post c f) a)
-> (ProPost t f b c -> t (Post c f) b)
-> ProPost t f b c
-> t (Post c f) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProPost t f b c -> t (Post c f) b
forall k (t :: (* -> *) -> k -> *) (f :: * -> *) (a :: k) b.
ProPost t f a b -> t (Post b f) a
unProPost