lama_byterun/tools/gtd_main.ml

open Language
type mode = GoToDef | Usages
type config =
  { mutable filename : string
  ; mutable pos : string
  ; mutable line : int
  ; mutable col: int
  ; mutable mode: mode
  }

let config = { filename= "file.ml"; pos="0,0"; line=0; col=0; mode = GoToDef }
let parse_loc loc =
  Scanf.sscanf loc "%d,%d" (fun l c -> config.line <- l; config.col <- c)

let () =
  Arg.parse
    [ "-pos", String parse_loc, "L,C when L is line and C is column"
    ; "-def", Unit (fun () -> config.mode <- GoToDef), "go to definition"
    ; "-use", Unit (fun () -> config.mode <- Usages), "find usages"
    ]
    (fun name -> config.filename <- name)
    "Help"


module Introduced = Map.Make(String)

exception DefinitionFound of (string * Loc.t)

let do_find e =
  let on_name name map =
    match Loc.get name with
    | Some (l,c) when l=config.line && c = config.col ->
        (* we found what we want *)
        let (l,c) = Introduced.find name map in
        raise (DefinitionFound (name,(l,c)))
    | _ -> map
  in

  (* looks for line,col in the tree *)
  let ooo (foldl_decl, fself) = object
    inherit [_,_] Language.Expr.foldl_t_t_stub (foldl_decl, fself) as super
    method! c_Var _inh _ name = on_name name _inh
    method! c_Ref _inh _ name = on_name name _inh
    method c_Scope inh e names r =
      let map = ListLabels.fold_left ~init:inh names ~f:(fun acc (fname,(_,info)) ->
        let acc = Introduced.add fname (Loc.get_exn fname) acc in
        match info with
        | `Variable _ ->  acc
        | `Fun (args, _body) ->
            List.fold_left (fun acc name -> Introduced.add name (Loc.get_exn name) acc) acc args
        )
      in
      super#c_Scope map e names r
  end in

  (* Format.printf "STUB. Ht size = %d\n%!" (Loc.H.length Loc.tab);
  Loc.H.iter (fun k (l,c) -> Format.printf "%s -> (%d,%d)\n%!" k l c) Loc.tab; *)

  let (_,fold_t) = Expr.fix_decl Expr.foldl_decl_0 ooo in
  match fold_t Introduced.empty e with
  | exception (DefinitionFound arg) -> Some arg
  | _ -> None


let find_usages root (def_name,(_,_)) =
  let on_name name acc =
    if String.equal def_name name
    then (Loc.get_exn name) :: acc
    else acc
  in

  let ooo (foldl_decl, fself) = object
    inherit [_,_] Language.Expr.foldl_t_t_stub (foldl_decl, fself) as super
    method! c_Var _inh _ name = on_name name _inh
    method! c_Ref _inh _ name = on_name name _inh
    method c_Scope inh e names r =
      (* if we hide interesting name, then we stop the search *)
      if List.exists (fun (n,_) -> String.equal n def_name) (names : (string * _) list)
      then inh
      else super#c_Scope inh e names r
  end in

  let (_,fold_t) = Expr.fix_decl Expr.foldl_decl_0 ooo in
  fold_t [] root


let () =
  let cfg = object
    method get_include_paths = ["."; "./runtime"] method get_infile = config.filename method is_workaround=false end
  in
  match Language.run_parser cfg with
  | `Fail s -> failwith s
  | `Ok ((_,_), e) ->
      Format.printf "%s\n%!" (GT.show Expr.t e);
      match do_find e with
      | None -> Format.printf "Definition not found\n%!"
      | Some (name,(l,c)) ->
          match config.mode with
          | GoToDef -> Format.printf "found definition for `%s` at (%d,%d)\n%!" name l c;
          | Usages ->
              let locs = find_usages e (name,(l,c)) in
              Format.printf "Total %d usages found\n%!" (List.length locs);
              List.iter (fun (l,c) -> Format.printf "(%d,%d) %!" l c) locs;
              Format.printf "\n%!"