递归到 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 函数，并在遇到 Recurse 标记时调用 createParser。由于无限循环，这不起作用。
使用像 IORef/STRef 这样的可变引用来传递一个引用，一旦转换完成，该引用就会被更新以引用最终的解析器。我不知道如何将 IO/ST monads 线程化到解析器转换函数中。
状态单子。我不知道如何通过状态 monad 传递引用。

我希望这是有道理的，如果我需要详细说明，请告诉我。如果有帮助，我也可以推送我的完整项目。

感谢阅读！

编辑：我在 https://pastebin.com/DN0JJ9BA

对我的原始示例进行了更改以演示无限循环问题（在下面的答案中整合了很好的建议）

Answer 1

我相信你可以在这里使用懒惰。将 final 解析器作为参数传递给 transformSyntaxExprToParser，当您看到 Recurse 时，return 解析器。

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 构造一个 new 解析器，从而构造一个新的解析器……等等。我上面的代码所做的只是传入 same 解析器。

如果在构建解析器时需要执行单子副作用，例如日志记录，那么您可以使用递归do，例如，一些假设MonadLog class 举例：

{-# 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 块引入了一个递归绑定，您可以使用副作用构建它。一般来说，需要注意确保像这样的递归定义足够惰性，也就是说，你不会比预期更快地强制结果，但这里的递归模式非常简单，你永远不会检查 self 解析器，只把它当作一个黑盒子来挂接到其他解析器。

此方法还明确了 Recurse 的范围是什么，并开启了引入本地递归解析器的可能性，使用新的本地 [=27] 对 transformSyntaxExprToParser 的新调用=] 参数。

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

Recursing to a function that doesn't exist yet in Haskell

haskell

functional-programming

parsec

parser-combinators

megaparsec