Generic zipWith

In response to the traverse-with-class 1.0 announcement, user Gurkenglas asks:

Can you use something like this to do something like gzipWith (+) :: (Int, Double) -> (Int, Double) -> (Int, Double)?

There are two separate challenges here:

1. How do we traverse two structures in lockstep?
2. How do we make sure that the values we are combining are of the same type?

Because traverse-with-class implements Michael D. Adams’s generic zipper, I first thought that it would suffice to traverse the two values simultaneously. That didn’t quite work out. That zipper is designed to traverse the structure in all four directions: not just left and right, but also up and down. Therefore, if we want to traverse an (Int, Double) tuple with a Num constraint, all possible substructures — including (Int, Double) itself — must satisfy that constraint. The way this manifests itself is through Rec c constraints, which cannot be satisfied for tuples without defining extra Num instances.

It is possible to design a restricted zipper that would only travel left and right and will not impose any unnecessary constraints. But because we need only a simple one-way traversal, we can get away with something even simpler — a free applicative functor. (Indeed, a free applicative is a building block in Adams’s zipper.)

This is simple and beautiful: because a free applicative functor is an applicative functor, we can gtraverse with it; and because a free applicative functor is essentially a heterogeneous list, we can zip two such things together.

Another way we could approach this is by using Oleg’s Zipper from any Traversable, which is based on the continuation monad. I haven’t tried it, but I think it should work, too.

Now we arrive at the second challenge. In traverse-with-class, when we traverse a heterogeneous value, we observe each field as having an existential type exists a . c a => a. If the type of (+) was something like (Num a1, Num a2) => a1 -> a2 -> a1 — as it is in many object-oriented languages — it would be fine. But in Haskell, we can only add two Num values if they are of the same type.

Packages like one-liner or generics-sop use a type-indexed generic representation, so we can assert field-wise type equality of two structures at compile time. traverse-with-class is not typed in this sense, so we need to rely on run-time type checks via Typeable.

The full code for gzipWith is given below. Note that relying on Ørjan’s free applicative has two important consequences:

1. We zip from right to left, so that gzipWith @Num (+) [1,2,3] [1,2] evaluates to [3,5], not [2,4].
2. For GTraversable instances that are right-associated (e.g. the standard GTraversable instance for lists), the complexity is quadratic.

I believe that both of these issues can be resolved, but I don’t have the time to spend on this at the moment.

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances,
             ConstraintKinds, RankNTypes, AllowAmbiguousTypes, TypeApplications,
             UndecidableInstances, GADTs, UndecidableSuperClasses,
             FlexibleContexts, TypeOperators #-}

import Data.Typeable
import Data.Generics.Traversable

-- TypeableAnd c is a synonym for (c a, Typeable a)
class    (c a, Typeable a) => TypeableAnd c a
instance (c a, Typeable a) => TypeableAnd c a

-- Ørjan Johansen’s free applicative functor
data Free c a
  = Pure a
  | forall b. (c b, Typeable b) => Snoc (Free c (b -> a)) b

instance Functor (Free c) where
  fmap f (Pure x) = Pure $ f x
  fmap f (Snoc lft x) = Snoc (fmap (f .) lft) x

instance Applicative (Free c) where
  pure = Pure
  tx <*> Pure e = fmap ($ e) tx
  tx <*> Snoc ty az = Snoc ((.) <$> tx <*> ty) az

unit :: TypeableAnd c b => b -> Free c b
unit = Snoc (Pure id)

toFree :: forall c a . GTraversable (TypeableAnd c) a => a -> Free c a
toFree = gtraverse @(TypeableAnd c) unit

fromFree :: Free c a -> a
fromFree free =
  case free of
    Pure a -> a
    Snoc xs x -> fromFree xs x

zipFree :: (forall b . c b => b -> b -> b) -> Free c a -> Free c a -> Free c a
zipFree f free1 free2 =
  case (free1, free2) of
    (Pure a1, _) -> Pure a1
    (_, Pure a2) -> Pure a2
    (Snoc xs1 (x1 :: b1), Snoc xs2 (x2 :: b2)) ->
      case (eqT :: Maybe (b1 :~: b2)) of
        Nothing -> error "zipFree: incompatible types"
        Just Refl -> Snoc (zipFree f xs1 xs2) (f x1 x2)

gzipWith
  :: forall c a . GTraversable (TypeableAnd c) a
  => (forall b . c b => b -> b -> b)
  -> a -> a -> a
gzipWith f a1 a2 = fromFree $ zipFree f (toFree @c a1) (toFree @c a2)

zippedTuple :: (Int, Double)
zippedTuple = gzipWith @Num (+) (1, 1) (3, pi)
-- (4,4.141592653589793)