package base_quickcheck

  1. Overview
  2. Docs
Randomized testing framework, designed for compatibility with Base

Install 

dune-project
 Dependency

github.com MIT License Edit opam file Versions (9)

Authors

  1. J
    Jane Street Group, LLC

Maintainers

  1. J
    Jane Street developers

Sources

v0.14.1.tar.gz
sha256=b69a18bf0149e3b553ada9af5258681000948bfb7b6646fee66aa462b507b058
md5=d04738d4499e256b752bc40fcdb9730d

doc/src/ppx_quickcheck_expander/ppx_observer_expander.ml.html

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

let any ~loc = [%expr Base_quickcheck.Observer.opaque]

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

let compound_hash ~loc ~size_expr ~hash_expr ~hash_pat ~observer_exprs ~field_exprs =
  let alist = List.zip_exn observer_exprs field_exprs in
  List.fold_right alist ~init:hash_expr ~f:(fun (observer_expr, field_expr) body_expr ->
    [%expr
      let [%p hash_pat] =
        Base_quickcheck.Observer.observe
          [%e observer_expr]
          [%e field_expr]
          ~size:[%e size_expr]
          ~hash:[%e hash_expr]
      in
      [%e body_expr]])
;;

let compound
      (type field)
      ~observer_of_core_type
      ~loc
      ~fields
      (module Field : Field_syntax.S with type ast = field)
  =
  let fields = List.map fields ~f:Field.create in
  let field_pats, field_exprs = gensyms "x" (List.map fields ~f:Field.location) in
  let pat = Field.pattern fields ~loc field_pats in
  let observer_exprs =
    List.map fields ~f:(fun field -> observer_of_core_type (Field.core_type field))
  in
  let size_pat, size_expr = gensym "size" loc in
  let hash_pat, hash_expr = gensym "hash" loc in
  [%expr
    Base_quickcheck.Observer.create
      (fun [%p pat] ~size:[%p size_pat] ~hash:[%p hash_pat] ->
         [%e
           compound_hash ~loc ~size_expr ~hash_expr ~hash_pat ~observer_exprs ~field_exprs])]
;;

let variant
      (type clause)
      ~observer_of_core_type
      ~loc
      ~clauses
      (module Clause : Clause_syntax.S with type ast = clause)
  =
  let clauses = Clause.create_list clauses in
  let pat, expr = gensym "x" loc in
  let size_pat, size_expr = gensym "size" loc in
  let hash_pat, hash_expr = gensym "hash" loc in
  [%expr
    Base_quickcheck.Observer.create
      (fun [%p pat] ~size:[%p size_pat] ~hash:[%p hash_pat] ->
         [%e
           pexp_match
             ~loc
             expr
             (List.map clauses ~f:(fun clause ->
                let core_type_list = Clause.core_type_list clause in
                let observer_exprs = List.map core_type_list ~f:observer_of_core_type in
                let field_pats, field_exprs =
                  gensyms
                    "x"
                    (List.map core_type_list ~f:(fun core_type -> core_type.ptyp_loc))
                in
                let lhs = Clause.pattern clause ~loc field_pats in
                let body =
                  compound_hash
                    ~loc
                    ~size_expr
                    ~hash_expr
                    ~hash_pat
                    ~observer_exprs
                    ~field_exprs
                in
                let rhs =
                  match Clause.salt clause with
                  | None -> body
                  | Some salt ->
                    pexp_let
                      ~loc
                      Nonrecursive
                      [ value_binding
                          ~loc
                          ~pat:hash_pat
                          ~expr:
                            [%expr
                              Base.hash_fold_int [%e hash_expr] [%e eint ~loc salt]]
                      ]
                      body
                in
                case ~lhs ~guard:None ~rhs))])]
;;