Add Services for Ocsigen.

types/types.ml

@@ -7,7 +7,7 @@ let () =
   Stats.register Stats.Summary
     (fun ppf -> Format.fprintf ppf "Allocated type nodes:%i@\n" !count)
 
-(*
+(* 
 To be sure not to use generic comparison ...
 *)
 let (=) : int -> int -> bool = (==)
@@ -25,6 +25,30 @@ type const =
   | Record of const label_map
   | String of U.uindex * U.uindex * U.t * const
 
+type service_params =
+  | TProd of service_params * service_params
+  | TOption of service_params 
+  | TList of string * service_params
+  | TSet of service_params
+  | TSum of service_params * service_params
+  | TString of string
+  | TInt of string
+  | TInt32 of string
+  | TInt64 of string
+  | TFloat of string 
+  | TBool of string
+  | TFile of string
+      (* | TUserType of string * (string -> 'a) * ('a -> string) *)
+  | TCoord of string 
+  | TCoordv of service_params * string
+  | TESuffix of string 
+  | TESuffixs of string
+      (*  | TESuffixu of (string * (string -> 'a) * ('a -> string)) *)
+  | TSuffix of (bool * service_params)
+  | TUnit 
+  | TAny
+  | TConst of string;;
+
 module Const = struct
   type t = const
 
@@ -1648,7 +1672,8 @@ struct
     if (pri >= 2) && (List.length def >= 2) 
     then Format.fprintf ppf "@[(%a)@]" aux def
     else aux ppf def
-  and do_print pri ppf = function
+  and do_print pri ppf = 
+    function
     | Neg { def = [] } -> Format.fprintf ppf "Any"
     | Neg t -> Format.fprintf ppf "Any \\ (@[%a@])" (do_print_slot 0) t
     | Abs t -> Format.fprintf ppf "?(@[%a@])" (do_print_slot 0) t
@@ -1748,7 +1773,7 @@ struct
 
 
   let get_name = function
-    | { state = `Named n } -> n
+      | { state = `Named n } -> n
     | _ -> assert false
 
   let print ppf t =
@@ -1797,6 +1822,96 @@ struct
     
 end
 
+module Service =
+struct
+  let prepare t = 
+    let t = Print.uniq t in
+    let t = Print.prepare t in 
+    Print.assign_name t;
+    t;;
+
+  let print_to_string f =
+    let b = Buffer.create 1024 in
+    let ppf = Format.formatter_of_buffer b in
+    f ppf;
+    Format.pp_print_flush ppf ();
+    Buffer.contents b
+
+  let get_gname (cu,n) =
+    Ns.QName.to_string n;;
+
+  let get_gtype t name =
+    let s = get_gname t in
+    match s with 
+      | "Int" -> TInt(name)
+      | "String" -> TString(name)
+      | "Float" -> TFloat(name)
+      | "Bool" -> TBool(name)
+      | _ -> TUnit;;
+
+  let rec convert (s : Print.nd) name = 
+    match s.Print.state with 
+      | `Named n -> assert false
+      | `GlobalName n -> get_gtype n name
+      | _ -> convert_real name s.Print.def
+  and convert_real name def = 
+    let rec aux = function
+      | [] -> assert false
+      | [ h ] -> convert_expr name h
+      | h :: t -> assert false
+    in 
+    aux def
+  and convert_expr name = function 
+    | Print.Neg { Print.def = [] } -> assert false
+    | Print.Neg t -> convert t name
+    | Print.Abs t -> convert t name
+    | Print.Name n -> assert false
+    | Print.Char c -> assert false
+    | Print.Regexp r -> convert_regexp name r
+    | Print.Xml (tag,attr,t) -> convert t (convert_tag tag);
+    | _ -> assert false
+  and convert_regexp name = function
+    | Pretty.Seq (r1,r2) -> 
+	TProd((convert_regexp name r1),(convert_regexp name r2))
+    | Pretty.Alt (r,Pretty.Epsilon) | Pretty.Alt (Pretty.Epsilon,r) -> 
+	  TOption((convert_regexp name r))
+    | Pretty.Alt (r1,r2) -> 
+	TSum((convert_regexp name r1), (convert_regexp name r2))
+    | Pretty.Star r -> TSet((convert_regexp name r))
+    | Pretty.Plus r -> TSet((convert_regexp name r))
+    | Pretty.Trans t -> convert t name
+    | _ -> assert false
+  and convert_tag =
+    function 
+      | `Tag s -> print_to_string s
+      | `Type t -> assert false;;
+
+  let clear () =
+    Print.count_name := 0; 
+    Print.to_print := [];
+    DescrHash.clear Print.memo;;
+
+  let to_service_params t = 
+    let s = prepare t in
+    let ret = convert s "" in
+    clear ();
+    ret;;
+
+  let to_string t =
+    let rec aux = function 
+      | TInt n -> "TInt(" ^ n ^ ")"
+      | TFloat n -> "TFloat(" ^ n ^ ")"
+      | TBool n -> "TBool(" ^ n ^ ")"
+      | TString n -> "TString(" ^ n ^ ")"
+      | TProd (e1, e2) -> "TProd(" ^ (aux e1) ^ "," ^ (aux e2) ^ ")"
+      | TOption e -> "TOption(" ^ (aux e) ^ ")"
+      | TSet e -> "TSet(" ^ (aux e) ^ ")"
+      | TUnit -> "TUnit()"
+      | TSum (e1, e2) -> "TSum(" ^ (aux e1) ^ "," ^ (aux e2) ^ ")"
+      | _ -> " unknown "
+    in aux t;;
+end
+
 module Positive =
 struct
   type rhs = [ `Type of descr | `Cup of v list | `Times of v * v | `Xml of v * v ]

types/types.mli

@@ -9,6 +9,29 @@ type const =
   | Record of const label_map
   | String of U.uindex * U.uindex * U.t * const
 
+type service_params =
+  | TProd of service_params * service_params
+  | TOption of service_params 
+  | TList of string * service_params
+  | TSet of service_params
+  | TSum of service_params * service_params
+  | TString of string
+  | TInt of string
+  | TInt32 of string
+  | TInt64 of string
+  | TFloat of string 
+  | TBool of string
+  | TFile of string
+      (* | TUserType of string * (string -> 'a) * ('a -> string) *)
+  | TCoord of string 
+  | TCoordv of service_params * string
+  | TESuffix of string 
+  | TESuffixs of string
+      (*  | TESuffixu of (string * (string -> 'a) * ('a -> string)) *)
+  | TSuffix of (bool * service_params)
+  | TUnit 
+  | TAny
+  | TConst of string;;
 
 module Const: Custom.T with type t = const
 
@@ -283,6 +306,12 @@ sig
   val to_string: t -> string
 end
 
+module Service :
+sig
+  val to_service_params: t -> service_params
+  val to_string: service_params -> string
+end
+
 module Witness: sig
   type witness
   val print_witness: Format.formatter -> witness -> unit