Parser Combinators in Haskell

（以下大部份說明文字亂譯自 scm 老師的原文 XD。）

考慮這種 binary tree：

data Tree = A | B | Bin (Tree, Tree)
     deriving Show

我們可以用比較簡短的語法印出這種樹，把 A 印為 a、B 印為 b、Bin (t, u) 印為 (t,u)。例如 (Bin (A,Bin (B,A)) 就印為 (a,(b,a))。這樣的語法可用以下的 context-free grammar 描述：

S ::= ( S , S ) | a | b

在一般的程式語言之內寫一個 recursive-descent parser 並非易事。但若有了 higher-order functions，我們就可以如下為上述語言建造出一個 parser：

pTree :: Parser Char Tree
pTree =  (lit '(' *> pTree <*> lit ',' *> pTree <* lit ')') `using` Bin
      <|> lit 'a'                                           `using` const A
      <|> lit 'b'                                           `using` const B

pTree 的定義和 grammar S 面貌相似：每個 terminal（小括號、逗號、a 和 b）都套上 lit，concatenation (sequencing) 以 *>、<*、和 <*> 明確表示，各種可能情況之間則以 <|> 分隔。'using' 子句說明如何建造出對應的樹。

這是怎麼做的呢？

Parser a b 的輸入是一連串的 tokens of type a，它將這串 tokens 的某個 prefix 解析為某個型別為 b 的東西。這個型別該怎麼定義呢？很顯然，Parser a b 接收一個 list of a 並傳回一個 b-structure：

type Parser a b = [a] -> b

但 parser 不一定會耗盡所有的 input tokens，這樣的設計在我們把 parsers 串起來的時候會有用。因此我們除了讓 parser 傳回一個 b-structure 以外，也傳回尚未消耗的 list of tokens：

type Parser a b = [a] -> (b, [a])

最後，parser 可能會因為輸入不合法而解析失敗，或者它可能傳回多個可能的解析結果。因此我們讓 parser 傳回「可能的解析結果」所形成的序列（list）：

type Parser a b = [a] -> [(b, [a])]

如果解析失敗，parser 就傳回 []。

我們定義另一個函式 parse「執行」一個 parser。這個函式選出第一個「耗盡整個輸入字串」的解析結果：

parse :: Parser a b -> [a] -> b
parse p = fst . head . filter (null . snd) . p

fail 這個 parser 的解析永遠是失敗的：

fail : Parser a b
fail xs = []

與之相反的是 succeed，它總是立即解析成功，不消耗任何輸入：

succeed :: Parser a ()
succeed xs = [((), xs)]

換句話說，這個 parser 接受空字串。

lit x 這個 parser 檢查輸入的第一個 token 是否等於 x，如果真的是這樣就傳回 x（因此它的型別是 Parser a a）以及尚未解析的剩餘輸入。這是唯一可行的解析方式。若不然，它就傳回一個 empty list 代表解析失敗，因為沒有以 x 起頭的解析方式。

lit :: Eq a => a -> Parser a a
lit x (y : xs) | x == y = [(y, xs)]
lit x _ = []

p1 <|> p2 這個 parser（p1 OR p2）試著用 p1 和 p2 分別進行解析，然後合併兩者結果。那就單純是把兩個 parsers 傳回的 lists 串接在一起。

infixr 6 <|>
(<|>) :: Parser a b -> Parser a b -> Parser a b
(p1 <|> p2) xs = p1 xs ++ p2 xs

p1 <*> p2 這個 parser（p1 followed by p2）先用 p1 解析輸入字串，再用 p2 解析剩餘的字串。假設 p1 造出一個 b-structure、p2 造出一個 c-structure，那麼 p1 <*> p2 會把兩者的結果放進一個 pair (b, c) 裡面當作自己的結果。這個 parser combinator 用 list comprehension 會比較好寫：輸入 xs，對於 p1 xs 的每個解析結果 (b, ys)，用 p2 解析 ys 產生一群結果 (c, zs)，然後把 (b, c) 和剩餘的輸入 zs 組合成一個 pair 放進 resulting list。

(<*>) :: Parser a b -> Parser a c -> Parser a (b, c)
(p1 <*> p2) xs = [ ((b, c), zs) | (b, ys) <- p1 xs, (c, zs) <- p2 ys ]

給定一個 parser p :: Parser a b 和一個函式 f :: b -> c，(p `using` f) 是一個新的 parser，把 f 套用到 p 的結果：

using :: Parser a b -> (b -> c) -> Parser a c
p `using` f = map (cross f id) . p

其中 cross 是標準的 product functor：

split f g a = (f a, g a)
cross f g   = split (f . fst) (g . snd)

p1 *> p2 很類似 p1 <*> p2，但它會丟棄 p1 的結果。這個 combinator 可用 <*> 和 using 定義：

infixr 8 *>
(*>) :: Parser a b -> Parser a c -> Parser a c
p1 *> p2 = (p1 <*> p2) `using` snd

<* 是 *> 的對偶：

infixr 8 <*
(<*) :: Parser a b -> Parser a c -> Parser a b
p1 <* p2 = (p1 <*> p2) `using` fst

至此我們已經定義了一個內嵌於 Haskell 的 domain-specific embedded language，專門用來解析語言。讓我們試用這些 combinators。以下這個簡單的 grammar 描述「反二進位數字」：

B ::= 0 | 1 | 0 B | 1 B

例如 "11010" 的值是 11（因為數字的順序是反的）。欸，選這種奇怪的例子只是為了練習啦 XD。以下就是它的 parser：

pB :: Parser Char Int
pB =     lit '0'         `using` const 0
     <|> lit '1'         `using` const 1
     <|> (lit '0' *> pB) `using` (*2)
     <|> (lit '1' *> pB) `using` ((+1) . (*2))

一些執行例子：pB "1101" = [(1,"101"),(3,"01"),(3,"1"),(11,"")]、parse pB "1101" = 11。

如果我們改用下面這個 grammar 可以嗎？

B ::= 0 | 1 | B 0 | B 1

很可惜，這個 grammar 是個 left-recursive grammar，而我們的 recursive-descent parser 只能處理 LL grammar。LL 的第二個 L 代表解析方式是 leftmost derivation，所以如果有 left-recursion 就會遞迴個沒完。

回到我們一開始定義的 parser pTree。如我們一再提及，用這樣的方法寫出的 parsers 都是 recursive-descent (hence top-down) parsers，也就是從 start symbol 逐漸展開一棵樹（unfold?!）。詳情可參考 dragon book 2/e, section 4.4，其中 p.218 有精美插圖 XD。單純的 recursive-descent parsing 可能需要 backtrack，因為展開某個 nonterminal 的時候可能選錯 production rule。這裡的精神是 "nondeterministically" 選一個 production rule，實作上用 subset construction 把所有可能的結果收集起來，到最後才挑出成功解析的結果。

另一種印樹的形式是把 Bin (t, u) 印為 (t)u。例如 Bin (Bin (A,B), Bin (A,B)) 印為 ((a)b)(a)b。對應的 grammar 是

S ::= ( S ) S | a | b

Parser 則可寫為

pTree2 :: Parser Char Tree
pTree2 =
      lit 'a'                                   `using` const A
  <|> lit 'b'                                   `using` const B
  <|> (lit '(' *> pTree2 <*> lit ')' *> pTree2) `using` Bin

最後讓我們試一個稍微實際一點的例子，處理「反二進位數字」的加法與乘法算式。算式的 grammar 是

Expr ::= Expr + Term | Term
Term ::= Term * Factor | Factor
Factor ::= B | ( Expr )

是個超標準的版本。（我高中看 C++ grammar 的時候就看過啦 XD。）不過這個 grammar 是 left-recursive，所以我們必須做點變換，消除 left-recursion（ref. dragon book, section 4.3.3）。這過程其實就是把 non-empty snoc-lists 換成對應的 cons-lists。轉換後的 grammar 變成

Expr ::= Term Expr'
Expr' ::= + Term Expr' | ε
Term ::= Factor Term'
Term' ::= * Factor Term' | ε
Factor ::= B | ( Expr )

其實差不多就是 dragon book 的 example 4.27。

定義 Token 型別為

data Token = Number Int | Plus | Multiply | LeftP | RightP
     deriving (Eq, Show)

pToken :: Parser Char [Token] 會把輸入字串裂解為一連串的 tokens。為了讓效率好一點，我們定義 munch :: Parser a b -> Parser a b 把一個 parser 轉換為 "greedy" parser ─ resulting parser 只挑出剩餘字串長度最短的那個結果。

munch :: Parser a b -> Parser a b
munch p = cond null id ((:[]) . foldr1 f) . p
  where f p q = if sndlen p < sndlen q then p else q
        sndlen = length . snd

其中 cond 是 McCarthy conditional form：

cond p f g a = if p a then f a else g a

於是我們就可以定義 pToken：

pToken :: Parser Char [Token]
pToken =
      succeed               `using` const []
  <|> (lit ' ' *> pToken)
  <|> (lit '+' *> pToken)   `using` (Plus :)
  <|> (lit '*' *> pToken)   `using` (Multiply :)
  <|> (lit '(' *> pToken)   `using` (LeftP :)
  <|> (lit ')' *> pToken)   `using` (RightP :)
  <|> (munch pB <*> pToken) `using` (uncurry (:) . cross Number id)

其中第二條是忽略空格的規則。令

s = "001101 + 101 * (011 + 1 + 10)"

那麼 parse pToken s = [Number 44,Plus,Number 5,Multiply,LeftP,Number 6,Plus,Number 1,Plus,Number 1,RightP]。

接下來我們定義 abstract syntax tree 的型別。

data ExprTree = Operand Int
              | PlusBin ExprTree ExprTree
              | MultiplyBin ExprTree ExprTree
     deriving Show

對應的 fold operator 是

foldet f g h (Operand n) = h n
foldet f g h (PlusBin t u) = f (foldet f g h t) (foldet f g h u)
foldet f g h (MultiplyBin t u) = g (foldet f g h t) (foldet f g h u)

想對一個算式求值，可用以下函式：

evalExpr :: [Char] -> Int
evalExpr = foldet (+) (*) id . parse pExpr . parse pToken

其中 pExpr :: Parser Char ExprTree 是 Expr grammar 的 parser。例如 parse pExpr (parse Token s) = PlusBin (Operand 44) (MultiplyBin (Operand 5) (PlusBin (PlusBin (Operand 6) (Operand 1)) (Operand 1)))。定義 pExpr 會碰上一點麻煩，因為經過 left-recursion elimination 的 grammar 和我們想建造的樹形不一樣了！更精確地講，pExpr'（注意是 Expr "prime"）傳回的是個 partial syntax tree，裡面有個洞是要放 + 左邊的樹。But hey, we are working in a functional language! 我們就讓 pExpr' 的結果是 ExprTree -> ExprTree，這個 function 拿一個 ExprTree 塞到那棵 partial syntax tree 的洞裡面，傳回一棵完整的樹。這樣我們就可以定義出全部的 parsers：

pExpr :: Parser Token ExprTree
pExpr = (pTerm <*> pExpr') `using` uncurry (flip ($))

pExpr' :: Parser Token (ExprTree -> ExprTree)
pExpr' =
      succeed
          `using` const id
  <|> (lit Plus *> pTerm <*> pExpr')
          `using` (\(t, f) -> \u -> f (PlusBin u t))

pTerm :: Parser Token ExprTree
pTerm = (pFactor <*> pTerm') `using` (uncurry (flip ($)))
  
pTerm' :: Parser Token (ExprTree -> ExprTree)
pTerm' =
      succeed
          `using` const id
  <|> (lit Multiply *> pFactor <*> pTerm')
          `using` (\(t, f) -> \u -> f (MultiplyBin u t))

pFactor :: Parser Token ExprTree
pFactor = lit LeftP *> pExpr <* lit RightP
      <|> pNumber `using` Operand

pNumber :: Parser Token Int
pNumber (Number x : ys) = [(x, ys)]
pNumber _ = []

有了傳回 syntax tree 的 parser，要轉 postfix form 也很容易：

postExpr :: [Char] -> [Char]
postExpr = foldet f g h . parse pExpr . parse pToken
           where f s t = s ++ t ++ "+"
                 g s t = s ++ t ++ "*"
                 h x   = "[" ++ show x ++ "]"

例如 postExpr s = "[44][5][6][1]+[1]+*+"。

--
好長 Orz。