Commit bb6194bb authored by Jérôme Maloberti's avatar Jérôme Maloberti

Add Services for Ocsigen.

parent 63328458
......@@ -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 ]
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment