Rework Binary Expression Parser

ast.ml

@@ -41,6 +41,7 @@ module Value = struct
 end
 
 (* binary operator *)
+(* binary operator has type 'a -> 'a -> 'b. *)
 module Binop = struct
   type t =
     | Add | Sub | Mul | Div (* arithmetics *)

parser.ml

@@ -5,6 +5,7 @@ module S = Set.Make(String)
 
 exception Expected of string
 exception Unexpected_token of string
+exception End_of_tokens
 
 let expected t =
   raise @@ Expected t
@@ -28,9 +29,9 @@ let precedence = [
 let precedence_of op =
   Hashtbl.find precedence op
 
-let is_left_to_right = function
-  | Add | Sub | Mul | Div -> true
-  | _ -> assert false
+let op_is_right_to_left = function
+  | Exp -> true
+  | _ -> false
 
 let operators = [
   Token.Plus, Add;
@@ -45,6 +46,9 @@ let token_to_op tok =
   try Hashtbl.find operators tok
   with _ -> failwith "Parser.token_to_op"
 
+let token_is_operator tok =
+  Hashtbl.mem operators tok
+
 (* common parsers *)
 
 let idents set seq =
@@ -82,10 +86,10 @@ let parse ts =
   (* value := int | ( expr ) *)
   let rec value seq =
     match seq () with
-    | Seq.Nil -> assert false
+    | Seq.Nil -> raise End_of_tokens
     | Seq.Cons (x, seq) -> begin match x with
         | Token.Int n -> Value (Int n), seq
-        | Token.Float n -> Value (Float n), seq
+        | Float n -> Value (Float n), seq
         | LParen -> expr seq
         | _ -> unexpected_token x
       end
@@ -95,29 +99,22 @@ let parse ts =
     match seq () with
     | Seq.Nil -> left, Seq.empty
     | Seq.Cons (x, seq) -> begin match x with
-        | Token.Plus | Minus | Asterisk | Slash | Percent as op ->
+        | op when token_is_operator op ->
           let op = token_to_op op in
           let o = precedence_of op in 
-          if o > pre then (* op has to be calculated first *)
+          (* op has to be calculated first *)
+          if o > pre || op_is_right_to_left op && o = pre then
             let v, seq = value seq in
             let right, seq = binop o v seq in
             binop pre (Ast.binop left op right) seq
           else
             left, Seq.cons x seq
-        | Carret as op ->
-          let op = token_to_op op in
-          let o = precedence_of op in 
-          if o >= pre then (* op has to be calculated first *)
-            let v, seq = value seq in
-            let right, seq = binop o v seq in
-            binop pre (Ast.binop left op right) seq
-          else
-            left, Seq.cons x seq
-        | RParen -> left, seq
+        | Token.RParen -> left, seq
         | _ -> unexpected_token x
       end
 
-  and level _ seq =
+  (* level_inner := "get" | "set" [op] *)
+  and level_inner _ seq =
     let id, seq = idents (S.of_list ["get"; "set"]) seq in
     let op, seq = operator seq in
     if id = "get" then
@@ -128,9 +125,12 @@ let parse ts =
     else
       failwith "Parser.level"
 
+  (* expr := "level" level_inner
+   *       | value binop_right
+   *)
   and expr seq =
     seq |> either
-      (ident "level" @> level)
+      (ident "level" @> level_inner)
       (value @> binop ~-1)
   in
   let ast, rest = expr ts in