package ppx_expect_nobase

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

Source file main.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
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
open Expect_test_common
open Ppxlib
open Ast_builder.Default

let lift_location
      ~loc
      ({ filename; line_number; line_start; start_pos; end_pos } : File.Location.t)
  =
  Merlin_helpers.hide_expression
    [%expr
      ({ filename =
           Expect_test_common.File.Name.of_string
             [%e estring ~loc (File.Name.to_string filename)]
       ; line_number = [%e eint ~loc line_number]
       ; line_start = [%e eint ~loc line_start]
       ; start_pos = [%e eint ~loc start_pos]
       ; end_pos = [%e eint ~loc end_pos]
       }
       : Expect_test_common.File.Location.t)]
;;

let eoption ~loc x =
  match x with
  | None -> pexp_construct ~loc (Located.mk ~loc (lident "None")) None
  | Some e -> pexp_construct ~loc (Located.mk ~loc (lident "Some")) (Some e)
;;

let estring_option ~loc x = eoption ~loc (Option.map (estring ~loc)  x)

let lift_expectation ~loc ({ tag; body; extid_location; body_location } : _ Expectation.t)
  =
  Merlin_helpers.hide_expression
    [%expr
      ({ tag = [%e estring_option ~loc tag]
       ; body =
           [%e
             match body with
             | Exact string -> [%expr Exact [%e estring ~loc string]]
             | Output -> [%expr Output]
             | Pretty string -> [%expr Pretty [%e estring ~loc string]]
             | Unreachable -> [%expr Unreachable]]
       ; extid_location = [%e lift_location ~loc extid_location]
       ; body_location = [%e lift_location ~loc body_location]
       }
       : string Expect_test_common.Expectation.t)]
;;

(* Grab a list of all the output expressions *)
let collect_expectations =
  object
    inherit [(Location.t * Expectation.Raw.t) list] Ast_traverse.fold as super

    method! expression expr acc =
      match Expect_extension.match_expectation expr with
      | None -> super#expression expr acc
      | Some ext ->
        assert_no_attributes expr.pexp_attributes;
        (expr.pexp_loc, ext) :: acc
  end
;;

let replace_expects =
  object
    inherit Ast_traverse.map as super

    method! expression ({ pexp_attributes; pexp_loc = loc; _ } as expr) =
      match Expect_extension.match_expectation expr with
      | None -> super#expression expr
      | Some ext ->
        let f_var =
          match ext.body with
          | Exact _ | Pretty _ | Unreachable -> "Expect_test_collector.save_output"
          | Output -> "Expect_test_collector.save_and_return_output"
        in
        let expr =
          [%expr [%e evar ~loc f_var] [%e lift_location ~loc ext.extid_location]]
        in
        { expr with pexp_attributes }
  end
;;

module Hashtbl = struct
include Hashtbl
let find_or_add tbl key ~default =
  match find tbl key with
  | v -> v
  | exception Not_found ->
    let v = default () in
    add tbl key v;
    v
end

let file_digest =
  let cache = Hashtbl.create 32 in
  fun fname ->
    Hashtbl.find_or_add cache fname ~default:(fun () ->
      Stdlib.Digest.file fname |> Stdlib.Digest.to_hex)
;;

let chop_prefix ~prefix fname =
  if String.starts_with ~prefix fname
  then Some (String.sub fname (String.length prefix) (String.length fname - String.length prefix))
  else None

let chop_dot_slash_prefix ~fname =
  match chop_prefix ~prefix:"./" fname with
  | Some fname -> fname
  | None -> fname
;;

let expand_filename fname =
  match Filename.is_relative fname with
  | true->
    (* If [dirname] is given and [fname] is relative, then prepend [dirname]. *)
    (* Filename.concat dirname (chop_dot_slash_prefix ~fname) *)
    chop_dot_slash_prefix ~fname
  | _ -> fname
;;

let rewrite_test_body ~descr ~tags ~uncaught_exn ~called_by_merlin pstr_loc body =
  let loc = pstr_loc in
  let expectations =
    ListLabels.map (collect_expectations#expression body []) ~f:(fun (loc, expect_extension) ->
      lift_expectation ~loc expect_extension)
    |> elist ~loc
  in
  let uncaught_exn =
    Option.map (fun (loc, expectation) ->
      lift_expectation ~loc expectation)
      uncaught_exn
    |> eoption ~loc
  in
  let body = replace_expects#expression body in
  let absolute_filename =
    expand_filename pstr_loc.loc_start.pos_fname
  in
  let hash =
    if called_by_merlin
    then Stdlib.Digest.string ""
    else file_digest loc.loc_start.pos_fname
  in
  [%expr
    let module Expect_test_collector = Expect_test_collector.Make (Expect_test_config) in
    Expect_test_collector.run
      ~file_digest:(Expect_test_common.File.Digest.of_string [%e estring ~loc hash])
      ~location:[%e lift_location ~loc (Ppx_expect_payload.transl_loc pstr_loc)]
      ~absolute_filename:[%e estring ~loc absolute_filename]
      ~description:[%e estring_option ~loc descr]
      ~tags:[%e elist ~loc (List.map (estring ~loc) tags)]
      ~expectations:[%e expectations]
      ~uncaught_exn_expectation:[%e uncaught_exn]
      ~inline_test_config:(module Inline_test_config)
      (fun () -> [%e body])]
;;

module P = struct
  open Ast_pattern

  let uncaught_exn =
    Attribute.declare_with_name_loc
      "@expect.uncaught_exn"
      Attribute.Context.value_binding
      (map1' (Ppx_expect_payload.pattern ()) ~f:(fun loc x -> loc, x))
      (fun ~name_loc (loc, x) ->
         loc, Ppx_expect_payload.make x ~kind:Normal ~extension_id_loc:name_loc)
  ;;

  let opt_name () =
    map (pstring __) ~f:(fun f x -> f (Some x)) ||| map ppat_any ~f:(fun f -> f None)
  ;;

  let pattern () =
    pstr
      (pstr_value
         nonrecursive
         (Attribute.pattern
            uncaught_exn
            (value_binding
               ~pat:
                 (map
                    (Attribute.pattern Ppx_inline_test.tags (opt_name ()))
                    ~f:(fun f attributes name_opt ->
                      f
                        ~name:name_opt
                        ~tags:
                          (match attributes with
                           | None -> []
                           | Some x -> x)))
               ~expr:__)
          ^:: nil)
       ^:: nil)
  ;;
end

(* Set to [true] when we see a [%expect_test] extension *)
module Has_tests =
  Driver.Create_file_property
    (struct
      let name = "ppx_expect.has_tests"
    end)
    (struct type t = bool
      let sexp_of_t = Sexplib.Conv.sexp_of_bool
      let t_of_sexp = Sexplib.Conv.bool_of_sexp
    end )

let expect_test =
  Extension.V3.declare_inline
    "expect_test"
    Structure_item
    (P.pattern ())
    (fun ~ctxt uncaught_exn ~name ~tags code ->
       let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in
       let loc = { loc with loc_ghost = true } in
       let called_by_merlin =
         String.equal (Ppxlib.Expansion_context.Extension.tool_name ctxt) "merlin"
       in
       Has_tests.set true;
       Ppx_inline_test.validate_extension_point_exn
         ~name_of_ppx_rewriter:"ppx_expect"
         ~loc
         ~tags;
       rewrite_test_body ~descr:name ~tags ~uncaught_exn ~called_by_merlin loc code
       |> Ppx_inline_test.maybe_drop loc)
;;

let () =
  Driver.register_transformation
    "expect_test"
    ~rules:[ Context_free.Rule.extension expect_test ]
    ~enclose_impl:(fun whole_loc ->
      match whole_loc, Ppx_inline_test_libname.get () with
      | None, _ | _, None -> [], []
      | Some loc, Some _ ->
        let loc = { loc with loc_ghost = true } in
        let maybe_drop = Ppx_inline_test.maybe_drop in
        let absolute_filename =
          expand_filename loc.loc_start.pos_fname
        in
        let header =
          let loc = { loc with loc_end = loc.loc_start } in
          maybe_drop
            loc
            [%expr
              Expect_test_collector.Current_file.set
                ~absolute_filename:[%e estring ~loc absolute_filename]]
        and footer =
          let loc = { loc with loc_start = loc.loc_end } in
          maybe_drop loc [%expr Expect_test_collector.Current_file.unset ()]
        in
        header, footer)
;;
OCaml

Innovation. Community. Security.