haskell - 递归到 Haskell 中尚不存在的函数

Question

我在用 Haskell 编写解析器时遇到了问题，希望有人能帮忙解决!
它比我通常的解析器要复杂一些，因为有两层解析。首先将语言定义解析为 AST，然后将该 AST 转换为另一个解析实际语言的解析器。
到目前为止，我已经取得了相当不错的进展，但我一直坚持在语言定义中实现递归。当语言定义从 AST 转换为递归函数中的解析器时，如果它还不存在，我无法弄清楚它如何调用自己。
我发现解释我的问题有点困难，所以也许一个例子会有所帮助。
语言定义可能定义一种语言由三个顺序的关键字和括号中的可选递归组成。

A B C ($RECURSE)

这将被解析为一个 AST，如:

[Keyword "A", Keyword "B", Keyword "C", Optional (Many [Recurse])]

Many这个例子并不是真的需要，但在我的实际项目中，可选块可以有多个语法元素，所以 Optional将包含 Many有 n 个元素。
然后我希望它被转换成一个解析器来解析如下字符串:

A B C
A B C (A B C)
A B C (A B C (A B C))

我已将我的项目归结为最简单的示例。你可以看到我的 TODO 评论，我在那里试图实现递归。

{-# LANGUAGE OverloadedStrings #-}

module Example
  ( runExample,
  )
where

import Control.Applicative hiding (many, some)
import Data.Text (Text)
import Data.Void
import System.IO as SIO
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char (space1, string')
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Megaparsec.Debug
import Text.Pretty.Simple (pPrint)

-- Types

type Parser = Parsec Void Text

data SyntaxAst = Keyword Text | Recurse | Optional SyntaxAst | Many [SyntaxAst]

--  Megaparsec Base Parsers

-- Space consumer - used by other parsers to ignore whitespace
sc :: Parser ()
sc =
  L.space
    space1
    (L.skipLineComment "--")
    (L.skipBlockComment "/*" "*/")

-- Runs a parser, then consumes any left over space with sc
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc

-- Parses a string, then consumes any left over space with sc
symbol :: Text -> Parser Text
symbol = L.symbol sc

-- Parses something between parentheses
inParens :: Parser a -> Parser a
inParens =
  between
    (symbol "(")
    (symbol ")")

-- Transforms the AST into a parser
transformSyntaxExprToParser :: SyntaxAst -> Parser [Text]
transformSyntaxExprToParser (Many exprs) = dbg "Many" (createParser exprs)
transformSyntaxExprToParser (Keyword text) = dbg "Keyword" (pure <$> lexeme (string' text))
transformSyntaxExprToParser (Optional inner) = dbg "Optional" (option [] (try (inParens (transformSyntaxExprToParser inner))))
transformSyntaxExprToParser Recurse = dbg "Recurse" (pure ["TODO"]) -- TODO: How do I recurse here?
-- transformSyntaxExprToParser s Recurse = dbg "Recurse" (createParser s) -- Seems to work in the example, but in my actual application creates an infinite loop and freezes

-- Walks over the parser AST and convert it to a parser
createParser :: [SyntaxAst] -> Parser [Text]
createParser expressions =
  do
    foldr1 (liftA2 (<>)) (fmap transformSyntaxExprToParser expressions)

runExample :: IO ()
runExample = do
  -- To make the example simple, lets cut out the language definition parsing and just define
  -- it literally.
  let languageParser = createParser [Keyword "A", Keyword "B", Keyword "C", Optional (Many [Recurse])]
  let run p = runParser p "" "A B C (A B C (A B C))"
  let result = run languageParser
  case result of
    Left bundle -> SIO.putStrLn (errorBundlePretty bundle)
    Right xs -> pPrint xs

我尝试过的几件事:

将原始 AST 传递给 transformSyntaxExprToParser函数和调用 createParser当Recurse遇到 token 。由于无限循环，这不起作用。

使用像 IORef/STRef 这样的可变引用传入一个引用，一旦转换完成，该引用就会更新以引用最终的解析器。我不知道如何将 IO/ST monad 线程化到解析器转换函数中。

状态单子(monad)。我不知道如何通过 state monad 传递引用。

我希望这是有道理的，如果我需要详细说明，请告诉我。如果有帮助，我也可以推进我的整个项目。
谢谢阅读!
编辑:我对原始示例进行了更改，以在 https://pastebin.com/DN0JJ9BA 上演示无限循环问题(在下面的答案中整合了出色的建议)

Answer 1

我相信你可以在这里使用懒惰。将最终解析器作为参数传递给 transformSyntaxExprToParser ，当您看到 Recurse ，返回那个解析器。

transformSyntaxExprToParser :: Parser [Text] -> SyntaxAst -> Parser [Text]
transformSyntaxExprToParser self = go
  where
    go (Keyword text) = dbg "Keyword" (pure <$> lexeme (string' text))
    go (Optional inner) = dbg "Optional" (option [] (try (inParens (go inner))))
    go Recurse = dbg "Recurse" self

createParser :: [SyntaxAst] -> Parser [Text]
createParser expressions = parser
  where
    parser = foldr1 (liftA2 (<>))
      (fmap (transformSyntaxExprToParser parser) expressions)

这应该产生完全相同的递归解析器，就像你直接编写它一样。一个 Parser最终只是一个数据结构，您可以使用其 Monad 的实例来构造它, Applicative , Alternative ， ＆C。
您使用可变引用(例如 IORef)执行此操作的想法本质上是在构建和评估 thunk 时发生的事情。
你的想法几乎是正确的:

Pass the original AST up to the transformSyntaxExprToParser function and call createParser when the Recurse token is encountered. This didn't work due to infinite loops.

问题是您正在为每个 Recurse 构建一个新的解析器。 ，来自同一输入，其中包含 Recurse ，从而构建一个新的解析器……等等。我上面的代码所做的只是传入同一个解析器。
如果您在构建解析器时需要执行 monadic 副作用，例如日志记录，那么您可以使用递归 do ，例如，一些假设 MonadLog插图类:

{-# Language RecursiveDo #-}

transformSyntaxExprToParser :: (MonadLog m) => Parser [Text] -> SyntaxAst -> m (Parser [Text])
transformSyntaxExprToParser self = go
  where
    go (Keyword text) = do
      logMessage "Got ‘Keyword’"
      pure $ dbg "Keyword" (pure <$> lexeme (string' text))
    go (Optional inner) = do
      logMessage "Got ‘Optional’"
      inner' <- go inner
      pure $ dbg "Optional" (option [] (try (inParens inner')))
    go Recurse = do
      logMessage "Got ‘Recurse’"
      pure $ dbg "Recurse" self

createParser :: (MonadFix m, MonadLog m) => [SyntaxAst] -> m (Parser [Text])
createParser expressions = do
  rec
    parser <- fmap (foldr1 (liftA2 (<>)))
      (traverse (transformSyntaxExprToParser parser) expressions)
  pure parser

rec块引入了一个递归绑定(bind)，您可以使用副作用构造它。一般来说，需要注意确保像这样的递归定义足够懒惰，也就是说，您不会比预期更快地强制结果，但这里的递归模式非常简单，您从不检查 self解析器，仅将其视为黑匣子以连接其他解析器。
该方法还明确了 Recurse 的范围。是，并开启了引入本地递归解析器的可能性，新调用 transformSyntaxExprToParser与新本地 self争论。