viewcvs.cgi/types/builtin.ml

open Builtin_defs

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

(* Types *)

let types =
  [ 
    "Empty",   Types.empty;
    "Any",     any;
    "Int",     int;
    "Char",    Types.char Chars.any;
    "Byte",    char_latin1;
    "Atom",    atom;
    "Pair",    Types.Product.any;
    "Arrow",   Types.Arrow.any;
    "Record",  Types.Record.any;
    "String",  string;
    "Latin1",  string_latin1;
    "Bool",    bool;
    "Float",   float;
  ]

let env =
  List.fold_left
    (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
    )
    Typer.empty_env
    types

(* Operators *)

open Operators

let binary_op_gen = register_binary

let unary_op_gen = register_unary


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

let binary_op_cst = register_op2


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

let unary_op_warning name targ w t run =
  unary_op_gen name
    (fun arg constr precise ->
       let res = arg targ true in
       if not (Types.subtype res w) then
         raise (Typer.Warning ("This operator may fail",t));
       t)
    run

open Ident

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

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

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

let eval_load_file ~utf8 e =
  Location.protect_op "load_file";
  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
  if utf8 then 
    match U.mk_check s with 
      | Some s -> Value.string_utf8 s 
      | None -> raise exn_load_file_utf8
  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));;
  
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));;

(* I/O *)
  
register_fun "string_of" 
  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)
  );;

register_fun "load_xml"
  string_latin1 any
  (fun v -> Load_xml.load_xml (Value.get_string_latin1 v));;
  
register_fun "load_html"
  string_latin1 Sequence.any
  (fun v -> Load_xml.load_html  (Value.get_string_latin1 v));;

register_fun "load_file_utf8" 
  string_latin1 string 
  (eval_load_file ~utf8:true);;

register_fun "load_file" 
  string_latin1 string_latin1 
  (eval_load_file ~utf8:false);;

register_fun "getenv" string_latin1 string_latin1
  (fun e ->
     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);;

let argv = ref Value.Absent;;

register_fun "argv" nil (Sequence.star string_latin1)
  (fun e ->
     Location.protect_op "argv";
     !argv);;


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);;

register_fun "print"
  string_latin1 nil
  (fun v ->
     Location.protect_op "print";
     print_string (Value.get_string_latin1 v);
     flush stdout;
     Value.nil
  );;

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
  );;

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

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

binary_op_warning2 "dump_to_file"
  string_latin1 string string_latin1 nil
  (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"
  string_latin1 string nil
  (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 "+"
  (fun arg1 arg2 constr precise ->
     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
     )
     else raise (Typer.Error "The first argument mixes integers and records"))
  (fun v1 v2 -> match (v1,v2) with
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.add x y)
     | (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
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
     | _ -> assert false);;

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

binary_op_cst "/"
  int int int
  (fun v1 v2 -> match (v1,v2) with
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.div x y)
     | _ -> assert false);;

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


binary_op_gen "@"
  (fun arg1 arg2 constr precise ->
     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;;
  

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

(* CQL agregats *)

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

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

register_fun "sum" (Sequence.plus int) int
  (Value.query_sum );;
  
register_fun "avg" (Sequence.plus int) int
  (Value.query_avg );;

register_fun "count" Sequence.any int
  (Value.query_count );;
  

register_fun "member" (Sequence.plus any)  bool
  (Value.query_member );;

register_fun "distinct_values" (Sequence.star any) Sequence.any
  (Value.query_distinct );;
1	abate	501	open Builtin_defs
2	abate	66
3	abate	1215	let eval = ref (fun ppf err s -> assert false)
4
5	abate	421	(* Types *)
6
7	abate	18	let types =
8			[
9			"Empty", Types.empty;
10	abate	421	"Any", any;
11			"Int", int;
12	abate	18	"Char", Types.char Chars.any;
13	abate	391	"Byte", char_latin1;
14	abate	421	"Atom", atom;
15	abate	43	"Pair", Types.Product.any;
16			"Arrow", Types.Arrow.any;
17			"Record", Types.Record.any;
18	abate	421	"String", string;
19	abate	391	"Latin1", string_latin1;
20	abate	956	"Bool", bool;
21			"Float", float;
22	abate	421	]
23
24	abate	686	let env =
25			List.fold_left
26	abate	698	(fun accu (n,t) ->
27			let n = Ident.U.mk n in
28			Types.Print.register_global n t;
29			Typer.enter_type (Ident.ident n) t accu
30			)
31	abate	686	Typer.empty_env
32	abate	421	types
33
34			(* Operators *)
35
36	abate	691	open Operators
37
38	abate	1239	let binary_op_gen = register_binary
39	abate	421
40	abate	1238	let unary_op_gen = register_unary
41	abate	421
42
43			let binary_op name t1 t2 f run =
44			binary_op_gen
45			name
46	abate	1239	(fun arg1 arg2 constr precise ->
47	abate	421	f (arg1 t1 true) (arg2 t2 true))
48			run
49
50	abate	1239	let binary_op_cst = register_op2
51	abate	421
52	abate	1239
53	abate	421	let binary_op_warning2 name t1 t2 w2 t run =
54			binary_op_gen name
55	abate	1239	(fun arg1 arg2 constr precise ->
56	abate	421	ignore (arg1 t1 false);
57			let r = arg2 t2 true in
58			if not (Types.subtype r w2) then
59	abate	1239	raise (Typer.Warning ("This operator may fail", t));
60	abate	421	t)
61			run
62
63			let unary_op_warning name targ w t run =
64	abate	691	unary_op_gen name
65	abate	1238	(fun arg constr precise ->
66	abate	691	let res = arg targ true in
67			if not (Types.subtype res w) then
68	abate	1238	raise (Typer.Warning ("This operator may fail",t));
69	abate	691	t)
70			run
71	abate	421
72			open Ident
73
74			let exn_load_file_utf8 =
75			Value.CDuceExn (
76			Value.Pair (
77	abate	656	Value.Atom (Atoms.V.mk_ascii "load_file_utf8"),
78	abate	421	Value.string_latin1 "File is not a valid UTF-8 stream"))
79
80			let exn_int_of =
81			Value.CDuceExn (
82			Value.Pair (
83	abate	656	Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
84	abate	421	Value.string_latin1 "int_of"))
85
86	abate	644	let exn_not_found =
87	abate	656	Value.CDuceExn (Value.Atom (Atoms.V.mk_ascii "Not_found"))
88	abate	644
89	abate	421	let eval_load_file ~utf8 e =
90			Location.protect_op "load_file";
91	abate	1203	let fn = Value.get_string_latin1 e in
92			let s = match Url.process fn with
93			\| Url.Filename fn ->
94			let ic = open_in fn in
95			let len = in_channel_length ic in
96			let s = String.create len in
97			really_input ic s 0 len;
98			close_in ic;
99			s
100			\| Url.Url txt ->
101			txt
102			in
103	abate	421	if utf8 then
104	abate	691	match U.mk_check s with
105			\| Some s -> Value.string_utf8 s
106			\| None -> raise exn_load_file_utf8
107	abate	421	else Value.string_latin1 s
108
109
110			let () = ();;
111
112			(* Comparison operators *)
113
114			binary_op "="
115			any any
116			(fun t1 t2 ->
117			if Types.is_empty (Types.cap t1 t2) then false_type
118			else bool)
119			(fun v1 v2 ->
120			Value.vbool (Value.compare v1 v2 == 0));;
121
122			binary_op_cst "<="
123			any any bool
124			(fun v1 v2 -> Value.vbool (Value.compare v1 v2 <= 0));;
125
126			binary_op_cst "<"
127			any any bool
128			(fun v1 v2 -> Value.vbool (Value.compare v1 v2 < 0));;
129
130	abate	771	binary_op_cst ">="
131	abate	421	any any bool
132			(fun v1 v2 ->
133			Value.vbool (Value.compare v1 v2 >= 0));;
134
135			binary_op_cst ">"
136			any any bool
137			(fun v1 v2 ->
138			Value.vbool (Value.compare v1 v2 > 0));;
139
140			(* I/O *)
141
142	abate	1238	register_fun "string_of"
143	abate	421	any string_latin1
144			(fun v ->
145			let b = Buffer.create 16 in
146			let ppf = Format.formatter_of_buffer b in
147			Value.print ppf v;
148			Format.pp_print_flush ppf ();
149			Value.string_latin1 (Buffer.contents b)
150			);;
151
152	abate	1238	register_fun "load_xml"
153			string_latin1 any
154	abate	421	(fun v -> Load_xml.load_xml (Value.get_string_latin1 v));;
155
156	abate	1238	register_fun "load_html"
157			string_latin1 Sequence.any
158	abate	421	(fun v -> Load_xml.load_html (Value.get_string_latin1 v));;
159
160	abate	1238	register_fun "load_file_utf8"
161			string_latin1 string
162	abate	421	(eval_load_file ~utf8:true);;
163
164	abate	1238	register_fun "load_file"
165			string_latin1 string_latin1
166	abate	421	(eval_load_file ~utf8:false);;
167
168	abate	1238	register_fun "getenv" string_latin1 string_latin1
169	abate	644	(fun e ->
170	abate	1097	Location.protect_op "getenv";
171			let var = Value.get_string_latin1 e in
172			try Value.string_latin1 (Sys.getenv var)
173			with Not_found -> raise exn_not_found);;
174	abate	644
175	abate	1097	let argv = ref Value.Absent;;
176	abate	644
177	abate	1238	register_fun "argv" nil (Sequence.star string_latin1)
178	abate	1097	(fun e ->
179			Location.protect_op "argv";
180			!argv);;
181	abate	644
182	abate	1097
183	abate	1239	register_fun "print_xml"
184			Types.any string_latin1
185			(fun v -> Print_xml.print_xml ~utf8:false !Eval.ns_table v);;
186	abate	421
187	abate	1239	register_fun "print_xml_utf8"
188			Types.any string
189			(fun v -> Print_xml.print_xml ~utf8:true !Eval.ns_table v);;
190	abate	542
191	abate	1238	register_fun "print"
192			string_latin1 nil
193	abate	421	(fun v ->
194			Location.protect_op "print";
195			print_string (Value.get_string_latin1 v);
196			flush stdout;
197			Value.nil
198			);;
199
200	abate	1238	register_fun "print_utf8"
201			string nil
202			(fun v ->
203			Location.protect_op "print";
204			let s = Value.cduce2ocaml_string_utf8 v in
205			print_string (U.get_str s);
206			flush stdout;
207			Value.nil
208			);;
209
210	abate	421	unary_op_warning "int_of"
211			string intstr int
212			(fun v ->
213			let (s,_) = Value.get_string_utf8 v in
214	abate	656	try Value.Integer (Intervals.V.mk (U.get_str s)) (* UTF-8 is ASCII compatible ! *)
215	abate	421	with Failure _ -> raise exn_int_of);;
216
217	abate	1238	register_fun "atom_of"
218	abate	421	string atom
219			(fun v ->
220			let (s,_) = Value.get_string_utf8 v in (* TODO: check that s is a correct Name wrt XML *)
221	abate	656	Value.Atom (Atoms.V.mk Ns.empty s));;
222	abate	421
223			binary_op_warning2 "dump_to_file"
224	abate	1238	string_latin1 string string_latin1 nil
225	abate	421	(fun f v ->
226			Location.protect_op "dump_to_file";
227			let oc = open_out (Value.get_string_latin1 f) in
228			output_string oc (Value.get_string_latin1 v);
229			close_out oc;
230			Value.nil);;
231
232			binary_op_cst "dump_to_file_utf8"
233	abate	1238	string_latin1 string nil
234	abate	421	(fun f v ->
235			Location.protect_op "dump_to_file_utf8";
236			let oc = open_out (Value.get_string_latin1 f) in
237			let (v,_) = Value.get_string_utf8 v in
238			output_string oc (U.get_str v);
239			close_out oc;
240			Value.nil);;
241
242			(* Integer operators *)
243
244			binary_op_gen "+"
245	abate	1239	(fun arg1 arg2 constr precise ->
246	abate	421	let t1 = arg1 (Types.cup int Types.Record.any) true in
247			if Types.subtype t1 int
248			then (
249			let t2 = arg2 int true in
250			Types.interval
251			(Intervals.add (Types.Int.get t1) (Types.Int.get t2))
252			)
253			else if Types.subtype t1 Types.Record.any
254			then (
255			let t2 = arg2 Types.Record.any true in
256			Types.Record.merge t1 t2
257			)
258	abate	1239	else raise (Typer.Error "The first argument mixes integers and records"))
259	abate	421	(fun v1 v2 -> match (v1,v2) with
260	abate	656	\| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.add x y)
261	abate	421	\| (Value.Record r1, Value.Record r2) -> Value.Record (LabelMap.merge (fun x y -> y) r1 r2)
262			\| _ -> assert false);;
263
264			binary_op "-"
265			int int
266			(fun t1 t2 ->
267			Types.interval
268			(Intervals.sub (Types.Int.get t1) (Types.Int.get t2)))
269			(fun v1 v2 -> match (v1,v2) with
270	abate	656	\| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
271	abate	421	\| _ -> assert false);;
272
273			binary_op_cst "*"
274			int int int
275			(fun v1 v2 -> match (v1,v2) with
276	abate	656	\| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.mult x y)
277	abate	421	\| _ -> assert false);;
278
279	abate	487	binary_op_cst "/"
280	abate	421	int int int
281			(fun v1 v2 -> match (v1,v2) with
282	abate	656	\| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.div x y)
283	abate	421	\| _ -> assert false);;
284
285			binary_op_cst "mod"
286			int int int
287			(fun v1 v2 -> match (v1,v2) with
288	abate	656	\| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.modulo x y)
289	abate	421	\| _ -> assert false);;
290
291
292			binary_op_gen "@"
293	abate	1239	(fun arg1 arg2 constr precise ->
294	abate	421	let constr' = Sequence.star
295			(Sequence.approx (Types.cap Sequence.any constr)) in
296			let exact = Types.subtype constr' constr in
297			if exact then
298			let t1 = arg1 constr' precise
299			and t2 = arg2 constr' precise in
300			if precise then Sequence.concat t1 t2 else constr
301			else
302			(* Note:
303			the knownledge of t1 may makes it useless to
304			check t2 with 'precise' ... *)
305			let t1 = arg1 constr' true
306			and t2 = arg2 constr' true in
307			Sequence.concat t1 t2)
308			Value.concat;;
309
310			unary_op_gen "flatten"
311			Typer.flatten
312			Value.flatten;;
313
314
315	abate	1238	register_fun "raise" any Types.empty
316	abate	1215	(fun v -> raise (Value.CDuceExn v));;
317	abate	1244
318	abate	1251	(* CQL agregats *)
319	abate	1244
320	abate	1251	register_fun "min" (Sequence.plus any) any
321	abate	1244	(Value.query_min );;
322
323	abate	1251	register_fun "max" (Sequence.plus any) any
324	abate	1245	(Value.query_max );;
325	abate	1246
326	abate	1251	register_fun "sum" (Sequence.plus int) int
327	abate	1246	(Value.query_sum );;
328	abate	1247
329	abate	1251	register_fun "avg" (Sequence.plus int) int
330	abate	1247	(Value.query_avg );;
331
332	abate	1248	register_fun "count" Sequence.any int
333	abate	1247	(Value.query_count );;
334
335	abate	1251
336	abate	1253	register_fun "member" (Sequence.plus any) bool
337	abate	1251	(Value.query_member );;
338
339	abate	1253	register_fun "distinct_values" (Sequence.star any) Sequence.any
340	abate	1251	(Value.query_distinct );;