parsing - Haskell Arrowパーサーで「ゼロ以上」を実装すると無限ループ

Question

Haskell で矢印を使用する方法を学んでおり、次のパーサーを実装しています。

最後の 2 つのテストを除いて、すべてのテストは問題なく動作します。

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

これらのテストは無限ループに陥ります。問題はなぜですか？私が見る限り、それはうまくいくはずですか？

{-# 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"