File: reconcile.ml

package info (click to toggle)
ppxlib 0.15.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, bullseye, sid
  • size: 1,284 kB
  • sloc: ml: 17,184; sh: 149; makefile: 36; python: 36
file content (296 lines) | stat: -rw-r--r-- 10,120 bytes parent folder | download
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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
open Import
open Utils

module Context = struct
  type 'a t =
    | Extension          of 'a Extension.Context.t
    | Floating_attribute of 'a Attribute.Floating.Context.t

  let paren pp ppf x =
    Caml.Format.fprintf ppf "(%a)" pp x

  let printer
    : type a. a t -> Caml.Format.formatter -> a -> unit =
    let open Extension.Context in
    let open Attribute.Floating.Context in
    function
    | Extension Class_expr       -> Pprintast.class_expr
    | Extension Class_field      -> Pprintast.class_field
    | Extension Class_type       -> Pprintast.class_type
    | Extension Class_type_field -> Pprintast.class_type_field
    | Extension Core_type        -> paren Pprintast.core_type
    | Extension Expression       -> paren Pprintast.expression
    | Extension Module_expr      -> Pprintast.module_expr
    | Extension Module_type      -> Pprintast.module_type
    | Extension Pattern          -> paren Pprintast.pattern
    | Extension Signature_item   -> Pprintast.signature_item
    | Extension Structure_item   -> Pprintast.structure_item

    | Floating_attribute Structure_item   -> Pprintast.structure_item
    | Floating_attribute Signature_item   -> Pprintast.signature_item
    | Floating_attribute Class_field      -> Pprintast.class_field
    | Floating_attribute Class_type_field -> Pprintast.class_type_field
end

module Replacement = struct
  type data =
    | Values : 'a Context.t * 'a Context_free.Generated_code_hook.single_or_many -> data
    | Text of string

  type t =
    { start : Lexing.position
    ; stop  : Lexing.position
    ; data  : data
    }

  let make ~context ~start ~stop ~repl () =
    { start; stop; data = Values (context, repl) }

  let make_text ~start ~stop ~repl () =
    { start; stop; data = Text repl }

  let text block =
    match block.data with
    | Text s -> s
    | Values (context, generated) ->
      let s =
        let printer = Context.printer context in
        match generated with
        | Single x ->
          Caml.Format.asprintf "%a" printer x
        | Many l ->
          Caml.Format.asprintf "%a"
            (fun ppf l ->
               List.iter l ~f:(fun x ->
                 printer ppf x;
                 Caml.Format.pp_print_newline ppf ()))
            l
      in
      let is_ws = function (' '|'\t'|'\r') -> true | _ -> false in
      let strip_ws s i len =
        let len = ref len in
        while (!len > 0 && is_ws s.[i + !len - 1]) do len := !len - 1 done;
        String.sub s ~pos:i ~len:!len
      in
      let rec loop s pos =
        if pos >= String.length s
        then []
        else
          let idx =
            match String.index_from_opt s pos '\n' with
            | Some i -> i
            | None -> String.length s
          in
          strip_ws s pos (idx - pos) :: "\n" :: loop s (idx + 1)
      in
      String.concat ~sep:"" (loop s 0)
end
open Replacement

module Replacements = struct
  type t = Replacement.t list

  (* Merge locations of the generated code. Overlapping locations are merged into one. The
     result is sorted from the beginning of the file to the end. *)
  let check_and_sort ~input_filename ~input_name repls =
    List.iter repls ~f:(fun repl ->
      if String.(<>) repl.start.pos_fname input_name ||
         String.(<>) repl.stop .pos_fname input_name then
        Location.raise_errorf ~loc:(Location.in_file input_filename)
          "ppxlib_driver: the rewriting contains parts from another file.\n\
           It is too complicated to reconcile it with the source";
      assert (repl.start.pos_cnum <= repl.stop.pos_cnum));
    let repls =
      List.sort repls ~cmp:(fun  a b ->
        let d = compare a.start.pos_cnum b.stop.pos_cnum in
        if d = 0 then
          (* Put the largest first, so that the following [filter] functions always picks up
             the lartest first when several generated repls start at the same position *)
          compare b.stop.pos_cnum a.stop.pos_cnum
        else
          d)
    in
    let rec filter prev repls ~acc =
      match repls with
      | [] -> List.rev (prev :: acc)
      | repl :: repls ->
        if prev.stop.pos_cnum > repl.start.pos_cnum then begin
          if prev.stop.pos_cnum >= repl.stop.pos_cnum then
            (* [repl] is included in [prev] => skip [repl] *)
            filter prev repls ~acc
          else
            Location.raise_errorf
              "ppxlib_driver: locations of generated code are overlapping, cannot reconcile"
              ~loc:{ loc_start = repl.start; loc_end = prev.stop; loc_ghost = false };
        end else
          filter repl repls ~acc:(prev :: acc)
    in
    match repls with
    | [] -> []
    | repl :: repls ->
      filter repl repls ~acc:[]
  ;;
end

let count_newlines s =
  let n = ref 0 in
  String.iter s ~f:(function
    | '\n' -> n := !n + 1
    | _    -> ());
  !n

let generated_code_begin =
  "(* -----{ GENERATED CODE BEGIN }------------------------------------- *)"
let generated_code_end =
  "(* -----{ GENERATED CODE END   }------------------------------------- *)"

type mode =
  | Using_line_directives
  | Delimiting_generated_blocks

type target =
  | Output of mode
  | Corrected

let skip_blank_eol contents (pos : Lexing.position) =
  let rec loop cnum =
    if cnum = String.length contents then
      { pos with pos_cnum = cnum }
    else
      match contents.[cnum] with
      | ' ' | '\t' | '\r' -> loop (cnum + 1)
      | '\n' ->
        { pos with
          pos_cnum = cnum + 1
        ; pos_lnum = pos.pos_lnum + 1
        ; pos_bol  = cnum + 1
        }
      | _ -> pos
  in
  loop pos.pos_cnum

let with_output ~styler ~(kind:Kind.t) fn ~f =
  match styler with
  | None -> with_output fn ~binary:false ~f
  | Some cmd ->
    let tmp_fn, oc =
      Caml.Filename.open_temp_file "ppxlib_driver"
        (match kind with Impl -> ".ml" | Intf -> ".mli")
    in
    let cmd =
      Printf.sprintf "%s %s%s" cmd (Caml.Filename.quote tmp_fn)
        (match fn with
         | None -> ""
         | Some fn -> " > " ^ Caml.Filename.quote fn)
    in
    let n =
      Exn.protectx tmp_fn ~finally:Caml.Sys.remove ~f:(fun _ ->
        Exn.protectx oc ~finally:close_out ~f:f;
        Caml.Sys.command cmd)
    in
    if n <> 0 then begin
      Printf.eprintf "command exited with code %d: %s\n" n cmd;
      Caml.exit 1
    end

let reconcile ?styler (repls : Replacements.t) ~kind ~contents ~input_filename
      ~output ~input_name ~target =
  let repls = Replacements.check_and_sort ~input_filename ~input_name repls in
  let output_name =
    match output with
    | None -> "<stdout>"
    | Some fn -> fn
  in
  with_output output ~styler ~kind ~f:(fun oc ->
    let copy_input pos ~up_to ~line ~last_is_text ~is_text =
      let pos = if last_is_text then pos else skip_blank_eol contents pos in
      if pos.pos_cnum < up_to then begin
        (match target with
         | Output Using_line_directives ->
           Printf.fprintf oc "# %d %S\n%*s" pos.pos_lnum input_name
             (pos.pos_cnum - pos.pos_bol) ""
         | Output Delimiting_generated_blocks | Corrected -> ());
        output_substring oc contents ~pos:pos.pos_cnum ~len:(up_to - pos.pos_cnum);
        let line = ref (line + 1) in
        for i = pos.pos_cnum to up_to - 1 do
          if Char.equal contents.[i] '\n' then line := !line + 1
        done;
        let line = !line in
        if not is_text && Char.(<>) contents.[up_to - 1] '\n' then
          (output_char oc '\n'; line + 1)
        else
          line
      end else
        line
    in
    let rec loop line (pos : Lexing.position) repls ~last_is_text =
      match repls with
      | [] ->
        ignore (copy_input pos ~up_to:(String.length contents) ~line
                  ~last_is_text ~is_text:false : int)
      | repl :: repls ->
        let is_text =
          match repl.data with
          | Text _ -> true
          | Values _ -> false
        in
        let line =
          copy_input pos ~up_to:repl.start.pos_cnum ~line ~last_is_text ~is_text
        in
        let s = Replacement.text repl in
        let line =
          match target with
          | Output Using_line_directives ->
            Printf.fprintf oc "# %d %S\n" (line + 1) output_name;
            line + 1
          | Output Delimiting_generated_blocks ->
            Printf.fprintf oc "%s\n" generated_code_begin;
            line + 1
          | Corrected ->
            line
        in
        output_string oc s;
        let line = line + count_newlines s in
        loop_consecutive_repls line repl.stop repls ~last_is_text:is_text
    and loop_consecutive_repls line (pos : Lexing.position) repls ~last_is_text =
      match repls with
      | [] -> end_consecutive_repls line pos repls ~last_is_text
      | repl :: repls' ->
        let pos = if last_is_text then pos else skip_blank_eol contents pos in
        if pos.pos_cnum < repl.start.pos_cnum then
          end_consecutive_repls line pos repls ~last_is_text
        else begin
          let s = Replacement.text repl in
          output_string oc s;
          let line = line + count_newlines s in
          let last_is_text =
            match repl.data with
            | Text _ -> true
            | Values _ -> false
          in
          loop_consecutive_repls line repl.stop repls' ~last_is_text
        end
    and end_consecutive_repls line pos repls ~last_is_text =
      (match target with
       | Output Using_line_directives | Corrected -> ()
       | Output Delimiting_generated_blocks ->
         Printf.fprintf oc "%s\n" generated_code_end);
      loop line pos repls ~last_is_text
    in
    let pos =
      { Lexing.
        pos_fname = input_name
      ; pos_lnum  = 1
      ; pos_bol   = 0
      ; pos_cnum  = 0
      }
    in
    match repls with
    | { start = { pos_cnum = 0; _ }; _ } :: _ ->
      (match target with
       | Output Using_line_directives | Corrected -> ()
       | Output Delimiting_generated_blocks ->
         Printf.fprintf oc "%s\n" generated_code_begin);
      loop_consecutive_repls 1 pos repls ~last_is_text:false
    | _ ->
      loop 1 pos repls ~last_is_text:false)