使用 Haskell/Megaparsec : StateT for building up local, 词法范围进行解析？

Question

所以我正在尝试做标准的“为类似方案的语言编写一个解析器”练习来找出 MegaParsec 和 monad 转换器。根据许多教程和博客文章的建议，我使用 ReaderT 和 local 来实现词法作用域。

我在尝试实现 let* 时遇到了麻烦。 let 和 let* 共享相同的语法，绑定(bind)变量以在后续表达式中使用。两者之间的区别在于 let* 允许您在后续绑定(bind)中使用绑定(bind)，而 let 则不允许:

(let ((x 1) (y 2)) (+ x y))       ; 3
(let* ((x 1) (y (+ x x)) (+ x y)) ; 3
(let ((x 1) (y (+ x x)) (+ x y))  ; Error unbound symbol "x"

我的问题是，在解析 let* 表达式时，我需要将绑定(bind)一一添加到当前范围，以便每个绑定(bind)都可以在后续范围中使用。这似乎是 StateT 的一个很好的用例；允许我一次建立一个绑定(bind)的本地范围。然后，在解析完所有新绑定(bind)后，我可以将这些绑定(bind)以及从父作用域继承的绑定(bind)一起通过 local 传递给 let* 表达式的第三个参数。

我按如下方式构建我的 monad 变压器堆栈:

type Parser = Parsec Void String
type Env = Map.Map String Float
type RSParser = ReaderT Env (StateT Env Parser)

这是解析器，在仍然表达我的观点的同时，尽可能地简化了。特别是，Float 是唯一的数据类型，+、* 和 let* 是唯一的命令。

data Op = Plus | Times

spaceConsumer :: Parser ()
spaceConsumer = Lexer.space space1
                            (Lexer.skipLineComment ";")
                            (Lexer.skipBlockComment "#|" "|#")
lexeme :: Parser a -> RSParser a
lexeme = lift . lift . Lexer.lexeme spaceConsumer

lParen, rParen :: RSParser Char
lParen = lexeme $ char '('
rParen = lexeme $ char ')'

plus, times :: RSParser Op
plus = lexeme $ char '+' $> Plus
times = lexeme $ char '*' $> Times

keyValuePair :: RSParser ()
keyValuePair = between lParen rParen $ do
    state <- get
    name  <- lift . lift $ Lexer.lexeme spaceConsumer (some letterChar)
    x     <- num
    modify (union (fromList [(name, x)]))

keyValuePairs :: RSParser ()
keyValuePairs = between lParen rParen (many keyValuePair) $> ()

num :: RSParser Float
num = lexeme $ Lexer.signed (return ()) Lexer.float

expr, var :: RSParser Float
expr = num <|> var <|> between lParen rParen (arithExpr <|> letStarExpr)
var = do
    env <- ask
    lift . lift $ do
        name <- Lexer.lexeme spaceConsumer (some letterChar)
        case Map.lookup name env of
            Nothing -> mzero
            Just x  -> return x
arithExpr = do
    op   <- (plus <|> times) <?> "operation"
    args <- many (expr <?> "argument")
    return $ case op of
        Plus  -> sum args
        Times -> product args
letStarExpr = lexeme (string "let*") *> do
    keyValuePairs
    bindings <- get
    local (Map.union bindings) expr

main :: IO ()
main = do
    parseTest (runStateT (runReaderT expr (fromList [("x", 1)])) Map.empty)
              "(+ (let* ((x 666.0)) x) x)"
        -- (667.0,fromList [("x",666.0)]) Ok
    parseTest (runStateT (runReaderT expr (fromList [("x", 1)])) Map.empty)
              "(+ (let* ((x 666.0)) x) (let* ((w 0.0)) x))"
        -- (1332.0,fromList [("x",666.0)]) Wrong

上面的第一个测试成功，但第二个测试失败。它失败是因为第一个 let* 表达式中保存 x 绑定(bind)的可变状态被转移到第二个 let* 表达式。 我需要一种方法来使这个可变状态本地到相关的计算中，而这是我不知道该怎么做的。是否有类似的来自Reader的本地命令用于状态？我使用了错误的 monad 变压器堆栈吗？我的方法有根本缺陷吗？

我尝试过的天真的(回想起来)解决方案是通过向 letStarExpr 添加 put Map.empty 语句来重置每个 let* 表达式的可变状态:

letStarExpr = lexeme (string "let*") *> do
    keyValuePairs
    bindings <- get
    put Map.empty
    local (Map.union bindings) expr

但这与嵌套的 let* 表达式不兼容:

parseTest (runStateT (runReaderT expr (fromList [("x", 1)])) Map.empty)
    (let* ( (x 666.0) (y (let* ((z 3.0)) z)) ) x)

给出 1.0 而不是 666.0。

有什么想法吗？

Answer 1

正如 Alexis King 在评论中指出的那样，将解析与评估分开是标准做法。

但是，为了解决当前问题，可以在此处以惯用的方式进行解析时进行评估。关键点如下:没有任何上下文相关规则的词法作用域只需要一个 Reader monad，用于作用域/类型检查和评估。原因在于“词法”属性:纯嵌套作用域对作用域结构的其他分支没有副作用，因此状态中不应该携带任何内容。所以最好去掉State。

有趣的部分是letStarExpr。在那里，我们不能再使用many，因为它不允许我们处理每个键值对上新绑定(bind)的名称。相反，我们可以编写 many 的自定义版本，它使用 local 在每个递归步骤上绑定(bind)一个新名称。在代码示例中，我只是使用 fix 内联此函数。

另一个注意事项:lift 不应该与 mtl 共同使用； mtl 的目的是消除大多数提升。 megaparsec 导出已在 MonadParsec 上得到推广。下面是一个使用 megaparsec 7.0.4 的代码示例，我做了上面提到的更改和一些进一步的风格更改。

import Control.Monad.Reader
import Data.Map as Map
import Data.Void

import Text.Megaparsec
import qualified Text.Megaparsec.Char as Char
import qualified Text.Megaparsec.Char.Lexer as Lexer

type Env    = Map String Double
type Parser = ReaderT Env (Parsec Void String)

spaceConsumer :: Parser ()
spaceConsumer = Lexer.space Char.space1
                            (Lexer.skipLineComment ";")
                            (Lexer.skipBlockComment "#|" "|#")

lexeme = Lexer.lexeme spaceConsumer
symbol = Lexer.symbol spaceConsumer
char   = lexeme . Char.char

parens :: Parser a -> Parser a
parens = between (char '(') (char ')')

num :: Parser Double
num = lexeme $ Lexer.signed (pure ()) Lexer.float

identifier :: Parser String
identifier = try $ lexeme (some Char.letterChar)

keyValuePair :: Parser (String, Double)
keyValuePair = parens ((,) <$> identifier <*> num)

expr :: Parser Double
expr = num <|> var <|> parens (arithExpr <|> letStarExpr)

var :: Parser Double
var = do
  env  <- ask
  name <- identifier
  maybe mzero pure (Map.lookup name env)

arithExpr :: Parser Double
arithExpr =
      (((sum <$ char '+') <|> (product <$ char '*')) <?> "operation")
  <*> many (expr <?> "argument")

letStarExpr :: Parser Double
letStarExpr = do
  symbol "let*"
  char '('
  fix $ \go ->
        (char ')' *> expr)
    <|> do {(x, n) <- keyValuePair; local (insert x n) go}

main :: IO ()
main = do
    parseTest (runReaderT expr (fromList [("x", 1)]))
              "(+ (let* ((x 666.0)) x) x)"
    parseTest (runReaderT expr (fromList [("x", 1)]))
              "(+ (let* ((x 666.0)) x) (let* ((w 0.0)) x))"