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
|
module D = DataType
module F = Functions
module Data = struct
(*** Values definitions *)
type 'a value =
| Bool: D.Bool.t -> D.Bool.t value
| Num: D.Num.t ScTypes.dataFormat * D.Num.t -> D.Num.t value
| String: UTF8.t -> UTF8.t value
| List: 'a ScTypes.dataFormat * 'a list -> 'a list value
| Matrix: 'a ScTypes.dataFormat * 'a list list -> 'a list list value
(** Extract the type and the content from a value *)
let get_argument: type a. a value -> a F.typ * a = function
| Bool b -> F.t_bool, b
| Num (_, n) -> F.t_int, n
| String s -> F.t_string, s
| List (t, l) -> F.t_list (F.typ_of_format t), l
| Matrix (t, l) -> F.t_list (F.t_list (F.typ_of_format t)), l
end
(** Functions are stored as a mutable catalog. A setter is given *)
let catalog = ref (F.C.compile F.C.empty)
let set_catalog t = catalog := t
type existencialResult =
| Result : 'a Data.value -> existencialResult [@@unboxed]
let inject:
type a. a ScTypes.dataFormat -> a -> existencialResult = fun resultFormat res ->
begin match resultFormat with
| ScTypes.Bool -> Result (Data.Bool res)
| ScTypes.String -> Result (Data.String res)
| ScTypes.Number -> Result (Data.Num (resultFormat, res))
| ScTypes.Date -> Result (Data.Num (resultFormat, res))
end
(** Extract the format from a list of results *)
let build_format_list ll () =
List.map (fun (Result x) ->
begin match x with
| Data.Bool _ -> ScTypes.DataFormat.F (ScTypes.Bool)
| Data.Num (x, _) -> ScTypes.DataFormat.F x
| Data.String _ -> ScTypes.DataFormat.F (ScTypes.String)
| Data.List (f, _) -> ScTypes.DataFormat.F f
| Data.Matrix (f, _) -> ScTypes.DataFormat.F f
end
) ll
(** Call the function with the arguments *)
let call name args = begin
let name' = UTF8.to_utf8string name in
begin try match args with
| [] ->
let arg1 = (F.t_unit, ()) in
let F.C.R(ret, res) = F.C.eval1 !catalog name' arg1 in
let returnType = ScTypes.DataFormat.guess_format_result ret (fun () -> raise Errors.TypeError) in
inject returnType res
| (Result p1)::[] ->
let arg1 = Data.get_argument p1 in
let F.C.R(ret, res) = F.C.eval1 !catalog name' arg1 in
let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in
inject returnType res
| (Result p1)::(Result p2)::[] ->
let arg1 = Data.get_argument p1
and arg2 = Data.get_argument p2 in
let F.C.R(ret, res) = F.C.eval2 !catalog name' arg1 arg2 in
let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in
inject returnType res
| (Result p1)::(Result p2)::(Result p3)::[] ->
let arg1 = Data.get_argument p1
and arg2 = Data.get_argument p2
and arg3 = Data.get_argument p3 in
let F.C.R(ret, res) = F.C.eval3 !catalog name' arg1 arg2 arg3 in
let returnType = ScTypes.DataFormat.guess_format_result ret (build_format_list args) in
inject returnType res
| _ -> raise Not_found
with Not_found ->
let signature = List.map (fun (Result x) ->
let formatter = Format.str_formatter in
Functions.repr formatter (fst @@ Data.get_argument x);
Format.flush_str_formatter ()) args in
raise (Errors.Undefined (name, signature))
end
end
let eval mapper value = begin
(** Extract the value from a raw type.
If the value is Undefined, raise an exception.
*)
let extract_value : ScTypes.result -> existencialResult = begin function
| ScTypes.Result (ScTypes.Num (f, n)) -> Result (Data.Num (f, n))
| ScTypes.Result (ScTypes.Bool b) -> Result (Data.Bool b)
| ScTypes.Result (ScTypes.Str s) -> Result (Data.String s)
| ScTypes.Error x -> raise x
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 -> ScTypes.Refs.(
begin match ScTypes.Refs.get_content @@ mapper r with
| C (Value (format, f)) -> begin match format with
| ScTypes.Date -> Result (Data.Num (format, f))
| ScTypes.Number -> Result (Data.Num (format, f))
| ScTypes.String -> Result (Data.String f)
| ScTypes.Bool -> Result (Data.Bool f)
end
| C (List (format, l)) -> Result (Data.List (format, l))
| C (Matrix (format, l)) -> Result (Data.Matrix (format, l))
end)
(* Evaluate the expression *)
| ScTypes.Expression e -> extract e
| ScTypes.Value v -> extract_value (ScTypes.Result v)
| ScTypes.Call (name, args) ->
let args' = List.map extract args in
call name args'
end in
let Result r = ((extract[@tailrec]) value) in
begin match r with
| Data.Bool b -> ScTypes.Result (ScTypes.boolean b)
| Data.String s -> ScTypes.Result (ScTypes.string s)
| Data.Num (format, n) ->
begin match ScTypes.get_numeric_type format with
| ScTypes.Date -> ScTypes.Result (ScTypes.date n)
| ScTypes.Number -> ScTypes.Result (ScTypes.number n)
end
| _ -> raise Errors.TypeError
end
end
|
