Source

ocaml / otherlibs / labltk / compiler / maincompile.ml

  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
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
(***********************************************************************)
(*                                                                     *)
(*                 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
open Tables
open Printer
open Compile
open Intf

let flag_verbose = ref false
let verbose_string s =
  if !flag_verbose then prerr_string s
let verbose_endline s =
  if !flag_verbose then prerr_endline s

let input_name = ref "Widgets.src"
let output_dir = ref ""
let destfile f = Filename.concat !output_dir f

let usage () =
  prerr_string "Usage: tkcompiler input.src\n";
  flush stderr;
  exit 1


let prerr_error_header () =
  prerr_string "File \""; prerr_string !input_name;
  prerr_string "\", line ";
  prerr_string (string_of_int !Lexer.current_line);
  prerr_string ": "

(* parse Widget.src config file *)
let parse_file filename =
  let ic = open_in_bin filename in
  let lexbuf =
    try
      let code_list = Ppparse.parse_channel ic in
      close_in ic;
      let buf = Buffer.create 50000 in
      List.iter (Ppexec.exec
                   (fun l -> Buffer.add_string buf
                       (Printf.sprintf "##line %d\n" l))
                   (Buffer.add_string buf))
        (if !Flags.camltk then Code.Define "CAMLTK" :: code_list
        else code_list);
      Lexing.from_string (Buffer.contents buf)
    with
    | Ppparse.Error s ->
        close_in ic;
        raise (Compiler_Error (Printf.sprintf "Preprocess error: %s" s))
  in
  try
    while true do
      Parser.entry Lexer.main lexbuf
    done
  with
  | Parsing.Parse_error ->
      prerr_error_header();
      prerr_string "Syntax error \n";
      exit 1
  | Lexer.Lexical_error s ->
      prerr_error_header();
      prerr_string "Lexical error (";
      prerr_string s;
      prerr_string ")\n";
      exit 1
  | Duplicate_Definition (s,s') ->
      prerr_error_header();
      prerr_string s; prerr_string " "; prerr_string s';
      prerr_string " is defined twice.\n";
      exit 1
  | Compiler_Error s ->
      prerr_error_header();
      prerr_string "Internal error: "; prerr_string s; prerr_string "\n";
      prerr_string "Please report bug\n";
      exit 1
  | End_of_file ->
      ()

(* The hack to provoke the production of cCAMLtoTKoptions_constrs *)

(* Auxiliary function: the list of all the elements associated to keys
   in an hash table. *)
let elements t =
 let elems = ref [] in
 Hashtbl.iter (fun _ d -> elems := d :: !elems) t;
 !elems;;

(* Verifies that duplicated clauses are semantically equivalent and
   returns a unique set of clauses. *)
let uniq_clauses = function
  | [] -> []
  | l ->
     let check_constr constr1 constr2 =
       if constr1.template <> constr2.template then
       begin
        let code1, vars11, vars12, opts1 =
         code_of_template ~context_widget:"dummy" constr1.template in
        let code2, vars12, vars22, opts2 =
         code_of_template ~context_widget:"dummy" constr2.template in
        let err =
         Printf.sprintf
          "uncompatible redondant clauses for variant %s:\n %s\n and\n %s"
          constr1.var_name code1 code2 in
        Format.print_newline();
        print_fullcomponent constr1;
        Format.print_newline();
        print_fullcomponent constr2;
        Format.print_newline();
        prerr_endline err;
        fatal_error err
       end in
     let t = Hashtbl.create 11 in
     List.iter l
      ~f:(fun constr ->
       let c = constr.var_name in
       if Hashtbl.mem t c
       then (check_constr constr (Hashtbl.find t c))
       else Hashtbl.add t c constr);
     elements t;;

let option_hack oc =
  if Hashtbl.mem types_table "options" then
   let typdef = Hashtbl.find types_table "options" in
   let hack =
     { parser_arity = OneToken;
       constructors = begin
         let constrs =
           List.map typdef.constructors ~f:
             begin fun c ->
               { component = Constructor;
                 ml_name = (if !Flags.camltk then "C" ^ c.ml_name
                            else c.ml_name);
                 var_name = c.var_name; (* as variants *)
                 template =
                 begin match c.template with
                   ListArg (x :: _) -> x
                 | _ -> fatal_error "bogus hack"
                 end;
                 result = UserDefined "options_constrs";
                 safe = true }
             end in
         if !Flags.camltk then constrs else uniq_clauses constrs (* JPF ?? *)
       end;
       subtypes = [];
       requires_widget_context = false;
       variant = false }
   in
   write_CAMLtoTK
     ~w:(output_string oc) ~def:hack ~safetype:false "options_constrs"

let realname name =
  (* module name fix for camltk *)
  if !Flags.camltk then "c" ^ String.capitalize name
  else name
;;

(* analize the parsed Widget.src and output source files *)
let compile () =
  verbose_endline "Creating _tkgen.ml ...";
  let oc = open_out_bin (destfile "_tkgen.ml") in
  let oc' = open_out_bin (destfile "_tkigen.ml") in
  let oc'' = open_out_bin (destfile "_tkfgen.ml") in
  let sorted_types = Tsort.sort types_order in
  verbose_endline "  writing types ...";
  List.iter sorted_types ~f:
  begin fun typname ->
  verbose_string ("    " ^ typname ^ " ");
  try
    let typdef = Hashtbl.find types_table typname in
    verbose_string "type ";
    write_type ~intf:(output_string oc)
               ~impl:(output_string oc')
               typname ~def:typdef;
    verbose_string "C2T ";
    write_CAMLtoTK ~w:(output_string oc') typname ~def:typdef;
    verbose_string "T2C ";
    if List.mem typname !types_returned then
    write_TKtoCAML ~w:(output_string oc') typname ~def:typdef;
    verbose_string "CO ";
    if not !Flags.camltk then (* only for LablTk *)
      write_catch_optionals ~w:(output_string oc') typname ~def:typdef;
    verbose_endline "."
  with Not_found ->
    if not (List.mem_assoc typname !types_external) then
    begin
      verbose_string "Type ";
      verbose_string typname;
      verbose_string " is undeclared external or undefined\n"
    end
    else verbose_endline "."
  end;
  verbose_endline "  option hacking ...";
  option_hack oc';
  verbose_endline "  writing functions ...";
  List.iter ~f:(write_function ~w:(output_string oc'')) !function_table;
  close_out oc;
  close_out oc';
  close_out oc'';
  (* Write the interface for public functions *)
  (* this interface is used only for documentation *)
  verbose_endline "Creating _tkgen.mli ...";
  let oc = open_out_bin (destfile "_tkgen.mli") in
  List.iter (sort_components !function_table)
    ~f:(write_function_type ~w:(output_string oc));
  close_out oc;
  verbose_endline "Creating other ml, mli ...";
  let write_module wname wdef =
    verbose_endline ("  "^wname);
    let modname = realname wname in
    let oc = open_out_bin (destfile (modname ^ ".ml"))
    and oc' = open_out_bin (destfile (modname ^ ".mli")) in
    Copyright.write ~w:(output_string oc);
    Copyright.write ~w:(output_string oc');
    begin match wdef.module_type with
      Widget -> output_string oc' ("(* The "^wname^" widget *)\n")
    | Family -> output_string oc' ("(* The "^wname^" commands  *)\n")
    end;
    List.iter ~f:(fun s -> output_string oc s; output_string oc' s)
      begin
        if !Flags.camltk then
          [ "open CTk\n";
            "open Tkintf\n";
            "open Widget\n";
            "open Textvariable\n\n" ]
        else
          [ "open StdLabels\n";
            "open Tk\n";
            "open Tkintf\n";
            "open Widget\n";
            "open Textvariable\n\n" ]
      end;
    output_string oc "open Protocol\n";
    begin match wdef.module_type with
      Widget ->
        if !Flags.camltk then begin
          camltk_write_create ~w:(output_string oc) wname;
          camltk_write_named_create ~w:(output_string oc) wname;
          camltk_write_create_p ~w:(output_string oc') wname;
          camltk_write_named_create_p ~w:(output_string oc') wname;
        end else begin
          labltk_write_create ~w:(output_string oc) wname;
          labltk_write_create_p ~w:(output_string oc') wname
        end
    | Family -> ()
    end;
    List.iter ~f:(write_function ~w:(output_string oc))
          (sort_components wdef.commands);
    List.iter ~f:(write_function_type ~w:(output_string oc'))
          (sort_components wdef.commands);
    List.iter ~f:(write_external ~w:(output_string oc))
           (sort_components wdef.externals);
    List.iter ~f:(write_external_type ~w:(output_string oc'))
           (sort_components wdef.externals);
    close_out oc;
    close_out oc'
  in Hashtbl.iter write_module module_table;

  (* wrapper code camltk.ml and labltk.ml *)
  if !Flags.camltk then begin
    let oc = open_out_bin (destfile "camltk.ml") in
    Copyright.write ~w:(output_string oc);
    output_string oc
"(** This module Camltk provides the module name spaces of the CamlTk API.\n\
\n\
  The users of the CamlTk API should open this module first to access\n\
  the types, functions and modules of the CamlTk API easier.\n\
  For the documentation of each sub modules such as [Button] and [Toplevel],\n\
  refer to its defintion file,  [cButton.mli], [cToplevel.mli], etc.\n\
 *)\n\
\n\
";
    output_string oc "include CTk\n";
    output_string oc "module Tk = CTk\n";
    Hashtbl.iter (fun name _ ->
      let cname = realname name in
      output_string oc (Printf.sprintf "module %s = %s;;\n"
                          (String.capitalize name)
                          (String.capitalize cname))) module_table;
    close_out oc
  end else begin
    let oc = open_out_bin (destfile "labltk.ml") in
    Copyright.write ~w:(output_string oc);
    output_string oc
"(** This module Labltk provides the module name spaces of the LablTk API,\n\
  useful to call LablTk functions inside CamlTk programs. 100% LablTk users\n\
  do not need to use this. *)\n\
\n\
";
    output_string oc "module Widget = Widget;;\n\
module Protocol = Protocol;;\n\
module Textvariable = Textvariable;;\n\
module Fileevent = Fileevent;;\n\
module Timer = Timer;;\n\
";
    Hashtbl.iter (fun name _ ->
      let cname = realname name in
      output_string oc (Printf.sprintf "module %s = %s;;\n"
                          (String.capitalize name)
                          (String.capitalize cname))) module_table;
    (* widget typer *)
    output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n";
    Hashtbl.iter (fun name def ->
      match def.module_type with
      | Widget ->
          output_string oc (Printf.sprintf
              "let %s (w : any widget) =\n" name);
          output_string oc (Printf.sprintf
              "  Rawwidget.check_class w widget_%s_table;\n" name);
          output_string oc (Printf.sprintf
              "  (Obj.magic w : %s widget);;\n\n" name);
      | _ -> () ) module_table;
    close_out oc
  end;

  (* write the module list for the Makefile *)
  (* and hack to death until it works *)
  let oc = open_out_bin (destfile "modules") in
  if !Flags.camltk then output_string oc "CWIDGETOBJS="
  else output_string oc "WIDGETOBJS=";
  Hashtbl.iter
    (fun name _ ->
      let name = realname name in
      output_string oc " ";
      output_string oc name;
      output_string oc ".cmo")
    module_table;
  output_string oc "\n";
  Hashtbl.iter
    (fun name _ ->
      let name = realname name in
      output_string oc name;
      output_string oc ".ml ")
    module_table;
  output_string oc ": _tkgen.ml\n\n";
  Hashtbl.iter
    (fun name _ ->
      let name = realname name in
      output_string oc name;
      output_string oc ".cmo : ";
      output_string oc name;
      output_string oc ".ml\n";
      output_string oc name;
      output_string oc ".cmi : ";
      output_string oc name;
      output_string oc ".mli\n")
    module_table;

  (* for camltk.ml wrapper *)
  if !Flags.camltk then begin
    output_string oc "camltk.cmo : cTk.cmo ";
    Hashtbl.iter
      (fun name _ ->
        let name = realname name in
        output_string oc name;
        output_string oc ".cmo ") module_table;
    output_string oc "\n"
  end;
  close_out oc

let main () =
  Arg.parse
    [ "-verbose",  Arg.Unit (fun () -> flag_verbose := true),
      "Make output verbose";
      "-camltk", Arg.Unit (fun () -> Flags.camltk := true),
      "Make CamlTk interface";
      "-outdir", Arg.String (fun s -> output_dir := s),
      "output directory";
      "-debugpp", Arg.Unit (fun () -> Ppexec.debug := true),
      "debug preprocessor"
    ]
    (fun filename -> input_name := filename)
    "Usage: tkcompiler <source file>" ;
  if !output_dir = "" then begin
    prerr_endline "specify -outdir option";
    exit 1
  end;
  try
    verbose_endline "Parsing...";
    parse_file !input_name;
    verbose_endline "Compiling...";
    compile ();
    verbose_endline "Finished";
    exit 0
  with
  | Lexer.Lexical_error s ->
      prerr_string "Invalid lexical character: ";
      prerr_endline s;
      exit 1
  | Duplicate_Definition (s, s') ->
      prerr_string s; prerr_string " "; prerr_string s';
      prerr_endline " is redefined illegally";
      exit 1
  | Invalid_implicit_constructor c ->
      prerr_string "Constructor ";
      prerr_string c;
      prerr_endline " is used implicitly before defined";
      exit 1
  | Tsort.Cyclic ->
      prerr_endline "Cyclic dependency of types";
      exit 1

let () = Printexc.catch main ()
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.