Source

planck / lib / op_prec.ml

Full commit
open Sexplib.Conv

module Operator = struct
  type t = { 
    prec : float; (* just a joke :-) *)
    kind : [ `Infix of [ `Left | `Right | `Noassoc ] | `Prefix | `Postfix ]
  } with sexp
    
  let prec_app = 1000.0
  let app = { prec = prec_app; kind = `Infix `Left }

  let show t = 
    let kind = match t.kind with
      | `Infix `Left -> "infix left"
      | `Infix `Right -> "infix right"
      | `Infix `Noassoc -> "infix noassoc"
      | `Prefix -> "prefix"
      | `Postfix -> "postfix"
    in
    Printf.sprintf "%s %f" kind t.prec
end

module O = Operator

module Make(A : sig
  type t
  type op
  val show_op : op -> string
  val app : t -> t -> t
  val binop : op -> t -> t -> t
  val unop : op -> t -> t
end) = struct

  (* List like e1, e2, ..., en is implemented as infix with special builder *)
  type t = 
    | Infix of O.t * A.op option * t * t (* None means application *)
    | Postfix of O.t * A.op * t
    | Prefix of O.t * A.op * t
    | Terminal of A.t

  type error = 
    | Ambiguous of O.t * A.op option * O.t * A.op option
    | Empty
    | NoRightArg of O.t * A.op
    | NoLeftArg of O.t * A.op

  let format_op ppf (o, aop) =
    let show_aop_opt = function
      | None -> "application"
      | Some aop -> A.show_op aop
    in
    Format.fprintf ppf "%s (%s)" (show_aop_opt aop) (Operator.show o)
    
  let format_error ppf = 
    function
      | Ambiguous (lo, laop, ro, raop) ->
          Format.fprintf ppf "@[<v2>Ambiguous operator uses:@ %a@ %a@]"
            format_op (lo, laop)
            format_op (ro, raop)
      | Empty -> Format.fprintf ppf "Empty input"
      | NoRightArg (o, aop) ->
          Format.fprintf ppf "No right argument for %a" format_op (o, Some aop)
      | NoLeftArg (o, aop) ->
          Format.fprintf ppf "No left argument for %a" format_op (o, Some aop)

  exception Error of error

  let ambiguous o aop o' aop' = raise (Error (Ambiguous (o, aop, o', aop')))

  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 =
    let open O in
    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 -> ambiguous lop la op a 
        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 -> ambiguous op a rop ra
  
  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 -> ambiguous op (Some a) op' (Some a')
        | _ -> 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 -> ambiguous op' (Some a') op (Some a)
        | _ -> 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 app = infix O.app None

  let rec parse treeopt contextopt str = 
    match treeopt with
    | None ->
        begin match str with
        | [] -> 
            begin match contextopt with
            | Some (op, a) -> raise (Error (NoRightArg (op, a)))
            | None -> raise (Error Empty)
            end
        | `Term t :: str -> parse (Some (terminal t)) None str
        | `Op (op, a) :: str ->
            begin match op.O.kind with
            | `Prefix -> prefix op a (parse None (Some (op, a)) str)
            | `Postfix | `Infix _ -> raise (Error (NoLeftArg (op, a)))
            end
        end
    | Some tree ->
        begin match str with
        | [] -> tree
        | `Term t :: str -> parse (Some (app tree (terminal t))) None str
        | `Op (op, a) :: str ->
            begin match op.O.kind with
            | `Prefix -> app tree (prefix op a (parse None (Some (op, a)) str))
            | `Postfix -> parse (Some (postfix op a tree)) None str
            | `Infix _ -> infix op (Some a) tree (parse None (Some (op, a)) str)
            end
        end

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