package ppx_quick_test

  1. Overview
  2. Docs
package ppx_quick_test
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file file_corrections.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
open! Core

module Insertion = struct
  type t =
    { placement_cnum : int
    ; value : string
    }
  [@@deriving sexp]

  let apply_all ~original insertions =
    let verify_insertions_range () =
      let all_insertions_in_range =
        List.for_all insertions ~f:(fun { placement_cnum; _ } ->
          0 <= placement_cnum && placement_cnum <= String.length original)
      in
      match all_insertions_in_range with
      | true -> ()
      | false ->
        raise_s
          [%message
            {|"ppx_quick_test" bug! Attempted to insert correction at at out of bounds location.|}
              (insertions : t list)
              ~original_legnth:(String.length original : int)
              (original : string)]
    in
    let get_and_verify_insertion_map insertions =
      let insertion_map =
        List.map insertions ~f:(fun { placement_cnum; value } -> placement_cnum, value)
        |> Map.of_alist_or_error (module Int)
      in
      match insertion_map with
      | Ok map -> map
      | Error error ->
        raise_s
          [%message
            {|"ppx_quick_test" bug! Attempt to insert multiple corrections at the same location.|}
              (error : Error.t)
              (insertions : t list)
              (original : string)]
    in
    verify_insertions_range ();
    let insertions_map = get_and_verify_insertion_map insertions in
    let total_output_length =
      String.length original
      + List.sum (module Int) insertions ~f:(fun t -> String.length t.value)
    in
    let buffer = Buffer.create total_output_length in
    let insert_if_found ~index =
      match Map.find insertions_map index with
      | None -> ()
      | Some str_to_insert -> Buffer.add_string buffer str_to_insert
    in
    String.iteri original ~f:(fun i c ->
      insert_if_found ~index:i;
      Buffer.add_char buffer c);
    insert_if_found ~index:(String.length original);
    Buffer.contents buffer
  ;;
end

type t =
  { mutable insertions : Insertion.t list
  ; filename : string
  ; mutable disabled : bool
  }

let global_registry = ref String.Map.empty

let create ~filename =
  let new_ = { insertions = []; filename; disabled = false } in
  global_registry
    := match Map.add !global_registry ~key:filename ~data:new_ with
       | `Ok map -> map
       | `Duplicate ->
         raise_s
           [%message
             "ppx_quick_test bug: tried to create a registry for the same file twice"
               ~duplicate:(filename : string)]
;;

let make_corrected_file ~filename =
  match Map.find !global_registry filename with
  | None ->
    raise_s
      [%message
        "ppx_quick_test bug: tried to create a corrected file for a file that was not \
         registered"
          ~unregistered_file:(filename : string)]
  | Some t ->
    (match `Disabled t.disabled, t.insertions with
     | `Disabled true, _ | _, [] -> ()
     | _, insertions ->
       let filename = Filename.basename t.filename in
       let prev_contents = In_channel.read_all filename in
       let next_contents = Insertion.apply_all ~original:prev_contents insertions in
       (match Make_corrected_file.f ~path:filename ~next_contents () with
        | Ok _ -> ()
        | Error _ ->
          let message =
            {|"ppx_quick_test" found failing tests and suggests adding the inputs to your examples for regression testing.|}
          in
          Stdio.eprintf "%s\n%!" message;
          exit 1))
;;

let add_insertion ~filename insertion =
  match Map.find !global_registry filename with
  | None ->
    raise_s
      [%message
        "ppx_quick_test bug: tried to add an insertion for a file that was not registered"
          ~unregistered_file:(filename : string)]
  | Some t -> t.insertions <- insertion :: t.insertions
;;

let disable_due_to_pending_error ~filename =
  match Map.find !global_registry filename with
  | None ->
    raise_s
      [%message
        "ppx_quick_test bug: tried to disable corrections for a filename that was never \
         registered"
          ~unregistered_file:(filename : string)]
  | Some t -> t.disabled <- true
;;