Applicative instance of List runs forever in composition law test with QuickCheck/Checkers

Question

I want to implement the regular applicative instance for lists, using my customly defined list:

import Control.Monad

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

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


instance Functor List where
  fmap f (Cons x xs) = Cons (f x) (fmap f xs)
  fmap f Nil = Nil


instance Applicative List where
  pure x = Cons x Nil
  (<*>) Nil _ = Nil
  (<*>) _ Nil = Nil
  (<*>) (Cons f fs) xs = (+++) (fmap f xs) (fs <*> xs)

(+++) :: List a -> List a -> List a
(+++) (Cons x Nil) ys = Cons x ys
(+++) (Cons x xs) ys = Cons x xs'
  where xs' = (+++) xs ys

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 (Eq a) => EqProp (List a) where
  (=-=) = eq

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

My code passes all the applicative tests in Checkers except one, the composition law. No error occurs when testing the composition law, it just never finishes.

Does my code recur eternally in some way I am unable to see, or is it just veeery slow for testing the compositon law?

This is the error message I get if I control-c during the Checkers execution:

applicative:
  identity:     +++ OK, passed 500 tests.
  composition:  *** Failed! Exception: 'user interrupt' (after 66 tests): 
Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> Nil))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> (Cons <function> Nil))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
Cons (-61) (Cons (-24) (Cons 56 (Cons (-10) (Cons 28 (Cons 5 (Cons (-5) (Cons 33 (Cons 18 (Cons 47 (Cons 43 (Cons 43 (Cons (-58) (Cons 35 (Cons (-52) (Cons (-52) (Cons (-41) (Cons 3 (Cons (-7) (Cons (-53) (Cons (-22) (Cons (-20) (Cons (-12) (Cons 46 (Cons (-53) (Cons 35 (Cons (-31) (Cons (-10) (Cons 43 (Cons (-16) (Cons 47 (Cons 53 (Cons 22 (Cons 8 (Cons 1 (Cons (-64) (Cons (-39) (Cons (-57) (Cons 34 (Cons (-31) (Cons 20 (Cons (-39) (Cons (-47) (Cons (-59) (Cons 15 (Cons (-42) (Cons (-31) (Cons 4 (Cons (-62) (Cons (-14) (Cons (-24) (Cons 47 (Cons 42 (Cons 61 (Cons 29 (Cons (-25) (Cons 30 (Cons (-20) (Cons 16 (Cons (-30) (Cons (-38) (Cons (-7) (Cons 16 (Cons 19 (Cons 20 Nil))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
  homomorphism: +++ OK, passed 500 tests.
  interchange:  +++ OK, passed 500 tests.
  functor:      +++ OK, passed 500 tests.

If one of the functions is slow, I guess it is the (+++), but I do not know how GHC executes code well enough to understand why.

Update:

The composition law is:

pure (.) <*> u <*> v <*> w = u <*> (v <*> w)

Which I can show works with my code for simple examples:

Cons (+1) Nil <*> (Cons (*2) Nil <*> Cons 1 (Cons 2 (Cons 3 Nil)))

and

pure (.) <*> Cons (+1) Nil <*> Cons (*2) Nil <*> Cons 1 (Cons 2 (Cons 3 Nil))

Both give the same result, so why the composition law never ends has me stumped. Might this be a problem with the checkers library?

Answer 1

My first thought was that go was getting a negative argument and looping. However, when modifying it to use trace and throw an error if n < 0, I found that it's a lot simpler: your code is just really slow.

Here's the part I modified (go' was used for tracing, but I short circuited it for benchmarking):

import Debug.Trace

(+++) :: List a -> List a -> List a
{-# INLINE (+++) #-}
(+++) (Cons x Nil) ys = Cons x ys
(+++) (Cons x xs) ys = Cons x xs'
  where xs' = (+++) xs ys

maxListSize = 10

instance Arbitrary a => Arbitrary (List a)  where
  arbitrary = sized go''
    where
      go'' n = go' $ mod n maxListSize
      go' n = if n < 0 then error ("bad n:" ++ show n) else trace (show n ++ " , ") $ go n
      go 0 = pure Nil
      go n = do
        xs <- go' (n - 1)
        x  <- arbitrary
        return (Cons x xs)

Checking the trace for some sort of infinite loop, I found that things never stopped progressing, n kept decreasing then popping back up for the next test. It just took seconds for a single test when it slowed down. Remember you're trying to run 500 of each test.

My benchmarks aren't rigorous, but here's what I got (x is modulus, in range [1..18]):

Quick regression found 5.72238 - 2.8458 x + 0.365263 x^2. When I ran the trace, n kept increasing. Although I'm not sure how the tests are being run, if it increases n each test, then n would get up to 500.

The formula isn't really fair, but let's assume it's a decent bound. (I think it should be since the algorithm is O(n^2).)

Then running all the tests would take roughly 25 hours, on my machine.

P.S. Since all the tests pass for reasonable bounds on n and I can't find a bug, I think your code is correct.