@@ -5,6 +5,7 @@ type untaggedError =
5
5
| AtMostOneFunction
6
6
| AtMostOneString
7
7
| AtMostOneNumber
8
+ | AtMostOneBoolean
8
9
| DuplicateLiteral of string
9
10
| ConstructorMoreThanOneArg of string
10
11
type error =
@@ -34,6 +35,7 @@ let report_error ppf =
34
35
| AtMostOneString -> " At most one case can be a string type."
35
36
| AtMostOneNumber ->
36
37
" At most one case can be a number type (int or float)."
38
+ | AtMostOneBoolean -> " At most one case can be a boolean type."
37
39
| DuplicateLiteral s -> " Duplicate literal " ^ s ^ " ."
38
40
| ConstructorMoreThanOneArg (name ) -> " Constructor " ^ name ^ " has more than one argument." )
39
41
@@ -42,6 +44,7 @@ type block_type =
42
44
| IntType
43
45
| StringType
44
46
| FloatType
47
+ | BooleanType
45
48
| ArrayType
46
49
| FunctionType
47
50
| ObjectType
@@ -137,6 +140,9 @@ let get_block_type ~env (cstr : Types.constructor_declaration) :
137
140
| true , Cstr_tuple [{desc = Tconstr (path, _, _)}]
138
141
when Path. same path Predef. path_float ->
139
142
Some FloatType
143
+ | true , Cstr_tuple [{desc = Tconstr (path, _, _)}]
144
+ when Path. same path Predef. path_bool ->
145
+ Some BooleanType
140
146
| true , Cstr_tuple [{desc = Tconstr (path, _, _)}]
141
147
when Path. same path Predef. path_array ->
142
148
Some ArrayType
@@ -196,6 +202,7 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list)
196
202
let functionTypes = ref 0 in
197
203
let objectTypes = ref 0 in
198
204
let stringTypes = ref 0 in
205
+ let booleanTypes = ref 0 in
199
206
let numberTypes = ref 0 in
200
207
let unknownTypes = ref 0 in
201
208
let addStringLiteral ~loc s =
@@ -219,6 +226,8 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list)
219
226
raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction ));
220
227
if ! stringTypes > 1 then
221
228
raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString ));
229
+ if ! booleanTypes > 1 then
230
+ raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean ));
222
231
if ! numberTypes > 1 then
223
232
raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber ));
224
233
()
@@ -253,6 +262,9 @@ let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list)
253
262
| Some (IntType | FloatType ) ->
254
263
incr numberTypes;
255
264
invariant loc name
265
+ | Some BooleanType ->
266
+ incr booleanTypes;
267
+ invariant loc name
256
268
| Some StringType ->
257
269
incr stringTypes;
258
270
invariant loc name
@@ -315,6 +327,7 @@ module DynamicChecks = struct
315
327
let function_ = Untagged FunctionType |> tag_type
316
328
let string = Untagged StringType |> tag_type
317
329
let number = Untagged IntType |> tag_type
330
+ let boolean = Untagged BooleanType |> tag_type
318
331
319
332
let ( == ) x y = bin EqEqEq x y
320
333
let ( != ) x y = bin NotEqEq x y
@@ -333,6 +346,11 @@ module DynamicChecks = struct
333
346
| Int _ | Float _ -> true
334
347
| _ -> false )
335
348
in
349
+ let literals_overlaps_with_boolean () =
350
+ Ext_list. exists literal_cases (function
351
+ | Bool _ -> true
352
+ | _ -> false )
353
+ in
336
354
let literals_overlaps_with_object () =
337
355
Ext_list. exists literal_cases (function
338
356
| Null -> true
@@ -348,6 +366,8 @@ module DynamicChecks = struct
348
366
typeof e != number
349
367
| FloatType when literals_overlaps_with_number () = false ->
350
368
typeof e != number
369
+ | BooleanType when literals_overlaps_with_boolean () = false ->
370
+ typeof e != boolean
351
371
| ArrayType -> not (is_array e)
352
372
| FunctionType -> typeof e != function_
353
373
| ObjectType when literals_overlaps_with_object () = false ->
@@ -356,6 +376,7 @@ module DynamicChecks = struct
356
376
| StringType (* overlap *)
357
377
| IntType (* overlap *)
358
378
| FloatType (* overlap *)
379
+ | BooleanType (* overlap *)
359
380
| UnknownType -> (
360
381
(* We don't know the type of unknown, so we need to express:
361
382
this is not one of the literals *)
@@ -396,7 +417,7 @@ module DynamicChecks = struct
396
417
let add_runtime_type_check ~tag_type ~(block_cases : block_type list ) x y =
397
418
let has_array () = Ext_list. exists block_cases (fun t -> t = ArrayType ) in
398
419
match tag_type with
399
- | Untagged (IntType | StringType | FloatType | FunctionType ) ->
420
+ | Untagged (IntType | StringType | FloatType | BooleanType | FunctionType ) ->
400
421
typeof y == x
401
422
| Untagged ObjectType ->
402
423
if has_array () then typeof y == x &&& not (is_array y) else typeof y == x
0 commit comments