Commits

camlspotter committed fbf4f92

simplification of op_prec

Comments (0)

Files changed (5)

    stoken
    ptoken
    op_prec
-   op_prec2
 
 LIB = planck
 
 open Sexplib.Conv
 
-type op = { 
-  prec : float; (* just a joke :-) *)
-  kind : [ `Infix of [ `Left | `Right ] | `Prefix | `Postfix | `Noassoc ]
-} with sexp
+module Make(A : sig
+  type t
+  type op
+  val app : t -> t -> t
+  val binop : op -> t -> t -> t
+  val unop : op -> t -> t
+end) = struct
+  type op = { 
+    prec : float; (* just a joke :-) *)
+    kind : [ `Infix of [ `Left | `Right | `Noassoc ] | `Prefix | `Postfix ]
+  } with sexp
+  
+  let prec_app = 1000.0
+  let op_app = { prec = prec_app; kind = `Infix `Left }
+  
+(*
+  let tbl : (A.op, op) Hashtbl.t = Hashtbl.create 107
+*)
+  
+  (* List like e1, e2, ..., en is implemented as infix with special builder *)
+  type t = 
+    | Infix of op * A.op option * t * t (* None means application *)
+    | Postfix of op * A.op * t
+    | Prefix of op * A.op * t
+    | Terminal of A.t
 
-let tbl : (string, op) Hashtbl.t = Hashtbl.create 107
+  let rec build = function
+    | Terminal a -> a
+    | Infix (_, None, t1, t2) -> A.app (build t1) (build t2)
+    | Infix (_, Some op, t1, t2) -> A.binop op (build t1) (build t2)
+    | Postfix (_, op, t) | Prefix (_, op, t) -> A.unop op (build t)
 
-(* List like e1, e2, ..., en is implemented as infix with special builder *)
-type 'v t = 
-  | Infix of op * [ `List of 'v list -> 'v | `Binop of ('v -> 'v -> 'v) ] * 'v t * 'v t
-  | Parened of ('v -> 'v) * 'v t
-  | Postfix of op * ('v -> 'v) * 'v t
-  | Prefix of op * ('v -> 'v) * 'v t
-  | Terminal of 'v
-with sexp
+  let compare x y =
+    match compare x.prec y.prec with
+    | 1 -> `Strong
+    | -1 -> `Weak
+    | 0 ->
+        if x.kind = y.kind then 
+          match x.kind with
+          | `Infix `Left -> `Left
+          | `Infix `Right -> `Right
+          | `Infix `Noassoc -> `Error
+          | `Prefix | `Postfix -> assert false (* comparing prefixes / postfixes is non-sense *)
+        else `Error
+    | _ -> assert false (* impossible *)
+  
+(*
+  let rec build = function
+    | Terminal e -> e
+    | Parened (f, e) -> f (build e)
+    | Prefix (_op, f, e) | Postfix (_op, f, e) -> f (build e)
+    | Infix (_op, `Binop f, left, right) -> f (build left) (build right)
+    | Infix (op, `List f, left, right) -> f (List.map build (build_list op left right))
+        
+  (* stick list elements together *)
+  and build_list op e1 e2 =
+    let e1s = 
+      match e1 with
+      | Infix (op', _, e11, e12) when op = op' -> build_list op e11 e12
+      | _ -> [e1]
+    in
+    let e2s =
+      match e2 with
+      | Infix (op', _, e21, e22) when op = op' -> build_list op e21 e22
+      | _ -> [e2]
+    in
+    e1s @ e2s
+*)
+  
+  (* let pp ppf v = Sexplib.Sexp.pp_hum ppf (sexp_of_t v) *)
+  
+  (*
+  let build v = 
+    Format.eprintf "BUILD: %a@." pp v;
+    let res = build v in
+    Format.eprintf "BUILD DONE@.";
+    res
+  *)
+  
+  let terminal x = Terminal x
+  
+  let rec infix op a left right = infix_check_left op a left right 
+  
+  and infix_check_left op a e12 e3 =
+    match e12 with
+    | Terminal _ -> infix_check_right op a e12 e3
+    | Prefix (lop, la, e) -> 
+        begin match compare op lop with
+        | `Strong -> (* flip! : weak 1 + _ => weak <1 + _> *)
+            prefix lop la (infix op a e e3) 
+        | `Weak  | `Error -> (* ~ 1 + _ => <~ 1> + _ *) 
+            infix_check_right op a e12 e3    
+        | `Left | `Right -> (* impossible *) assert false             
+        end
+    | Postfix _ -> (* always a! * b => <a!> * b, when ! is postfix *)
+        infix_check_right op a e12 e3
+    | Infix (lop, la, e1, e2) -> 
+        begin match compare op lop with
+        | `Strong | `Right -> (* flip!: 0 - 1 * 2 => - 0 - <1 * 2> *)
+            infix lop la e1 (infix op a e2 e3) 
+        | `Weak | `Left -> (* 0 * 1 + 2 => <0 * 1> + 2 *)
+            infix_check_right op a e12 e3 
+        | `Error -> assert false  (* ERROR *)
+        end
+  
+  and infix_check_right op a e1 e23 =
+    match e23 with
+    | Terminal _ 
+    | Prefix _  (* always a * - b => a * <- b>, when - is prefix *) -> 
+        Infix (op, a, e1, e23)
+    | Postfix (rop, ra, e) -> 
+        begin match compare op rop with
+        | `Strong -> (* flip!: 1 + 2 weak => <1 + 2> weak *) 
+            postfix rop ra (infix op a e1 e)
+        | `Weak | `Error (* _ + 1 x => _ + <1 x> *) -> Infix (op, a, e1, e23) 
+        | `Left | `Right -> (* impossible *) assert false
+        end
+    | Infix (rop, ra, e2, e3) ->
+        match compare op rop with
+        | `Strong | `Left -> (* flip!: 0 * 1 + 2 => <0 * 1> + 2 *)
+            infix rop ra (infix op a e1 e2) e3
+        | `Weak | `Right -> (* 0 + 1 * 2 => 0 + <1 * 2> *)
+            Infix (op, a, e1, e23)
+        | `Error -> assert false (* ERROR *)
+  
+  and prefix op a e =
+    match e with
+    | Terminal _ 
+    | Prefix _ (* - - 1 *) -> Prefix (op, a, e)
+    | Postfix (op', a', e') -> (* - e ! *)
+        begin match compare op op' with
+        | `Strong -> (* <- e> ! *) postfix op' a' (prefix op a e')
+        | `Weak -> (* - <e !> *) Prefix (op, a, e)
+        | `Error -> assert false (* ERROR *)
+        | _ -> assert false (* impossible *)
+        end
+    | Infix (rop, ra, e1, e2) ->
+        match compare op rop with
+        | `Weak -> (* - 1 * 2 => - <1 * 2> *) 
+            Prefix (op, a, e)
+        | _ -> (* flip!: - 1 + 2 => <- 1> + 2 *)
+            infix rop ra (prefix op a e1) e2
+  
+  and postfix op a e =
+    match e with
+    | Terminal _ 
+    | Postfix _ (* 3 $ $ => <3 $> $ *) -> 
+        Postfix (op, a, e)
+    | Prefix (op', a', e') -> 
+        begin match compare op op' with
+        | `Strong -> (* flip!: - e ! => - <e !> *) prefix op' a' (postfix op a e')
+        | `Weak -> (* flip!: - e ! => <- e> ! *) Postfix (op, a, e)
+        | `Error -> assert false (* ERROR *)
+        | _ -> assert false (* impossible *)
+        end
+    | Infix (rop, ra, e1, e2) ->
+        match compare op rop with
+        | `Weak -> (* 1 * 2 $ => <1 * 2> $ *)
+            Postfix (op, a, e)
+        | _ -> (* flip!: 1 * 2 $ => 1 * <2 $> *) 
+            infix rop ra e1 (postfix op a e2)
+    
+  (*
+  let list op f = function
+    | [] -> []
+    | [e] -> [e]
+    | e1::e2::es ->
+  *)      
+        
+  (*
+  let infix op f left right = 
+    Format.eprintf "INFIX: %a (%a) (%a)@."
+      Sexplib.Sexp.pp_hum (sexp_of_op op)
+      pp left
+      pp right;
+    let res = infix op f left right in
+    Format.eprintf "INFIX DONE@.";
+    res
+  
+  let prefix op f e = 
+    Format.eprintf "PREFIX: %a (%a)@."
+      Sexplib.Sexp.pp_hum (sexp_of_op op)
+      pp e;
+    let res = prefix op f e in
+    Format.eprintf "PREFIX DONE@.";
+    res
+  
+  let postfix op f e = 
+    Format.eprintf "POSTFIX: %a (%a)@."
+      Sexplib.Sexp.pp_hum (sexp_of_op op)
+      pp e;
+    let res = postfix op f e in
+    Format.eprintf "POSTFIX DONE@.";
+    res
+  *)
+  
+  let app = infix op_app None
 
-let compare x y =
-  match compare x.prec y.prec with
-  | 1 -> `Strong
-  | -1 -> `Weak
-  | 0 ->
-      if x.kind = y.kind then 
-        match x.kind with
-        | `Infix `Left -> `Left
-        | `Infix `Right -> `Right
-        | `Prefix -> assert false
-        | `Postfix -> assert false
-        | `Noassoc -> `Error
-      else `Error
-  | _ -> assert false
+  let rec parse treeopt str = 
+    match treeopt with
+    | None ->
+        begin match str with
+        | [] -> failwith "empty"
+        | `Term t :: str -> parse (Some (terminal t)) str
+        | `Op (op, a) :: str ->
+            begin match op.kind with
+            | `Prefix -> prefix op a (parse None str)
+            | `Postfix -> failwith "postfix"
+            | `Infix _ -> failwith "infix"
+            end
+        end
+    | Some tree ->
+        begin match str with
+        | [] -> tree
+        | `Term t :: str -> parse (Some (app tree (terminal t))) str
+        | `Op (op, a) :: str ->
+            begin match op.kind with
+            | `Prefix -> app tree (prefix op a (parse None str))
+            | `Postfix -> parse (Some (postfix op a tree)) str
+            | `Infix _ -> infix op (Some a) tree (parse None str)
+            end
+        end
 
-let rec build = function
-  | Terminal e -> e
-  | Parened (f, e) -> f (build e)
-  | Prefix (_op, f, e) | Postfix (_op, f, e) -> f (build e)
-  | Infix (_op, `Binop f, left, right) -> f (build left) (build right)
-  | Infix (op, `List f, left, right) -> f (List.map build (build_list op left right))
-      
-(* stick list elements together *)
-and build_list op e1 e2 =
-  let e1s = 
-    match e1 with
-    | Infix (op', _, e11, e12) when op = op' -> build_list op e11 e12
-    | _ -> [e1]
-  in
-  let e2s =
-    match e2 with
-    | Infix (op', _, e21, e22) when op = op' -> build_list op e21 e22
-    | _ -> [e2]
-  in
-  e1s @ e2s
-
-let pp ppf v = Sexplib.Sexp.pp_hum ppf (sexp_of_t (fun _ -> Sexplib.Sexp.Atom "") v)
+  let parse xs = build (parse None xs)
 
 (*
-let build v = 
-  Format.eprintf "BUILD: %a@." pp v;
-  let res = build v in
-  Format.eprintf "BUILD DONE@.";
-  res
+  let list op = function
+    | [] -> assert false
+    | e::es -> 
+        let op = !find op in
+        List.fold_left (infix op) e es
+  let infix op = infix (!find op)
+  let prefix op = prefix (!find op)
+  let postfix op = postfix (!find op)
+  exception Op_not_found of A.op
+  let find_tbl op = try Hashtbl.find tbl op with Not_found -> raise (Op_not_found op)
+  let find = ref (fun op -> find_tbl op)
 *)
 
-let terminal x = Terminal x
-
-let parened f e = Parened (f, e)
-
-let rec infix op f left right = infix_left op f left right 
-
-and infix_left op f e12 e3 =
-  match e12 with
-  | Parened _ | Terminal _ -> infix_right op f e12 e3
-  | Prefix (lop, lf, e) -> 
-      begin match compare op lop with
-      | `Strong -> prefix lop lf (infix op f e e3)
-      | `Weak -> infix_right op f e12 e3
-      | `Error (* CR jfuruse: ? *) -> infix_right op f e12 e3 (* - 1 + _ => <- 1> + _ *)
-      | `Left | `Right -> assert false
-      end
-  | Postfix _ ->
-      (* always a! * b => <a!> * b, when ! is postfix *)
-      infix_right op f e12 e3
-  | Infix (lop, lf, e1, e2) -> 
-      begin match compare op lop with
-      | `Strong | `Right -> infix lop lf e1 (infix op f e2 e3)
-      | `Weak | `Left -> infix_right op f e12 e3
-      | `Error -> assert false
-      end
-
-and infix_right op f e1 e23 =
-  match e23 with
-  | Parened _ | Terminal _ -> Infix (op, f, e1, e23)
-  | Prefix _ -> 
-      (* always a * - b => a * <- b>, when - is prefix *) 
-      Infix (op, f, e1, e23)
-  | Postfix (rop, rf, e) -> 
-      begin match compare op rop with
-      | `Strong -> postfix rop rf (infix op f e1 e)
-      | `Weak -> Infix (op, f, e1, e23) 
-      | `Error (* CR jfuruse: ? *) -> Infix (op, f, e1, e23) (* _ + 1 x => _ + <1 x> *)
-      | `Left | `Right -> assert false
-      end
-  | Infix (rop, rf, e2, e3) ->
-      match compare op rop with
-      | `Strong | `Left -> infix rop rf (infix op f e1 e2) e3
-      | `Weak | `Right -> Infix (op, f, e1, e23)
-      | `Error -> assert false
-
-and prefix op f e =
-  match e with
-  | Parened _ | Terminal _ | Prefix _ (* left - left *) -> Prefix (op, f, e)
-  | Postfix (op', f', e') -> (* - e ! *)
-      begin match compare op op' with
-      | `Strong -> postfix op' f' (prefix op f e')
-      | `Weak -> Prefix (op, f, e)
-      | _ -> assert false
-      end
-  | Infix (rop, rf, e1, e2) ->
-      begin match compare op rop with
-      | `Weak -> Prefix (op, f, e)
-      | _ -> infix rop rf (prefix op f e1) e2 (* - <1 + 2> => (-1) + 2 *) 
-      end
-
-and postfix op f e =
-  match e with
-  | Parened _ | Terminal _ | Postfix _ (* right - right *) -> Postfix (op, f, e)
-  | Prefix (op', f', e') -> (* - e ! *)
-      begin match compare op op' with
-      | `Strong -> prefix op' f' (postfix op f e')
-      | `Weak -> Postfix (op, f, e)
-      | _ -> assert false
-      end
-  | Infix (rop, rf, e1, e2) ->
-      match compare op rop with
-      | `Weak -> Postfix (op, f, e)
-      | _ -> infix rop rf e1 (postfix op f e2)
-
-      
-  
-
-  
-(*
-let list op f = function
-  | [] -> []
-  | [e] -> [e]
-  | e1::e2::es ->
-*)      
-      
-  
-
-(*
-let infix op f left right = 
-  Format.eprintf "INFIX: %a (%a) (%a)@."
-    Sexplib.Sexp.pp_hum (sexp_of_op op)
-    pp left
-    pp right;
-  let res = infix op f left right in
-  Format.eprintf "INFIX DONE@.";
-  res
-
-let prefix op f e = 
-  Format.eprintf "PREFIX: %a (%a)@."
-    Sexplib.Sexp.pp_hum (sexp_of_op op)
-    pp e;
-  let res = prefix op f e in
-  Format.eprintf "PREFIX DONE@.";
-  res
-
-let postfix op f e = 
-  Format.eprintf "POSTFIX: %a (%a)@."
-    Sexplib.Sexp.pp_hum (sexp_of_op op)
-    pp e;
-  let res = postfix op f e in
-  Format.eprintf "POSTFIX DONE@.";
-  res
-*)
-
-exception Op_not_found of string
-let find_tbl op = try Hashtbl.find tbl op with Not_found -> raise (Op_not_found op)
-let find = ref (fun op -> find_tbl op)
-let list op f = function
-  | [] -> assert false
-  | e::es -> 
-      let op = !find op in
-      List.fold_left (infix op (`List f)) e es
-let infix op f = infix (!find op) (`Binop f)
-let prefix op = prefix (!find op)
-let postfix op = postfix (!find op)
+end 
 (** Tools for operator precedences and associativities *)
 
-type 'a t
-(** This is the abstract type of ``unresolved parse tree''.
+module Make(A : sig
+  type t
+  type op
+  val app : t -> t -> t
+  val binop : op -> t -> t -> t
+  val unop : op -> t -> t
+end) : sig
 
-    Type [s t] carries parse tree [s] whose operator precedences + associativities
-    are not fully resolved yet.
-
-    At parsing an expression with operators of type [s], 
-    first you can parse its sub-expressions from left to right 
-    without thinking about operator precedences or associativities. 
-    Instead, build [s t] instead of [s] using the combinators below.
-    Once the whole expression with operators is parsed as [s t], then
-    obtain the parse tree [s] by [build], which resolves all the necessary
-    operator precedences and associativities.
-
-    You can see a use example of this module at planck/test/expr.ml
-*)
-
-type op = {
-  prec : float; (** Operator precedence. Bigger is stronger. *)
-  kind : [ `Infix of [ `Left | `Right ] (** Infix, left or right associative *)
-         | `Noassoc 
-         | `Postfix 
-         | `Prefix
-         ];
-}
-
-val tbl : (string, op) Hashtbl.t
-(** Operator table. The resolution functions below uses this table to query operators
-    and its precedence information *)
-
-val find : (string -> op) ref
-(** By default [!find] is used to query operators from [tbl]. 
-    If your set of operators cannot use table based precedence + associativity query,
-    you can override this behavior by modifying the reference. 
-*)
-
-(** Resolution *)
-
-val build : 'a t -> 'a
-(** [build at] analyzes all the required precedencies + associativities in 
-    the unresolved parse tree [at] and returns the resolution result. *)
-
-(** Building 
-
-    You can build ['a t] using the following functions 
-    without thinking anything about precedences or connectivity.
-    Then use [build] for all the resolution.
-
-    For example, for 
-
-       1 + ~2 * 3        (~ for unary minus)
-
-    Just build the ['a t] from left to right:
-
-    let e = infix "+" plus (terminal one) 
-                           (prefix "~" (terminal two))
-    in
-    let e' = infix "*" mult e (terminal three) in
-
-    Then run [build e'] to get the resolved tree of ['a].        
-    
-*)
-
-val terminal : 'a -> 'a t
-(** [terminal a] takes a terminal object and returns its unresolved tree.
-    Terminal objects are leaves in parse trees which cannot be affected by operators: 
-    ex. ``10'', ``"hello"'', ``var'' 
+  type op = {
+    prec : float; (** Operator precedence. Bigger is stronger. *)
+    kind : [ `Infix of [ `Left | `Right | `Noassoc ] (** Infix, left or right associative *)
+           | `Postfix 
+           | `Prefix
+           ];
+  }
+  
+  val prec_app : float
+  (** Operator precedence of function application. = 1000.0 *)
+  
+(*
+  val tbl : (A.op, op) Hashtbl.t
+  (** Operator table. The resolution functions below uses this table to query operators
+      and its precedence information *)
+  
+  val find : (A.op -> op) ref
+  (** By default [!find] is used to query operators from [tbl]. 
+      If your set of operators cannot use table based precedence + associativity query,
+      you can override this behavior by modifying the reference. 
+  *)
 *)
   
-val parened : ('a -> 'a) -> 'a t -> 'a t
-(** [parened f at] creates the unresolved parse tree for the parenthesized expression
-    which [at] represents. For example, if [at] represents ``1 + 2'', [parened f at]
-    represents ``(1 + 2)''. At resolution, the result of [at] is given to the funciton 
-    [f] to create the result of [parened f at].
-*)
+  (** Resolution *)
 
-val infix : string -> ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
-(** [infix name f at1 at2] creates the unresolved parse tree for the expression
-    of a binary operator use [name] whose left argument is [at1] and right is [at2].
-    At resolution, the precedence and associativity of [name] is obtained from [find]
-    function above. Function [f] is used to create the result of the resolution. *)
-
-val prefix : string -> ('a -> 'a) -> 'a t -> 'a t
-(** [prefix name f at] creates the unresolved parse tree for the expression
-    prefixed by an operator [name] whose argument is [at].
-    At resolution, the precedence and associativity of [name] is obtained from [find]
-    function above. Function [f] is used to create the result of the resolution. *)
-
-val postfix : string -> ('a -> 'a) -> 'a t -> 'a t
-(** [postfix name f at] is just like [prefix name f at], but for postfix operators. *)
-
-val list : string -> ('a list -> 'a) -> 'a t list -> 'a t
-(** [list name f ats] creates the unresolved parse tree for the list style expression
-    which is separated by the operator [name] and has the elements [ats]. *)
+  val parse : [ `Op of op * A.op | `Term of A.t ] list -> A.t
+end

lib/op_prec2.ml

-type op = { 
-  prec : float; (* just a joke :-) *)
-  kind : [ `Infix of [ `Left | `Right ] | `Prefix | `Postfix | `Noassoc ]
-}
-
-let prec_app = 1000.0
-
-let compare x y =
-  match compare x.prec y.prec with
-  | 1 -> `Strong
-  | -1 -> `Weak
-  | 0 ->
-      if x.kind = y.kind then 
-        match x.kind with
-        | `Infix `Left -> `Left
-        | `Infix `Right -> `Right
-        | `Prefix -> assert false
-        | `Postfix -> assert false
-        | `Noassoc -> `Error
-      else `Error
-  | _ -> assert false
-
-let tbl : (string, op) Hashtbl.t = Hashtbl.create 107
-
-(* List like e1, e2, ..., en is implemented as infix with special builder *)
-type 'v t = 
-  | Infix of op * ('v -> 'v -> 'v)
-  | List of op * ('v list -> 'v)
-  | Postfix of op * ('v -> 'v)
-  | Prefix of op * ('v -> 'v)
-  | Terminal of 'v
-  | MarkApp (** mark for application *)
-
-type 'v tree =
-  | Leaf of 'v
-  | App of 'v t * 'v tree list
-
-let build build_app = 
-  let rec build = function
-    | Leaf v -> v
-    | App (Infix (_, f), [e1; e2]) -> f (build e1) (build e2)
-    | App (List (_, f), es) -> f (List.map build es)
-    | App (Postfix (_, f), [e1])
-    | App (Prefix (_, f), [e1]) -> f (build e1)
-    | App (Terminal v, es) -> build_app v (List.map build es)
-    | _ -> assert false
-  in
-  build
-
-(* 
-   f x y => f <> x <> y
-   1 + 2 => 1 + 2
-   f ~ 2 => f <> ~ 2
-   1 + ~ 2 => 1 + ~ 2
-   f 2 dollar 4 => f <> 2 dollar <> 4
-*)
-
-let rec add_explicit_app st = function
-  | [] -> List.rev st
-  | (Terminal _ as t1) :: ((Terminal _ | Prefix _  | Postfix _):: _ as ts) ->
-      add_explicit_app (MarkApp :: t1 :: st) ts
-  | (Terminal _ as t1) :: [] -> 
-      add_explicit_app (t1 :: st) []
-  | (Prefix _ as t1) :: ts -> 
-      add_explicit_app (t1 :: st) ts
-  | (Postfix _ as t1) :: ts ->
-      add_explicit_app (MarkApp :: t1 :: st) ts
-  | t1 :: ((Infix _ | List _):: _ as ts) -> 
-      add_explicit_app (t1 :: st) ts
-  | ((Infix _ | List _)as t1) :: ts ->
-      add_explicit_app (t1 :: st) ts
-  | _ :: MarkApp :: _
-  | MarkApp :: _ -> assert false
-
-let prec = function
-  | (Infix (op, _) | List (op, _) | Postfix (op, _) | Prefix (op, _)) -> Some op.prec
-  | MarkApp -> Some prec_app
-  | Terminal _ -> None
-
-let find_weakest ts = List.fold_left (fun st t ->
-  match st, prec t with
-  | _, None -> st
-  | Some v, Some v' -> Some (min v v')
-  | None, vopt -> vopt) None ts
-
-
 
 open Parser (* open Parser namespace *)
 
+module Tree = struct
+  type t = 
+    | Const of int
+    | Binop of char * t * t
+    | Unop of char * t
+
+  let rec eval = function
+    | Const n -> n
+    | Binop ('+', t1, t2) -> eval t1 + eval t2
+    | Binop ('-', t1, t2) -> eval t1 - eval t2
+    | Binop ('*', t1, t2) -> eval t1 * eval t2
+    | Binop ('/', t1, t2) -> eval t1 / eval t2
+    | Unop ('~', t1) -> - eval t1
+    | _ -> assert false
+
+  let rec show = function
+    | Const n -> string_of_int n
+    | Binop (char, t1, t2) -> "(" ^ show t1 ^ " " ^ String.make 1 char ^ " " ^ show t2 ^ ")"
+    | Unop (char, t1) -> "(" ^ String.make 1 char ^ " " ^ show t1  ^ ")"
+end
+
+module Op_prec = Op_prec.Make(struct
+  type t = Tree.t
+  type op = char
+  let app _f _a = assert false
+  let binop op a1 a2 = Tree.Binop(op, a1, a2)
+  let unop op a1 = Tree.Unop(op, a1)
+end)
+
 open Op_prec (* open Op_prec, functions for operator precedences *)
 
-let _ = 
-  Hashtbl.replace_list Op_prec.tbl [
-    "+",  { prec = 2.0; kind = `Infix `Left };
-    "-",  { prec = 2.0; kind = `Infix `Left };
-    "*",  { prec = 3.0; kind = `Infix `Left };
-    "/",  { prec = 3.0; kind = `Infix `Left };
-    "~",  { prec = 5.0; kind = `Prefix }; (* unary minus *)
+let tbl = Hashtbl.of_list 11 [
+    '+',  { prec = 2.0; kind = `Infix `Left };
+    '-',  { prec = 2.0; kind = `Infix `Left };
+    '*',  { prec = 3.0; kind = `Infix `Left };
+    '/',  { prec = 3.0; kind = `Infix `Left };
+    '~',  { prec = 5.0; kind = `Prefix }; (* unary minus *)
   ]
   
 (* parsing rules *)
 let blank = void (one_of [' '; '\t'; '\n'; '\r'])
 
-let combine_leftrec (non_leftrec : 'a Parser.t) (leftrec : 'a -> 'a Parser.t) =
+let rec simple_expr st = begin
   
-  non_leftrec >>= fun left ->
-  
-  let rec leftrecs left =
-    (leftrec left >>= fun left' -> leftrecs left')
-    <|> return left
-  in
-  leftrecs left
-
-(* Eta expansions with [st] are required, unfortunatelly *)
-let rec expr st = begin
-
-  combine_leftrec expr_non_leftrec expr_leftrec
-
-end st
-
-and expr_non_leftrec st = begin (* constant, parened and unary minus *)  
-
   (* Skip spaces *)
   ?* blank >>= fun () -> 
 
-  (constant >>= fun sv -> return (Op_prec.terminal sv))
+  constant
+
+  <|> (tokenp (function '+' | '-' | '*' | '/' | '~' -> true | _ -> false)
+         >>= fun char -> return (`Op (Hashtbl.find tbl char, char) ))
 
   <|> (token '(' >>= fun () ->
-       ?* blank >>= fun () ->
        expr >>= fun e ->
        ?* blank >>= fun () ->
-       token ')' <?> "missing closing paren" >>= fun () ->
-       return (Op_prec.parened (fun (s,v) -> Printf.sprintf "(%s)" s, v) e))
-      
-  (* Unary minus *)      
-  <|> (token '-' >>= fun () ->
-       ?* blank >>= fun () ->
-       expr >>= fun e ->
-       return (prefix "~" (fun (s,v) -> Printf.sprintf "~ %s" s, -v) e))
-
-end st
-
-and expr_leftrec e_left st = begin (* binop expr *)
-
-  ?* blank >>= fun () ->
-
-  (binop >>= fun binop ->
-   ?* blank >>= fun () ->
-   expr >>= fun e_right ->
-   return (binop e_left e_right))
-
-end st
-
-and binop st = begin
-  
-  (token '+' >>= fun () ->
-   return (Op_prec.infix "+" (fun (s1,v1) (s2,v2) -> Printf.sprintf "<%s + %s>" s1 s2, v1 + v2)))
-
-  <|> (token '-' >>= fun () ->
-       return (Op_prec.infix "-" (fun (s1,v1) (s2,v2) -> Printf.sprintf "<%s - %s>" s1 s2, v1 - v2)))
-
-  <|> (token '*' >>= fun () ->
-       return (Op_prec.infix "*" (fun (s1,v1) (s2,v2) -> Printf.sprintf "<%s * %s>" s1 s2, v1 * v2)))
-
-  <|> (token '/' >>= fun () ->
-       return (Op_prec.infix "/" (fun (s1,v1) (s2,v2) -> Printf.sprintf "<%s / %s>" s1 s2, v1 / v2)))
-
+       token ')' >>= fun () -> 
+       return (`Term e))
 end st
 
 and constant st = begin
   (* [0-9]+ *)
-  (matched (?+ (tokenp (function '0'..'9' -> true | _ -> false) <?> "decimal")) >>= fun s -> 
-   return (s, int_of_string s))
+  matched (?+ (tokenp (function '0'..'9' -> true | _ -> false) <?> "decimal")) 
+  >>= fun s -> return (`Term (Tree.Const (int_of_string s)))
+end st
 
+and expr st = begin
+  option (token '-') >>= fun unary_minus ->
+  ?++ simple_expr >>= fun es -> 
+  match unary_minus with
+  | Some () -> return (Op_prec.parse (`Op (Hashtbl.find tbl '~', '~') :: es))
+  | None -> return (Op_prec.parse es)
 end st
 
 (* For test *)
   let key = if size = 0 then 0 else Random.int 6 in
   match key with
   | 0 -> string_of_int (Random.int 10)
-  | 1 -> "- " ^ random (size-1) 
+  | 1 -> "(- " ^ random (size-1)  ^ ")" (* unary minus is different from ocaml *)
   | 2 -> "(" ^ random (size-1) ^ ")"
   | 3 -> random (size-1) ^ " + " ^ random (size-1)
   | 4 -> random (size-1) ^ " - " ^ random (size-1)
   | Result.Ok (res, _) -> 
       (* Check whether the original and parsed are identical *)
       (* Check of computed values are done outside of this program. See OMakefile. *)
-      let str, v = build res in 
-      let str_check = 
-        let buf = Buffer.create (String.length str) in
-        for i = 0 to String.length str - 1 do
-          match str.[i] with
-          | '~' -> Buffer.add_char buf '-'
-          | '<' | '>' -> ()
-          | c -> Buffer.add_char buf c
-        done;
-        Buffer.contents buf
-      in
-      Format.eprintf "parsed=%S@.res=%d@.@." str v;
-      if s <> str_check then failwithf "FAILURE\n%s\n%s\n" s str_check;
-      Format.printf "assert (%s = %d);;@." s v;
+      Format.eprintf "%s@." (Tree.show res);
+      let n = Tree.eval res in
+      Format.printf "assert (%s = %d);;@." s n;
+
   | Result.Error (pos, s) ->
       Format.eprintf "%a: syntax error: %s@." Position.File.format pos s;
       raise Exit