Constrained Applicatives

Posted on March 8, 2017
Tags: ,

In Haskell restricted monads are monads which can’t contain every type. Set is a good example. If you look in the documentation for Data.Set you’ll see several functions which correspond to functions in the Functor/Applicative/Monad typeclass hierarchy:

map :: Ord b => (a -> b) -> Set a -> Set b
singleton :: a -> Set a
foldMap :: Ord b => (a -> Set b) -> Set a -> Set b -- specialized

Unfortunately, though, Set can’t conform to Functor, because the signature of fmap looks like this:

fmap :: Functor f => (a -> b) -> f a -> f b

It doesn’t have an Ord constraint.

This is annoying: when using Set, lots of things have to be imported qualified, and you have to remember the slightly different names of extra functions like map. More importantly, you’ve lost the ability to write generic code over Functor or Monad which will work on Set.

There are a number of ways to get around this problem. Here, an approach using reflection-reification is explored. These are the types involved:

newtype SetC a = 
       SetC{unSetC :: forall r. Ord r => (a -> Set r) -> Set r}

reifySet :: Ord r => SetC r -> Set r
reifySet m = unSetC m singleton

reflectSet :: Ord r => Set r -> SetC r
reflectSet s = SetC $ \k -> S.foldr (\x r -> k x `union` r) S.empty s

SetC is just Cont in disguise. In fact, we can generalize this pattern, using Constraint Kinds:

newtype FreeT c m a = 
       FreeT { runFreeT :: forall r. c r => (a -> m r) -> m r}

reifySet :: Ord a => FreeT Ord Set a -> Set a
reifySet m = runFreeT m singleton

reflectSet :: Set r -> FreeT Ord Set r
reflectSet s = FreeT $ \k -> S.foldr (\x r -> k x `union` r) S.empty s

FreeT looks an awful lot like ContT by now. The type has some other interesting applications, though. For instance, this type:

type FM = FreeT Monoid Identity

Is the free monoid. If we use a transformers-style type synonym, the naming becomes even nicer:

type Free c = FreeT c Identity

runFree :: c r => Free c a -> (a -> r) -> r
runFree xs f = runIdentity (runFreeT xs (pure . f))

instance Foldable (Free Monoid) where
  foldMap = flip runFree

Check out this package for an implementation of the non-transformer Free.

Different Classes

This is still unsatisfying, though. Putting annotations around your code feels inelegant. The next solution is to replace the monad class altogether with our own, and turn on -XRebindableSyntax. There are a few ways to design this new class. One option is to use multi-parameter type classes. Another solution is with an associated type:

class Functor f where
  type Suitable f a :: Constraint
  fmap :: Suitable f b => (a -> b) -> f a -> f b

This is similar to the approach taken in the rmonad library, except that library doesn’t use constraint kinds (they weren’t available when the library was made), so it has to make do with a Suitable class. Also, the signature for fmap in rmonad is:

fmap :: (Suitable f a, Suitable f b) => (a -> b) -> f a -> f b

I don’t want to constrain a: I figure if you can get something into your monad, it must be suitable. And I really want to reduce the syntactic overhead of writing extra types next to your functions.

There’s also the supermonad library out there which is much more general than any of these examples: it supports indexed monads as well as constrained.

Anyway,Monad is defined similarly to Functor:

class Functor m => Monad m where
  return :: Suitable m a => a -> m a
  (>>=) :: Suitable m b => m a -> (a -> m b) -> m b

Again, I want to minimize the use of Suitable, so for >>= there’s only a constraint on b.

Finally, here’s the Set instance:

instance Functor Set where
    type Suitable Set a = Ord a
    fmap = Set.map

Monomorphic

With equality constraints, you can actually make monomorphic containers conform to these classes (or, at least, wrappers around them).

import qualified Data.Text as Text

data Text a where
  Text :: Text.Text -> Text Char

instance Functor Text where
  type Suitable Text a = a ~ Char
  fmap f (Text xs) = Text (Text.map f xs)

This pattern can be generalized with some more GADT magic:

data Monomorphic xs a b where
        Monomorphic :: (a ~ b) => xs -> Monomorphic xs a b

instance (MonoFunctor xs, a ~ Element xs) => Functor (Monomorphic xs a) where
  type Suitable (Monomorphic xs a) b = a ~ b
  fmap f (Monomorphic xs) = Monomorphic (omap f xs)

Where omap comes from the mono-traversable package. You could go a little further, to Foldable:

instance (MonoFoldable xs, element ~ Element xs) =>
         Foldable (Monomorphic xs element) where
    foldr f b (Monomorphic xs) = ofoldr f b xs
    foldMap f (Monomorphic xs) = ofoldMap f xs
    foldl' f b (Monomorphic xs) = ofoldl' f b xs
    toList (Monomorphic xs) = otoList xs
    null (Monomorphic xs) = onull xs
    length (Monomorphic xs) = olength xs
    foldr1 f (Monomorphic xs) = ofoldr1Ex f xs
    elem x (Monomorphic xs) = oelem x xs
    maximum (Monomorphic xs) = maximumEx xs
    minimum (Monomorphic xs) = minimumEx xs
    sum (Monomorphic xs) = osum xs
    product (Monomorphic xs) = oproduct xs

Back to normal

Changing the FreeT type above a little, we can go back to normal functors and monads, and write more general reify and reflect functions:

newtype FreeT m a = 
       FreeT { runFreeT :: forall r. Suitable m r => (a -> m r) -> m r}
       
reify :: (Monad m, Suitable m a) => FreeT m a -> m a
reify = flip runFreeT return

reflect :: Monad m => m a -> FreeT m a
reflect x = FreeT (x >>=)

So now our types, when wrapped, can conform to the Prelude’s Functor. It would be nice if this type could be written like so:

reify :: Monad m => FreeT (Suitable m) m a -> m a
reify = flip runFreeT return

reflect :: Monad m => m a -> FreeT (Suitable m) m a
reflect x = FreeT (x >>=)

But unfortunately type families cannot be partially applied.

Applicatives

The classes above aren’t very modern: they’re missing applicative. This one is tricky:

class Functor f => Applicative f where
  pure :: Suitable a => a -> f a
  (<*>) :: Suitable f b => f (a -> b) -> f a -> f b

The issue is f (a -> b). There’s no way you’re getting some type like that into Set. This means that <*> is effectively useless. No problem, you think: define liftA2 instead:

class Functor f => Applicative f where
  pure :: Suitable a => a -> f a
  liftA2 :: Suitable f c => (a -> b -> c) -> f a -> f b -> f c

(<*>) :: (Applicative f, Suitable f b) => f (a -> b) -> f a -> f b
(<*>) = liftA2 ($)

Great! Now we can use it with set. However, there’s no way (that I can see) to define the other lift functions: liftA3, etc. Of course, if >>= is available, it’s as simple as:

liftA3 f xs ys zs = do
  x <- xs
  y <- ys
  z <- zs
  pure (f x y z)

But now we can’t define it for non-monadic applicatives (square matrices, ZipLists, etc.). This also forces us to use >>= when <*> may have been more efficient.

The functions we’re interested in defining look like this:

liftA2 :: Suitable f c => (a -> b -> c) -> f a -> f b -> f c
liftA3 :: Suitable f d => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA4 :: Suitable f e => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e

There’s a clear pattern, but no obvious way to abstract over it. Type-level shenanigans to the rescue!

The pattern might be expressed like this:

liftA :: Func args -> Func lifted args

We can store these types as heterogeneous lists:

infixr 5 :-
data Vect xs where
  Nil  :: Vect '[]
  (:-) :: x -> Vect xs -> Vect (x ': xs)

infixr 5 :*
data AppVect f xs where
  NilA :: AppVect f '[]
  (:*) :: f x -> AppVect f xs -> AppVect f (x ': xs)

And liftA can be represented like this:

liftA
    :: Suitable f b
    => (Vect xs -> b) -> AppVect f xs -> f b

liftA2
    :: Suitable f c
    => (a -> b -> c) -> f a -> f b -> f c
liftA2 f xs ys =
    liftA
        (\(x :- y :- Nil) ->
              f x y)
        (xs :* ys :* NilA)

liftA3
    :: Suitable f d
    => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 f xs ys zs =
    liftA
        (\(x :- y :- z :- Nil) ->
              f x y z)
        (xs :* ys :* zs :* NilA)

Cool! For unrestricted applicatives, we can define liftA in terms of <*>:

liftAP :: (Prelude.Applicative f) 
       => (Vect xs -> b) -> (AppVect f xs -> f b)
liftAP f NilA = Prelude.pure (f Nil)
liftAP f (x :* NilA) 
  = Prelude.fmap (f . (:-Nil)) x
liftAP f (x :* xs) 
  =  ((f .) . (:-)) Prelude.<$> x Prelude.<*> liftAP id xs

And for types with a monad instance, we can define it in terms of >>=:

liftAM :: (Monad f, Suitable f b) 
       => (Vect xs -> b) -> (AppVect f xs -> f b)
liftAM f NilA = pure (f Nil)
liftAM f (x :* NilA) = fmap (f . (:-Nil)) x
liftAM f (x :* xs) = x >>= \y -> liftAM (f . (y:-)) xs

Efficiency

This approach is really slow. Every function wraps up its arguments in a Vect, and it’s just generally awful.

What about not wrapping up the function? Type families can help here:

type family FunType (xs :: [*]) (y :: *) :: * where
  FunType '[] y = y
  FunType (x ': xs) y = x -> FunType xs y

It gets really difficult to define liftA using <*> now, though. liftAM, on the other hand, is a breeze:

liftAM :: Monad f => FunType xs a -> AppVect f xs -> f a
liftAM f Nil = pure f
liftAM f (x :< xs) = x >>= \y -> liftAM (f y) xs

And no vector constructors on the right of the bind!

Still, no decent definition using <*>. The problem is that we’re using a cons-list to represent a function’s arguments, but <*> is left-associative, so it builds up arguments as a snoc list. Lets try using a snoc-list as the type family:

infixl 5 :>
data AppVect f xs where
  Nil :: AppVect f '[]
  (:>) :: AppVect f xs -> f x -> AppVect f (x ': xs)

type family FunType (xs :: [*]) (y :: *) :: * where
  FunType '[] y = y
  FunType (x ': xs) y = FunType xs (x -> y)

liftA
    :: Suitable f a
    => FunType xs a -> AppVect f xs -> f a

liftAP now gets a natural definition:

liftAP :: Prelude.Applicative f => FunType xs a -> AppVect f xs -> f a
liftAP f Nil = Prelude.pure f
liftAP f (Nil :> xs) = Prelude.fmap f xs
liftAP f (ys :> xs) = liftAP f ys Prelude.<*> xs

But what about liftAM? It’s much more difficult, fundamentally because >>= builds up arguments as a cons-list. To convert between the two efficiently, we need to use the trick for reversing lists efficiently: build up the reversed list as you go.

liftAM :: (Monad f, Suitable f a) => FunType xs a -> AppVect f xs -> f a
liftAM = go pure where
  go :: (Suitable f b, Monad f) 
     => (a -> f b) -> FunType xs a -> AppVect f xs -> f b
  go f g Nil = f g
  go f g (xs :> x) = go (\c -> x >>= f . c) g xs

Using these definitions, we can make Set, Text, and all the rest of them applicatives, while preserving the applicative operations. Also, from my preliminary testing, there seems to be no overhead in using these new definitions for <*>.

Normalized Embedding

In Sculthorpe et al. (2013), there’s discussion of this type:

data NM :: (* -> Constraint) -> (* -> *) -> * -> * where
  Return :: a -> NM c t a
  Bind :: c x => t x -> (x -> NM c t a) -> NM c t a

This type allows constrained monads to become normal monads. It can be used for the same purpose as the FreeT type from above. In the paper, the free type is called RCodT.

One way to look at the type is as a concrete representation of the monad class, with each method being a constructor.

You might wonder if there are similar constructs for functor and applicative. Functor is simple:

data NF :: (* -> Constraint) -> (* -> *) -> * -> * where
  FMap :: c x => (x -> a) -> t x -> NF c t a

Again, this can conform to functor (and only functor), and can be interpreted when the final type is Suitable.

Like above, it has a continuation version, Yoneda.

For applicatives, though, the situation is different. In the paper, they weren’t able to define a transformer for applicatives that could be interpreted in some restricted applicative. I needed one because I wanted to use -XApplicativeDo notation: the desugaring uses <*>, not the liftAn functions, so I wanted to construct a free applicative using <*>, and run it using the lift functions. What I managed to cobble to gether doesn’t really solve the problem, but it works for -XApplicativeDo!

The key with a lot of this was realizing that <*> is snoc, not cons. Using a free applicative:

data Free f a where
  Pure :: a -> Free f a
  Ap :: Free f (a -> b) -> f a -> Free f b

instance Prelude.Functor (Free f) where
  fmap f (Pure a) = Pure (f a)
  fmap f (Ap x y) = Ap ((f .) Prelude.<$> x) y

instance Prelude.Applicative (Free f) where
  pure = Pure
  Pure f <*> y = Prelude.fmap f y
  Ap x y <*> z = Ap (flip Prelude.<$> x Prelude.<*> z) y

This type can conform to Applicative and Functor no problem. And all it needs to turn back into a constrained applicative is for the outer type to be suitable:

lift :: f a -> Free f a
lift = Ap (Pure id)

lower
    :: forall f a c.
       Free f a
    -> (forall xs. FunType xs a -> AppVect f xs -> f c)
    -> f c
lower (Pure x) f = f x Nil
lower (Ap fs x :: Free f a) f =
    lower fs (\ft av -> f ft (av :> x))

lowerConstrained
    :: (Constrained.Applicative f, Suitable f a)
    => Free f a -> f a
lowerConstrained x = lower x liftA

There’s probably a more efficient way to encode it, though.

Sculthorpe, Neil, Jan Bracker, George Giorgidze, and Andy Gill. 2013. “The Constrained-monad Problem.” In Proceedings of the 18th ACM SIGPLAN International Conference on Functional Programming, 287–298. ICFP ’13. New York, NY, USA: ACM. doi:10.1145/2500365.2500602. http://ku-fpg.github.io/files/Sculthorpe-13-ConstrainedMonad.pdf.