How do I create an applicative instance for ziplist?

Question

I want to implement an instance of Applicative for my custom list.

import Test.QuickCheck
import Test.QuickCheck.Checkers
import Test.QuickCheck.Classes


data List a =
  Nil
  | Cons a (List a)
  deriving (Eq, Show)

instance Eq a => EqProp (List a) where (=-=) = eq

instance Functor List where
  fmap _ Nil = Nil
  fmap f (Cons a Nil) = (Cons (f a) Nil)
  fmap f (Cons a as) = (Cons (f a) (fmap f as))

main = do
  let trigger = undefined :: List (Int, String, Int)
  quickBatch $ applicative trigger


instance Arbitrary a => Arbitrary (List a)  where
  arbitrary = sized go
    where go 0 = pure Nil
          go n = do
            xs <- go (n - 1)
            x  <- arbitrary
            return (Cons x xs)

instance Applicative List where
  pure x = (Cons x Nil)
  Nil <*> _ = Nil
  _ <*> Nil = Nil
 (Cons f fs) <*> (Cons a as) = (Cons (f a) (fs <*> as))

This gives the following bugs:

λ> main
applicative:
  identity:     *** Failed! Falsifiable (after 3 tests): 
Cons 0 (Cons (-1) Nil)
  composition:  *** Failed! Falsifiable (after 3 tests): 
Cons <function> (Cons <function> Nil)
Cons <function> (Cons <function> Nil)
Cons 1 (Cons (-2) Nil)
  homomorphism: +++ OK, passed 500 tests.
  interchange:  +++ OK, passed 500 tests.
  functor:      *** Failed! Falsifiable (after 3 tests): 
<function>
Cons (-2) (Cons (-1) Nil)

First is the id law is failing:

λ> Cons id Nil <*> Cons 0 (Cons (-1) Nil)
Cons 0 Nil

How do I fix this? pure takes an a not a List a so I do not see how to match on List and preserve the nested list structure.

The composition law also fails which is not strange:

λ> (Cons "b" Nil) <*> (Cons "c" Nil)

<interactive>:295:7:
    Couldn't match expected type ‘[Char] -> b’
                with actual type ‘[Char]’
    Relevant bindings include
      it :: List b (bound at <interactive>:295:1)
    In the first argument of ‘Cons’, namely ‘"b"’
    In the first argument of ‘(<*>)’, namely ‘(Cons "b" Nil)’
    In the expression: (Cons "b" Nil) <*> (Cons "c" Nil)

Edit: since I got great answers implementing applicative for ziplists, I have changed the question to be about ziplists.

Answer 1

For your ZipList -like approach we expect the following left-identity to hold:

pure id <*> someList = someList

For this, pure cannot return a single-element list, since this will stop immediately:

(Cons id Nil) <*> Cons 1 (Cons 2 Nil)
  = Cons (id 1) (Nil <*> Cons 2 Nil)
  = Cons 1 Nil

Which isn't the expected result for the left-identity. If pure cannot return only a single element list, how many should it return? The answer is: infinite:

repeatList :: a -> List a
repeatList x = let c = Cons x c in c

Why did I call this the ZipList approach? Because it's the same behaviour as in Control.Applicative.ZipList , which can be motivated with zipWith :

zipWithList :: (a -> b -> c) -> List a -> List b -> List c
zipWithList f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWithList f xs ys)
zipWithList _ _           _           = Nil

Now your instance is

instance Applicative List where
  pure  = repeatList
  (<*>) = zipWithList ($)

However , checkers cannot check this instance either due to your EqProb instance, since pure f <*> pure x == pure (fx) (homomorphism) results in a check on infinite lists. You can provide an alternative one, though. For example, you can take an arbitrary number of elements and compare them:

prop_sameList :: Eq a => (Int, Int) -> List a -> List a -> Property
prop_sameList bounds xs ys = forAll (choose bounds) $ \n -> 
  takeList n xs `eq` takeList n ys

takeList :: Int -> List a -> List a
takeList _ Nil = Nil
takeList n (Cons x xs)
 | n <= 0    = Nil
 | otherwise = Cons x (takeList (n - 1) xs)

Then, if you want to compare at least 1000 and at most 10000 elements, you can use:

instance Eq a => EqProb (List a) where
  (=-=) = prop_sameList (1000, 10000)

After all, we're just trying to find a list where our property does not hold.

Answer 2

Expanding on my comment to Zeta's much more deserving answer, you need a second change to get this test to run:

-- | Test lists for equality (fallibly) by comparing finite prefixes
--  of them.  I've arbitrarily chosen a depth of 1,000. There may be 
-- better ideas than that.
instance Eq a => EqProp (List a) where
    xs =-= ys = takeList 1000 xs `eq` takeList 1000 ys

-- | Take a prefix of up to @n@ elements from a 'List'.
takeList :: Int -> List a -> List a
takeList _ Nil = Nil
takeList n (Cons a as)
    | n > 0 = Cons a (takeList (n-1) as)
    | otherwise = Nil

With Zeta's changes and this one, your test suite passes:

applicative:
  identity:     +++ OK, passed 500 tests.
  composition:  +++ OK, passed 500 tests.
  homomorphism: +++ OK, passed 500 tests.
  interchange:  +++ OK, passed 500 tests.
  functor:      +++ OK, passed 500 tests.

The key insight to get here is that QuickCheck is, fundamentally, a tool for finding counterexamples to properties. QuickCheck generally cannot prove that a property holds for all possible inputs, because the domain may be infinite. That's the reason why there's an EqProp class in checkers ("Types of values that can be tested for equality, perhaps through random sampling")—so that we may implement techniques for searching for counterexamples for types and tests that don't admit of simple equality comparisons.