我正在学习使用Haskell语言的函数式编程。作为练习，我需要实现一个函数来解析String中的原始算术表达式。该函数必须能够处理双精度字面值、具有通常优先级和括号的运算+、-、*、/。

parseExpr :: String -> Except ParseError Expr

具有下一个定义的数据类型：

data ParseError = ErrorAtPos Natural
  deriving Show

newtype Parser a = P (ExceptState ParseError (Natural, String) a)
  deriving newtype (Functor, Applicative, Monad)

data Prim a
  = Add a a 
  | Sub a a 
  | Mul a a 
  | Div a a 
  | Abs a   
  | Sgn a
  deriving Show

data Expr
  = Val Double      
  | Op (Prim Expr)  
  deriving Show

其中ExceptState是修改后的State单子，允许引发指向错误位置的异常。

data Annotated e a = a :# e
  deriving Show
infix 0 :#

data Except e a = Error e | Success a 
  deriving Show

data ExceptState e s a = ES { runES :: s -> Except e (Annotated s a) }

此外，ExceptState还定义了Functor、Applicative和Monad示例，这些示例在前面已经过全面测试，因此我对它们的正确性持肯定态度。

instance Functor (ExceptState e s) where
  fmap func ES{runES = runner} = ES{runES = \s ->
    case (runner s) of
      Error err   -> Error err
      Success ans -> Success (mapAnnotated func $ ans) }

instance Applicative (ExceptState e s) where
  pure arg = ES{runES = \s -> Success (arg :# s)}
  p <*> q = Control.Monad.ap p q

instance Monad (ExceptState e s) where
  m >>= f = joinExceptState (fmap f m)
    where
      joinExceptState :: ExceptState e s (ExceptState e s a) -> ExceptState e s a
      joinExceptState ES{runES = runner} = ES{runES = \s ->
        case (runner s) of
          Error err -> Error err
          Success (ES{runES = runner2} :# s2) ->
            case (runner2 s2) of
              Error err           -> Error err
              Success (res :# s3) -> Success (res :# s3) }

为了实现函数parseExpr，我使用了基本的解析器组合子：

pChar :: Parser Char
pChar = P $ ES $ \(pos, s) ->
  case s of
    []     -> Error (ErrorAtPos pos)
    (c:cs) -> Success (c :# (pos + 1, cs))

parseError :: Parser a
parseError = P $ ES $ \(pos, _) -> Error (ErrorAtPos pos)

instance Alternative Parser where
  empty = parseError

  (<|>) (P(ES{runES = runnerP})) (P(ES{runES = runnerQ})) =
    P $ ES $ \(pos, s) ->
      case runnerP (pos, s) of
        Error _     -> runnerQ (pos, s)
        Success res -> Success res

instance MonadPlus Parser

用来构建更复杂的模型：

-- | elementary parser not consuming a character, failing if input doesn't
-- reach its end
pEof :: Parser ()
pEof = P $ ES $ \(pos, s) ->
  case s of
    [] -> Success (() :# (pos, []))
    _  -> Error $ ErrorAtPos pos

-- | parses a single digit value
parseVal :: Parser Expr
parseVal = Val <$> (fromIntegral . digitToInt) <$> mfilter isDigit pChar

-- | parses an expression inside parenthises
pParenth :: Parser Expr
pParenth = do
  void $ mfilter (== '(') pChar
  expr <- parseAddSub
  (void $ mfilter (== ')') pChar) <|> parseError
  return expr

-- | parses the most prioritised operations
parseTerm :: Parser Expr
parseTerm = pParenth <|> parseVal

parseAddSub :: Parser Expr
parseAddSub = do
  x <- parseTerm
  ys <- many parseSecond
  return $ foldl (\acc (sgn, y) -> Op $
    (if sgn == '+' then Add else Sub) acc y) x ys

  where
    parseSecond :: Parser (Char, Expr)
    parseSecond = do
      sgn <- mfilter ((flip elem) "+-") pChar
      y <- parseTerm <|> parseError
      return (sgn, y)

-- | Parses the whole expression. Begins from parsing on +, - level and
-- successfully consuming the whole string.
pExpr :: Parser Expr
pExpr = do
  expr <- parseAddSub
  pEof
  return expr

-- | More convinient way to run 'pExpr' parser
parseExpr :: String -> Except ParseError Expr
parseExpr = runP pExpr

因此，如果给定的String表达式有效，则此时函数按预期工作：

ghci> parseExpr "(2+3)-1"
Success (Op (Sub (Op (Add (Val 2.0) (Val 3.0))) (Val 1.0)))
ghci> parseExpr "(2+3-1)-1"
Success (Op (Sub (Op (Sub (Op (Add (Val 2.0) (Val 3.0))) (Val 1.0))) (Val 1.0)))

否则ErrorAtPos不指向所需位置：

ghci> parseExpr "(2+)-1"
Error (ErrorAtPos 1)
ghci> parseExpr "(2+3-)-1"
Error (ErrorAtPos 1)

我做错什么了？先谢谢你。
我的主要假设是Alternative Parser的函数(<|>)出了问题，它错误地更改了pos变量。

(<|>) (P(ES{runES = runnerP})) (P(ES{runES = runnerQ})) =
    P $ ES $ \(pos, s) ->
      case runnerP (pos, s) of
        -- Error _     -> runnerQ (pos, s)
        Error (ErrorAtPos pos')     -> runnerQ (pos' + pos, s)
        Success res -> Success res

但这导致了更奇怪的结果：

ghci> parseExpr "(5+)-3"
Error (ErrorAtPos 84)
ghci> parseExpr "(5+2-)-3"
Error (ErrorAtPos 372)

尽管我已经运行了instance Monad (ExceptState e s)的joinExceptState函数，但是更多的怀疑是针对instance Monad (ExceptState e s)的joinExceptState函数，怀疑它在(Natural, String)类型的s上不起作用，就像我在这个例子中缩进的那样。但是我不能只为这个具体的类型改变它。