Source

planck / 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