1 (***********************************************************************)
3 (* MLTk, Tcl/Tk interface of Objective Caml *)
5 (* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
6 (* projet Cristal, INRIA Rocquencourt *)
7 (* Jacques Garrigue, Kyoto University RIMS *)
9 (* Copyright 2002 Institut National de Recherche en Informatique et *)
10 (* en Automatique and Kyoto University. All rights reserved. *)
11 (* This file is distributed under the terms of the GNU Library *)
12 (* General Public License, with the special exception on linking *)
13 (* described in file LICENSE found in the Objective Caml source tree. *)
15 (***********************************************************************)
17 (* $Id: tables.ml 4745 2002-04-26 12:16:26Z furuse $ *)
22 (* Internal compiler errors *)
24 exception Compiler_Error of string
25 let fatal_error s = raise (Compiler_Error s)
28 (* Types of the description language *)
37 | Product of mltype list
38 | Record of (string * mltype) list
39 | UserDefined of string
40 | Subtype of string * string
41 | Function of mltype (* arg type only *)
42 | As of mltype * string
46 | TypeArg of string * mltype
47 | ListArg of template list
48 | OptionalArgs of string * template list * template list
50 (* Sorts of components *)
56 (* Full definition of a component *)
57 type fullcomponent = {
58 component : component_type;
59 ml_name : string; (* used for camltk *)
60 var_name : string; (* used just for labltk *)
67 List.sort ~cmp:(fun c1 c2 -> compare c1.ml_name c2.ml_name)
70 (* components are given either in full or abbreviated *)
75 (* A type definition *)
77 requires_widget_context: the converter of the type MUST be passed
78 an additional argument of type Widget.
86 parser_arity : parser_arity;
87 mutable constructors : fullcomponent list;
88 mutable subtypes : (string * fullcomponent list) list;
89 mutable requires_widget_context : bool;
90 mutable variant : bool
98 module_type : module_type;
99 commands : fullcomponent list;
100 externals : fullcomponent list
103 (******************** The tables ********************)
105 (* the table of all explicitly defined types *)
106 let types_table = (Hashtbl.create 37 : (string, type_def) Hashtbl.t)
107 (* "builtin" types *)
108 let types_external = ref ([] : (string * parser_arity) list)
109 (* dependancy order *)
110 let types_order = (Tsort.create () : string Tsort.porder)
111 (* Types of atomic values returned by Tk functions *)
112 let types_returned = ref ([] : string list)
114 let function_table = ref ([] : fullcomponent list)
115 (* Widget/Module table *)
116 let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t)
120 let rec getvarname ml_name temp =
122 let s = String.copy s in
123 if (try String.sub s ~pos:0 ~len:1 with _ -> "") = "-" then
124 String.sub s ~pos:1 ~len:(String.length s - 1)
130 if cd >= 'a' && cd <= 'z' then
131 s.[0] <- Char.chr (Char.code cd + (Char.code 'A' - Char.code 'a'))
137 let head = makecapital (offhypben begin
141 | ListArg (h::_) -> getvarname ml_name h
142 | OptionalArgs (s,_,_) -> s
146 let varname = if head = "" then ml_name
147 else if head.[0] >= 'A' && head.[0] <= 'Z' then head
151 (***** Some utilities on the various tables *****)
152 (* Enter a new empty type *)
153 let new_type typname arity =
154 Tsort.add_element types_order typname;
155 let typdef = {parser_arity = arity;
158 requires_widget_context = false;
160 Hashtbl.add types_table typname typdef;
164 (* Assume that types not yet defined are not subtyped *)
165 (* Widget is builtin and implicitly subtyped *)
169 let typdef = Hashtbl.find types_table s in
170 typdef.subtypes <> []
174 let requires_widget_context s =
176 (Hashtbl.find types_table s).requires_widget_context
180 let declared_type_parser_arity s =
182 (Hashtbl.find types_table s).parser_arity
185 try List.assoc s !types_external
188 prerr_string "Type "; prerr_string s;
189 prerr_string " is undeclared external or undefined\n";
190 prerr_string ("Assuming cTKtoCAML"^s^" : string -> "^s^"\n");
193 let rec type_parser_arity = function
200 | List _ -> MultipleToken
201 | Product _ -> MultipleToken
202 | Record _ -> MultipleToken
203 | UserDefined s -> declared_type_parser_arity s
204 | Subtype (s,_) -> declared_type_parser_arity s
205 | Function _ -> OneToken
206 | As (ty, _) -> type_parser_arity ty
208 let enter_external_type s v =
209 types_external := (s,v)::!types_external
211 (*** Stuff for topological Sort.list of types ***)
212 (* Make sure all types used in commands and functions are in *)
214 let rec enter_argtype = function
215 Unit | Int | Float | Bool | Char | String -> ()
216 | List ty -> enter_argtype ty
217 | Product tyl -> List.iter ~f:enter_argtype tyl
218 | Record tyl -> List.iter tyl ~f:(fun (l,t) -> enter_argtype t)
219 | UserDefined s -> Tsort.add_element types_order s
220 | Subtype (s,_) -> Tsort.add_element types_order s
221 | Function ty -> enter_argtype ty
222 | As (ty, _) -> enter_argtype ty
224 let rec enter_template_types = function
226 | TypeArg (l,t) -> enter_argtype t
227 | ListArg l -> List.iter ~f:enter_template_types l
228 | OptionalArgs (_,tl,_) -> List.iter ~f:enter_template_types tl
230 (* Find type dependancies on s *)
231 let rec add_dependancies s =
233 List ty -> add_dependancies s ty
234 | Product tyl -> List.iter ~f:(add_dependancies s) tyl
235 | Subtype(s',_) -> if s <> s' then Tsort.add_relation types_order (s', s)
236 | UserDefined s' -> if s <> s' then Tsort.add_relation types_order (s', s)
237 | Function ty -> add_dependancies s ty
238 | As (ty, _) -> add_dependancies s ty
241 let rec add_template_dependancies s = function
243 | TypeArg (l,t) -> add_dependancies s t
244 | ListArg l -> List.iter ~f:(add_template_dependancies s) l
245 | OptionalArgs (_,tl,_) -> List.iter ~f:(add_template_dependancies s) tl
247 (* Assumes functions are not nested in products, which is reasonable due to syntax*)
248 let rec has_callback = function
250 | TypeArg (l,Function _ ) -> true
252 | ListArg l -> List.exists ~f:has_callback l
253 | OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl
255 (*** Returned types ***)
257 if List.mem ty !types_returned then ()
258 else types_returned := ty :: !types_returned
260 let rec add_return_type = function
267 | List ty -> add_return_type ty
268 | Product tyl -> List.iter ~f:add_return_type tyl
269 | Record tyl -> List.iter tyl ~f:(fun (l,t) -> add_return_type t)
270 | UserDefined s -> really_add s
271 | Subtype (s,_) -> really_add s
272 | Function _ -> fatal_error "unexpected return type (function)" (* whoah *)
273 | As (ty, _) -> add_return_type ty
275 (*** Update tables for a component ***)
276 let enter_component_types {template = t; result = r} =
279 enter_template_types t
282 (******************** Types and subtypes ********************)
283 exception Duplicate_Definition of string * string
284 exception Invalid_implicit_constructor of string
286 (* Checking duplicate definition of constructor in subtypes *)
287 let rec check_duplicate_constr allowed c =
289 [] -> false (* not defined *)
291 if c.ml_name = c'.ml_name then (* defined *)
293 if c.template = c'.template then true (* same arg *)
294 else raise (Duplicate_Definition ("constructor",c.ml_name))
295 else raise (Duplicate_Definition ("constructor", c.ml_name))
296 else check_duplicate_constr allowed c rest
298 (* Retrieve constructor *)
299 let rec find_constructor cname = function
300 [] -> raise (Invalid_implicit_constructor cname)
301 | c::l -> if c.ml_name = cname then c
302 else find_constructor cname l
304 (* Enter a type, must not be previously defined *)
305 let enter_type typname ?(variant = false) arity constructors =
306 if Hashtbl.mem types_table typname then
307 raise (Duplicate_Definition ("type", typname)) else
308 let typdef = new_type typname arity in
309 if variant then typdef.variant <- true;
310 List.iter constructors ~f:
312 if not (check_duplicate_constr false c typdef.constructors)
314 typdef.constructors <- c :: typdef.constructors;
315 add_template_dependancies typname c.template
317 (* Callbacks require widget context *)
318 typdef.requires_widget_context <-
319 typdef.requires_widget_context ||
320 has_callback c.template
323 (* Enter a subtype *)
324 let enter_subtype typ arity subtyp constructors =
325 (* Retrieve the type if already defined, else add a new one *)
327 try Hashtbl.find types_table typ
328 with Not_found -> new_type typ arity
330 if List.mem_assoc subtyp typdef.subtypes
331 then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp))
333 let real_constructors =
334 List.map constructors ~f:
337 if not (check_duplicate_constr true c typdef.constructors)
339 add_template_dependancies typ c.template;
340 typdef.constructors <- c :: typdef.constructors
342 typdef.requires_widget_context <-
343 typdef.requires_widget_context ||
344 has_callback c.template;
346 | Abbrev name -> find_constructor name typdef.constructors
349 (* TODO: duplicate def in subtype are not checked *)
351 (subtyp , List.sort real_constructors
352 ~cmp:(fun c1 c2 -> compare c1.var_name c2.var_name)) ::
356 (******************** Widgets ********************)
357 (* used by the parser; when enter_widget is called,
358 all components are assumed to be in Full form *)
359 let retrieve_option optname =
361 try Hashtbl.find types_table "options"
363 Not_found -> raise (Invalid_implicit_constructor optname)
364 in find_constructor optname optiontyp.constructors
366 (* Sort components by type *)
367 let rec add_sort l obj =
369 [] -> [obj.component ,[obj]]
371 if obj.component = s' then
374 (s',l)::(add_sort rest obj)
376 let separate_components = List.fold_left ~f:add_sort ~init:[]
378 let enter_widget name components =
379 if Hashtbl.mem module_table name then
380 raise (Duplicate_Definition ("widget/module", name)) else
381 let sorted_components = separate_components components in
382 List.iter sorted_components ~f:
385 enter_subtype "options" MultipleToken
386 name (List.map ~f:(fun c -> Full c) l)
388 List.iter ~f:enter_component_types l
392 try List.assoc Command sorted_components
395 try List.assoc External sorted_components
398 Hashtbl.add module_table name
399 {module_type = Widget; commands = commands; externals = externals}
401 (******************** Functions ********************)
403 let enter_function comp =
404 enter_component_types comp;
405 function_table := comp :: !function_table
408 (******************** Modules ********************)
409 let enter_module name components =
410 if Hashtbl.mem module_table name then
411 raise (Duplicate_Definition ("widget/module", name)) else
412 let sorted_components = separate_components components in
413 List.iter sorted_components ~f:
415 Constructor, l -> fatal_error "unexpected Constructor"
416 | Command, l -> List.iter ~f:enter_component_types l
420 try List.assoc Command sorted_components
423 try List.assoc External sorted_components
426 Hashtbl.add module_table name
427 {module_type = Family; commands = commands; externals = externals}