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
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
|
module D = DataType
module T = Tools
let u = UTF8.from_utf8string
exception RegisteredFunction
(** Data format *)
type _ dataFormat =
| Date: D.Num.t dataFormat (* Date *)
| Number: D.Num.t dataFormat (* Number *)
| String: UTF8.t dataFormat (* String result, there is only one representation *)
| Bool: D.Bool.t dataFormat (* Boolean result *)
let most_generic_format: type a. a dataFormat -> a dataFormat -> a dataFormat =
begin fun a b -> match a, b with
| Number, x -> x
| x, Number -> x
| x, _ -> x
end
(*** Type definitions *)
type _ typ =
| Unit: unit typ
| Bool: D.Bool.t typ
| Num: D.Num.t typ
| String: UTF8.t typ
| List: 'a typ -> 'a list typ
let t_bool= Bool
let t_int = Num
let t_string = String
let t_list t = List t
let typ_of_format: type a. a dataFormat -> a typ = function
| Date -> Num
| Number -> Num
| String -> String
| Bool -> Bool
let rec compare_typ: type a b. a typ -> b typ -> (a, b) T.cmp = begin fun a b ->
match a, b with
| Unit, Unit -> T.Eq
| Bool, Bool -> T.Eq
| Num, Num -> T.Eq
| String, String -> T.Eq
| List l1, List l2 ->
begin match compare_typ l1 l2 with
| T.Lt -> T.Lt
| T.Eq -> T.Eq
| T.Gt -> T.Gt
end
| x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt
end
let rec print_typ: type a. Format.formatter -> a typ -> unit = fun printer typ -> match typ with
| Unit -> Format.fprintf printer "Unit"
| Bool -> Format.fprintf printer "Bool"
| Num -> Format.fprintf printer "Num"
| String -> Format.fprintf printer "String"
| List t -> Format.fprintf printer "List[%a]"
print_typ t
let default_format_for_type: type a. a typ -> a dataFormat = function
| Num -> Date
| String -> String
| Bool -> Bool
| List _ -> raise Errors.TypeError
| Unit -> raise Errors.TypeError
(** Results format.
Any value which can be encoded with different representation requires as
many format than there are representations for this value.
*)
type _ result =
| Numeric: D.Num.t result (* Any numeric format : the representation depends from the inputs *)
| Date: D.Num.t result (* Date *)
| Number: D.Num.t result (* Number *)
| String: UTF8.t result (* String result, there is only one representation *)
| Bool: D.Bool.t result (* Boolean result *)
let f_num = Numeric
let f_date = Date
let f_number = Number
let f_string = String
let f_bool = Bool
let specialize_result: type a. a result -> a dataFormat -> a result =
begin fun a b -> match a, b with
| Date, _ -> Date
| _, Date -> Date
| x, y -> x
end
let typ_of_result: type a. a result -> a typ = function
| Numeric -> Num
| Number -> Num
| Date -> Num
| Bool -> Bool
| String -> String
let rec compare_result: type a b. a result -> b result -> (a, b) T.cmp = begin fun a b ->
match a, b with
| Bool, Bool -> T.Eq
| Numeric, Numeric-> T.Eq
| String, String -> T.Eq
| Number, Number -> T.Eq
| Date, Date -> T.Eq
| x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt
end
(*** Values definitions *)
type 'a value =
| Bool: D.Bool.t -> D.Bool.t value
| Num: D.Num.t dataFormat * D.Num.t -> D.Num.t value
| String: UTF8.t -> UTF8.t value
| List: 'a dataFormat * 'a list -> 'a list value
| List2: 'a dataFormat * 'a list list -> 'a list list value
(** Get the value out of the box *)
let get_value_content: type a. a value -> a = function
| Bool b -> b
| Num (_, n) -> n
| String s -> s
| List (t, l) -> l
| List2 (t, l) -> l
(** Create a value from a known type and an unboxed value *)
let build_value: type a. a dataFormat -> a -> a value = begin fun format content ->
match (typ_of_format format), content with
| Unit, _ -> raise Errors.TypeError
| Bool, x -> Bool x
| Num, x -> Num (format, x)
| String, s -> String s
| List t, l -> raise Errors.TypeError
end
(* Extract the type from a boxed value *)
let type_of_value: type a. a value -> a typ = function
| Bool b -> Bool
| Num (n, _) -> Num
| String s -> String
| List (t, l) -> List (typ_of_format t)
| List2 (t, l) -> List (List (typ_of_format t))
let format_of_value: type a. a value -> a dataFormat = function
| Bool b -> Bool
| Num (f, _) -> f
| String s -> String
| List (t, l) -> raise Errors.TypeError
| List2 (t, l) -> raise Errors.TypeError
type existencialResult =
| Result : 'a value -> existencialResult
(** Catalog for all functions *)
module C = struct
(** This is the way the function is store in the map.
We just the return type, and the function itself.
For Fn1 and T1 constructors, we need to add extra information in the
GADT signature in order to help the compiler: 'a could be any ('a * 'b),
('a * 'b * 'c) and so on…
Instead of returning a signature with type 'a t_function, we have to
force it as 'a typ t_function.
*)
type _ t_function =
| Fn1: 'b result * ('a -> 'b) -> 'a typ t_function
| Fn2: 'c result * ('a -> 'b -> 'c) -> ('a * 'b) t_function
| Fn3: 'd result * ('a -> 'b -> 'c -> 'd) -> ('a * 'b * 'c) t_function
(** This is the key for storing functions in the map.
*)
type _ sig_typ =
| T1: 'a typ -> 'a typ t_function sig_typ
| T2: 'a typ * 'b typ -> ('a * 'b) t_function sig_typ
| T3: 'a typ * 'b typ * 'c typ -> ('a * 'b * 'c) t_function sig_typ
let print_sig_typ: type a. Format.formatter -> a sig_typ -> unit = begin fun printer typ ->
match typ with
| T1 a -> Format.fprintf printer "(%a)"
print_typ a
| T2 (a, b) -> Format.fprintf printer "(%a, %a)"
print_typ a
print_typ b
| T3 (a, b, c) -> Format.fprintf printer "(%a, %a, %a)"
print_typ a
print_typ b
print_typ c
end
module ComparableSignature = struct
type 'a t = 'a sig_typ
(** Compare two signature *)
let eq: type a b. a sig_typ -> b sig_typ -> (a, b) T.cmp = begin fun a b ->
match a, b with
| T1(a), T1(b) ->
begin match compare_typ a b with
| T.Lt -> T.Lt
| T.Gt -> T.Gt
| T.Eq -> T.Eq
end
| T2(a, b), T2(c, d) ->
begin match (compare_typ a c) with
| T.Lt -> T.Lt
| T.Gt -> T.Gt
| T.Eq ->
begin match (compare_typ b d) with
| T.Lt -> T.Lt
| T.Gt -> T.Gt
| T.Eq -> T.Eq
end
end
| T3(a, b, c), T3(d, e, f) ->
begin match (compare_typ a d) with
| T.Lt -> T.Lt
| T.Gt -> T.Gt
| T.Eq ->
begin match (compare_typ b e) with
| T.Lt -> T.Lt
| T.Gt -> T.Gt
| T.Eq ->
begin match (compare_typ c f) with
| T.Lt -> T.Lt
| T.Gt -> T.Gt
| T.Eq -> T.Eq
end
end
end
| x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt
end
end
module Catalog = Map.Make(String)
module Functions = Tools.Map(ComparableSignature)
(* This is the map which contains all the registered functions.
Each name is binded with another map with contains the function for each
signature.
*)
let (catalog:Functions.t Catalog.t ref) = ref Catalog.empty
(**
Register a function in the catalog. If the function is already defined,
raise an exception.
*)
let register name signature f = begin
let name' = String.uppercase_ascii name in
let map = begin match Catalog.find name' !catalog with
| exception Not_found ->
Functions.singleton signature f
| x ->
(* We prevent any update to already registered function *)
if (Functions.mem signature x) then
raise RegisteredFunction
else
Functions.add signature f x
end in
catalog := Catalog.add name' map !catalog
end
let inject: type a. a result -> (unit -> a dataFormat) -> a -> existencialResult = fun resultFormat f res ->
let (x:a value) = begin match resultFormat, res with
| Bool, x -> Bool x
| Numeric, x -> Num (f (), x)
| Date, x -> Num(Date, x)
| Number, x -> Num(Number, x)
| String, s -> String s
end in
Result x
(** Look in the catalog for a function with the given name and signature *)
let find_function: type a. string -> a t_function sig_typ -> a t_function = begin fun name signature ->
Catalog.find (String.uppercase_ascii name) !catalog
|> Functions.find signature
end
end
(** Guess the format to use for the result function from the arguments given.
The most specialized format take over the others.
*)
let guess_format_result: type a. a result -> existencialResult list -> unit -> a dataFormat =
begin fun init_value values () ->
let init_typ = typ_of_result init_value in
(* fold over the arguments, and check if they have the same format *)
let compare_format (currentResult: a result) (Result value): a result =
(* If the argument as the same type as the result format, just the most specialized *)
match compare_typ init_typ (type_of_value value) with
| T.Eq -> begin match value with
| Bool b -> Bool
| String s -> String
| Num (f, v) -> specialize_result currentResult f
(* There is no possibility to get init_typ as List typ*)
| List (f, v) -> raise Errors.TypeError
| List2 (f, v) -> raise Errors.TypeError
end
(* The types differ, handle the special cases for Lists *)
| _ ->
begin match value with
| List (f, v) ->
begin match compare_typ init_typ (typ_of_format f) with
| T.Eq -> specialize_result currentResult f
| _ -> currentResult
end
| List2 (f, v) ->
begin match compare_typ init_typ (typ_of_format f) with
| T.Eq -> specialize_result currentResult f
| _ -> currentResult
end
| _ -> currentResult
end in
begin match List.fold_left compare_format init_value values with
| String -> String
| Bool -> Bool
| Number -> Number
| Date -> Date
| Numeric -> Number
end
end
let register0 name returnType f =
C.register name (C.T1(Unit)) (C.Fn1 (returnType, f))
let register1 name typ1 returnType f =
C.register name (C.T1(typ1)) (C.Fn1 (returnType, f))
let register2 name (typ1, typ2) result f =
C.register name (C.T2(typ1, typ2)) (C.Fn2 (result, f))
let register3 name (typ1, typ2, typ3) result f =
C.register name (C.T3(typ1, typ2, typ3)) (C.Fn3 (result, f))
let call name args = begin
let name' = UTF8.to_utf8string name in
begin try match args with
| [] ->
let C.Fn1(ret, f) = C.find_function name' (C.T1 Unit) in
C.inject ret (fun () -> raise Errors.TypeError) (f ())
| (Result p1)::[] ->
let C.Fn1(ret, f) =
C.find_function name' (C.T1 (type_of_value p1)) in
C.inject ret (guess_format_result ret args) (f (get_value_content p1))
| (Result p1)::(Result p2)::[] ->
let C.Fn2(ret, f) =
C.find_function name' (C.T2 (type_of_value p1, type_of_value p2)) in
C.inject ret (guess_format_result ret args) (f (get_value_content p1) (get_value_content p2))
| (Result p1)::(Result p2)::(Result p3)::[] ->
let C.Fn3(ret, f) =
C.find_function name' (C.T3 (type_of_value p1, type_of_value p2, type_of_value p3)) in
C.inject ret (guess_format_result ret args) (f (get_value_content p1) (get_value_content p2) (get_value_content p3))
| _ -> raise Not_found
with Not_found ->
let signature = List.map (fun (Result x) ->
let formatter = Format.str_formatter in
print_typ formatter (type_of_value x);
Format.flush_str_formatter ()) args in
raise (Errors.Undefined (name, signature))
end
end
let repr mapper value = begin
(** Extract the value from a raw type.
If the value is Undefined, raise an exception.
*)
let extract_value = begin function
| ScTypes.Num (n,s) -> Result (Num (Number, (D.Num.of_num n)))
| ScTypes.Bool b -> Result (Bool b)
| ScTypes.Date d -> Result (Num (Date, (D.Num.of_num d)))
| ScTypes.Str s -> Result (String s)
| ScTypes.Undefined -> raise Errors.TypeError
end in
(** Extract the value from a raw type.
If the value is Undefined, provide a default result.
*)
let guess_value: type a. a typ -> ScTypes.types -> existencialResult = fun typ value -> begin
try extract_value value with Errors.TypeError ->
match typ with
| Num -> Result (Num (Number, (D.Num.nan)))
| Bool -> Result (Bool false)
| String -> Result (String (u""))
| List x -> Result (List ((default_format_for_type x), []))
| Unit -> raise Errors.TypeError
end in
let add_elem: type a. a typ -> a list * a dataFormat -> ScTypes.types -> a list * a dataFormat =
begin fun type_of (result, format_of) next ->
let Result r = guess_value type_of next in
begin match compare_typ type_of (type_of_value r) with
| T.Eq ->
let l' = (get_value_content r)::result in
l' , (most_generic_format (format_of_value r) format_of)
| _ -> raise Errors.TypeError
end
end in
(* Return the result for any expression as an ScTypes.types result *)
let rec get_repr: type a. a value -> ScTypes.types = begin function
| Bool b -> ScTypes.Bool b
| Num (format, n) -> begin match format with
| Number -> ScTypes.Num (D.Num.to_num n, None)
| Date -> ScTypes.Date (D.Num.to_num n)
| _ -> raise Errors.TypeError (* This pattern could be refuted *)
end
| String s -> ScTypes.Str s
| List (t, l) ->
List.hd l (* Extract the first element *)
|> build_value t (* Convert it in boxed value *)
|> get_repr (* Return it's representation *)
| List2 (t, l) ->
List.hd l (* Extract the first element *)
|> List.hd
|> build_value t (* Convert it in boxed value *)
|> get_repr (* Return it's representation *)
end in
(** Extract the value from an expression.
[extract typ expr] will evaluate the expression and return it. If the
result cannot be evaluated (because of references pointing to missing
values) a default value of type [typ] will be returned.
*)
let rec extract = begin function
(* For a reference to an external we first extract the value pointed *)
| ScTypes.Ref r ->
begin match mapper r with
| ScTypes.Refs.Single v -> extract_value v
| ScTypes.Refs.Array1 l ->
(* Guess the list type from it's first defined element *)
let Result r = extract_value (List.find ((!=) ScTypes.Undefined) l) in
let format_of = format_of_value r in
let type_of = type_of_value r in
(* Build the list with all the elements *)
let elems, format = List.fold_left (add_elem type_of) ([], format_of) l in
Result (List (format, elems))
| ScTypes.Refs.Array2 l ->
(* Guess the list type from it's first defined element *)
let Result r = extract_value (Tools.List.find2 ((!=) ScTypes.Undefined) l) in
let format_of = format_of_value r in
let type_of = type_of_value r in
(* Build the list with all the elements *)
let elems, format = List.fold_left (fun (result, format_of) elems ->
let elems, format = List.fold_left (add_elem type_of) ([], format_of) elems in
elems::result, (most_generic_format format_of format)
) ([], format_of) l in
Result (List2 (format, elems))
end
(* Evaluate the expression *)
| ScTypes.Expression e -> extract e
| ScTypes.Value v -> extract_value v
| ScTypes.Call (name, args) ->
let args' = List.map extract args in
call name args'
end
in
let Result r = extract value in
get_repr r
end
let wrap f =
let old_catalog = !C.catalog in
Tools.try_finally
(fun () -> C.catalog := C.Catalog.empty; f ())
(fun () -> C.catalog := old_catalog)
(* Register the standard functions *)
module MAKE(C: D.COMPARABLE) = struct
let register t = begin
register2 "=" (t, t) f_bool C.eq;
register2 "<>" (t, t) f_bool C.neq;
register2 ">" (t, t) f_bool C.gt;
register2 ">=" (t, t) f_bool C.ge;
register2 "<" (t, t) f_bool C.lt;
register2 "<=" (t, t) f_bool C.le;
end
end
(* Helper for list functions : reduce over a list of elements *)
let reduce name typ res f = begin
register1 name (t_list typ) res (fun x ->
List.fold_left f (List.hd x) x);
register1 name (t_list (t_list typ)) res (fun x ->
List.fold_left (List.fold_left f) (List.hd (List.hd x)) x);
end
(* Helper for list functions : fold over a list of elements *)
let fold name t_in t_out f init = begin
register1 name (t_list t_in) t_out (fun x ->
List.fold_left f init x);
register1 name (t_list (t_list t_in)) t_out (fun x ->
List.fold_left (List.fold_left f) init x);
end
let () = begin
let module CompareNum = MAKE(D.Num) in
CompareNum.register t_int;
register0 "rand" f_number D.Num.rnd;
register2 "+" (t_int, t_int) f_num D.Num.add;
register2 "-" (t_int, t_int) f_num D.Num.sub;
register2 "*" (t_int, t_int) f_number D.Num.mult;
register2 "/" (t_int, t_int) f_number D.Num.div;
register2 "^" (t_int, t_int) f_number D.Num.pow;
register1 "abs" t_int f_number D.Num.abs;
fold "sum" t_int f_number D.Num.add (D.Num.of_num (Num.num_of_int 0));
fold "product" t_int f_number D.Num.mult (D.Num.of_num (Num.num_of_int 1));
reduce "min" t_int f_num D.Num.min; (* Minimum value from a list *)
reduce "max" t_int f_num D.Num.max; (* Maximum value from a list *)
let module CompareBool = MAKE(D.Bool) in
CompareBool.register t_bool;
register0 "true" f_bool (fun () -> D.Bool.true_);
register0 "false" f_bool (fun () -> D.Bool.false_);
register1 "not" t_bool f_bool D.Bool.not;
register2 "and" (t_bool, t_bool) f_bool D.Bool.and_;
register2 "or" (t_bool, t_bool) f_bool D.Bool.or_;
register2 "xor" (t_bool, t_bool) f_bool D.Bool.neq;
let module CompareString = MAKE(D.String) in
CompareString.register t_string;
end
|