Source file ppx_generator_expander.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
open! Import

let arrow
      ~generator_of_core_type
      ~observer_of_core_type
      ~loc
      ~arg_label
      ~input_type
      ~output_type
  =
  let input_observer =
    match arg_label with
    | Nolabel | Labelled _ ->
      observer_of_core_type input_type
    | Optional _ ->
      [%expr
        Base_quickcheck.Observer.option
          [%e observer_of_core_type input_type]]
  in
  let output_generator =
    generator_of_core_type output_type
  in
  let unlabelled =
    [%expr
      Base_quickcheck.Generator.fn
        [%e input_observer]
        [%e output_generator]]
  in
  match arg_label with
  | Nolabel -> unlabelled
  | Labelled _
  | Optional _ ->
    [%expr
      Base_quickcheck.Generator.map
        ~f:[%e fn_map_label ~loc ~from:Nolabel ~to_:arg_label]
        [%e unlabelled]]

let compound_generator ~loc ~make_compound_expr generator_list =
  let size_pat, size_expr = gensym "size" loc in
  let random_pat, random_expr = gensym "random" loc in
  [%expr
    Base_quickcheck.Generator.create
      (fun ~size:[%p size_pat] ~random:[%p random_pat] ->
         [%e
           make_compound_expr ~loc
             (List.map generator_list ~f:(fun generator ->
                let loc = generator.pexp_loc in
                [%expr
                  Base_quickcheck.Generator.generate
                    [%e generator]
                    ~size:[%e size_expr]
                    ~random:[%e random_expr]]))])]

let compound
      (type field)
      ~generator_of_core_type
      ~loc
      ~fields
      (module Field : Field_syntax.S with type ast = field)
  =
  let fields = List.map fields ~f:Field.create in
  compound_generator
    ~loc
    ~make_compound_expr:(Field.expression fields)
    (List.map fields ~f:(fun field ->
       generator_of_core_type (Field.core_type field)))

let variant
      (type clause)
      ~generator_of_core_type
      ~loc
      ~variant_type
      ~clauses
      (module Clause : Clause_syntax.S with type ast = clause)
  =
  let clauses = Clause.create_list clauses in
  let generators =
    List.map clauses ~f:(fun clause ->
      let loc = Clause.location clause in
      compound_generator
        ~loc
        ~make_compound_expr:(Clause.expression clause variant_type)
        (List.map (Clause.core_type_list clause) ~f:generator_of_core_type))
  in
  [%expr Base_quickcheck.Generator.union [%e elist ~loc generators]]