Add associativity control

ast.ml

@@ -2,10 +2,12 @@ module Type = struct
   type t =
     | Int
     | Float
+    | String
 
   let to_string = function
     | Int -> "int"
     | Float -> "float"
+    | String -> "string"
 
   let merge a b =
     match a, b with
@@ -22,16 +24,24 @@ module Value = struct
   type t =
     | Int of int
     | Float of float
+    | String of string
     | Nop (* return of system operations *)
 
   let to_string = function
-    | Int n -> Printf.sprintf "%d" n
-    | Float n -> Printf.sprintf "%f" n
+    | Int n -> string_of_int n
+    | Float n -> string_of_float n
+    | String s -> s
     | Nop -> "nop"
 
+  let of_token = function
+    | Token.Int n -> Int n
+    | Float n -> Float n
+    | _ -> invalid_arg "Value.of_token"
+
   let typeof = function
     | Int _ -> Type.Int
     | Float _ -> Type.Float
+    | String _ -> Type.String
     | Nop -> failwith "Value.typeof"
 
   let promote = function
@@ -92,6 +102,8 @@ type t =
   | Binop of t * Binop.t * t
   | Set_binop_pre of Binop.t * t
   | Get_binop_pre of Binop.t
+  | Set_binop_aso of Binop.t * string
+  | Get_binop_aso of Binop.t
 
 let value v = Value v
 
@@ -115,5 +127,9 @@ let print ast =
       pr ")"
     | Get_binop_pre op ->
       pr "(get_pre %s)" (Binop.to_string op)
+    | Set_binop_aso (op, aso) ->
+      pr "(set_assoc %s %s)" (Binop.to_string op) aso
+    | Get_binop_aso op ->
+      pr "(get_pre %s)" (Binop.to_string op)
   in
   aux ast; pr "\n"

eval.ml

@@ -41,5 +41,12 @@ let eval vars ast =
       Nop
     | Get_binop_pre op ->
       Int (Hashtbl.find Parser.precedence op)
+    | Set_binop_aso (op, a) ->
+      Hashtbl.replace Parser.oper_assoc op @@ Parser.assoc_of_string a;
+      Nop
+    | Get_binop_aso op ->
+      match Hashtbl.find_opt Parser.oper_assoc op with
+      | None -> String "left"
+      | Some a -> String (Parser.assoc_to_string a)
   in
   aux ast

parser.ml

@@ -33,6 +33,15 @@ type associativity =
   | Left_to_right
   | Right_to_left
 
+let assoc_of_string = function
+  | "left" -> Left_to_right
+  | "right" -> Right_to_left
+  | _ -> invalid_arg "assoc_of_string"
+
+let assoc_to_string = function
+  | Left_to_right -> "left"
+  | Right_to_left -> "right"
+
 let oper_assoc = [
   Exp, Right_to_left;
 ] |> List.to_seq |> Hashtbl.of_seq
@@ -62,6 +71,13 @@ let token_is_operator tok =
 
 (* common parsers *)
 
+let token tok seq =
+  match seq () with
+  | Seq.Nil -> expected @@ Token.to_string tok
+  | Seq.Cons (x, seq) ->
+    if x = tok then x, seq
+    else expected @@ Token.to_string tok
+
 let idents set seq =
   match seq () with
   | Seq.Nil ->
@@ -85,23 +101,33 @@ let operator seq =
 
 (* parser combinators *)
 
-let either f g seq =
-  try f seq with _ -> g seq
+let oneof fs seq =
+  let rec aux = function
+    | [] -> assert false
+    | [f] -> f seq
+    | f::fs -> (try f seq with _ -> aux fs)
+  in
+  aux fs
 
-let (@>) f g seq =
+let (@>) f g = fun seq ->
   let a, seq = f seq in
   g a seq
 
-(* expr := "level" level_inner
+(* expr := level
+ *       | assoc
+ *       | let
  *       | value binop_right
 *)
-let rec expr seq =
-  seq |> either
-    (ident "level" @> level_inner)
-    (value @> binop ~-1)
+let rec expr pre seq =
+  seq |> oneof [
+    level;
+    assoc;
+    value @> binop pre;
+  ]
 
-(* level_inner := "get" | "set" [op] *)
-and level_inner _ seq =
+(* level := "level" {"get" | "set"} [op] *)
+and level seq =
+  let _, seq = ident "level" seq in
   let id, seq = idents (S.of_list ["get"; "set"]) seq in
   let op, seq = operator seq in
   if id = "get" then
@@ -112,7 +138,20 @@ and level_inner _ seq =
   else
     failwith "Parser.level"
 
-(* value := int | ( expr ) *)
+(* assoc := "assoc" {"get" | "set"} [op] *)
+and assoc seq =
+  let _, seq = ident "assoc" seq in
+  let id, seq = idents (S.of_list ["get"; "set"]) seq in
+  let op, seq = operator seq in
+  if id = "get" then
+    Get_binop_aso op, seq
+  else if id = "set" then
+    let a, seq = idents (S.of_list ["left"; "right"]) seq in
+    Set_binop_aso (op, a), seq
+  else
+    failwith "Parser.assoc"
+
+(* value := int | float | ( expr ) *)
 and value seq =
   match seq () with
   | Seq.Nil -> raise End_of_tokens
@@ -120,7 +159,10 @@ and value seq =
       | Token.Int n -> Value (Int n), seq
       | Float n -> Value (Float n), seq
       | Ident id -> Var id, seq
-      | LParen -> expr seq
+      | LParen ->
+        let e, seq = expr min_int seq in
+        let _, seq = token RParen seq in
+        e, seq
       | _ -> unexpected_token x
     end
 
@@ -131,20 +173,22 @@ and binop pre left seq =
   | Seq.Cons (x, seq) -> begin match x with
       | op when token_is_operator op ->
         let op = token_to_op op in
-        let o = precedence_of op in
+        let op_pre = precedence_of op in
         (* 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
+        if op_pre > pre
+        || (op_is_right_to_left op && op_pre = pre)
+        then
+          let right, seq = expr op_pre seq in
           binop pre (Ast.binop left op right) seq
         else
           left, Seq.cons x seq
-      | Token.RParen -> left, seq
+
+      | Token.RParen -> left, Seq.cons x seq
       | _ -> unexpected_token x
     end
 
 (* parse tokens *)
 let parse ts =
-  let ast, rest = expr ts in
+  let ast, rest = expr min_int ts in
   if rest () <> Seq.Nil then failwith "Parser.parse";
   ast