Infinite loop when implementing "zero or more" in Haskell Arrow parser

Question

I am learning how to use arrows in Haskell and have implemented the following parser.

All tests work fine except for the last two tests:

test (pZeroOrMore pDigit) "x123abc"
test (pZeroOrMore pDigit) "123abc"

Those tests get stuck in an infinite loop. The question is why? As far as I can see it should work OK?

{-# LANGUAGE Arrows #-}

module Code.ArrowParser where

import Control.Arrow
import Control.Category

import Data.Char

import Prelude hiding (id,(.))

---------------------------------------------------------------------

data Parser a b = Parser { runParser :: (a,String) -> Either (String,String) (b,String) }

---------------------------------------------------------------------

instance Category Parser where
    id = Parser Right

    (Parser bc) . (Parser ab) = Parser $ \a ->
        case ab a of
            Left    es  -> Left es
            Right   b   -> bc b

---------------------------------------------------------------------

instance Arrow Parser where
    arr ab = Parser $ \(a,s) -> Right (ab a,s)

    first (Parser ab) = Parser $ \((a,c),as) ->
        case ab (a,as) of
            Left    es      -> Left     es
            Right   (b,bs)  -> Right    ((b,c),bs)

---------------------------------------------------------------------

pChar :: Char -> Parser a Char

pChar c =
    pMatch (== c) ("'" ++ [c] ++ "' expected")

---------------------------------------------------------------------

pConst :: a -> Parser x a

pConst a = arr (\_ -> a)

---------------------------------------------------------------------

pDigit :: Parser a Int

pDigit =
    pMatch isDigit ("Digit expected") >>> arr (\c -> ord c - ord '0')

---------------------------------------------------------------------

pError :: String -> Parser a ()

pError e = Parser $ \(_,s) -> Left (e,s)

---------------------------------------------------------------------

pIf :: Parser a b -> Parser b c -> Parser a c -> Parser a c

pIf (Parser pc) (Parser pt) (Parser pf) = Parser $ \(a,as) ->
    case pc (a,as) of
        Right   (b,bs)  -> pt (b,bs)
        Left    _       -> pf (a,as)

---------------------------------------------------------------------

pMatch :: (Char -> Bool) -> String -> Parser a Char

pMatch f e = Parser $ \(_,s) ->
    if s /= [] && f (head s) then
        Right (head s,tail s)
    else
        Left (e, s)

---------------------------------------------------------------------

pMaybe :: (Char -> Maybe b) -> String -> Parser a b

pMaybe f e = Parser $ \(_,s) ->
    if s == [] then
        Left (e, s)
    else
        case f (head s) of
            Nothing -> Left  (e,s)
            Just b  -> Right (b,tail s)

---------------------------------------------------------------------

pZeroOrMore :: Parser () b -> Parser () [b]

pZeroOrMore p =
        pIf p (arr (\b -> [b])) (pConst [])
    >>> arr ((,) ())
    >>> first (pZeroOrMore p)
    >>> arr (\(b1,b0) -> b0 ++ b1)

---------------------------------------------------------------------

test :: Show a => Parser () a -> String -> IO ()

test p s =
    print $ runParser p ((),s)

---------------------------------------------------------------------

arMain :: IO ()

arMain = do
    test (pChar 'a') "abcdef"
    test (pChar 'b') "abcdef"
    test pDigit "54321"
    test (pIf (pChar 'a') (pChar 'b') (pChar 'c')) "abc"
    test (pIf (pChar 'a') (pChar 'b') (pChar 'c')) "bc"
    test (pIf (pChar 'a') (pChar 'b') (pChar 'c')) "c"
    test (pError "Error!" >>> pChar 'a') "abc"
    test (pZeroOrMore pDigit) "x123abc"
    test (pZeroOrMore pDigit) "123abc"

Answer 1

There's no stoppage condition on your pZeroOrMore function. The line pIf p (arr (\b -> [b])) (pConst []) is always returning Right ... even if there's no parse. Which means that the recursive call first (pZeroOrMore p) is always executed, thus the infinite loop.