Bug in Parser Combinators?

[Nick Kallen]

The following program is taken (almost exactly) from the Parser Combinators
chapter in the Clean book:

module test
import StdEnv, Parser
natural :: Parser Char Int
natural = <*> digit <@ foldl nextDigit 0
where nextDigit a b = a*10+b
digit :: Parser Char Int
digit = satisfy isDigit <@ digtoInt
Start = natural ['100']

When I try to run it, I get the error:
    Run time error, rule 'p' in module 'Parser' does not match

Parser is a module I made by almost directly copying the Parser Combinators
document (a copy is appended to this message). The error stems from <*>, but
I cannot see why my implementations
of <*> or any of the functions it depends upon are different (in meaning)
from those in the document. So I don't know what the error is.
    My guess is that there's an error in <&> in that the empty list xs1 as a
result of p1 cannot be correctly parsed by p2. This is corresponded by the
fact that (Start = natural ['100x']) works! This little kludge of inserting
something that wont let (satisfy isDigit) evaluate as true is unsatisfactory
in my oppinion.
    Now, I -assume- that the epsilon in the definition of <*> is supposed to
prevent this error. Unfortunately, it wont. Despite all the laziness, the
<&> is evaluated before the epsilon.

Does anyone have any clue as to how to fix this?
---
my module Parser is as follows:

implementation module Parser
import StdEnv
:: Parser s r :== [s] -> [([s], r)]
:: DetPars s r :== [s] -> r
token :: [s] -> Parser s [s] | Eq s
token k = p
where
  p xs
   | k == take n xs = [(drop n xs, k)]
   | otherwise = []
  n = length k
symbol :: s -> Parser s [s] | Eq s
symbol s = token [s]
satisfy :: (s -> Bool) -> Parser s s
satisfy f = p
where
  p [x:xs]
   | f x = [(xs, x)]
   | otherwise = []
succeed :: r -> Parser s r
succeed v = p
where
  p xs = [(xs, v)]
epsilon :: Parser s [r]
epsilon = succeed []
fail :: Parser s r
fail = p
where
  p xs = []
(<&>) infixr 6 :: (Parser s a) (Parser s b) -> Parser s (a, b)
(<&>) p1 p2 = p
where
  p xs = [ (xs2, (v1, v2))
   \\ (xs1, v1) <- p1 xs
   , (xs2, v2) <- p2 xs1
   ]
(<|>) infixr 4 :: (Parser s a) (Parser s a) -> Parser s a
(<|>) p1 p2 = p
where
  p xs = p1 xs ++ p2 xs
sp :: (Parser Char a) -> Parser Char a
sp p = p o dropWhile isSpace
spsymbol :: Char -> Parser Char [Char]
spsymbol c = symbol c o dropWhile isSpace
sptoken :: [Char] -> Parser Char [Char]
sptoken t = token t o dropWhile isSpace
just :: (Parser s a) -> Parser s a
just p = filter (isEmpty o fst) o p
(<@) infixl 5 :: (Parser s a) (a->b) -> Parser s b
(<@) p0 f = p
where
  p xs = [(ys, f v) \\ (ys, v) <- p0 xs]
some :: (Parser s a) -> DetPars s a
some p = snd o hd o just p
(<&) infixr 6 :: (Parser s a) (Parser s b) -> Parser s a
(<&) p q = p <&> q <@ fst
(&>) infixr 6 :: (Parser s a) (Parser s b) -> Parser s b
(&>) p q = p <&> q <@ snd
(<:&>) :: (Parser s a) (Parser s [a]) -> Parser s [a]
(<:&>) p q = p <&> q <@ (\(x, xs) -> [x:xs])
<*> :: (Parser s a) -> Parser s [a]
<*> p = (p <:&> <*> p)
<|> epsilon <@ (\_ -> [])

<+> :: (Parser s a) -> Parser s [a]
<+> p = p <:&> <*> p
<?> :: (Parser s a) -> Parser s [a]
<?> p = p <@ (\x -> [x])
<|> epsilon
first :: (Parser s a) -> Parser s a
first p = take 1 o p
<!*> :: ((Parser s a) -> Parser s [a])
<!*> = first o <*>
<!+> :: ((Parser s a) -> Parser s [a])
<!+> = first o <+>
<!?> :: ((Parser s a) -> Parser s [a])
<!?> = first o <?>
pack :: (Parser s a) (Parser s b) (Parser s c) -> Parser s b
pack s1 p s2 = s1 &> p <& s2
listOf :: (Parser s a) (Parser s b) -> Parser s [a]
listOf p s = p <:&> <*> (s &> p)
<|> epsilon
chainl :: (Parser s a) (Parser s (a a -> a)) -> Parser s a
chainl p s = p <&> <*> (s <&> p)
<@ (\(e0, l) -> foldl (\x (op, y) -> op x y) e0 l)
chainr :: (Parser s a) (Parser s (a a -> a)) -> Parser s a
chainr p s = <*> (p <&> s) <&> p
<@ (\(l, e0) -> foldr (\(x, op) y -> op x y) e0 l)
(<?@) infixl 5 :: (Parser s [a]) (b, a -> b) -> Parser s b
(<?@) p (no, yes) = p <@ f
where
  f [x] = yes x
  f [] = no
(<&=>) infixr 6 :: (Parser s a) (a -> Parser s b) -> Parser s b
(<&=>) p1 p2 = p
where
  p xs = [ tuples
   \\ (xs1, v1) <- p1 xs
   , tuples <- p2 v1 xs1
   ]
(<!>) infixr 4 :: (Parser s r) (Parser s r) -> Parser s r
(<!>) p q = p`
where
  p` xs = case p xs of
   [] -> q xs
   r -> r

-Nick