Source file `misc_utils.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
open Std

module Path : sig
  val is_opened : Env.t -> Path.t -> bool

  val to_shortest_lid :
    env:Env.t ->
    ?name:string ->
    env_check:(Longident.t -> Env.t -> 'a) -> Path.t -> Longident.t
end = struct
  let opens env =
    let rec aux acc = function
      | Env.Env_open (s, path) -> aux (path::acc) s
      | s ->
        Option.map ~f:(aux acc) (Browse_misc.summary_prev s)
        |> Option.value ~default:acc
    in
    aux [] env

  let is_opened env path = List.mem path ~set:(opens (Env.summary env))

  let rec to_shortest_lid ~(opens : Path.t list) = function
    | Path.Pdot (path, name) when List.exists ~f:(Path.same path) opens ->
      Longident.Lident name
    | Path.Pdot (path, name) -> Ldot (to_shortest_lid ~opens path, name)
    | Pident ident -> Lident (Ident.name ident)
    | _ -> assert false

  let maybe_replace_name ?name lid =
    let open Longident in
    Option.value_map name
      ~default:lid
      ~f:(fun name -> match lid with
        | Lident _ -> Lident name
        | Ldot (lid, _) -> Ldot (lid, name)
        | _ -> assert false)

  let to_shortest_lid ~env ?name ~env_check path =
    let opens = opens (Env.summary env) in
    let lid =
      to_shortest_lid ~opens path
      |> maybe_replace_name ?name
    in
    try
      env_check lid env |> ignore;
      lid
    with Not_found ->
      maybe_replace_name ?name (Untypeast.lident_of_path path)
end


let parenthesize_name name =
  (* Qualified operators need parentheses *)
  if name = "" || not (Oprint.parenthesized_ident name) then name else (
    if name.[0] = '*' || name.[String.length name - 1] = '*' then
      "( " ^ name ^ " )"
    else
      "(" ^ name ^ ")"
  )

module Compat = struct
  open Typedtree
  let pat_var_id_and_loc = function
    | { pat_desc = Tpat_var (id, loc); _ } -> Some (id, loc)
    | _ -> None

  let pat_alias_pat_id_and_loc = function
    | { pat_desc = Tpat_alias (pat, id, loc); _ } -> Some (pat, id, loc)
    | _ -> None
end