(***********************************************************************)
(* *)
(* 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
(* CONFIGURE *)
(* if you set it true, ImagePhoto and ImageBitmap will annoy you... *)
let safetype = true
let labeloff ~at l = match l with
"", t -> t
| l, t -> raise (Failure ("labeloff: " ^ l ^ " at " ^ at))
let labltk_labelstring l =
if l = "" then l else
if l.[0] = '?' then l ^ ":" else
"~" ^ l ^ ":"
let camltk_labelstring l =
if l = "" then l else
if l.[0] = '?' then l ^ ":" else ""
let labelstring l =
if !Flags.camltk then camltk_labelstring l
else labltk_labelstring l
let labltk_typelabel l =
if l = "" then l else l ^ ":"
let camltk_typelabel l =
if l = "" then l
else if l.[0] = '?' then l ^ ":" else ""
let typelabel l =
if !Flags.camltk then camltk_typelabel l
else labltk_typelabel l
let forbidden = [ "class"; "type"; "in"; "from"; "to" ]
let nicknames =
[ "class", "clas";
"type", "typ" ]
let small = String.lowercase_ascii
let gettklabel fc =
match fc.template with
ListArg( StringArg s :: _ ) ->
let s = small s in
if s = "" then s else
let s =
if s.[0] = '-'
then String.sub s ~pos:1 ~len:(String.length s - 1)
else s
in begin
if List.mem s forbidden then
try List.assoc s nicknames
with Not_found -> small fc.var_name
else s
end
| _ -> raise (Failure "gettklabel")
let count ~item:x l =
let count = ref 0 in
List.iter ~f:(fun y -> if x = y then incr count) l;
!count
let caml_name s =
let b = Buffer.create (String.length s) in
for i = 0 to String.length s - 1 do
let c = s.[i] in
if c <> ':' then Buffer.add_char b c
else if i > 0 && s.[i-1] = ':' then Buffer.add_char b '_'
done;
Buffer.contents b
(* Extract all types from a template *)
let rec types_of_template = function
StringArg _ -> []
| TypeArg (l, t) -> [l, t]
| ListArg l -> List.flatten (List.map ~f:types_of_template l)
| OptionalArgs (l, tl, _) ->
begin
match List.flatten (List.map ~f:types_of_template tl) with
["", t] -> ["?" ^ l, t]
| [_, _] -> raise (Failure "0 label required")
| _ -> raise (Failure "0 or more than 1 args in for optionals")
end
(*
* Pretty print a type
* used to write ML type definitions
*)
let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
let rec ppMLtype =
function
Unit -> "unit"
| Int -> "int"
| Float -> "float"
| Bool -> "bool"
| Char -> "char"
| String -> "string"
(* new *)
| List (Subtype (sup, sub)) ->
if !Flags.camltk then "(* " ^ sub ^ " *) " ^ caml_name sup ^ " list"
else begin
if return then
caml_name sub ^ "_" ^ caml_name sup ^ " list"
else begin
try
let typdef = Hashtbl.find types_table sup in
let fcl = List.assoc sub typdef.subtypes in
let tklabels = List.map ~f:gettklabel fcl in
let l = List.map fcl ~f:
begin fun fc ->
"?" ^ begin let p = gettklabel fc in
if count ~item:p tklabels > 1 then small fc.var_name else p
end
^ ":" ^
let l = types_of_template fc.template in
match l with
[] -> "unit"
| [lt] -> ppMLtype (labeloff lt ~at:"ppMLtype")
| l ->
"(" ^ String.concat ~sep:"*"
(List.map l
~f:(fun lt -> ppMLtype (labeloff lt ~at:"ppMLtype")))
^ ")"
end in
String.concat ~sep:" ->\n" l
with
Not_found -> Printf.eprintf "ppMLtype %s/%s\n" sup sub; exit (-1)
end
end
| List ty -> (ppMLtype ty) ^ " list"
| Product tyl ->
"(" ^ String.concat ~sep:" * " (List.map ~f:ppMLtype tyl) ^ ")"
| Record tyl ->
String.concat ~sep:" * "
(List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t))
| Subtype ("widget", sub) ->
if !Flags.camltk then "(* " ^ sub ^" *) widget" else
caml_name sub ^ " widget"
| UserDefined "widget" ->
if !Flags.camltk then "widget"
else begin
if any then "any widget" else
let c = String.make 1 (Char.chr(Char.code 'a' + !counter)) in
incr counter;
"'" ^ c ^ " widget"
end
| UserDefined s ->
if !Flags.camltk then s
else begin
(* a bit dirty hack for ImageBitmap and ImagePhoto *)
try
let typdef = Hashtbl.find types_table s in
if typdef.variant then
if return then try
"[>" ^
String.concat ~sep:"|"
(List.map typdef.constructors ~f:
begin
fun c ->
"`" ^ c.var_name ^
(match types_of_template c.template with
[] -> ""
| l -> " of " ^ ppMLtype (Product (List.map l
~f:(labeloff ~at:"ppMLtype UserDefined"))))
end) ^ "]"
with
Not_found -> prerr_endline ("ppMLtype " ^ s ^ " ?"); s
else if not def && List.length typdef.constructors > 1 then
"[< " ^ s ^ "]"
else s
else s
with Not_found -> s
end
| Subtype (s, s') ->
if !Flags.camltk then "(* " ^ s' ^ " *) " ^ caml_name s else
caml_name s' ^ "_" ^ caml_name s
| Function (Product tyl) ->
raise (Failure "Function (Product tyl) ? ppMLtype")
| Function (Record tyl) ->
"(" ^ String.concat ~sep:" -> "
(List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t))
^ " -> unit)"
| Function ty ->
"(" ^ (ppMLtype ty) ^ " -> unit)"
| As (t, s) ->
if !Flags.camltk then ppMLtype t
else s
in
ppMLtype
(* Produce a documentation version of a template *)
let rec ppTemplate = function
StringArg s -> s
| TypeArg (l, t) -> "<" ^ ppMLtype t ^ ">"
| ListArg l -> "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate l) ^ "}"
| OptionalArgs (l, tl, d) ->
"?" ^ l ^ "{" ^ String.concat ~sep:" " (List.map ~f:ppTemplate tl)
^ "}[<" ^ String.concat ~sep:" " (List.map ~f:ppTemplate d) ^ ">]"
let doc_of_template = function
ListArg l -> String.concat ~sep:" " (List.map ~f:ppTemplate l)
| t -> ppTemplate t
(*
* Type definitions
*)
(* Write an ML constructor *)
let write_constructor ~w {ml_name = mlconstr; template = t} =
w mlconstr;
begin match types_of_template t with
[] -> ()
| l -> w " of ";
w (ppMLtype ~any:true (Product (List.map l
~f:(labeloff ~at:"write_constructor"))))
end;
w " (* tk option: "; w (doc_of_template t); w " *)"
(* Write a rhs type decl *)
let write_constructors ~w = function
[] -> fatal_error "empty type"
| x :: l ->
write_constructor ~w x;
List.iter l ~f:
begin fun x ->
w "\n | ";
write_constructor ~w x
end
(* Write an ML variant *)
let write_variant ~w {var_name = varname; template = t} =
w "`";
w varname;
begin match types_of_template t with
[] -> ()
| l ->
w " of ";
w (ppMLtype ~any:true ~def:true
(Product (List.map l ~f:(labeloff ~at:"write_variant"))))
end;
w " (* tk option: "; w (doc_of_template t); w " *)"
let write_variants ~w = function
[] -> fatal_error "empty variants"
| l ->
List.iter l ~f:
begin fun x ->
w "\n | ";
write_variant ~w x
end
(* Definition of a type *)
let labltk_write_type ~intf:w ~impl:w' name ~def:typdef =
(* Only needed if no subtypes, otherwise use optionals *)
if typdef.subtypes = [] then begin
w "(* Variant type *)\n";
w ("type " ^ name ^ " = [");
write_variants ~w (sort_components typdef.constructors);
w "\n]\n\n"
end
(* CamlTk: List of constructors, for runtime subtyping *)
let write_constructor_set ~w ~sep = function
| [] -> fatal_error "empty type"
| x::l ->
w ("C" ^ x.ml_name);
List.iter l ~f: (function x ->
w sep;
w ("C" ^ x.ml_name))
(* CamlTk: Definition of a type *)
let camltk_write_type ~intf:w ~impl:w' name ~def:typdef =
(* Put markers for extraction *)
w "(* type *)\n";
w ("type " ^ name ^ " =\n");
w " | ";
write_constructors ~w (sort_components typdef.constructors);
w "\n(* /type *)\n\n";
(* Dynamic Subtyping *)
if typdef.subtypes <> [] then begin
(* The set of its constructors *)
if name = "options" then begin
w "(* type *)\n";
w ("type "^name^"_constrs =\n\t")
end else begin
(* added some prefix to avoid being picked up in documentation *)
w ("(* no doc *) type "^name^"_constrs =\n")
end;
w " | ";
write_constructor_set ~w:w ~sep: "\n | "
(sort_components typdef.constructors);
w "\n\n";
(* The set of all constructors *)
w' ("let "^caml_name name^"_any_table = [");
write_constructor_set ~w:w' ~sep:"; "
(sort_components typdef.constructors);
w' ("]\n\n");
(* The subset of constructors for each subtype *)
List.iter ~f:(function (s,l) ->
w' ("let "^caml_name name^"_"^caml_name s^"_table = [");
write_constructor_set ~w:w' ~sep:"; " (sort_components l);
w' ("]\n\n"))
typdef.subtypes
end
let write_type ~intf:w ~impl:w' name ~def:typdef =
(if !Flags.camltk then camltk_write_type else labltk_write_type)
~intf:w ~impl:w' name ~def:typdef
(************************************************************)
(* Converters *)
(************************************************************)
let rec converterTKtoCAML ~arg = function
| Int -> "int_of_string " ^ arg
| Float -> "float_of_string " ^ arg
| Bool -> "(match " ^ arg ^ " with\n\
| \"1\" -> true\n\
| \"0\" -> false\n\
| s -> Pervasives.raise (Invalid_argument (\"cTKtoCAMLbool\" ^ s)))"
| Char -> "String.get " ^ arg ^ " 0"
| String -> arg
| UserDefined s -> "cTKtoCAML" ^ s ^ " " ^ arg
| Subtype ("widget", s') when not !Flags.camltk ->
String.concat ~sep:" "
["(Obj.magic (cTKtoCAMLwidget "; arg; ") :"; s'; "widget)"]
| Subtype (s, s') ->
if !Flags.camltk then
"cTKtoCAML" ^ s ^ " " ^ arg
else
"cTKtoCAML" ^ s' ^ "_" ^ s ^ " " ^ arg
| List ty ->
begin match type_parser_arity ty with
OneToken ->
String.concat ~sep:" "
["(List.map (function x ->";
converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"]
| MultipleToken ->
String.concat ~sep:" "
["iterate_converter (function x ->";
converterTKtoCAML ~arg:"x" ty; ")"; arg; ")"]
end
| As (ty, _) -> converterTKtoCAML ~arg ty
| t ->
prerr_endline ("ERROR with " ^ arg ^ " " ^ ppMLtype t);
fatal_error "converterTKtoCAML"
(*******************************)
(* Wrappers *)
(*******************************)
let varnames ~prefix n =
let rec var i =
if i > n then []
else (prefix ^ string_of_int i) :: var (succ i)
in var 1
(*
* generate wrapper source for callbacks
* transform a function ... -> unit in a function : unit -> unit
* using primitives arg_ ... from the protocol
* Warning: sequentiality is important in generated code
* TODO: remove arg_ stuff and process lists directly ?
*)
let rec wrapper_code ~name ty =
match ty with
Unit -> "(fun _ -> " ^ name ^ " ())"
| As (ty, _) -> wrapper_code ~name ty
| ty ->
"(fun args ->\n " ^
begin match ty with
Product tyl -> raise (Failure "Product -> record was done. ???")
| Record tyl ->
(* variables for each component of the product *)
let vnames = varnames ~prefix:"a" (List.length tyl) in
(* getting the arguments *)
let readarg =
List.map2 vnames tyl ~f:
begin fun v (l, ty) ->
match type_parser_arity ty with
OneToken ->
"let (" ^ v ^ ", args) = " ^
converterTKtoCAML ~arg:"(List.hd args)" ty ^
", List.tl args in\n "
| MultipleToken ->
"let (" ^ v ^ ", args) = " ^
converterTKtoCAML ~arg:"args" ty ^
" in\n "
end in
String.concat ~sep:"" readarg ^ name ^ " " ^
String.concat ~sep:" "
(List.map2 ~f:(fun v (l, _) ->
if !Flags.camltk then v
else labelstring l ^ v) vnames tyl)
(* all other types are read in one operation *)
| List ty ->
name ^ "(" ^ converterTKtoCAML ~arg:"args" ty ^ ")"
| String ->
name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")"
| ty ->
begin match type_parser_arity ty with
OneToken ->
name ^ "(" ^ converterTKtoCAML ~arg:"(List.hd args)" ty ^ ")"
| MultipleToken ->
"let (v, _) = " ^ converterTKtoCAML ~arg:"args" ty ^
" in\n " ^ name ^ " v"
end
end ^ ")"
(*************************************************************)
(* Parsers *)
(* are required only for values returned by commands and *)
(* functions (table is computed by the parser) *)
(* Tuples/Lists are Ok if they don't contain strings *)
(* they will be returned as list of strings *)
(* Can we generate a "parser" ?
-> all constructors are unit and at most one int and one string, with null constr
*)
type parser_pieces =
{ mutable zeroary : (string * string) list ; (* kw string, ml name *)
mutable intpar : string list; (* one at most, mlname *)
mutable stringpar : string list (* idem *)
}
type mini_parser =
NoParser
| ParserPieces of parser_pieces
let can_generate_parser constructors =
let pp = {zeroary = []; intpar = []; stringpar = []} in
if List.for_all constructors ~f:
begin fun c ->
let vname = if !Flags.camltk then c.ml_name else c.var_name in
match c.template with
ListArg [StringArg s] ->
pp.zeroary <- (s, vname) ::
pp.zeroary; true
| ListArg [TypeArg(_, Int)] | ListArg[TypeArg(_, Float)] ->
if pp.intpar <> [] then false
else (pp.intpar <- [vname]; true)
| ListArg [TypeArg(_, String)] ->
if pp.stringpar <> [] then false
else (pp.stringpar <- [vname]; true)
| _ -> false
end
then ParserPieces pp
else NoParser
(* We can generate parsers only for simple types *)
(* we should avoid multiple walks *)
let labltk_write_TKtoCAML ~w name ~def:typdef =
if typdef.parser_arity = MultipleToken then
prerr_string ("You must write cTKtoCAML" ^ name ^
" : string list ->" ^ name ^ " * string list\n")
else
let write ~consts ~name =
match can_generate_parser consts with
NoParser ->
prerr_string
("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n")
| ParserPieces pp ->
w ("let cTKtoCAML" ^ name ^ " n =\n");
(* First check integer *)
if pp.intpar <> [] then
begin
w (" try `" ^ List.hd pp.intpar ^ " (int_of_string n)\n");
w (" with _ ->\n")
end;
w (" match n with\n");
List.iter pp.zeroary ~f:
begin fun (tk, ml) ->
w " | \""; w tk; w "\" -> `"; w ml; w "\n"
end;
let final = if pp.stringpar <> [] then
"n -> `" ^ List.hd pp.stringpar ^ " n"
else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML"
^ name ^ ": \" ^ s))"
in
w " | ";
w final;
w "\n\n"
in
begin
write ~name ~consts:typdef.constructors;
List.iter typdef.subtypes ~f: begin
fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts
end
end
let camltk_write_TKtoCAML ~w name ~def:typdef =
if typdef.parser_arity = MultipleToken then
prerr_string ("You must write cTKtoCAML" ^ name ^
" : string list ->" ^ name ^ " * string list\n")
else
let write ~consts ~name =
match can_generate_parser consts with
NoParser ->
prerr_string
("You must write cTKtoCAML" ^ name ^ " : string ->" ^ name ^ "\n")
| ParserPieces pp ->
w ("let cTKtoCAML" ^ name ^ " n =\n");
(* First check integer *)
if pp.intpar <> [] then
begin
w (" try " ^ List.hd pp.intpar ^ " (int_of_string n)\n");
w (" with _ ->\n")
end;
w (" match n with\n");
List.iter pp.zeroary ~f:
begin fun (tk, ml) ->
w " | \""; w tk; w "\" -> "; w ml; w "\n"
end;
let final = if pp.stringpar <> [] then
"n -> " ^ List.hd pp.stringpar ^ " n"
else "s -> Pervasives.raise (Invalid_argument (\"cTKtoCAML"
^ name ^ ": \" ^ s))"
in
w " | ";
w final;
w "\n\n"
in
begin
write ~name ~consts:typdef.constructors;
List.iter typdef.subtypes ~f: begin
fun (subname, consts) -> write ~name:(subname ^ "_" ^ name) ~consts
end
end
let write_TKtoCAML ~w name ~def:typdef =
(if !Flags.camltk then camltk_write_TKtoCAML else labltk_write_TKtoCAML)
~w name ~def: typdef
(******************************)
(* Converters *)
(******************************)
(* Produce an in-lined converter OCaml -> Tk for simple types *)
(* the converter is a function of type: <type> -> string *)
let rec converterCAMLtoTK ~context_widget argname ty =
match ty with
Int -> "TkToken (string_of_int " ^ argname ^ ")"
| Float -> "TkToken (Printf.sprintf \"%g\" " ^ argname ^ ")"
| Bool -> "if " ^ argname ^ " then TkToken \"1\" else TkToken \"0\""
| Char -> "TkToken (Char.escaped " ^ argname ^ ")"
| String -> "TkToken " ^ argname
| As (ty, _) -> converterCAMLtoTK ~context_widget argname ty
| UserDefined s ->
let name = "cCAMLtoTK" ^ s ^ " " in
let args = argname in
let args =
if !Flags.camltk then begin
if is_subtyped s then (* unconstraint subtype *)
s ^ "_any_table " ^ args
else args
end else args
in
let args =
if requires_widget_context s then
context_widget ^ " " ^ args
else args in
name ^ args
| Subtype ("widget", s') ->
if !Flags.camltk then
let name = "cCAMLtoTKwidget " in
let args = "widget_"^caml_name s'^"_table "^argname in
let args =
if requires_widget_context "widget" then
context_widget^" "^args
else args in
name^args
else begin
let name = "cCAMLtoTKwidget " in
let args = "(" ^ argname ^ " : " ^ caml_name s' ^ " widget)" in
name ^ args
end
| Subtype (s, s') ->
let name =
if !Flags.camltk then "cCAMLtoTK" ^ s ^ " "
else "cCAMLtoTK" ^ s' ^ "_" ^ s ^ " "
in
let args =
if !Flags.camltk then begin
caml_name s^"_"^caml_name s'^"_table "^argname
end else begin
if safetype then
"(" ^ argname ^ " : [< " ^ caml_name s' ^ "_" ^ caml_name s ^ "])"
else argname
end
in
let args =
if requires_widget_context s then context_widget ^ " " ^ args
else args in
name ^ args
| Product tyl ->
let vars = varnames ~prefix:"z" (List.length tyl) in
String.concat ~sep:" "
("let" :: String.concat ~sep:"," vars :: "=" :: argname ::
"in TkTokenList [" ::
String.concat ~sep:"; "
(List.map2 vars tyl ~f:(converterCAMLtoTK ~context_widget)) ::
["]"])
| List ty -> (* Just added for Imagephoto.put *)
String.concat ~sep:" "
[(if !Flags.camltk then
"TkQuote (TkTokenList (List.map (fun y -> "
else
"TkQuote (TkTokenList (List.map ~f:(fun y -> ");
converterCAMLtoTK ~context_widget "y" ty;
")";
argname;
"))"]
| Function _ -> fatal_error "unexpected function type in converterCAMLtoTK"
| Unit -> fatal_error "unexpected unit type in converterCAMLtoTK"
| Record _ -> fatal_error "unexpected product type in converterCAMLtoTK"
(*
* Produce a list of arguments from a template
* The idea here is to avoid allocation as much as possible
*
*)
let code_of_template ~context_widget ?func:(funtemplate=false) template =
let catch_opts = ref ("", "") in (* class name and first option *)
let variables = ref [] in
let variables2 = ref [] in
let varcnter = ref 0 in
let optionvar = ref None in
let newvar1 l =
match !optionvar with
Some v -> optionvar := None; v
| None ->
incr varcnter;
let v = "v" ^ (string_of_int !varcnter) in
variables := (l, v) :: !variables; v in
let newvar2 l =
match !optionvar with
Some v -> optionvar := None; v
| None ->
incr varcnter;
let v = "v" ^ (string_of_int !varcnter) in
variables2 := (l, v) :: !variables2; v in
let newvar = ref newvar1 in
let rec coderec = function
StringArg s -> "TkToken \"" ^ s ^ "\""
| TypeArg (_, List (Subtype (sup, sub))) when not !Flags.camltk ->
begin try
let typdef = Hashtbl.find types_table sup in
let classdef = List.assoc sub typdef.subtypes in
let lbl = gettklabel (List.hd classdef) in
catch_opts := (sub ^ "_" ^ sup, lbl);
newvar := newvar2;
"TkTokenList opts"
with Not_found ->
raise (Failure (Printf.sprintf "type %s(%s) not found" sup sub));
end
| TypeArg (l, List ty) ->
(if !Flags.camltk then
"TkTokenList (List.map (function x -> "
else
"TkTokenList (List.map ~f:(function x -> ")
^ converterCAMLtoTK ~context_widget "x" ty
^ ") " ^ !newvar l ^ ")"
| TypeArg (l, Function tyarg) ->
"let id = register_callback " ^ context_widget
^ " ~callback: " ^ wrapper_code ~name:(!newvar l) tyarg
^ " in TkToken (\"camlcb \" ^ id)"
| TypeArg (l, ty) -> converterCAMLtoTK ~context_widget (!newvar l) ty
| ListArg l ->
"TkQuote (TkTokenList ["
^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "])"
| OptionalArgs (l, tl, d) ->
let nv = !newvar ("?" ^ l) in
optionvar := Some nv; (* Store *)
let argstr = String.concat ~sep:"; " (List.map ~f:coderec tl) in
let defstr = String.concat ~sep:"; " (List.map ~f:coderec d) in
"TkTokenList (match " ^ nv ^ " with\n"
^ " | Some " ^ nv ^ " -> [" ^ argstr ^ "]\n"
^ " | None -> [" ^ defstr ^ "])"
in
let code =
if funtemplate then
match template with
ListArg l ->
"[|" ^ String.concat ~sep:";\n " (List.map ~f:coderec l) ^ "|]"
| _ -> "[|" ^ coderec template ^ "|]"
else
match template with
ListArg [x] -> coderec x
| ListArg l ->
"TkTokenList [" ^
String.concat ~sep:";\n " (List.map ~f:coderec l) ^
"]"
| _ -> coderec template
in
code, List.rev !variables, List.rev !variables2, !catch_opts
(*
* Converters for user defined types
*)
(* For each case of a concrete type *)
let labltk_write_clause ~w ~context_widget comp =
let warrow () = w " -> " in
w "`";
w comp.var_name;
let code, variables, variables2, (co, _) =
code_of_template ~context_widget comp.template in
(* no subtype I think ... *)
if co <> "" then raise (Failure "write_clause subtype ?");
begin match variables with
| [] -> warrow()
| [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow()
| l ->
w " ( ";
w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l));
w ")";
warrow()
end;
w code
let camltk_write_clause ~w ~context_widget ~subtype comp =
let warrow () =
w " -> ";
if subtype then
w ("chk_sub \""^comp.ml_name^"\" table C" ^ comp.ml_name ^ "; ")
in
w comp.ml_name; (* we use ml_name, not var_name, specialized for labltk *)
let code, variables, variables2, (co, _) =
code_of_template ~context_widget comp.template in
(* no subtype I think ... *)
if co <> "" then raise (Failure "write_clause subtype ?");
begin match variables with
| [] -> warrow()
| [x] -> w " "; w (labeloff x ~at:"write_clause"); warrow()
| l ->
w " ( ";
w (String.concat ~sep:", " (List.map ~f:(labeloff ~at:"write_clause") l));
w ")";
warrow()
end;
w code
let write_clause ~w ~context_widget ~subtype comp =
if !Flags.camltk then camltk_write_clause ~w ~context_widget ~subtype comp
else labltk_write_clause ~w ~context_widget comp
(* The full converter *)
let write_CAMLtoTK ~w ~def:typdef ?safetype:(st = true) name =
let write_one name constrs =
let subtype = typdef.subtypes <> [] in
w ("let cCAMLtoTK" ^ name);
let context_widget =
if typdef.requires_widget_context then begin
w " w"; "w"
end
else
"dummy" in
if !Flags.camltk && subtype then w " table";
if st then begin
w " : ";
if typdef.variant then w ("[< " ^ name ^ "]") else w name;
w " -> tkArgs "
end;
w (" = function");
List.iter constrs
~f:(fun c -> w "\n | "; write_clause ~w ~context_widget ~subtype c);
w "\n\n\n"
in
let constrs = typdef.constructors in
if !Flags.camltk then write_one name constrs
else begin
(* Only needed if no subtypes, otherwise use optionals *)
if typdef.subtypes == [] then
write_one name constrs
else
List.iter constrs ~f:
begin fun fc ->
let code, vars, _, (co, _) =
code_of_template ~context_widget:"dummy" fc.template in
if co <> "" then fatal_error "optionals in optionals";
let vars = List.map ~f:snd vars in
w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name);
w " ("; w (String.concat ~sep:", " vars); w ") =\n ";
w code; w "\n\n"
end
end
(* Tcl does not really return "lists". It returns sp separated tokens *)
let rec write_result_parsing ~w = function
List String ->
w "(splitlist res)"
| List ty ->
if !Flags.camltk then
w (" List.map " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
else
w (" List.map ~f: " ^ converterTKtoCAML ~arg:"(splitlist res)" ty)
| Product tyl -> raise (Failure "Product -> record was done. ???")
| Record tyl -> (* of course all the labels are "" *)
let rnames = varnames ~prefix:"r" (List.length tyl) in
w " let l = splitlist res in";
w ("\n if List.length l <> " ^ string_of_int (List.length tyl));
w ("\n then Pervasives.raise (TkError (\"unexpected result: \" ^ res))");
w ("\n else ");
List.iter2 rnames tyl ~f:
begin fun r (l, ty) ->
if l <> "" then raise (Failure "lables in return type!!!");
w (" let " ^ r ^ ", l = ");
begin match type_parser_arity ty with
OneToken ->
w (converterTKtoCAML ~arg:"(List.hd l)" ty); w (", List.tl l")
| MultipleToken ->
w (converterTKtoCAML ~arg:"l" ty)
end;
w (" in\n")
end;
w (String.concat ~sep:", " rnames)
| String ->
w (converterTKtoCAML ~arg:"res" String)
| As (ty, _) -> write_result_parsing ~w ty
| ty ->
match type_parser_arity ty with
OneToken -> w (converterTKtoCAML ~arg:"res" ty)
| MultipleToken -> w (converterTKtoCAML ~arg:"(splitlist res)" ty)
let labltk_write_function ~w def =
w ("let " ^ caml_name def.ml_name);
(* a bit approximative *)
let context_widget = match def.template with
ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1"
| ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1"
| _ -> "dummy" in
let code, variables, variables2, (co, lbl) =
code_of_template ~func:true ~context_widget def.template in
(* Arguments *)
let uv, lv, ov =
let rec replace_args ~u ~l ~o = function
[] -> u, l, o
| ("", 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 (variables @ variables2))
in
let has_opts = (ov <> [] || co <> "") in
if not has_opts then List.iter uv ~f:(fun x -> w " "; w x);
List.iter (lv@ov) ~f:(fun (l, v) -> w " "; w (labelstring l); w v);
if co <> "" then begin
if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta");
w " =\n";
w (co ^ "_optionals");
if lv = [] && ov = [] then w (" ?" ^ lbl ^ ":eta");
w " (fun opts";
if uv = [] then w " ()" else
if has_opts then List.iter uv ~f:(fun x -> w " "; w x);
w " ->\n"
end else begin
if (ov <> [] || lv = []) && uv = [] then w " ()" else
if has_opts then List.iter uv ~f:(fun x -> w " "; w x);
w " =\n"
end;
begin match def.result with
| Unit | As (Unit, _) -> w "tkCommand "; w code
| ty ->
w "let res = tkEval "; w code ; w " in \n";
write_result_parsing ~w ty
end;
if co <> "" then w ")";
w "\n\n"
let camltk_write_function ~w def =
w ("let " ^ caml_name def.ml_name);
(* a bit approximative *)
let context_widget = match def.template with
ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1"
| ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1"
| _ -> "dummy" in
let code, variables, variables2, (co, lbl) =
code_of_template ~func:true ~context_widget def.template in
(* Arguments *)
let uv, ov =
let rec replace_args ~u ~o = function
[] -> u, o
| ("", 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 (variables @ variables2))
in
let has_opts = ov <> [] (* (ov <> [] || co <> "") *) in
if not has_opts then List.iter uv ~f:(fun x -> w " "; w x);
List.iter ov ~f:(fun (l, v) -> w " "; w (labelstring l); w v);
begin
if uv = [] then w " ()" else
if has_opts then List.iter uv ~f:(fun x -> w " "; w x);
w " =\n"
end;
begin match def.result with
| Unit | As (Unit, _) -> w "tkCommand "; w code
| ty ->
w "let res = tkEval "; w code ; w " in \n";
write_result_parsing ~w ty
end;
w "\n\n"
(*
w ("let " ^ def.ml_name);
(* a bit approximative *)
let context_widget = match def.template with
ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1"
| ListArg (TypeArg(_, Subtype("widget", _)) :: _) -> "v1"
| _ -> "dummy" in
let code, variables, variables2, (co, lbl) =
code_of_template ~func:true ~context_widget def.template in
let variables = variables @ variables2 in
(* Arguments *)
begin match variables with
[] -> w " () =\n"
| l ->
let has_normal_argument = ref false in
List.iter (fun (l,x) ->
w " ";
if l <> "" then
if l.[0] = '?' then w (l ^ ":") else has_normal_argument := true
else has_normal_argument := true;
w x) l;
if not !has_normal_argument then w " ()";
w " =\n"
end;
begin match def.result with
| Unit | As (Unit, _) -> w "tkCommand "; w code
| ty ->
w "let res = tkEval "; w code ; w " in \n";
write_result_parsing ~w ty
end;
w "\n\n"
*)
let write_function ~w def =
if !Flags.camltk then camltk_write_function ~w def
else labltk_write_function ~w def
;;
let labltk_write_create ~w clas =
let oclas = caml_name clas in
w ("let create ?name =\n");
w (" " ^ oclas ^ "_options_optionals (fun opts parent ->\n");
w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n");
w " tkCommand [|";
w ("TkToken \"" ^ clas ^ "\";\n");
w (" TkToken (Widget.name w);\n");
w (" TkTokenList opts |];\n");
w (" w)\n\n\n")
let camltk_write_create ~w clas =
w ("let create ?name parent options =\n");
w (" let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n");
w " tkCommand [|";
w ("TkToken \"" ^ clas ^ "\";\n");
w (" TkToken (Widget.name w);\n");
w (" TkTokenList (List.map (function x -> "^
converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n");
w (" |];\n");
w (" w\n\n")
let camltk_write_named_create ~w clas =
w ("let create_named parent name options =\n");
w (" let w = new_atom \"" ^ clas ^ "\" ~parent ~name in\n");
w " tkCommand [|";
w ("TkToken \"" ^ clas ^ "\";\n");
w (" TkToken (Widget.name w);\n");
w (" TkTokenList (List.map (function x -> "^
converterCAMLtoTK "w" "x" (Subtype("options",clas)) ^ ") options)\n");
w (" |];\n");
w (" w\n\n")
(* Search Path. *)
let search_path = ref ["."]
(* taken from utils/misc.ml *)
let find_in_path path name =
if not (Filename.is_implicit name) then
if Sys.file_exists name then name else raise Not_found
else begin
let rec try_dir = function
[] -> raise Not_found
| dir :: rem ->
let fullname = Filename.concat dir name in
if Sys.file_exists fullname then fullname else try_dir rem
in try_dir path
end
(* builtin-code: the file (without suffix) is in .template... *)
(* not efficient, but hell *)
let write_external ~w def =
match def.template with
| StringArg fname ->
begin try
let realname = find_in_path !search_path (fname ^ ".ml") in
let ic = open_in_bin realname in
try
let code_list = Ppparse.parse_channel ic in
close_in ic;
List.iter (Ppexec.exec (fun _ -> ()) w)
(if !Flags.camltk then
Code.Define "CAMLTK" :: code_list else code_list );
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")
let write_catch_optionals ~w clas ~def:typdef =
if typdef.subtypes = [] then () else
List.iter typdef.subtypes ~f:
begin fun (subclass, classdefs) ->
w ("let " ^ caml_name subclass ^ "_" ^ caml_name clas ^
"_optionals f = fun\n");
let tklabels = List.map ~f:gettklabel classdefs in
let l =
List.map classdefs ~f:
begin fun fc ->
(*
let code, vars, _, (co, _) =
code_of_template ~context_widget:"dummy" fc.template in
if co <> "" then fatal_error "optionals in optionals";
*)
let p = gettklabel fc in
(if count ~item:p tklabels > 1 then small fc.var_name else p),
small fc.ml_name
end in
let p = List.map l ~f:(fun (si, _) -> " ?" ^ si) in
let v =
List.map l ~f:
begin fun (si, s) ->
"(maycons ccCAMLtoTK" ^ caml_name clas ^ "_" ^ caml_name s ^ " " ^ si
end in
w (String.concat ~sep:"\n" p);
w " ->\n";
w " f ";
w (String.concat ~sep:"\n " v);
w "\n []";
w (String.make (List.length v) ')');
w "\n\n"
end