[译] 用 Haskell 写简单的 Monadic Parser

原文:

Simple Monadic Parser in Haskell
http://michal.muskala.eu/2015/09/23/simple-monadic-parser-in-haskell.html

---

最近我开始学习 Haskell, 同时很享受 Haskel 提供的视野. 可能以后会再写一篇.
今天我分享我用 Haskell 写的第一个比较大的程序.

Real World Haskell 的错误处理章节 激发了这篇文章的
也是这篇文章和代码想法背后最初的来源
书的作者是 Bryan O'Sullivan, Don Stewart, 和 John Goerzen
我推荐所有想要学习 Haskell 的人看这本书

Brainfuck 语言

学 Haskell 的时候我给自己定了一个目标 -- 写一个 Brainfuck 的优化编译器
如果你不熟悉 Brainfuck -- 它是一门极为简单的 toy 语言
它在一个内存单元的队列上进行操作, 每个初始值都是 0
存在一个指针, 初始状态下指向第一个内存单元
你可以通过下面 8 个操作来操作指针和内存单元

符号	含义
>	指针右移一位
<	指针左移一位
+	当前内存单元数值增大
-	当前内存单元数值减小
.	输出当前指针表示的字符
',`	输入一个字符, 存储在当前指针的内存单元
[	如果当前指针对应内存单元是 0, 跳过匹配的 ]
]	如果当前指针对应内存单元非 0, 跳回匹配的 [

所有其他符号被认为是注释

如果你对语言奇怪的名字有疑问 -- 我可以给你看下 Brainfuck 的 "Hello World"
我觉得这让名字惨痛而且明显

++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]>>.>
---.+++++++..+++.>>.<-.<.+++.------.--------.>>+.>++.

因为语言简单, 所以存在大量可以由编译器优化的地方
也是学习他们的一个好机会

基本的 Parser

不过还是回到 parser 本身上
我知道 Haskell 已经有很棒的 parser, 特别是 Parsec 和 Attoparsec
不过我要自己写一个, 为了多学一点 Monad, 以及怎么用 Haskell

首先我定义两个类型: AST 是我们的目标,
然后 ParseError 用来区别错误的结果:

data ParseError = Unexpected Char
                | UnexpectedEof
                | Unknown
                deriving (Eq, Show)

data AST = PtrMove Int
         | MemMove Int
         | Output
         | Input
         | Loop [AST]
         deriving (Eq, Show)

Monad 部分我用 mtl 包
我们的 Parser Monad 会复合一个内部的 State Monad 保存正在 parse 的字符串
以及 ExceptT Monad Transformer 用来处理解析错误
为了能够简单地 derive 所需的 Monad Typeclass
我们需要激活 GeneralizedNewtypeDeriving 语言扩展

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

newtype Parser a = P { runP :: ExceptT ParseError (State String) a
                     } deriving ( Monad
                                , MonadError ParseError
                                , MonadState String
                                )

然后来定义我们用来运行 Monad 的函数, 它只是解开不同的层次, 梳理出结果

runParser :: Parser a -> String -> Either ParseError (a, String)
runParser parser str =
  case (runState . runExceptT . runP) parser str of
    (Left err, _)   -> Left err
    (Right r, rest) -> Right (r, rest)

然后定义基础的 parser -- satisfy 用来 parse 满足一个断言的字符:

satisfy :: (Char -> Bool) -> Parser Char
satisfy predicate = do
  s <- get
  case s of
    x:xs | predicate x -> do
             put xs
             return x
    x:_ -> throwError (Unexpected x)
    []  -> throwError UnexpectedEof

我们从内部的 State Monad 中拿到 Parser State (也就是正在解析的字符串)
然后检查字符串中的第一个是否匹配
匹配的时候, 我们更新一遍 State, 返回匹配的结果 Char
我们运行 Parser 的时候它会被包裹在一个 Right Char 的值当中
如果断言不满足, 那么我们跑出一个 Unexpected Char 的错误
借助于 ExceptT Monad transformer 我们可以抛出错误
分支被触发的话, 它会使得 Parser 返回 Left (Unexpected Char)
如果没有输入的内容可以处理, 我们抛出一个 UnexpectedEof 错误

Parser combinators

准备好了这些基本的模块, 我们可以开始考虑组合多个 Parser 的办法
用来处理更大块的输入内容

需要从两个 Parser 之中选择的办法
我们需要让 Parser 能尝试运行一个 Parser, 在失败时运行另一个
要定义一个 option 函数, 专门用来做这个事情
可以认为这是一个把两个 Parser 组合成一个的办法

option :: Parser a -> Parser a -> Parser a
option parser1 parser2 = do
  s <- get
  parser1 `catchError` \_ -> do
    put s
    parser2

这一次也是, 我们重新得到 State. 然后尝试用第一个 Parser 来解析
catchError 函数是借助于 ExceptT transformer 提供的
它会尝试左边的代码, 失败的话, 它会处理右边的函数, 同时传入错误作为参数
我们实际上不关心错误内容, 所以这里我们直接重置初始状态然后继续
(因为我们需要再一次解析同样的输入内容), 然后运行另一个 Parser

这样我们也很容易定义函数接收一列 Parser 然后逐个应用, 返回一个成功的 Parser
定义函数名是 choice, 因为这是从多个 parser 当中做选择:

choice :: [Parser a] -> Parser a
choice = foldr option (throwError Unknown)

这个函数中唯一不直接展示的是函数的初始值
默认情况下我们认为 Parser 会随着一个 Unknown 错误执行失败
我们把 Parser 队列逐个 fold 过去, 直到有一个执行成功
借助于惰性计算, 我们不用担心后面的可能运行成功的 Parser
在进行 fold 而没有足够的 Parser 时, option 会得到一个 Unknown 错误
如果你传入一个空列表, 没有 Parser 可以执行, 我们返回一个 Unknown 错误
因为我们在不执行的情况下不知道是什么错误

然后我想到会需要执行一个 Parser 很多次
于是定义是个 many 函数, 它接收一个 Parser 然后尽可能多次尝试执行
最后返回解析成功的数据的列表
它看起来可能短, 不过我觉得这是这篇博客中最复杂的一个函数
我尝试一下彻底解释一遍:

many :: Parser a -> Parser [a]
many parser = recurse `catchError` \_ -> return []
  where recurse = do
          result <- parser
          rest   <- many parser
          return (result:rest)

复杂的原因是其中包含了一些奇特的人工的递归. 发生了什么呢?
首先我们尝试用 recurse(不用管什么意思 -- 先不管它)
如果执行失败, 我们直接返回一个空的列表, 用前面的 catchError 函数忽略报错
那么递归过程当中发生了什么?
首先, 执行一次 Parser, 展开其中的数据
然后, 递归执行 Parser 很多次, 得到其余的可以解析的输入内容
最后, 把第一次解析的结果和其余内解析的结果用 cons 拼接在一起

具体来说是怎么运行的呢? 来看一个例子, 一步一步看下去
比如我们从字符串 "aab" 解析字符 'a'
运行到 many 函数, 马上进度 recurse 辅助函数
这里会执行一个解析, 得到 'a' 作为结果
在最后得到的结果会是 'a':rest, 其中 rest 是后面递归调用自身的结果
继续, 再一次递归进入函数, 这次输入内容只有 "ab" 了
再一次会得到另一个 'a'. 大概就像是得到一个 'a':'a':rest 的结果
然后又一次递归进入函数, 这一次只有 "b" 作为输入了
这样的话, 显然尝试去解析 'a' 会得到一个错误
那么, 就进入到处理错误的代码了, 直接返回一个空的列表
现在可以回到递归调用然后得到最终结果 'a':'a':[], 实际上就是 ['a', 'a']
输入内容当中还剩下一个 "b". 就是这样

怪复杂的. 还好这些已经现在我们需要的全部的组合子

解析一下 Brainfuck

目前为止我们已经写好了基础的模块, 看一下怎么解析 Brainfuck 程序
我们需要一个基础的 Parser 用来处理单一的 Brainfuck 指令, 比如 parseOne:

parseOne :: Parser AST
parseOne = choice [ transform '>' (PtrMove 1)
                  , transform '<' (PtrMove (-1))
                  , transform '+' (MemMove 1)
                  , transform '-' (MemMove (-1))
                  , transform ',' Output
                  , transform '.' Input
                  , parseLoop
                  ]
  where transform char ast = expect char >> return ast
        expect char = satisfy (== char)

代码定义了两个辅助函数:
expect 通过前面的 satisfy 函数直接期望找到特定的字符
transform 用来处理给出的字符, 匹配成功时返回 AST 块
用这些辅助函数就定义好多有 Brainfuck 基本的指令了
然后用前面定义的 choice 组合子运行他们的整体的列表
一直到其中一个能够解析出输入内容

这里还有一个 parseLoop Parser(猜一下)用来解析循环, 现在来定义:

parseLoop :: Parser AST
parseLoop = do
  consume '['
  steps <- many parseOne
  consume ']'
  return (Loop steps)
  where consume char = satisfy (== char) >> return ()

我觉得这个比较直接 -- 首先处理左括号,
然后用 many 组合子尽可能多地解析元素(用前面的 parseOne Parser)
然后期望找到一个右括号. 最后返回 AST 到循环当中
其中 consume 辅助函数也很简单, 它尝试解析提供的字符,
如果解析成功, 返回 unit (), 因为我们不需要这里实际的结果

注意这两个函数人为地递归了 parseLoop 会调用 parseOne
而 parseOne 会调用 parseLoop. 以此来处理嵌套的循环

我们还需要一个函数来 Parser 整个程序 -- 一个表示解析完成的办法
为此定义一个是 eof 函数:

eof :: Parser ()
eof = do
  s <- get
  case s of
    [] -> return ()
    _  -> throwError UnexpectedEof

这也很简单. 先观察 Parser 的当前状态,
如果是空字符串了就是到达结尾了, 返回一个 unit, 不需要任何有意义的返回值
如有还有内容可以解析, 就抛出一个 UnexpectedEof 错误
你可能觉得这个选择有点绕 -- 为什么还有东西解析时候抛出 UnexpectedEof?
想一下我们为什么要写到这部分的代码, 你会觉得清晰一些
比方说要解析不正常的循环 "[.+-", 用 parseLoop 解析时会发生什么?
在查找右括号时会失败, 剩下就是一段不能解析的内容
如果这里用的用的是 eof Parser 希望解析结束, 很明显要抛 UnexpectedEof 错误

最终定以后一个 Brainfuck 的 Parser:

parseAll :: Parser [AST]
parseAll = do
  exprs <- many parseOne
  eof
  return exprs

我们解析掉了所有的简单指令
最后我们解析完了需要先解析的内容, 也就遇到的 EOF.

用这个 Parser 就可以组装一个 parse 函数解析 Brainfuck 的字符程序
最后返回解析完成的 AST 或者一个错误:

parse :: String -> Either ParseError [AST]
parse = fmap fst . runParser parseAll . filter isMeaningful
  where isMeaningful = (`elem` "><+-,.[]")

我们首先过滤掉输入字符串剩下有意义的 Brainfuck 指令(其余都是注释)
接着运行 Parser, 最后展开结果

结论

Haskell 以其优秀的 Parser 闻名, 现在可以看到为什么了
不到 100 行代码, 就定义了一个功能完整的 Parser,
以及错误处理, 而且用起来简单和直观
这些代码有很多地方可以被优化, 或者用更多的范畴论调味
(比如用 Control.Applicative 里的 Alternative class 定义 many
这样 Parser 就是这些 class 的成员了
或者把在 Parser 类型里把 choice 函数缩减为简单的 asum)
不过我觉得这套代码实现比较清晰, 而且关注了最重要的部分
而不是关注了 Haskell typeclass 的复杂之处
就算那很有意思也不是本篇文章的重点了

可以在这里看到本文使用的代码