Well, for one, it's a bad sieve algorithm.

I think a neat algorithm to demonstrate laziness and Haskell clarity would be enumerating the Calkin-Wilf rationals. [0] It's quite a bit longer but demonstrates a number of neat ideas. I'll start first with a derivation which demonstrates all of the structure of the algorithm and then go through a series of mechanical transforms so that by the end I have a one-liner and a comparable Python implementation.

The first algorithm comes directly from the paper and uses an intermediary infinite tree to represent the rationals.

    data BTree a = Node a (BTree a) (BTree a)

    fold :: (a -> x -> x -> x) -> BTree a -> x
    fold f (Node a l r) = f a (fold f l) (fold f r)

    unfold :: (x -> (a, x, x)) -> x -> BTree a
    unfold f x = let (a, l, r) = f x in Node a (unfold f l) (unfold f r)

    breadthFirst :: BTree a -> [a]
    breadthFirst = concat . fold glue where
      glue a ls rs = [a] : zipWith (++) ls rs

    allRationals :: Fractional a => [a]
    allRationals = breadthFirst (unfold step (1, 1)) where
      step (m, n) = ( m/n, (m, m+n)
                         , (n+m, n) )

In 16 lines I've got an infinite binary tree, its natural fold and unfold, a breadth first search, and a lazy algorithm for generating all of the rationals with no repeats. The whole thing is simple, natural, beautiful, and efficient! It demonstrates infinite recursive types, laziness, higher-order functions, and bounded polymorphism.

And also a neat algorithm!

The downside is that 16 lines is pretty long.

By inlining the fold and unfold I can get it down to 9 lines:

    data BTree a = Node a (BTree a) (BTree a)

    breadthFirst :: BTree a -> [a]
    breadthFirst = concat . glue where
      glue (Node a ls rs) = [a] : zipWith (++) (glue ls) (glue rs)

    rats :: Fractional a => [a]
    rats = breadthFirst (generate (1, 1)) where
      generate (m, n) = Node (m/n) (generate (m, m+n)) (generate (n+m, n))

If I'm allowed imports we can use Data.Tree and make this a one-liner!

    import Data.Tree

    allRationals :: Fractional a => [a]
    allRationals = flatten (unfoldTree step (1, 1)) where
      step (m, n) = ( m/n, [ (m, m+n), (n+m, n) ] )

Finally, if I go another route and fuse the fold and unfold together into a hylomorphism

    data Trip a x = Trip a x x deriving Functor

    hylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
    hylo phi psi = phi . fmap (hylo phi psi) . psi

    allRationals :: Fractional a => [a]
    allRationals = concat (hylo glue step (1, 1)) where
      glue (Trip a ls rs) = [a] : zipWith (++) ls rs
      step (m, n) = Trip (m/n) (m, m+n) (n+m, n)

we can hide the tree entirely and demonstrate `deriving`... at considerable cost to clarity! With a little more golfing (read: inlining) we arrive at this beauty:

    allRationals :: Fractional a => [a]
    allRationals = concat (go (1, 1)) where
      go               = glue . next . step
      next (a, b, c)   = (a, f b, f c)
      glue (a, ls, rs) = [a] : zipWith (++) ls rs
      step (m, n)      = ( m/n, (m, m+n), (n+m, n) )

which at least has the bonus of demonstrating some nice co-recursion between go and next. Or even, ultimately:

    allRationals :: Fractional a => [a]
    allRationals = concat (go 1 1) where go m n = [m/n] : zipWith (++) (go m (m+n)) (go (n+m) n)

which is actually kind of nice again if almost all of the structure has vanished.

Note that if `interleave` were part of the Prelude then we could write

    allRationals :: Fractional a => [a]
    allRationals = go 1 1 where go m n = (m/n) : interleave (go m (m+n)) (go (n+m) n)

given

    interleave :: [a] -> [a] -> [a]
    interleave []     ys     = ys
    interleave xs     []     = xs
    interleave (x:xs) (y:ys) = x : y : interleave xs ys

which is a little prettier and directly comparable to something Pythonic like

    from fractions import Fraction
    from itertools import islice

    def interleave(x, y):
      while True:
        yield x.next()
        yield y.next()

    def all_rationals():
      def go(m, n):
        yield (m/n)
        for v in interleave(go(m, m+n), go(m+n, n)):
          yield v
      return go(Fraction(1,1), Fraction(1,1))

    def rationals(n):
      return list(islice(all_rationals(), n))

[0] http://www.cs.ox.ac.uk/jeremy.gibbons/publications/rationals...