path: root/otherlibs/labltk/compiler/maincompile.ml

(***********************************************************************)
(*                                                                     *)
(*                 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 ()