Source

planck / lib / op_prec.ml

Full commit
open Sexplib.Conv

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 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)

  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 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 parse xs = build (parse None xs)

(*
  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)
*)

end