Add parser combinators

parser.ml

@@ -35,6 +35,39 @@ let token_to_op = function
   | Slash -> Div
   | _ -> failwith "Parser.token_to_op"
 
+(* common parsers *)
+
+let idents set seq =
+  match seq () with
+  | Seq.Nil ->
+    let msg = "ident " ^ (S.elements set |> String.concat " or ") in
+    expected msg
+  | Seq.Cons (x, seq) -> begin
+      match x with
+      | Token.Ident id when S.mem id set -> id, seq
+      | _ -> unexpected_token x
+    end
+
+let ident str seq =
+  idents (S.singleton str) seq
+
+let operator seq =
+  match seq () with
+  | Seq.Nil -> expected "operator"
+  | Seq.Cons (x, seq) ->
+    try token_to_op x, seq with
+    | _ -> expected "operator"
+
+(* parser combinators *)
+
+let either f g seq =
+  try f seq with _ -> g seq
+
+let (@>) f g seq =
+  let a, seq = f seq in
+  g a seq
+
+(* parse tokens *)
 let parse ts =
   (* value := int | ( expr ) *)
   let rec value seq =
@@ -64,41 +97,21 @@ let parse ts =
         | _ -> unexpected_token x
       end
 
-  and ident set seq =
+  and level _ seq =
-    match seq () with
+    let id, seq = idents (S.of_list ["get"; "set"]) seq in
-    | Seq.Nil ->
-      let msg = "ident " ^ (S.elements set |> String.concat " or ") in
-      expected msg
-    | Seq.Cons (x, seq) -> begin match x with
-        | Token.Ident id when S.mem id set -> id, seq
-        | _ -> unexpected_token x
-      end
-
-  and operator seq =
-    match seq () with
-    | Seq.Nil -> expected "operator"
-    | Seq.Cons (x, seq) ->
-      try token_to_op x, seq with
-      | _ -> expected "operator"
-
-  and level seq =
-    let id, seq = ident (S.of_list ["get"; "set"]) seq in
     let op, seq = operator seq in
     if id = "get" then
       Get_binop_pre op, seq
-    else
+    else if id = "set" then
       let v, seq = value seq in
       Set_binop_pre (op, v), seq
+    else
+      failwith "Parser.level"
 
   and expr seq =
-    match seq () with
+    seq |> either
-    | Seq.Nil -> Value Unit, Seq.empty (* nop *)
+      (ident "level" @> level)
-    | Seq.Cons (x, s) -> begin match x with
+      (value @> binop ~-1)
-        | Ident "level" -> level s
-        | _ ->
-          let left, seq = value seq in
-          binop ~-1 left seq
-      end
   in
   let ast, rest = expr ts in
   if rest () <> Seq.Nil then failwith "Parser.parse";