Source file ast_traverse.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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
open! Import

class map =
  object
    inherit Ppxlib_traverse_builtins.map
    inherit Ast.map
  end

class iter =
  object
    inherit Ppxlib_traverse_builtins.iter
    inherit Ast.iter
  end

class ['acc] fold =
  object
    inherit ['acc] Ppxlib_traverse_builtins.fold
    inherit ['acc] Ast.fold
  end

class ['acc] fold_map =
  object
    inherit ['acc] Ppxlib_traverse_builtins.fold_map
    inherit ['acc] Ast.fold_map
  end

class ['ctx] map_with_context =
  object
    inherit ['ctx] Ppxlib_traverse_builtins.map_with_context
    inherit ['ctx] Ast.map_with_context
  end

class virtual ['res] lift =
  object
    inherit ['res] Ppxlib_traverse_builtins.lift
    inherit ['res] Ast.lift
  end

let module_name = function None -> "_" | Some name -> name
let enter name path = if String.is_empty path then name else path ^ "." ^ name
let enter_opt name_opt path = enter (module_name name_opt) path

class map_with_path =
  object
    inherit [string] map_with_context as super

    (* WAS:
       method! structure_item_desc path x =
       match x with
       | Pstr_module mb -> super#structure_item_desc (enter mb.pmb_name.txt path) x
       | _ -> super#structure_item_desc path x

       Overriding [module_binding] seems to be OK because it does not catch
       local module bindings because at the moment the parsetree doesn't make
       use of [module_binding] for local modules, but that might change in the
       future, so this might be something to keep in mind.

       The following:

           module A = struct .. end
           module A = struct .. end

       is disallowed, but

           let _ = .. let module A = struct .. end in ..
           module A = struct .. end
           let _ = .. let module A = struct .. end in ..

       isn't, and the "path" constructed here would be able to differentiate
       between them. *)
    method! module_binding path mb =
      super#module_binding (enter_opt mb.pmb_name.txt path) mb

    method! module_declaration path md =
      super#module_declaration (enter_opt md.pmd_name.txt path) md

    method! module_type_declaration path mtd =
      super#module_type_declaration (enter mtd.pmtd_name.txt path) mtd
  end

let var_names_of =
  object
    inherit [string list] fold as super

    method! pattern p acc =
      let acc = super#pattern p acc in
      match p.ppat_desc with Ppat_var { txt; _ } -> txt :: acc | _ -> acc
  end

let ec_enter_module_opt ~loc name_opt ctxt =
  Expansion_context.Base.enter_module ~loc (module_name name_opt) ctxt

class map_with_expansion_context =
  object (self)
    inherit [Expansion_context.Base.t] map_with_context as super

    method! expression ctxt expr =
      super#expression (Expansion_context.Base.enter_expr ctxt) expr

    method! module_binding ctxt mb =
      super#module_binding
        (ec_enter_module_opt ~loc:mb.pmb_loc mb.pmb_name.txt ctxt)
        mb

    method! module_declaration ctxt md =
      super#module_declaration
        (ec_enter_module_opt ~loc:md.pmd_loc md.pmd_name.txt ctxt)
        md

    method! module_type_declaration ctxt mtd =
      super#module_type_declaration
        (Expansion_context.Base.enter_module ~loc:mtd.pmtd_loc mtd.pmtd_name.txt
           ctxt)
        mtd

    method! value_description ctxt vd =
      super#value_description
        (Expansion_context.Base.enter_value ~loc:vd.pval_loc vd.pval_name.txt
           ctxt)
        vd

    method! value_binding ctxt { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } =
      let all_var_names = var_names_of#pattern pvb_pat [] in
      let var_name = Stdppx.List.last all_var_names in
      let in_binding_ctxt =
        match var_name with
        | None -> ctxt
        | Some var_name ->
            Expansion_context.Base.enter_value ~loc:pvb_loc var_name ctxt
      in
      let pvb_pat = self#pattern ctxt pvb_pat in
      let pvb_expr = self#expression in_binding_ctxt pvb_expr in
      let pvb_attributes = self#attributes in_binding_ctxt pvb_attributes in
      let pvb_loc = self#location ctxt pvb_loc in
      { pvb_pat; pvb_expr; pvb_attributes; pvb_loc }
  end

class sexp_of =
  object
    inherit [Sexp.t] Ast.lift
    method int = sexp_of_int
    method string = sexp_of_string
    method bool = sexp_of_bool
    method char = sexp_of_char
    method float = sexp_of_float
    method int32 = sexp_of_int32
    method int64 = sexp_of_int64
    method nativeint = sexp_of_nativeint
    method unit = sexp_of_unit
    method option = sexp_of_option
    method list = sexp_of_list
    method array : 'a. ('a -> Sexp.t) -> 'a array -> Sexp.t = sexp_of_array
    method other : 'a. 'a -> Sexp.t = fun _ -> Sexp.Atom "_"

    method record fields =
      List
        (List.map fields ~f:(fun (label, sexp) ->
             Sexp.List [ Atom label; sexp ]))

    method constr tag args =
      match args with [] -> Atom tag | _ -> List (Atom tag :: args)

    method tuple l = List l
  end

let sexp_of = new sexp_of