How to construct an Applicative instance with constraints (similarly to constructing Monad instances using ContT)

Question

This question deals with constructing a proper Monad instance from something that is a monad, but only under certain constraints - for example Set. The trick is to wrap it into ContT, which defers the constraints to wrapping/unwrapping its values.

Now I'd like to do the same with Applicatives. In particular, I have an Applicative instance whose pure has a type-class constraint. Is there a similar trick how to construct a valid Applicative instance?

(Is there "the mother of all applicative functors" just as there is for monads?)

Answer 1

What may be the most consistent way available is starting from Category, where it's quite natural to have a restriction to objects: Object!

class Category k where
  type Object k :: * -> Constraint
  id :: Object k a => k a a
  (.) :: (Object k a, Object k b, Object k c)
     => k b c -> k a b -> k a c

Then we define functors similar to how Edward does it

class (Category r, Category t) => Functor f r t | f r -> t, f t -> r where
  fmap :: (Object r a, Object t (f a), Object r b, Object t (f b))
             => r a b -> t (f a) (f b)

All of this works nicely and is implemented in the constrained-categories library, which – shame on me! – still isn't on Hackage.

Applicative is unfortunately a bit less straightforward to do. Mathematically, these are monoidal functors, so we first need monoidal categories. categories has that class, but it doesn't work with the constraint-based version because our objects are always anything of kind * with a constraint. So what I did is make up a Curry class, which kind of approximates this.

Then, we can do Monoidal functors:

class (Functor f r t, Curry r, Curry t) => Monoidal f r t where
  pure :: (Object r a, Object t (f a)) => a `t` f a
  fzipWith :: (PairObject r a b, Object r c, PairObject t (f a) (f b), Object t (f c))
              => r (a, b) c -> t (f a, f b) (f c)

This is actually equivalent to Applicative when we have proper closed cartesian categories. In the constrained-categories version, the signatures unfortunately look very horrible:

  (<*>) :: ( Applicative f r t
           , MorphObject r a b, Object r (r a b)
           , MorphObject t (f a) (f b), Object t (t (f a) (f b)), Object t (f (r a b))
           , PairObject r (r a b) a, PairObject t (f (r a b)) (f a)
           , Object r a, Object r b, Object t (f a), Object t (f b))
       => f (r a b) `t` t (f a) (f b)

Still, it actually works – for the unconstrained case, duh! I haven't yet found a convenient way to use it with nontrivial constraints.

But again, Applicative is equivalent to Monoidal, and that can be used as demonstrated in the Set example.

Answer 2

I'm not sure the notion of "restricted applicative" is unique, as different presentations are not isomorphic. That said here is one and something at least somewhat along the lines of Codensity. The idea is to have a "free functor" together with a unit

{-# LANGUAGE TypeFamilies, ConstraintKinds, ExistentialQuantification #-}

import GHC.Prim (Constraint)
import Control.Applicative

class RFunctor f where
  type C f :: * -> Constraint
  rfmap :: C f b => (a -> b) -> f a -> f b

class RFunctor f => RApplicative f where
  rpure :: C f a => a -> f a
  rzip :: f a -> f b -> f (a,b)

data UAp f a
  = Pure  a
  | forall b. Embed (f b) (b -> a)

toUAp :: C f a => f a -> UAp f a
toUAp x = Embed x id

fromUAp :: (RApplicative f, C f a) => UAp f a -> f a
fromUAp (Pure x) = rpure x
fromUAp (Embed x f) = rfmap f x

zipUAp :: RApplicative f => UAp f a -> UAp f b -> UAp f (a,b)
zipUAp (Pure a) (Pure b) = Pure (a,b)
zipUAp (Pure a) (Embed b f) = Embed b (\x -> (a,f x))
zipUAp (Embed a f) (Pure b) = Embed a (\x -> (f x,b))
zipUAp (Embed a f) (Embed b g) = Embed (rzip a b) (\(x,y) -> (f x,g y))

instance Functor (UAp f) where
  fmap f (Pure a) = Pure (f a)
  fmap f (Embed a g) = Embed a (f . g)

instance RApplicative f => Applicative (UAp f) where
  pure = Pure
  af <*> ax = fmap (\(f,x) -> f x) $ zipUAp af ax

EDIT: Fixed some bugs. That is what happens when you don't compile before posting.