问在Haskell Arrow解析器中实现“0或更多”时的无限循环

EN

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"