Source

compiler-libs-hack / overload / mod.ml

Full commit
open Types
open Typedtree

let print_ident ppf id = Format.fprintf ppf "%s/%d" id.Ident.name id.Ident.stamp

let rec print_path ppf = function
  | Path.Pident id -> print_ident ppf id
  | Path.Pdot (p, name, n) -> Format.fprintf ppf "%a.%s__%d" print_path p name n
  | Path.Papply (p1, p2) -> Format.fprintf ppf "%a(%a)" print_path p1 print_path p2

let get_name = function
  | Path.Pident id -> Ident.name id
  | Path.Pdot (_, name, _) -> name
  | Path.Papply _ -> assert false

let test env ty vdesc =
  let snapshot = Btype.snapshot () in
  let ity = Ctype.instance env vdesc.val_type in
  let res = try  Ctype.unify env ty ity; true with _ -> false in
  Btype.backtrack snapshot;
  res

let resolve_overloading exp lidloc path = 
  let env = exp.exp_env in

  let name = get_name path in

  let rec find_candidates (path : Path.t) mty =
    (* Format.eprintf "Find_candidates %a@." print_path path; *)

    let sg = match Mtype.scrape env mty with
      | Mty_signature sg -> sg
      | _ -> assert false
    in
    List.fold_right (fun sitem st -> match sitem with
    | Sig_value (id, _vdesc) when Ident.name id = name -> 
        let lident = Longident.Ldot (Untypeast.lident_of_path path, Ident.name id) in
        let path, vdesc = Env.lookup_value lident env  in
        if test env exp.exp_type vdesc then (path, vdesc) :: st else st
    | Sig_module (id, _mty, _) -> 
        let lident = Longident.Ldot (Untypeast.lident_of_path path, Ident.name id) in
        let path, mty = Env.lookup_module lident env  in
        find_candidates path mty @ st
    | _ -> st) sg []
  in
  
  let lid_opt = match path with
    | Path.Pident _ -> None
    | Path.Pdot (p, _, _) -> Some (Untypeast.lident_of_path p)
    | Path.Papply _ -> assert false
  in

  match 
    Env.fold_modules (fun _name path mty st -> 
      find_candidates path mty @ st) lid_opt env []
  with
  | [] -> failwith "overload resolution failed: no match" 
  | [path, vdesc] -> 
      Format.eprintf "RESOLVED: %a@." print_path path;
      let ity = Ctype.instance env vdesc.val_type in
      Ctype.unify env exp.exp_type ity; (* should succeed *)
      { exp with 
        exp_desc = Texp_ident (path, {lidloc with Asttypes.txt = Untypeast.lident_of_path path}, vdesc);
        exp_type = exp.exp_type }
  | _ -> failwith "overload resolution failed: too ambiguous" 

class map = object
  inherit [unit] Ttmap.omap_pattern as super

  method ref f () r = 
    let c = !r in
    let (), c' = f () c in
    let r' = if c == c' then r else ref c' in
    (), r'

  method option f () = function
    | None -> (), None
    | (Some v as o) -> 
        let (), v' = f () v in
        (), if v = v' then o else Some v'

  method list f () xs = 
    let xs' = List.map (fun x -> snd (f () x)) xs in
    (), if List.for_all2 (==) xs xs' then xs else xs'

  method! expression () = function
    | ({ exp_desc= Texp_ident (path, lidloc, vdesc) } as e)-> 
        begin match vdesc.val_kind with
        | Val_prim { Primitive.prim_name = "OVERLOADED" } ->
            (), resolve_overloading e lidloc path
        | _ -> super#expression () e
        end
    | e -> super#expression () e
end

let structure str = 
  let o = new map in
  let _, str =  o#structure () str in
  str