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

(*                                                                     *)

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

(*                                                                     *)

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

open Tables;;

open Format;;

let (.![]<-) = Bytes.set ;;

let escape_string s =

  let more = ref 0 in

  for i = 0 to String.length s - 1 do

   match s.[i] with

   | '\\' | '\"' | '\'' -> incr more

   |  _ -> ()

  done;

  if !more = 0 then s else

  let res = Bytes.create (String.length s + !more) in

  let j = ref 0 in

  for i = 0 to String.length s - 1 do

   let c = s.[i] in

   match c with

   | '\\' | '\"' |'\'' -> res.![!j] <- '\\'; incr j; res.![!j] <- c; incr j

   | _ -> res.![!j] <- c; incr j

  done;

  Bytes.to_string res

;;

let escape_char c = if c = '\'' then "\\\'" else String.make 1 c;;

let print_quoted_string s = printf "\"%s\"" (escape_string s);;

let print_quoted_char c = printf "\'%s\'" (escape_char c);;

let print_quoted_int i =

  if i < 0 then printf "(%d)" i else printf "%d" i

;;

let print_quoted_float f =

  if f <= 0.0 then printf "(%f)" f else printf "%f" f

;;

(* Iterators *)

let print_list f l =

  printf "@[<1>[";

  let rec pl = function

  | [] -> printf "@;<0 -1>]@]"

  | [x] -> f x; pl []

  | x :: xs -> f x; printf ";@ "; pl xs in

  pl l

;;

let print_array f v =

  printf "@[<2>[|";

  let l = Array.length v in

  if l >= 1 then f v.(0);

  if l >= 2 then

   for i = 1 to l - 1 do

    printf ";@ "; f v.(i)

   done;

  printf "@;<0 -1>|]@]"

;;

let print_option f = function

  | None -> print_string "None"

  | Some x -> printf "@[<1>Some@ "; f x; printf "@]"

;;

let print_bool = function

  | true -> print_string "true" | _ -> print_string "false"

;;

let print_poly x = print_string "<poly>";;

(* Types of the description language *)

let rec print_mltype = function

  | Unit -> printf "Unit" | Int -> printf "Int" | Float -> printf "Float"

  | Bool -> printf "Bool" | Char -> printf "Char" | String -> printf "String"

  | List m -> printf "@[<1>(%s@ " "List"; print_mltype m; printf ")@]"

  | Product l_m ->

     printf "@[<1>(%s@ " "Product"; print_list print_mltype l_m; printf ")@]"

  | Record l_t_s_m ->

     printf "@[<1>(%s@ " "Record";

     print_list

      (function (s, m) ->

        printf "@[<1>("; print_quoted_string s; printf ",@ "; print_mltype m;

        printf ")@]")

      l_t_s_m;

     printf ")@]"

  | UserDefined s ->

     printf "@[<1>(%s@ " "UserDefined"; print_quoted_string s; printf ")@]"

  | Subtype (s, s0) ->

     printf "@[<1>(%s@ " "Subtype"; printf "@[<1>("; print_quoted_string s;

     printf ",@ "; print_quoted_string s0; printf ")@]"; printf ")@]"

  | Function m ->

     printf "@[<1>(%s@ " "Function"; print_mltype m; printf ")@]"

  | As (m, s) ->

     printf "@[<1>(%s@ " "As"; printf "@[<1>("; print_mltype m; printf ",@ ";

     print_quoted_string s; printf ")@]"; printf ")@]"

;;

let rec print_template = function

  | StringArg s ->

     printf "@[<1>(%s@ " "StringArg"; print_quoted_string s; printf ")@]"

  | TypeArg (s, m) ->

     printf "@[<1>(%s@ " "TypeArg"; printf "@[<1>("; print_quoted_string s;

     printf ",@ "; print_mltype m; printf ")@]"; printf ")@]"

  | ListArg l_t ->

     printf "@[<1>(%s@ " "ListArg"; print_list print_template l_t;

     printf ")@]"

  | OptionalArgs (s, l_t, l_t0) ->

     printf "@[<1>(%s@ " "OptionalArgs"; printf "@[<1>(";

     print_quoted_string s; printf ",@ "; print_list print_template l_t;

     printf ",@ "; print_list print_template l_t0; printf ")@]"; printf ")@]"

;;

(* Sorts of components *)

let rec print_component_type = function

  | Constructor -> printf "Constructor" | Command -> printf "Command"

  | External -> printf "External"

;;

(* Full definition of a component *)

let rec print_fullcomponent = function

  {component = c; ml_name = s; var_name = s0; template = t; result = m;

   safe = b;

  } ->

    printf "@[<1>{"; printf "@[<1>component =@ "; print_component_type c;

    printf ";@]@ "; printf "@[<1>ml_name =@ "; print_quoted_string s;

    printf ";@]@ "; printf "@[<1>var_name =@ "; print_quoted_string s0;

    printf ";@]@ "; printf "@[<1>template =@ "; print_template t;

    printf ";@]@ "; printf "@[<1>result =@ "; print_mltype m; printf ";@]@ ";

    printf "@[<1>safe =@ "; print_bool b; printf ";@]@ "; printf "@,}@]"

;;

(* components are given either in full or abbreviated *)

let rec print_component = function

  | Full f -> printf "@[<1>(%s@ " "Full"; print_fullcomponent f; printf ")@]"

  | Abbrev s ->

     printf "@[<1>(%s@ " "Abbrev"; print_quoted_string s; printf ")@]"

;;

(* A type definition *)

(*

 requires_widget_context: the converter of the type MUST be passed

   an additional argument of type Widget.

*)

let rec print_parser_arity = function

  | OneToken -> printf "OneToken" | MultipleToken -> printf "MultipleToken"

;;

let rec print_type_def = function

  {parser_arity = p; constructors = l_f; subtypes = l_t_s_l_f;

   requires_widget_context = b; variant = b0;

  } ->

    printf "@[<1>{"; printf "@[<1>parser_arity =@ "; print_parser_arity p;

    printf ";@]@ "; printf "@[<1>constructors =@ ";

    print_list print_fullcomponent l_f; printf ";@]@ ";

    printf "@[<1>subtypes =@ ";

    print_list

     (function (s, l_f0) ->

       printf "@[<1>("; print_quoted_string s; printf ",@ ";

       print_list print_fullcomponent l_f0; printf ")@]")

     l_t_s_l_f;

    printf ";@]@ "; printf "@[<1>requires_widget_context =@ "; print_bool b;

    printf ";@]@ "; printf "@[<1>variant =@ "; print_bool b0; printf ";@]@ ";

    printf "@,}@]"

;;

let rec print_module_type = function

  | Widget -> printf "Widget" | Family -> printf "Family"

;;

let rec print_module_def = function

  {module_type = m; commands = l_f; externals = l_f0; } ->

    printf "@[<1>{"; printf "@[<1>module_type =@ "; print_module_type m;

    printf ";@]@ "; printf "@[<1>commands =@ ";

    print_list print_fullcomponent l_f; printf ";@]@ ";

    printf "@[<1>externals =@ "; print_list print_fullcomponent l_f0;

    printf ";@]@ "; printf "@,}@]"

;;