Haskell Megaparsec：如何显示导致错误的所有解析器的回溯？

Question

这是我的玩具文件：

import Text.Megaparsec
import Text.Megaparsec.Char
import Data.Void (Void)

type Parser = Parsec Void String

myParser :: Parser String
myParser = do
            d <- digitChar
            c <- letterChar
            return $ replicate (read [d]) c

现在从 ghci，如果我输入

parseTest (myParser <?> "foo") "3a"

，我会按预期得到

"aaa"

，但如果我输入

parseTest (myParser <?> "foo") "33a"

，则会得到：

1:2:
  |
1 | 33a
  |  ^
unexpected '3'
expecting letter

错误消息在这个简单的情况下是有意义的（我必须输入一个字母而不是另一个数字），但是当编写更复杂的解析器时，

letterChar

可能出现在任意数量的复合解析器中，所以不清楚which

letterChar 

是失败的一个。由于我为我的解析器传递了一个标签

foo

，因此如果错误消息显示如下内容，我希望它是这样的：

1:2:
  |
1 | 33a
  |  ^
error while parsing foo:
  unexpected '3'
  expecting letter

更一般地说，只要我使用

<?>

给解析器标签，我就希望显示错误的整个回溯，例如：

error while parsing grandparent:
  error while parsing parent:
    unexpected '3'
    expecting letter

有没有办法在兆秒差距中做到这一点？

Answer 1

Megaparsec 没有内置支持执行此操作，但您可以使用其自定义错误机制。

我们可以定义一个自定义错误类型，将上下文标签添加到现有的

ParseError

中，以及

ShowErrorComponent

实例以将其显示在错误消息中。 （这里

Ord

的奇怪孤儿

ParseError

实例满足了一项技术要求。自定义错误需要一个

Ord

实例，但

ParseError

没有实例，因此如果我们想要包含嵌套的对象，我们必须派生一个我们的自定义错误中的 ParseError。）

data ErrorWithLabel = ErrorWithLabel String (ParseError String ErrorWithLabel)
  deriving (Eq, Ord)

-- orphan instance needed for technical reasons
deriving instance Ord (ParseError String ErrorWithLabel)

instance ShowErrorComponent ErrorWithLabel where
  showErrorComponent (ErrorWithLabel l e) =
    "while parsing " <> l <> ",\n" <> parseErrorTextPretty e

它本身不会执行任何操作，但我们可以修改

<?>

及其非运算符等效项

label

的定义来利用此自定义错误。具体来说，我们可以修改它们，以便它们调用

label

的原始 Megaparsec 定义，它可以正确处理解析器在不消耗输入的情况下失败的情况（通过将标签呈现为“最低”错误），然后 also 处理以下情况：解析器在消耗输入后失败（通过用

ErrorWithLabel

上下文包装错误）：

import Text.Megaparsec hiding (label, (<?>))
import qualified Text.Megaparsec as P
import Text.Megaparsec.Internal (ParsecT(..))
import qualified Data.Set as Set

label :: String -> Parser p -> Parser p
label l p = ParsecT $ \s cok cerr eeok eerr ->
  let addLabel e = FancyError (errorOffset e) .
        Set.singleton . ErrorCustom $ ErrorWithLabel l e
  in unParser (P.label l p) s cok (cerr . addLabel) eeok eerr

infix 0 <?>
(<?>) :: Parser p -> String -> Parser p
(<?>) = flip label

这对于您的示例来说效果很好：

λ> parseTest (myParser <?> "foo") "33a"
1:2:                                                                                                     
  |                                                                                                      
1 | 33a                                                                                                  
  |  ^                                                                                                   
while parsing foo,                                                                                       
unexpected '3'                                                                                           
expecting letter

λ> parseTest ((myParser <?> "parent") <?> "grandparent") "33a"
1:2:                                                                                                     
  |                                                                                                      
1 | 33a                                                                                                  
  |  ^                                                                                                   
while parsing grandparent,                                                                               
while parsing parent,                                                                                    
unexpected '3'                                                                                           
expecting letter                                                                                         

完整的代码示例，带有一些稍微复杂的标签：

{-# LANGUAGE GHC2021 #-}

module Main where

import Text.Megaparsec hiding (label, (<?>))
import qualified Text.Megaparsec as P
import Text.Megaparsec.Internal (ParsecT(..))
import Text.Megaparsec.Char
import qualified Data.Set as Set

data ErrorWithLabel = ErrorWithLabel String (ParseError String ErrorWithLabel)
  deriving (Eq, Ord)

deriving instance Ord (ParseError String ErrorWithLabel)

instance ShowErrorComponent ErrorWithLabel where
  showErrorComponent (ErrorWithLabel l e) =
    "while parsing " <> l <> ",\n" <> parseErrorTextPretty e

type Parser = Parsec ErrorWithLabel String

label :: String -> Parser p -> Parser p
label l p = ParsecT $ \s cok cerr eeok eerr ->
  let addLabel e = FancyError (errorOffset e) .
        Set.singleton . ErrorCustom $ ErrorWithLabel l e
  in unParser (P.label l p) s cok (cerr . addLabel) eeok eerr

infix 0 <?>
(<?>) :: Parser p -> String -> Parser p
(<?>) = flip label

repspec :: Parser String
repspec = (do
  d <- digitChar
  c <- letterChar <?> "a character to replicate"
  return $ replicate (read [d]) c)
  <?> "replication spec"

literal :: Parser String
literal = between (char '\'') (char '\'') (takeWhileP Nothing (/= '\'')) <?> "literal string"

comment :: Parser String
comment = "" <$ char ';' <* takeRest <?> "a comment"

expr :: Parser String
expr = (repspec <|> literal <?> "expression")
  <|>  (comment <?> "comment")

main :: IO ()
main = mapM_ (parseTest (expr <* eof))
  [ "3a"   -- parses okay

  , "33a"  -- while parsing expression,
  --  ^    -- while parsing repspec,
           -- unexpected '3'
           -- expected a character to replicate

  , "?"    -- unexpected '?'
  -- ^     -- expecting comment or expression

  , "'x"   -- while parsing expression,
  --   ^   -- while parsing literal string,
           -- unexpected end of input
           -- expecting '''
  ]