builtin.ml 8.24 KB
Newer Older
1
open Builtin_defs
2

3
4
let eval = ref (fun ppf err s -> assert false)

5
6
(* Types *)

7
8
9
let types =
  [ 
    "Empty",   Types.empty;
10
11
    "Any",     any;
    "Int",     int;
12
    "Char",    Types.char Chars.any;
13
    "Byte",    char_latin1;
14
    "Atom",    atom;
15
16
17
    "Pair",    Types.Product.any;
    "Arrow",   Types.Arrow.any;
    "Record",  Types.Record.any;
18
    "String",  string;
19
    "Latin1",  string_latin1;
20
21
    "Bool",    bool;
    "Float",   float;
22
23
  ]

24
25
let env =
  List.fold_left
26
27
28
29
30
    (fun accu (n,t) -> 
       let n = Ident.U.mk n in
       Types.Print.register_global n t;
       Typer.enter_type (Ident.ident n) t accu
    )
31
    Typer.empty_env
32
33
34
35
    types

(* Operators *)

36
37
open Operators

38
let binary_op_gen = register_binary
39

40
let unary_op_gen = register_unary
41
42
43
44
45


let binary_op name t1 t2 f run =
  binary_op_gen
    name
46
    (fun arg1 arg2 constr precise ->
47
48
49
       f (arg1 t1 true) (arg2 t2 true))
    run

50
51
let binary_op_cst = register_op2

52
53
54

let binary_op_warning2 name t1 t2 w2 t run =
  binary_op_gen name
55
    (fun arg1 arg2 constr precise ->
56
57
58
       ignore (arg1 t1 false); 
       let r = arg2 t2 true in
       if not (Types.subtype r w2) then
59
	 raise (Typer.Warning ("This operator may fail", t));
60
61
62
63
       t)
    run

let unary_op_warning name targ w t run =
64
  unary_op_gen name
65
    (fun arg constr precise ->
66
67
       let res = arg targ true in
       if not (Types.subtype res w) then
68
	 raise (Typer.Warning ("This operator may fail",t));
69
70
       t)
    run
71
72
73
74
75
76

open Ident

let exn_load_file_utf8 = 
  Value.CDuceExn (
    Value.Pair (
77
      Value.Atom (Atoms.V.mk_ascii "load_file_utf8"),
78
79
80
81
82
      Value.string_latin1 "File is not a valid UTF-8 stream"))

let exn_int_of = 
  Value.CDuceExn (
    Value.Pair (
83
      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
84
85
      Value.string_latin1 "int_of"))

86
let exn_not_found =
87
  Value.CDuceExn (Value.Atom (Atoms.V.mk_ascii "Not_found"))
88

89
90
let eval_load_file ~utf8 e =
  Location.protect_op "load_file";
91
92
93
94
95
96
97
98
99
100
101
102
  let fn = Value.get_string_latin1 e in
  let s = match Url.process fn with 
    | Url.Filename fn ->
	let ic = open_in fn in
	let len = in_channel_length ic in
	let s = String.create len in
	really_input ic s 0 len;
	close_in ic;
	s
    | Url.Url txt ->
	txt
  in
103
  if utf8 then 
104
105
106
    match U.mk_check s with 
      | Some s -> Value.string_utf8 s 
      | None -> raise exn_load_file_utf8
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
  else Value.string_latin1 s


let () = ();;

(* Comparison operators *)

binary_op "=" 
  any any 
  (fun t1 t2 ->
     if Types.is_empty (Types.cap t1 t2) then false_type
     else bool)
  (fun v1 v2 ->
     Value.vbool (Value.compare v1 v2 == 0));;
  
binary_op_cst "<=" 
  any any bool
  (fun v1 v2 -> Value.vbool (Value.compare v1 v2 <= 0));;
  
binary_op_cst "<" 
  any any bool
  (fun v1 v2 -> Value.vbool (Value.compare v1 v2 < 0));;
  
130
binary_op_cst ">=" 
131
132
133
134
135
136
137
138
139
140
141
  any any bool
  (fun v1 v2 -> 
     Value.vbool (Value.compare v1 v2 >= 0));;
  
binary_op_cst ">" 
  any any bool
  (fun v1 v2 -> 
     Value.vbool (Value.compare v1 v2 > 0));;

(* I/O *)
  
142
register_fun "string_of" 
143
144
145
146
147
148
149
150
151
  any string_latin1
  (fun v -> 
     let b = Buffer.create 16 in
     let ppf = Format.formatter_of_buffer b in
     Value.print ppf v;
     Format.pp_print_flush ppf ();
     Value.string_latin1 (Buffer.contents b)
  );;

152
153
register_fun "load_xml"
  string_latin1 any
154
155
  (fun v -> Load_xml.load_xml (Value.get_string_latin1 v));;
  
156
157
register_fun "load_html"
  string_latin1 Sequence.any
158
159
  (fun v -> Load_xml.load_html  (Value.get_string_latin1 v));;

160
161
register_fun "load_file_utf8" 
  string_latin1 string 
162
163
  (eval_load_file ~utf8:true);;

164
165
register_fun "load_file" 
  string_latin1 string_latin1 
166
  (eval_load_file ~utf8:false);;
167

168
register_fun "getenv" string_latin1 string_latin1
169
  (fun e ->
170
171
172
173
     Location.protect_op "getenv";
     let var = Value.get_string_latin1 e in
     try Value.string_latin1 (Sys.getenv var)
     with Not_found -> raise exn_not_found);;
174

175
176
let argv = ref Value.Absent;;

177
register_fun "argv" nil (Sequence.star string_latin1)
178
179
180
  (fun e ->
     Location.protect_op "argv";
     !argv);;
181

182

183
184
185
186
187
188
189
register_fun "print_xml" 
  Types.any string_latin1
  (fun v -> Print_xml.print_xml ~utf8:false !Eval.ns_table v);;

register_fun "print_xml_utf8" 
  Types.any string
  (fun v -> Print_xml.print_xml ~utf8:true !Eval.ns_table v);;
190

191
192
register_fun "print"
  string_latin1 nil
193
194
195
196
197
198
199
  (fun v ->
     Location.protect_op "print";
     print_string (Value.get_string_latin1 v);
     flush stdout;
     Value.nil
  );;

200
201
202
203
204
205
206
207
208
209
register_fun "print_utf8"
  string nil
  (fun v ->
     Location.protect_op "print";
     let s = Value.cduce2ocaml_string_utf8 v in
     print_string (U.get_str s);
     flush stdout;
     Value.nil
  );;

210
211
212
213
unary_op_warning "int_of"
  string intstr int
  (fun v ->
     let (s,_) = Value.get_string_utf8 v in
214
     try Value.Integer (Intervals.V.mk (U.get_str s)) (* UTF-8 is ASCII compatible ! *)
215
216
     with Failure _ -> raise exn_int_of);;

217
register_fun "atom_of"
218
219
220
  string atom
  (fun v ->
     let (s,_) = Value.get_string_utf8 v in (* TODO: check that s is a correct Name wrt XML *)
221
     Value.Atom (Atoms.V.mk Ns.empty s));;
222
223

binary_op_warning2 "dump_to_file"
224
  string_latin1 string string_latin1 nil
225
226
227
228
229
230
231
232
  (fun f v ->
     Location.protect_op "dump_to_file";
     let oc = open_out (Value.get_string_latin1 f) in
     output_string oc (Value.get_string_latin1 v);
     close_out oc;
     Value.nil);;
    
binary_op_cst "dump_to_file_utf8"
233
  string_latin1 string nil
234
235
236
237
238
239
240
241
242
243
244
  (fun f v ->
     Location.protect_op "dump_to_file_utf8";
     let oc = open_out (Value.get_string_latin1 f) in
     let (v,_) = Value.get_string_utf8 v in
     output_string oc (U.get_str v);
     close_out oc;
     Value.nil);;

(* Integer operators *)

binary_op_gen "+"
245
  (fun arg1 arg2 constr precise ->
246
247
248
249
250
251
252
253
254
255
256
257
     let t1 = arg1 (Types.cup int Types.Record.any) true in
     if Types.subtype t1 int 
     then (
       let t2 = arg2 int true in
       Types.interval
	 (Intervals.add (Types.Int.get t1) (Types.Int.get t2))
     )
     else if Types.subtype t1 Types.Record.any 
     then (
       let t2 = arg2 Types.Record.any true in 
       Types.Record.merge t1 t2
     )
258
     else raise (Typer.Error "The first argument mixes integers and records"))
259
  (fun v1 v2 -> match (v1,v2) with
260
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.add x y)
261
262
263
264
265
266
267
268
269
     | (Value.Record r1, Value.Record r2) -> Value.Record (LabelMap.merge (fun x y -> y) r1 r2)
     | _ -> assert false);;
      
binary_op "-"
  int int
  (fun t1 t2 ->
     Types.interval 
     (Intervals.sub (Types.Int.get t1) (Types.Int.get t2)))
  (fun v1 v2 -> match (v1,v2) with
270
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
271
272
273
274
275
     | _ -> assert false);;

binary_op_cst "*"
  int int int
  (fun v1 v2 -> match (v1,v2) with
276
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.mult x y)
277
278
     | _ -> assert false);;

279
binary_op_cst "/"
280
281
  int int int
  (fun v1 v2 -> match (v1,v2) with
282
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.div x y)
283
284
285
286
287
     | _ -> assert false);;

binary_op_cst "mod"
  int int int
  (fun v1 v2 -> match (v1,v2) with
288
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.modulo x y)
289
290
291
292
     | _ -> assert false);;


binary_op_gen "@"
293
  (fun arg1 arg2 constr precise ->
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
     let constr' = Sequence.star 
		     (Sequence.approx (Types.cap Sequence.any constr)) in
     let exact = Types.subtype constr' constr in
     if exact then
       let t1 = arg1 constr' precise
       and t2 = arg2 constr' precise in
       if precise then Sequence.concat t1 t2 else constr
     else
       (* Note:
	  the knownledge of t1 may makes it useless to
	  check t2 with 'precise' ... *)
       let t1 = arg1 constr' true
       and t2 = arg2 constr' true in
       Sequence.concat t1 t2)
  Value.concat;;

unary_op_gen "flatten"
  Typer.flatten
  Value.flatten;;
  

315
register_fun "raise" any Types.empty
316
  (fun v -> raise (Value.CDuceExn v));;
317

318
(* CQL agregats *)
319

320
register_fun "min" (Sequence.plus any) any
321
322
  (Value.query_min );;

323
register_fun "max" (Sequence.plus any) any
324
  (Value.query_max );;
325

326
register_fun "sum" (Sequence.plus int) int
327
  (Value.query_sum );;
328
  
329
register_fun "avg" (Sequence.plus int) int
330
331
  (Value.query_avg );;

332
register_fun "count" Sequence.any int
333
334
  (Value.query_count );;
  
335
336
337
338
339
340

binary_op_cst "member" any Sequence.any  bool
  (Value.query_member );;

register_fun "distinct_values" Sequence.any Sequence.any
  (Value.query_distinct );;