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
|
(*************************************************************************)
(* *)
(* Objective Caml LablTk library *)
(* *)
(* Francois Rouaix, Francois Pessaux and Jun Furuse *)
(* projet Cristal, INRIA Rocquencourt *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
(* Copyright 1999 Institut National de Recherche en Informatique et *)
(* en Automatique and Kyoto University. All rights reserved. *)
(* This file is distributed under the terms of the GNU Library *)
(* General Public License. *)
(* *)
(*************************************************************************)
(* $Id$ *)
(* Write .mli for widgets *)
open Tables
open Compile
let write_create_p :w wname =
w "val create :\n ?name:string ->\n";
begin
try
let option = Hashtbl.find types_table key:"options" in
let classdefs = List.assoc key:wname option.subtypes in
let tklabels = List.map fun:gettklabel classdefs in
let l = List.map classdefs fun:
begin fun fc ->
begin let p = gettklabel fc in
if count item:p tklabels > 1 then small fc.ml_name else p
end, fc.template
end in
w (String.concat sep:" ->\n"
(List.map l fun:
begin fun (s,t) ->
" ?" ^ s ^ ":"
^(ppMLtype
(match types_of_template t with
[t] -> labeloff t at:"write_create_p"
| [] -> fatal_error "multiple"
| l -> Product (List.map fun:(labeloff at:"write_create_p") l)))
end))
with Not_found -> fatal_error "in write_create_p"
end;
w (" ->\n 'a widget -> "^wname^" widget\n");
w " (* [create p options ?name] creates a new widget with\n";
w " parent p and new patch component name.\n";
w " Options are restricted to the widget class subset,\n";
w " and checked dynamically. *)\n"
(* Unsafe: write special comment *)
let write_function_type :w def =
if not def.safe then w "(* unsafe *)\n";
w "val "; w def.ml_name; w " : ";
let us, ls, os =
let tys = types_of_template def.template in
let rec replace_args :u :l :o = function
[] -> u, l, o
| (_,List(Subtype _) as x)::ls ->
replace_args :u :l o:(x::o) ls
| ("",_ as x)::ls ->
replace_args u:(x::u) :l :o ls
| (p,_ as x)::ls when p.[0] = '?' ->
replace_args :u :l o:(x::o) ls
| x::ls ->
replace_args :u l:(x::l) :o ls
in
replace_args u:[] l:[] o:[] (List.rev tys)
in
let counter = ref 0 in
List.iter (ls @ os @ us)
fun:(fun (l,t) -> labelprint :w l; w (ppMLtype t :counter); w " -> ");
if (os <> [] || ls = []) && us = [] then w "unit -> ";
w (ppMLtype any:true return:true def.result); (* RETURN TYPE !!! *)
w " \n";
(* w "(* tk invocation: "; w (doc_of_template def.template); w " *)"; *)
if def.safe then w "\n\n"
else w "\n(* /unsafe *)\n\n"
let write_external_type :w def =
match def.template with
StringArg fname ->
let ic = open_in_bin (fname ^ ".mli") in
if not def.safe then w "(* unsafe *)\n";
begin try
while true do
w (input_line ic);
w "\n"
done
with End_of_file ->
close_in ic;
if def.safe then w "\n\n"
else w "\n(* /unsafe *)\n\n"
end
| _ -> raise (Compiler_Error "invalid external definition")
|
