Mokkosuでパーサコンビネータを作ってみた

概要

Graham Hutton と Erik Meijer の Monadic Parsing in Haskell を参考に、Mokkosu でパーサコンビネータを作ってみました。

• Graham Hutton and Erik Meijer. FUNCTIONAL PEARL Monadic parsing in Haskell. Journal of Functional Programming, Volume 8, Issue 04, pp 437-444. (著者版)

パーサの型

まずパーサの型を以下のように定めます。

type Parser<T> = Parser ([Char] -> [(T, [Char])]);

パーサは文字列のリストを受け取って結果と残りの文字列のリストを返す関数として定義します。個の戻り値のリストは、パースに失敗した場合は空リストになります。

Parserのタグを外すparse関数を定義しておきます。

let parse ~Parse(p) = p;

型は以下のようになります。

parse : Parser<α> -> [Char] -> [(α, [Char])]

for式に対応させる

for式でパーサを書けるようにします。まず、現在のfor式の定義をバックアップします。

let old_for_zero = __for_zero;
let old_for_unit = __for_unit;
let old_for_bind = __for_bind;

順番に定義していきましょう。__for_zeroには失敗を表すパーサを代入します。

let __for_zero = Parser (const []);

型は以下のようになります。

__for_zero : Parser<α>

次に、__for_unitには値を受け取ってその値をパースの結果とする関数を代入します。

let __for_unit x = Parser { cs -> [(x, cs)] };

型は以下のようになります。

__for_unit : α -> Parser<α>

最後に__for_bindに2つのパーサを結合する関数を代入します。

let __for_bind ~Parser(p) f =
  Parser {
    cs -> concat_map { (x, cs2) -> parse (f x) cs2 } (p cs)
  };

型は以下のようになります。

__for_bind : Parser<α> -> (α -> Parser<β>) -> Parser<β>

Applicativeスタイルで書けるようにする

パーサはやはりApplicativeスタイルで書きたくなると思うのでいくつか演算子を定義しておきます。

まずは、またはを表す演算子(<|>)を定義します。

let __operator_ltbargt p q = Parser { cs ->
  match (parse p cs) {
    [] -> match (parse q cs) {
      [] -> [];
      x :: xs -> [x];
    };
    x :: xs -> [x];
  }};

型は以下のようになります。

__operator_ltbargt : Parser<α> -> Parser<α> -> Parser<α>

次に、(<$>)演算子を定義します。

let __operator_ltdollgt f p = for x <- p in f x;

型は以下のようになります

__operator_ltdollgt : (α -> β) -> Parser<α> -> Parser<β>

次は、(<*>)演算子です。

let __operator_ltastgt p q =
  for f <- p;
      x <- q;
  in f x;

最後に(<*)演算子と(*>)演算子を定義しましょう。

let __operator_ltast p q = const <$> p <*> q;
let __operator_astgt p q = const id <$> p <*> q;

型は以下のようになります。

__operator_ltast : Parser<α> -> Parser<β> -> Parser<α>
__operator_astgt : Parser<α> -> Parser<β> -> Parser<β>

基本的なパーサ

基本的なパーサを順番に定義していきましょう。最初は無条件に1文字を読み込むパーサです。

let item = Parser { [] -> []; c :: cs -> [(c, cs)] };

型は以下のようになります。

item : Parser<Char>

次に条件を満たす1文字を読み込むパーサを作ります。

let sat f =
  for c <- item;
      if f c;
  in c;

型は以下のようになります。

sat : (Char -> Bool) -> Parser<Char>

次に指定した1文字を読み込むパーサです。

let char c = sat ((==)c);

型は以下のようになります。

char : Char -> Parser<Char>

指定した文字列を読み込むパーサを作ります。

let string str =
  let cs = string_to_list str in
  fun loop = {
    [] -> __for_unit [];
    c :: cs -> for _ <- char c;
                   _ <- loop cs;
               in (c :: cs);
  } in list_to_string <$> loop cs;

型は以下のようになります。

string : String -> Parser<String>

再帰的なコンビネータ

0回以上の繰り返しと1回以上の繰り返しのコンビネータを定義します。

fun many p = many1 p <|> __for_unit []
and many1 p =
  for x <- p;
      xs <- many p;
  in (x :: xs);

型は以下のようになります。

many : Parser<α> -> Parser<[α]>
many1 : Parser<α> -> Parser<[α]>

sepbyとsepby1を定義します。

fun sepby p sep = p `sepby1` sep <|> __for_unit []
and sepby1 p sep =
  for x <- p;
      xs <- many (for _ <- sep; x <- p in x);
  in x :: xs;

型は以下のようになります。

sepby : Parser<α> -> Parser<β> -> Parser<[α]>
sepby1 : Parser<α> -> Parser<β> -> Parser<[α]>

最後にchainlとchainl1を定義します。

fun chainl p op x = p `chainl1` op <|> __for_unit x
and chainl1 p op =
  fun loop x =
    (for f <- op;
         y <- p;
         r <- loop (f x y);
     in r) <|> __for_unit x
  in
  for x <- p;
      r <- loop x;
  in r;

型は以下のようになります。

chainl : Parser<α> -> Parser<α -> α -> α> -> α -> Parser<α>
chainl1 : Parser<α> -> Parser<α -> α -> α> -> Parser<α>

空白を扱うコンビネータ

space関数、token関数、symb関数、apply関数を以下のように定義します。

let space = many (sat is_whitespace);

let token p =
  for x <- p;
      _ <- space;
  in x;

let symb str = token (string str);

let apply p str =
  parse (for _ <- space; r <- p in r) (string_to_list str);

型は以下のようになります。

space : Parser<[Char]>
token : Parser<α> -> Parser<α>
symb : String -> Parser<String>
apply : Parser<α> -> String -> [(α, [Char])]

数式のパーサの例

これまで定義したコンビネータを使って、数式のパーサは以下のように定義できます。

fun expr () = term () `chainl1` addop ()

and term () = factor () `chainl1` mulop ()

and factor () =  digit ()
             <|> (for _ <- symb "(";
                      e <- expr ();
                      _ <- symb ")";
                  in e)

and digit () = for x <- token (sat is_digit)
               in char_to_int x - char_to_int '0'

and addop () =  (for _ <- symb "+" in (+))
            <|> (for _ <- symb "-" in (-))

and mulop () =  (for _ <- symb "*" in (*))
            <|> (for _ <- symb "/" in (/))

以下の文を実行してみましょう。

let (result, []) :: _ = apply (expr ()) "1 - 2 * 3 + 4";
println result;

実行すると出力ウインドウに以下のように表示されます。

-1

ソースコード全体

#------------------------------------------------------------
#! @file    Parser.mok
#! @brief   パーサコンビネータ実装例
#! @author  lambdataro
#------------------------------------------------------------

__define "CONSOLE_APPLICATION";

type Parser<T> = Parser ([Char] -> [(T, [Char])]);

let parse ~Parser(p) = p;

let old_for_zero = __for_zero;
let old_for_unit = __for_unit;
let old_for_bind = __for_bind;

let __for_zero = Parser (const []);

let __for_unit x = Parser { cs -> [(x, cs)] };

let __for_bind ~Parser(p) f =
  Parser {
    cs -> concat_map { (x, cs2) -> parse (f x) cs2 } (p cs)
  };

let __operator_ltbargt p q = Parser { cs ->
  match (parse p cs) {
    [] -> match (parse q cs) {
      [] -> [];
      x :: xs -> [x];
    };
    x :: xs -> [x];
  }};

let __operator_ltdollgt f p = for x <- p in f x;

let __operator_ltastgt p q =
  for f <- p;
      x <- q;
  in f x;

let __operator_ltast p q = const <$> p <*> q;
let __operator_astgt p q = const id <$> p <*> q;

let item = Parser { [] -> []; c :: cs -> [(c, cs)] };

let sat f =
  for c <- item;
      if f c;
  in c;

let char c = sat ((==)c);

let string str =
  let cs = string_to_list str in
  fun loop = {
    [] -> __for_unit [];
    c :: cs -> for _ <- char c;
                   _ <- loop cs;
               in (c :: cs);
  } in list_to_string <$> loop cs;

fun many p = many1 p <|> __for_unit []
and many1 p =
  for x <- p;
      xs <- many p;
  in x :: xs;

fun sepby p sep = p `sepby1` sep <|> __for_unit []
and sepby1 p sep =
  for x <- p;
      xs <- many (for _ <- sep; x <- p in x);
  in x :: xs;

fun chainl p op x = p `chainl1` op <|> __for_unit x
and chainl1 p op =
  fun loop x =
    (for f <- op;
         y <- p;
         r <- loop (f x y);
     in r) <|> __for_unit x
  in
  for x <- p;
      r <- loop x;
  in r;

let space = many (sat is_whitespace);

let token p =
  for x <- p;
      _ <- space;
  in x;

let symb str = token (string str);

let apply p str =
  parse (for _ <- space; r <- p in r) (string_to_list str);

fun expr () = term () `chainl1` addop ()

and term () = factor () `chainl1` mulop ()

and factor () =  digit ()
             <|> (for _ <- symb "(";
                      e <- expr ();
                      _ <- symb ")";
                  in e)

and digit () = for x <- token (sat is_digit)
               in char_to_int x - char_to_int '0'

and addop () =  (for _ <- symb "+" in (+))
            <|> (for _ <- symb "-" in (-))

and mulop () =  (for _ <- symb "*" in (*))
            <|> (for _ <- symb "/" in (/))

;

let (result, []) :: _ = apply (expr ()) "1 - 2 * 3 + 4";
println result;