package base_quickcheck

You can search for identifiers within the package.

in-package search v0.2.0

Randomized testing framework, designed for compatibility with Base

Install

dune-project

Dependency

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

Authors

J

Jane Street Group, LLC

Maintainers

J

Jane Street developers

Sources

v0.14.1.tar.gz

sha256=b69a18bf0149e3b553ada9af5258681000948bfb7b6646fee66aa462b507b058

md5=d04738d4499e256b752bc40fcdb9730d

doc/src/ppx_quickcheck_expander/clause_syntax.ml.html

Source file `clause_syntax.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
open! Import
include Clause_syntax_intf

module Variant = struct
  type ast = constructor_declaration

  type t =
    { ast : ast
    ; position : int
    }

  let create_list list =
    List.mapi list ~f:(fun position ast ->
      let loc = ast.pcd_loc in
      match ast.pcd_res with
      | Some _ -> unsupported ~loc "GADT"
      | None -> { ast; position })
  ;;

  let salt t = Some t.position
  let location t = t.ast.pcd_loc

  let weight_attribute =
    Attribute.declare
      "quickcheck.weight"
      Attribute.Context.constructor_declaration
      Ast_pattern.(pstr (pstr_eval __ nil ^:: nil))
      (fun x -> x)
  ;;

  let weight t =
    match Attribute.get weight_attribute t.ast with
    | Some expr -> expr
    | None -> efloat ~loc:{ (location t) with loc_ghost = true } "1."
  ;;

  let core_type_list t =
    match t.ast.pcd_args with
    | Pcstr_tuple list -> list
    | Pcstr_record label_decl_list ->
      List.map label_decl_list ~f:(fun label_decl -> label_decl.pld_type)
  ;;

  let pattern t ~loc pat_list =
    let arg =
      match t.ast.pcd_args with
      | Pcstr_tuple _ ->
        (match pat_list with
         | [] -> None
         | [ pat ] -> Some pat
         | _ -> Some (ppat_tuple ~loc pat_list))
      | Pcstr_record label_decl_list ->
        let alist =
          List.map2_exn label_decl_list pat_list ~f:(fun label_decl pat ->
            lident_loc label_decl.pld_name, pat)
        in
        Some (ppat_record ~loc alist Closed)
    in
    ppat_construct ~loc (lident_loc t.ast.pcd_name) arg
  ;;

  let expression t ~loc _ expr_list =
    let arg =
      match t.ast.pcd_args with
      | Pcstr_tuple _ ->
        (match expr_list with
         | [] -> None
         | [ expr ] -> Some expr
         | _ -> Some (pexp_tuple ~loc expr_list))
      | Pcstr_record label_decl_list ->
        let alist =
          List.map2_exn label_decl_list expr_list ~f:(fun label_decl expr ->
            lident_loc label_decl.pld_name, expr)
        in
        Some (pexp_record ~loc alist None)
    in
    pexp_construct ~loc (lident_loc t.ast.pcd_name) arg
  ;;
end

module Polymorphic_variant = struct
  type ast = row_field
  type t = ast

  let create_list = Fn.id

  let salt t =
    match t.prf_desc with
    | Rtag (label, _, _) -> Some (Ocaml_common.Btype.hash_variant label.txt)
    | Rinherit _ -> None
  ;;

  let location t = t.prf_loc

  let weight_attribute =
    Attribute.declare
      "quickcheck.weight"
      Attribute.Context.rtag
      Ast_pattern.(pstr (pstr_eval __ nil ^:: nil))
      (fun x -> x)
  ;;

  let weight t =
    match Attribute.get weight_attribute t with
    | Some expr -> expr
    | None -> efloat ~loc:{ (location t) with loc_ghost = true } "1."
  ;;

  let core_type_list t =
    match t.prf_desc with
    | Rtag (_, _, core_type_list) -> core_type_list
    | Rinherit core_type -> [ core_type ]
  ;;

  let pattern t ~loc pat_list =
    match t.prf_desc, pat_list with
    | Rtag (label, true, []), [] -> ppat_variant ~loc label.txt None
    | Rtag (label, false, [ _ ]), [ pat ] -> ppat_variant ~loc label.txt (Some pat)
    | Rtag (label, false, [ _ ]), _ :: _ :: _ ->
      ppat_variant ~loc label.txt (Some (ppat_tuple ~loc pat_list))
    | Rinherit { ptyp_desc; _ }, [ { ppat_desc; _ } ] ->
      (match ptyp_desc with
       | Ptyp_constr (id, []) ->
         (match ppat_desc with
          | Ppat_var var -> ppat_alias ~loc (ppat_type ~loc id) var
          | _ ->
            internal_error
              ~loc
              "cannot bind a #<type> pattern to anything other than a variable")
       | _ ->
         unsupported ~loc "inherited polymorphic variant type that is not a type name")
    | Rtag (_, true, _ :: _), _ | Rtag (_, false, ([] | _ :: _ :: _)), _ ->
      unsupported ~loc "intersection type"
    | Rtag (_, true, []), _ :: _
    | Rtag (_, false, [ _ ]), []
    | Rinherit _, ([] | _ :: _ :: _) ->
      internal_error ~loc "wrong number of arguments for variant clause"
  ;;

  let expression t ~loc core_type expr_list =
    match t.prf_desc, expr_list with
    | Rtag (label, true, []), [] -> pexp_variant ~loc label.txt None
    | Rtag (label, false, [ _ ]), [ expr ] -> pexp_variant ~loc label.txt (Some expr)
    | Rtag (label, false, [ _ ]), _ :: _ :: _ ->
      pexp_variant ~loc label.txt (Some (pexp_tuple ~loc expr_list))
    | Rinherit inherited_type, [ expr ] ->
      pexp_coerce ~loc expr (Some inherited_type) core_type
    | Rtag (_, true, _ :: _), _ | Rtag (_, false, ([] | _ :: _ :: _)), _ ->
      unsupported ~loc "intersection type"
    | Rtag (_, true, []), _ :: _
    | Rtag (_, false, [ _ ]), []
    | Rinherit _, ([] | _ :: _ :: _) ->
      internal_error ~loc "wrong number of arguments for variant clause"
  ;;
end