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
|
(***********************************************************************)
(* *)
(* MLTk, Tcl/Tk interface of OCaml *)
(* *)
(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
(* projet Cristal, INRIA Rocquencourt *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
(* Copyright 2002 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, with the special exception on linking *)
(* described in file LICENSE found in the OCaml source tree. *)
(* *)
(***********************************************************************)
(* $Id$ *)
open StdLabels
(* Write .mli for widgets *)
open Tables
open Compile
let labltk_write_create_p ~w wname =
w "val create :\n ?name:string ->\n";
begin
try
let option = Hashtbl.find types_table "options" in
let classdefs = List.assoc wname option.subtypes in
let tklabels = List.map ~f:gettklabel classdefs in
let l = List.map classdefs ~f:
begin fun fc ->
begin let p = gettklabel fc in
if count ~item:p tklabels > 1 then small fc.var_name else p
end,
fc.template
end in
w (String.concat ~sep:" ->\n"
(List.map l ~f:
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 ~f:(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 ?name parent options...] creates a new widget with\n";
w " parent [parent] and new patch component [name], if specified. *)\n\n"
;;
let camltk_write_create_p ~w wname =
w "val create : ?name: string -> widget -> options list -> widget \n";
w "(** [create ?name parent options] creates a new widget with\n";
w " parent [parent] and new patch component [name] if specified.\n";
w " Options are restricted to the widget class subset, and checked\n";
w " dynamically. *)\n\n"
;;
let camltk_write_named_create_p ~w wname =
w "val create_named : widget -> string -> options list -> widget \n";
w "(** [create_named parent name options] creates a new widget with\n";
w " parent [parent] and new patch component [name].\n";
w " This function is now obsolete and unified with [create]. *)\n\n";
;;
(* Unsafe: write special comment *)
let labltk_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
let params =
if os = [] then us @ ls else ls @ os @ us in
List.iter params ~f:
begin fun (l, t) ->
if l <> "" then w (l ^ ":");
w (ppMLtype t ~counter);
w " -> "
end;
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"
else w "\n(* /unsafe *)\n"
let camltk_write_function_type ~w def =
if not def.safe then w "(* unsafe *)\n";
w "val "; w def.ml_name; w " : ";
let us, os =
let tys = types_of_template def.template in
let rec replace_args ~u ~o = function
[] -> u, o
| ("", _ as x)::ls ->
replace_args ~u:(x::u) ~o ls
| (p, _ as x)::ls when p.[0] = '?' ->
replace_args ~u ~o:(x::o) ls
| x::ls ->
replace_args ~u:(x::u) ~o ls
in
replace_args ~u:[] ~o:[] (List.rev tys)
in
let counter = ref 0 in
let params =
if os = [] then us else os @ us in
List.iter params ~f:
begin fun (l, t) ->
if l <> "" then if l.[0] = '?' then w (l ^ ":");
w (ppMLtype t ~counter);
w " -> "
end;
if 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"
else w "\n(* /unsafe *)\n"
(*
if not def.safe then w "(* unsafe *)\n";
w "val "; w def.ml_name; w " : ";
let tys = types_of_template def.template in
let counter = ref 0 in
let have_normal_arg = ref false in
List.iter tys ~f:
begin fun (l, t) ->
if l <> "" then
if l.[0] = '?' then w (l^":")
else begin
have_normal_arg := true;
w (" (* " ^ l ^ ":*)")
end
else have_normal_arg := true;
w (ppMLtype t ~counter);
w " -> "
end;
if not !have_normal_arg then w "unit -> ";
w (ppMLtype ~any:true ~return:true def.result); (* RETURN TYPE !!! *)
w " \n";
if def.safe then w "\n"
else w "\n(* /unsafe *)\n"
*)
let write_function_type ~w def =
if !Flags.camltk then camltk_write_function_type ~w def
else labltk_write_function_type ~w def
let write_external_type ~w def =
match def.template with
| StringArg fname ->
begin try
let realname = find_in_path !search_path (fname ^ ".mli") in
let ic = open_in_bin realname in
try
let code_list = Ppparse.parse_channel ic in
close_in ic;
if not def.safe then w "(* unsafe *)\n";
List.iter (Ppexec.exec (fun _ -> ()) w)
(if !Flags.camltk then
Code.Define "CAMLTK" :: code_list else code_list );
if def.safe then w "\n\n"
else w "\n(* /unsafe *)\n\n"
with
| Ppparse.Error s ->
close_in ic;
raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
with
| Not_found ->
raise (Compiler_Error ("can't find external file: " ^ fname))
end
| _ -> raise (Compiler_Error "invalid external definition")
|
