(***********************************************************************)

(*                                                                     *)

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