module Data.TypeRig.Productable where

import Control.Applicative
import Control.Arrow
import Control.Category
import Data.Functor.Invariant
import Data.Kind
import Data.Semigroup
import Prelude hiding ((.), id)
import qualified Text.ParserCombinators.ReadPrec as ReadPrec

infixr 3 <***>, ***>, <***

-- | Composability via type product '(,)' and unit type '()'.
type Productable :: (Type -> Type) -> Constraint
class Invariant f => Productable f where
    rUnit :: f ()
    default rUnit :: Applicative f => f ()
    rUnit = forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    (<***>) :: f a -> f b -> f (a, b)
    default (<***>) :: Applicative f => f a -> f b -> f (a, b)
    (<***>) = forall (f :: Type -> Type) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,)
    (***>) :: f () -> f a -> f a
    f ()
fu ***> f a
fa = forall (f :: Type -> Type) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap (\((), a
a) -> a
a) (\a
a -> ((), a
a)) forall a b. (a -> b) -> a -> b
$ f ()
fu forall (f :: Type -> Type) a b.
Productable f =>
f a -> f b -> f (a, b)
<***> f a
fa
    (<***) :: f a -> f () -> f a
    f a
fa <*** f ()
fu = forall (f :: Type -> Type) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap (\(a
a, ()) -> a
a) (\a
a -> (a
a, ())) forall a b. (a -> b) -> a -> b
$ f a
fa forall (f :: Type -> Type) a b.
Productable f =>
f a -> f b -> f (a, b)
<***> f ()
fu

instance Productable Endo where
    rUnit :: Endo ()
rUnit = forall a. (a -> a) -> Endo a
Endo forall {k} (cat :: k -> k -> Type) (a :: k).
Category cat =>
cat a a
id
    Endo a -> a
p <***> :: forall a b. Endo a -> Endo b -> Endo (a, b)
<***> Endo b -> b
q = forall a. (a -> a) -> Endo a
Endo forall a b. (a -> b) -> a -> b
$ \(a
a, b
b) -> (a -> a
p a
a, b -> b
q b
b)

instance Productable m => Productable (Kleisli m a) where
    rUnit :: Kleisli m a ()
rUnit = forall (m :: Type -> Type) a b. (a -> m b) -> Kleisli m a b
Kleisli forall a b. (a -> b) -> a -> b
$ \a
_ -> forall (f :: Type -> Type). Productable f => f ()
rUnit
    Kleisli a -> m a
p <***> :: forall a b. Kleisli m a a -> Kleisli m a b -> Kleisli m a (a, b)
<***> Kleisli a -> m b
q = forall (m :: Type -> Type) a b. (a -> m b) -> Kleisli m a b
Kleisli forall a b. (a -> b) -> a -> b
$ \a
a -> a -> m a
p a
a forall (f :: Type -> Type) a b.
Productable f =>
f a -> f b -> f (a, b)
<***> a -> m b
q a
a

instance Productable ReadPrec.ReadPrec