l4/pkg/ocaml/ocaml/contrib/otherlibs/labltk/compiler/tables.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   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. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16
  17 (* $Id: tables.ml 4745 2002-04-26 12:16:26Z furuse $ *)
  18
  19 open StdLabels
  20 open Support
  21
  22 (* Internal compiler errors *)
  23
  24 exception Compiler_Error of string
  25 let fatal_error s = raise (Compiler_Error s)
  26
  27
  28 (* Types of the description language *)
  29 type mltype =
  30    Unit
  31  | Int
  32  | Float
  33  | Bool
  34  | Char
  35  | String
  36  | List of mltype
  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
  43
  44 type template =
  45    StringArg of string
  46  | TypeArg of string * mltype
  47  | ListArg of template list
  48  | OptionalArgs of string * template list * template list
  49
  50 (* Sorts of components *)
  51 type component_type =
  52    Constructor
  53  | Command
  54  | External
  55
  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 *)
  61   template : template;
  62   result   : mltype;
  63   safe : bool
  64   }
  65
  66 let sort_components =
  67   List.sort ~cmp:(fun c1 c2 ->  compare c1.ml_name c2.ml_name)
  68
  69
  70 (* components are given either in full or abbreviated *)
  71 type component =
  72    Full of fullcomponent
  73  | Abbrev of string
  74
  75 (* A type definition *)
  76 (*
  77  requires_widget_context: the converter of the type MUST be passed
  78    an additional argument of type Widget.
  79 *)
  80
  81 type parser_arity =
  82   OneToken
  83 | MultipleToken
  84
  85 type type_def = {
  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
  91 }
  92
  93 type module_type =
  94     Widget
  95   | Family
  96
  97 type module_def = {
  98   module_type : module_type;
  99   commands : fullcomponent list;
 100   externals : fullcomponent list
 101 }
 102
 103 (******************** The tables ********************)
 104
 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)
 113 (* Function table *)
 114 let function_table = ref ([] : fullcomponent list)
 115 (* Widget/Module table *)
 116 let module_table = (Hashtbl.create 37 : (string, module_def) Hashtbl.t)
 117
 118
 119 (* variant name *)
 120 let rec getvarname ml_name temp =
 121   let offhypben s =
 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)
 125     else s
 126   and makecapital s =
 127     begin
 128       try
 129         let cd = s.[0] in
 130           if cd >= 'a' && cd <= 'z' then
 131             s.[0] <- Char.chr (Char.code cd + (Char.code 'A' - Char.code 'a'))
 132       with
 133         _ -> ()
 134     end;
 135     s
 136   in
 137     let head =  makecapital (offhypben begin
 138                   match temp with
 139                     StringArg s -> s
 140                   | TypeArg (s,t) -> s
 141                   | ListArg (h::_) -> getvarname ml_name h
 142                   | OptionalArgs (s,_,_) -> s
 143                   | ListArg [] -> ""
 144                 end)
 145     in
 146     let varname = if head = "" then ml_name
 147                   else if head.[0] >= 'A' && head.[0] <= 'Z' then head
 148                        else ml_name
 149     in varname
 150
 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;
 156                 constructors = [];
 157                 subtypes = [];
 158                 requires_widget_context = false;
 159                 variant = false} in
 160     Hashtbl.add types_table typname typdef;
 161     typdef
 162
 163
 164 (* Assume that types not yet defined are not subtyped *)
 165 (* Widget is builtin and implicitly subtyped *)
 166 let is_subtyped s =
 167   s = "widget" ||
 168   try
 169     let typdef = Hashtbl.find types_table s in
 170       typdef.subtypes <> []
 171   with
 172     Not_found -> false
 173
 174 let requires_widget_context s =
 175   try
 176     (Hashtbl.find types_table s).requires_widget_context
 177   with
 178     Not_found -> false
 179
 180 let declared_type_parser_arity s =
 181   try
 182     (Hashtbl.find types_table s).parser_arity
 183   with
 184     Not_found ->
 185       try List.assoc s !types_external
 186       with
 187         Not_found ->
 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");
 191            OneToken
 192
 193 let rec type_parser_arity = function
 194    Unit -> OneToken
 195  | Int -> OneToken
 196  | Float -> OneToken
 197  | Bool -> OneToken
 198  | Char -> OneToken
 199  | String -> OneToken
 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
 207
 208 let enter_external_type s v =
 209   types_external := (s,v)::!types_external
 210
 211 (*** Stuff for topological Sort.list of types ***)
 212 (* Make sure all types used in commands and functions are in *)
 213 (* the table *)
 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
 223
 224 let rec enter_template_types = function
 225      StringArg _ -> ()
 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
 229
 230 (* Find type dependancies on s *)
 231 let rec add_dependancies s =
 232   function
 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
 239   | _ -> ()
 240
 241 let rec add_template_dependancies s = function
 242      StringArg _ -> ()
 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
 246
 247 (* Assumes functions are not nested in products, which is reasonable due to syntax*)
 248 let rec has_callback = function
 249      StringArg _ -> false
 250    | TypeArg (l,Function _ ) -> true
 251    | TypeArg _ -> false
 252    | ListArg l -> List.exists ~f:has_callback l
 253    | OptionalArgs (_,tl,_) -> List.exists ~f:has_callback tl
 254
 255 (*** Returned types ***)
 256 let really_add ty =
 257   if List.mem ty !types_returned then ()
 258   else types_returned := ty :: !types_returned
 259
 260 let rec add_return_type = function
 261     Unit -> ()
 262   | Int -> ()
 263   | Float -> ()
 264   | Bool -> ()
 265   | Char -> ()
 266   | String -> ()
 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
 274
 275 (*** Update tables for a component ***)
 276 let enter_component_types {template = t; result = r} =
 277   add_return_type r;
 278   enter_argtype r;
 279   enter_template_types t
 280
 281
 282 (******************** Types and subtypes ********************)
 283 exception Duplicate_Definition of string * string
 284 exception Invalid_implicit_constructor of string
 285
 286 (* Checking duplicate definition of constructor in subtypes *)
 287 let rec check_duplicate_constr allowed c =
 288   function
 289     [] -> false         (* not defined *)
 290   | c'::rest ->
 291     if c.ml_name = c'.ml_name then  (* defined *)
 292       if allowed then
 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
 297
 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
 303
 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:
 311     begin fun c ->
 312       if not (check_duplicate_constr false c typdef.constructors)
 313       then begin
 314          typdef.constructors <- c :: typdef.constructors;
 315          add_template_dependancies typname c.template
 316       end;
 317       (* Callbacks require widget context *)
 318       typdef.requires_widget_context <-
 319         typdef.requires_widget_context ||
 320                 has_callback c.template
 321     end
 322
 323 (* Enter a subtype *)
 324 let enter_subtype typ arity subtyp constructors =
 325   (* Retrieve the type if already defined, else add a new one *)
 326   let typdef =
 327     try Hashtbl.find types_table typ
 328     with Not_found -> new_type typ arity
 329   in
 330     if List.mem_assoc subtyp typdef.subtypes
 331     then raise (Duplicate_Definition ("subtype", typ ^" "^subtyp))
 332     else begin
 333       let real_constructors =
 334         List.map constructors ~f:
 335           begin function
 336             Full c ->
 337               if not (check_duplicate_constr true c typdef.constructors)
 338               then begin
 339                 add_template_dependancies typ c.template;
 340                 typdef.constructors <- c :: typdef.constructors
 341               end;
 342               typdef.requires_widget_context <-
 343                 typdef.requires_widget_context ||
 344                 has_callback c.template;
 345               c
 346           | Abbrev name -> find_constructor name typdef.constructors
 347           end
 348       in
 349        (* TODO: duplicate def in subtype are not checked *)
 350        typdef.subtypes <-
 351           (subtyp , List.sort real_constructors
 352              ~cmp:(fun c1 c2 -> compare c1.var_name c2.var_name)) ::
 353           typdef.subtypes
 354     end
 355
 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 =
 360   let optiontyp =
 361     try Hashtbl.find types_table "options"
 362     with
 363       Not_found -> raise (Invalid_implicit_constructor optname)
 364   in find_constructor optname optiontyp.constructors
 365
 366 (* Sort components by type *)
 367 let rec add_sort l obj =
 368   match l with
 369     []  -> [obj.component ,[obj]]
 370   | (s',l)::rest ->
 371      if obj.component = s' then
 372        (s',obj::l)::rest
 373      else
 374        (s',l)::(add_sort rest obj)
 375
 376 let separate_components =  List.fold_left ~f:add_sort ~init:[]
 377
 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:
 383     begin function
 384       Constructor, l ->
 385         enter_subtype "options" MultipleToken
 386           name (List.map ~f:(fun c -> Full c) l)
 387     | Command, l ->
 388         List.iter ~f:enter_component_types l
 389     | External, _ -> ()
 390     end;
 391   let commands =
 392       try List.assoc Command sorted_components
 393       with Not_found -> []
 394   and externals =
 395       try List.assoc External sorted_components
 396       with Not_found -> []
 397   in
 398   Hashtbl.add module_table name
 399     {module_type = Widget; commands = commands; externals = externals}
 400
 401 (******************** Functions ********************)
 402
 403 let enter_function comp =
 404   enter_component_types comp;
 405   function_table := comp :: !function_table
 406
 407
 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:
 414     begin function
 415       Constructor, l -> fatal_error "unexpected Constructor"
 416     | Command, l -> List.iter ~f:enter_component_types l
 417     | External, _ -> ()
 418     end;
 419   let commands =
 420       try List.assoc Command sorted_components
 421       with Not_found -> []
 422   and externals =
 423       try List.assoc External sorted_components
 424       with Not_found -> []
 425   in
 426     Hashtbl.add module_table name
 427       {module_type = Family; commands = commands; externals = externals}