続・頭の悪いパーサコンビネータ

あれからだいぶ直してしまったので1から説明します。YT版Parser Combinator for OCaml……どう見てもHaskellやCleanのそれの劣化版ですが。
ええと、まず、今更言うまでもないですがパーサコンビネータというのはパースする関数とパースする関数をくっつける関数のことです。できるものは単なるトップダウンの再帰下降なLLパーサです。状態遷移表を使うパーサのほうが全てにおいて優秀ですが、状態遷移表を使うパーサはプリプロセッサになっていて使い勝手が大変悪いのが普通です。パーサコンビネータはプリプロセッサをかます必要がないため、とくに@や&や'Accessを付けずに関数名だけで関数を値として使える言語では、手書きパーサの面倒な定型句を省くのに便利です。ソースの見た目を短くするためだけにクロージャ・カリー化を連発しますのでコンパイル後は典型的な「10%のコードを実行するために90%の以下略」状態になります。しかしパーサというのは手書きすると面倒なものですので、どれだけ効率が悪くても最初から書く気にならないよりマシです。
パーサコンビネータを作る/使うには、まず元となるパースする関数の型を決めないとです。相変わらず私は部屋を掃除しないため一向に使えないCleanのパーサコンビネータの解説によりますと、パーサの型は以下のようになっています。

:: Parser symbol result :== [symbol] -> [([symbol],result)]

エラー処理をするときは、結果を3つ組にするといいようです。
しかし、これでは、入力がリストになります。単方向リストなればこそ、「残り」を返せるのですが……HaskellやCleanならともかく、OCamlですと、ソースファイルをメモリマップしたBigarrayあたりを使いたいじゃないですか。従ってインデックスを使います。実際にはどうにでもできるように抽象型にします。
また、結果がリストになっていますが、これはCleanには遅延評価があるため実際には先頭1要素分しかパースされないとかそんならしいです。OCamlにもlazyはありますが、OCamlの文法でlazyなリストを作ろうと思えば、この間試したように記述が面倒になります。手間を省くためにパーサコンビネータを使おうというのにそれでは本末転倒ですので、結果はlazyなリストではなく正格なoptionで済ませてしまいます。
エラーについては、破壊的に記録していきます。
そんなこんなでパーサの型はこうなりました。

type 'a parser = unit -> p_pos -> Env.t -> ('a * p_pos) option

unitの部分は、パーサを直列にくっつける際には、前の値を受け取るために他の型に置き換えて使うことになります。あと、実際のコードは次のように書きたいのですが、文法上let recでは引数無し形式の宣言がエラーにされてしまいますので、unit型の引数を先頭に持ってくることで()を書けるようになってコンパイルが通ります。

(* ERROR *)
let rec syntax1 = ...
and syntax2 = ...

(* OK *)
let rec syntax1 () = ...
and syntax2 () = ...

こうすると、各パーサを使う箇所毎に個別に関数を作る関数が走った上でとどめにカリー化までしてしまいますのでますます効率が悪くなるのですが、手間には変えられません。かといってrecをやめると再帰できなくなりますのでそっちの方が困ります。もともと遅延評価が前提のような気がひしひしとするパーサコンビネータを、OCamlのような正格の(C++のtemplateを使ったspiritのように静的に解決されることが保証されているわけでもない)言語上で、手間のためだけに使おうというのですから……そんなわけで今のところ効率云々はもう諦めてしまっているのですが、その実私はOCamlの初心者中の初心者ですので、何か見落としているに違いない。いやこれは絶対何か手がある予感。例えばEiffelのonceみたいなものがあればいいわけですから。偉い人がもし見ておられましたらアドバイスくださいお願いします。
話の筋を元に戻して、Env.tはこんなのです。パーサ関数群はファンクタに閉じ込めて、入力元を切り替えられるようにしようという寸法。ついでにエラーもここに押し込めてます。

module type PARSING_ENV =
  sig
    type t
    type element
    type position_key
    val peek : t -> element option
    val junk : t -> unit
    val position : t -> position_key
    val rollback : t -> position_key -> unit
    val include_file : t -> string -> unit
    val message : t -> position_key -> int -> string -> unit
  end

peekとかjunkはStreamのそれです。messageはエラーを記録します。positionで現在位置を得て、rollbackでそこに戻ります。rollbackでは位置を戻すほか、messageで追加したエラーのうち、戻った位置以降のエラーを捨てなければなりません。実際にはパースは先頭から行いますので、当然エラーは位置の順に追加されていくわけですので、stackにでもpushしていって、rollbackでは戻った位置以降のものをpopするだけでOKです。順不同でエラーを追加していく場合は優先順位付きdouble-ended queueみたいなものが必要になりますが、どの道OCamlはそういうのは短く書けちゃいます。
パーサ関数群のファンクタはこんな感じで。

module Parser = functor (Env: PARSING_ENV with type element = char) -> struct
  type p_pos = Env.position_key
  ...

この中にパーサ関数を書いていくわけです。
まずは基本となる、特定の1文字を受け付けるパーサ関数が必要です。

val p_char : Env.element -> unit -> p_pos -> Env.t -> (Env.element * p_pos) option

実装はこんな。

let p_char (c: char) () (p: p_pos) e = (
  match Env.peek e with
  | Some r -> 
    if r = c then (
      Env.junk e;
      Some (r, p)
    ) else (
      None
    )
  | None -> None
);;

これを使ってp_char 'A'のように部分適用しますと、char parser型の関数になります。
あとはp_char_rangeやp_char_not、EOF判定するp_endとかそんなのがあればいいでしょう。
基本的なパーサができたら、以降はそれを組み合わせて複雑なパーサを作っていきます。つまりここからがパーサコンビネータです。
HaskellやCleanではパーサコンビネータとして演算子<&>や<|>が使われていますが、OCamlでは右結合の演算子が、**... lsl lsr asr @... ^...しかない現実があります。この中から選ぶなら@...だと思うのは私だけでしょうか。
というわけでまず@&&と@||を定義します。この@&&と@||は、OCamlの&&と||を真似たのであって、C言語の&&と||とはきっと何の関係もありませんことをねがっています。しかしねがいはかなわなかった。ふざけるな3000ギタン返せ。ねがいがかなわない条件あれいまいちわからないです。壷持ってないときに壷増大効果が出たあたりでしょうか。

val ( @&& ) :
  ('a -> p_pos -> Env.t -> ('b * p_pos) option) ->
  (unit -> p_pos -> Env.t -> ('c * p_pos) option) ->
  'a -> p_pos -> Env.t -> (('b * 'c) * p_pos) option
val ( @|| ) :
  ('a -> p_pos -> Env.t -> ('b * p_pos) option) ->
  ('a -> p_pos -> Env.t -> ('b * p_pos) option) ->
  'a -> p_pos -> Env.t -> ('b * p_pos) option

最近鬼月を使えば影法師系を手軽に倒せることに気付きましたなんてのはどうでもよくて、先のparser型でunitになっている箇所が多相になっていますが、これは他のパーサの後ろにくっついて値を変換するパーサ、というものを使うためです。@&&は単に2つのパーサの結果をタプルで返しますが、実際にはこんなもの役に立たないわけです。char parserとchar parserを合成するとstring parserやBuffer.t parserになって欲しいわけです。今からくり白蛇なんですけどペリカン2世の出現率が低くて困ります。
そこで、1階からずっと召喚の罠を集めているのですが……じゃなくて、@&&と似て少し違う@=>演算子も用意します。モナドの>>=のノリです。

val ( @=> ) :
  ('a -> p_pos -> Env.t -> ('b * p_pos) option) ->
  ('b -> p_pos -> Env.t -> ('c * p_pos) option) ->
  'a -> p_pos -> Env.t -> ('c * p_pos) option

@=>は基本的には@&&と同じですが、結果をタプルにする代わりに、右辺を、元々parser型がunitに固定していた位置に左辺が返した結果を取る関数とします。
そうするとp_charの他に@=>の右辺用のp_char_addみたいなものが必要になります。が、ここでcharとcharをくっつけてstringにする処理というのは、yaccで言うところのアクションに相当するわけですので、パーサ関数と一緒にするのはあまり嬉しくありません。似たようなパーサ関数を量産するのも手間ですし、何よりアクションはその場で匿名関数でも使って書きたいじゃないですか。折角匿名関数あるんですから。
というわけで次の演算子を作りました。/...は@...よりも優先順位が高いためちょうどいいです。//なのは、見た目に煩くないからであって、C++のコメント//とはきっと何の関係もありませんことをねがっています。ちなみにAdaやHaskellの--は左右対称っぽいので避けました。ところで通路でしおいやんになめられた直後に店で特製おにぎり買ったら力+1効果が出て、ねがいの腕輪よりも特製おにぎりの方がありがたく思えました。しおいやんになめられるのは死ぬより嫌なのは私だけでしょうか。毒矢やおばけ大根は特に気にしないんですが、なんででしょうね。

val ( // ) :
  'a parser ->
  ('b -> 'a -> 'c) -> 'b -> p_pos -> Env.t -> ('c * p_pos) option

これを使えばp_char 'A' @=> p_char 'B' // (fun a b -> ... ) @=> ...と続けていけます。
こうしてパーサからパーサを作っていくわけですが、先のlet rec中では引数無しの宣言ができない問題がありますので、次のようなものはエラーになります。

(* SYNTAX ERROR *)
let rec syntax1 = syntax2 @&& syntax2
and syntax2 = p_char 'A' @=> p_char 'B' // (fun a b -> ...)

かといって()だけ付けても型が変わってしまいます。

(* TYPE ERROR *)
let rec syntax1 () = syntax2 @&& syntax2
and syntax2 () = p_char 'A' @=> p_char 'B' // (fun a b -> ...)

ですので、次のようなものを使って、無理やり型を合わせます。

let p_do (s: 'a parser) = (
  s ()
);;

(* OK *)
let rec syntax1 () = p_do (syntax2 @&& syntax2)
and syntax2 () = p_do (p_char 'A' @=> p_char 'B' // (fun a b -> ...))

parse等ではなくてdoなのは、やはりこれもモナドのノリです。
これで大体説明したかな……/*/や/?/なんかは単にバリエーションですし想像つくと思いますので省略させてください。
後は位置情報とエラー処理ですね。
parser型の返値のタプル上の右側のp_posは、現在位置ではなくて、最初の位置を延々保持し続けます。これは、エラーメッセージを表示するとき、"source:line:column:Unknown idenfifier XYZ"のcolumnとして、XYZの右端ではなく左端を表示させたいからです。
"X * Y"をエラーにするときに、Xではなく*の位置を表示させたいときは、"*"をパースするところでp_set_positionを挟んでおけばOKです。本当の現在位置は、Env.tが破壊的に覚えてくれていますので、関数の引数や返値にする必要は無いです。破壊的に覚えてくれていますのでって凄い日本語ですね。考えてみれば破壊的に更新するなんて言われたら、意味のある値は残らないと取るほうが普通かも。誰ですか破壊的なんて使い始めたのは。「上書き」でいいじゃんねえ。
そうやって渡されてきた位置を結果の値の方に含めたいときは、p_positionか/%/ v_with_positionかパーサ関数を演算子ではなくて手動で合成するとか、まあ適当に。
エラー処理は、/~/を使います。左辺のパーサがNoneを返したら、右辺の(匿名)関数でそれを適当な有効な値に挿げ替えれば、エラーを検出しながらパースを続けることができます。/~/の右辺の匿名関数にはEnv.messageに現在のEnv.tが部分適用されたものも渡されてきますので、必要に応じて呼び出せばエラーメッセージも記録できます。
以下全ソース。

module ValueCombinator = struct
  
  let v_identity x = x;;
  
  let v_ignore x _ = x;;

  let v_error level message (m, p, _) x = (
    m p level message;
    x
  );;

  let v_error_current level message (m, _, p) x = (
    m p level message;
    x
  );;

  module Buffer = struct
    include Buffer;;
  
    let create_empty () = create 0;;
  
    let of_char c = (
      let buffer = create 0 in
      add_char buffer c;
      buffer
    );;
    
    let of_string s = (
      let buffer = create 0 in
      add_string buffer s;
      buffer
    );;
    
    let add_char_r b c = (
      add_char b c;
      b
    );;
    
    let add_string_r b s = (
      add_string b s;
      b
    );;
    
    let add_char_string_r b (c, s) = (
      add_char b c;
      add_string b s;
      b
    );;
  end;;
end;;

module type PARSING_ENV = sig
  type t;;
  type element;;
  type position_key;;
  val peek: t -> element option;;
  val junk: t -> unit;;
  val position: t -> position_key;;
  val rollback: t -> position_key -> unit;;
  val include_file: t -> string -> unit;;
  val message: t -> position_key -> int -> string -> unit;;
end;;

module ParserCombinator = functor (Env: PARSING_ENV) -> struct

  type p_pos = Env.position_key;;
  type p_info = (p_pos -> int -> string -> unit) * p_pos * p_pos;;

  type 'a parser = unit -> p_pos -> Env.t -> ('a * p_pos) option;;

  let p_do (s: 'a parser) = (
    s ()
  );;

  let p_try (s: 'a parser) = (
    fun () (_: p_pos) (e: Env.t) -> (
      let p = Env.position e in
      begin match s () p e with
      | Some _ as x -> x
      | None ->
        Env.rollback e p;
        None
      end
    ): 'a parser
  );;

  let p_run (s: 'a parser) (e: Env.t) = (
    s () (Env.position e) e
  );;

  let p_with_position (s: 'a parser) = (
    fun () (p: p_pos) (e: Env.t) -> (
      match s () (Env.position e) e with
      | Some (r1, p1) -> Some ((r1, p1), p)
      | None -> None
    ): ('a * p_pos) parser
  );;

  (* parser *)

  let p_any () (p: p_pos) e = (
    match Env.peek e with
    | Some r -> 
      Env.junk e;
      Some (r, p)
    | None -> None
  );;

  let p_end v (p: p_pos) e = (
    match Env.peek e with
    | Some _ -> None
    | None -> Some (v, p)
  );;

  let p_position () (p: p_pos) e = (
    Some (p, p)
  );;

  let p_current_position () (p: p_pos) e = (
    Some (Env.position e, p): (p_pos * p_pos) option
  );;

  let p_set_position v (_: p_pos) e = (
    Some (v, Env.position e): ('a * p_pos) option
  );;

  (* postfix *)

  let ( !// ) f v (p: p_pos) (_: Env.t) = (
    Some (f v, p)
  );;

  let ( !/// ) (f: p_info -> 'a -> 'b) v (p: p_pos) e = (
    Some (f (Env.message e, p, Env.position e) v, p)
  );;

  (* infix left to right *)

  let ( // ) (s: 'a parser) f v p (e: Env.t) = (
    begin match s () p e with
    | Some (r1, p1) -> Some (f v r1, p1)
    | None -> None
    end
  );;

  let ( /// ) (s: 'a parser) (f: p_info -> 'b -> 'a -> 'c) v (p: p_pos) (e: Env.t) = (
    match s () p e with
    | Some (r1, p1) -> Some (f (Env.message e, p1, Env.position e) v r1, p1)
    | None -> None
  );;

  let ( /%/ ) (s: 'a parser) f = (
    (f s: 'a parser)
  );;

  let ( /?/ ) s f v (p: p_pos) (e: Env.t) = (
    match s () p e with
    | Some (r1, p1) -> Some (f v r1, p1)
    | None -> Some (v, p)
  );;

  let ( /??/ ) s (f1, f2) v (p: p_pos) (e: Env.t) = (
    match s () p e with
    | Some (r1, p1) -> Some (f1 v r1, p1)
    | None -> Some (f2 v, p)
  );;

  let rec ( /*/ ) s f v (p: p_pos) (e: Env.t) = (
    match s () p e with
    | Some (r1, p1) -> ( /*/ ) s f (f v r1) p1 e
    | None -> Some (v, p)
  );;

  let ( /+/ ) s f v (p: p_pos) (e: Env.t) = (
    match s () p e with
    | Some (r1, p1) -> ( /*/ ) s f (f v r1) p1 e
    | None -> None
  );;

  let ( /~/ ) s (f: p_info -> 'a -> 'a) (v: 'a) (p: p_pos) (e: Env.t) = (
    match s v p e with
    | Some (_, (_: p_pos)) as x -> x
    | None -> Some (f (Env.message e, p, Env.position e) v, p)
  );;

  (* infix right to left *)

  let ( @|| ) s1 s2 v (p: p_pos) (e: Env.t) = (
    let i = Env.position e in
    begin match s1 v p e with
    | Some (_, (_: p_pos)) as x1 -> x1
    | None -> 
      Env.rollback e i;
      s2 v p e
    end
  );;

  let ( @&& ) s1 s2 v (p: p_pos) (e: Env.t) = (
    match s1 v p e with
    | Some (v1, (p1: p_pos)) ->
      begin match s2 () p1 e with
      | Some (v2, (p2: p_pos)) -> Some ((v1, v2), p2)
      | None -> None
      end
    | None -> None
  );;

  let ( @?&& ) s1 s2 v (p: p_pos) e = (
    let i = Env.position e in
    let (r1, p1) = (
      match s1 v p e with 
      | Some (x, p1) -> (Some x, p1)
      | None -> 
        Env.rollback e i;
        (None, p)
    ) in
    begin match s2 () p1 e with
    | Some (r2, (p2: p_pos)) -> Some ((r1, r2), p2)
    | None -> None
    end
  );;

  let ( @=> ) s1 s2 v (p: p_pos) (e: Env.t) = (
    match s1 v p e with
    | Some (r1, (p1: p_pos)) ->
      begin match s2 r1 p1 e with
      | Some (_, (_: p_pos)) as x2 -> x2
      | None -> None
      end
    | None -> None
  );;

end;;

module CharParser = functor (Env: PARSING_ENV with type element = char) -> struct

  type p_pos = Env.position_key;;

  let p_char (c: char) () (p: p_pos) e = (
    match Env.peek e with
    | Some r -> 
      if r = c then (
        Env.junk e;
        Some (r, p)
      ) else (
        None
      )
    | None -> None
  );;

  let p_char_not c () (p: p_pos) e = (
    match Env.peek e with
    | Some r -> 
      if r <> c then (
        Env.junk e;
        Some (r, p)
      ) else (
        None
      )
    | None -> None
  );;

  let p_char_i c () (p: p_pos) e = (
    match Env.peek e with
    | Some r -> 
      if Char.uppercase r = c then (
        Env.junk e;
        Some (r, p)
      ) else (
        None
      )
    | None -> None
  );;

  let p_char_range (cf: char) (cl: char) () (p: p_pos) e = (
    match Env.peek e with
    | Some r -> 
      if r >= cf && r <= cl then (
        Env.junk e;
        Some (r, p)
      ) else (
        None
      )
    | None -> None
  );;

  let p_char_i_range cf cl () (p: p_pos) e = (
    match Env.peek e with
    | Some r -> 
      let u = Char.uppercase r in
      if u >= cf && u <= cl then (
        Env.junk e;
        Some (r, p)
      ) else (
        None
      )
    | None -> None
  );;

end;;