Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

3528 lines (3252 sloc) 166.11 kb
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
module String = Base.String
module List = Base.List
module PI = Parse_idl
module O = Ocaml
module Cons = O.Cons
let testfile = false
let debug = ref false
let verbose = ref (!debug)
let module_name = ref ""
let output_suffix = ref "types"
let bsl_prefix = ref "bsl"
(*let encoding_number = ref 2*)
let ocaml_wrap_opt = ref true
let opa_wrap_opt = ref true
let native_parser = ref true
let hlnet_logging = ref false
let protocol_version = ref 1
let default_port = ref 49152
let default_addr = ref "Unix.inet_addr_loopback"
let logger_function = ref "Logger.log"
let create_functions = ref true
let tojson_functions = ref true
let fromjson_functions = ref true
let string_functions = ref true
let bsl_file = ref true
let no_ocaml = ref false
let no_opa = ref false
let protocol_name = ref None
let mns = ref ""
let _Mns = ref ""
let bslmns = ref ""
let base = ref ""
type opts = {
opt_debug : bool;
opt_verbose : bool;
opt_module_name : string;
opt_output_suffix : string;
opt_bsl_prefix : string;
(*opt_encoding_number : int;*)
opt_ocaml_wrap_opt : bool;
opt_opa_wrap_opt : bool;
opt_native_parser : bool;
opt_hlnet_logging : bool;
opt_protocol_version : int;
opt_default_port : int;
opt_default_addr : string;
opt_logger_function : string;
opt_create_functions : bool;
opt_tojson_functions : bool;
opt_fromjson_functions : bool;
opt_string_functions : bool;
opt_bsl_file : bool;
opt_no_ocaml : bool;
opt_no_opa : bool;
opt_mns : string;
}
let default_opts = ref {
opt_debug = false;
opt_verbose = false;
opt_module_name = "";
opt_output_suffix = "types";
opt_bsl_prefix = "bsl";
(*opt_encoding_number = 2;*)
opt_ocaml_wrap_opt = true;
opt_opa_wrap_opt = true;
opt_native_parser = true;
opt_hlnet_logging = false;
opt_protocol_version = 1;
opt_default_port = 49152;
opt_default_addr = "Unix.inet_addr_loopback";
opt_logger_function = "Logger.log";
opt_create_functions = true;
opt_tojson_functions = true;
opt_fromjson_functions = true;
opt_string_functions = true;
opt_bsl_file = true;
opt_no_ocaml = false;
opt_no_opa = false;
opt_mns = "";
}
let save_opts () = {
opt_debug = !debug;
opt_verbose = !verbose;
opt_module_name = !module_name;
opt_output_suffix = !output_suffix;
opt_bsl_prefix = !bsl_prefix;
(*opt_encoding_number = !encoding_number;*)
opt_ocaml_wrap_opt = !ocaml_wrap_opt;
opt_opa_wrap_opt = !opa_wrap_opt;
opt_native_parser = !native_parser;
opt_hlnet_logging = !hlnet_logging;
opt_protocol_version = !protocol_version;
opt_default_port = !default_port;
opt_default_addr = !default_addr;
opt_logger_function = !logger_function;
opt_create_functions = !create_functions;
opt_tojson_functions = !tojson_functions;
opt_fromjson_functions = !fromjson_functions;
opt_string_functions = !string_functions;
opt_bsl_file = !bsl_file;
opt_no_ocaml = !no_ocaml;
opt_no_opa = !no_opa;
opt_mns = !mns;
}
let restore_opts {
opt_debug;
opt_verbose;
opt_module_name;
opt_output_suffix;
opt_bsl_prefix;
(*opt_encoding_number;*)
opt_ocaml_wrap_opt;
opt_opa_wrap_opt;
opt_native_parser;
opt_hlnet_logging;
opt_protocol_version;
opt_default_port;
opt_default_addr;
opt_logger_function;
opt_create_functions;
opt_tojson_functions;
opt_fromjson_functions;
opt_string_functions;
opt_bsl_file;
opt_no_ocaml;
opt_no_opa;
opt_mns;
} =
debug := opt_debug;
verbose := opt_verbose;
module_name := opt_module_name;
output_suffix := opt_output_suffix;
bsl_prefix := opt_bsl_prefix;
(* bslmns := opt_bsl_prefix; *)
(*encoding_number := opt_encoding_number;*)
ocaml_wrap_opt := opt_ocaml_wrap_opt;
opa_wrap_opt := opt_opa_wrap_opt;
native_parser := opt_native_parser;
hlnet_logging := opt_hlnet_logging;
protocol_version := opt_protocol_version;
default_port := opt_default_port;
default_addr := opt_default_addr;
logger_function := opt_logger_function;
create_functions := opt_create_functions;
tojson_functions := opt_tojson_functions;
fromjson_functions := opt_fromjson_functions;
string_functions := opt_string_functions;
bsl_file := opt_bsl_file;
no_ocaml := opt_no_ocaml;
no_opa := opt_no_opa;
mns := opt_mns
let printf = Printf.printf
let eprintf = Printf.eprintf
let fprintf = Printf.fprintf
let sprintf = Printf.sprintf
let rec ll l = match l with | [] -> [] | [_] -> [] | h::t -> h::(ll t)
let lc1 s = let ss = String.copy s in ss.[0] <- (Char.lowercase ss.[0]); ss
let ispfx pfxs name = List.exists (fun pfx -> String.is_prefix pfx name) pfxs
let name_of_prefix prefixes str =
List.fold_left (fun name pfx -> if String.is_prefix pfx name then String.remove_prefix pfx name else name) str prefixes
let opt () = if !ocaml_wrap_opt then " option" else ""
let optS () = if !ocaml_wrap_opt then "Some " else ""
let fail () = if !ocaml_wrap_opt then "None" else "raise (Failure \"parse_error\")"
let string_of_idl = function
| PI.IDLType (name,type_expr,None) -> sprintf "IDLType (%s,%s)" name (Tools.str_of_type_expr type_expr)
| PI.IDLType (name,type_expr,Some s) -> sprintf "IDLType (%s,%s,\"%s\")" name (Tools.str_of_type_expr type_expr) s
| PI.IDLSar (name,sndtype,rcvtype) -> sprintf "IDLSar (%s,%s,%s)" name sndtype rcvtype
| PI.IDLLet expr -> sprintf "IDLLet %s" (Tools.str_of_expr expr)
(* Handlers for typenames:
* Complicated by the presence of external types which are encoded in
* the type name as: ["external";<name>;[<ocaml type name (list)>]]
*)
type tn = string list
type ext = (string * string) list
type exts = (string * ext) list
type tyexts = tn list * exts
let string_of_tyns tyns = String.concat ", " (List.map (fun itn -> (String.concat "." itn)) tyns)
let string_of_tynames tynames = "["^(string_of_tyns tynames)^"]"
let string_of_al ?(sep1="; ") ?(sep2="=>") vtos al =
String.concat sep1 (List.map (fun (k,v) -> sprintf "%s%s%s" k sep2 (vtos v)) al)
let string_of_exts = string_of_al (fun l -> "["^string_of_al (fun s -> s) l^"]")
let string_of_tyexts ((tyns,exts):tyexts) = sprintf "([%s],<%s>)" (string_of_tyns tyns) (string_of_exts exts)
let opa_tyn tn ((tyns,exts):tyexts) =
match tn with
| [tn] -> [tn]
| [mn;tn] -> [(lc1 mn);tn]
| "external"::_ -> failwith "external type expected for OPA type name"
| _ -> assert false
let str_of_tyn = function
| "external"::_::rest -> String.concat "." rest
| tyn -> String.concat "." tyn
let tyn_base = function
| [tn] -> tn
| [_; tn] -> tn
| "external"::t::_ -> t
| _ -> assert false
let cmp_tyn tn1 tn2 = tyn_base tn1 = tyn_base tn2
type tyntype =
ExternalTyn of (tn * ext)
| InternalTyn of tn
| UnknownTyn
let get_tyn tn ((tyns,exts):tyexts) =
let tnb = tyn_base tn in
match List.find_opt (fun (name,_) -> name = tnb) exts, List.find_opt (fun tyn -> cmp_tyn tn tyn) tyns with
| (Some (_,ext),Some tn) -> ExternalTyn (tn,ext)
| (None,Some tn) -> InternalTyn tn
| _ -> UnknownTyn
let var_of_tyn tyn = "__"^(tyn_base tyn)
(* Module naming routines.
* Centralised here because we have to be able to access all of these
* from all phases.
*)
let rmv_suffix from_suffix filename =
if Filename.check_suffix filename from_suffix
then Filename.chop_suffix filename from_suffix
else filename
let getbase filename from_suffix =
if !module_name = ""
then rmv_suffix from_suffix (Filename.basename filename)
else !module_name
let setsuffix filename prefix from_suffix to_suffix extension =
let d = Filename.dirname filename in
let base = getbase filename from_suffix in
Filename.concat d ((Tools.add_prefix ~force_split:true (Tools.add_suffix base to_suffix) prefix)^extension)
let modnamesuffix from_suffix filename = Tools.add_suffix ~force_split:true (getbase filename from_suffix) !output_suffix
let prefixmodname prefix from_suffix filename = Tools.add_prefix ~force_split:true (modnamesuffix from_suffix filename) prefix
let output_header oc filename intro cs ce =
let tim = Time.localtime (Time.now ()) in
fprintf oc "%s Translated from %s\n%s Date: %s %s\n %s\n\n%s %s %s\n\n%!"
cs filename (if ce = "" then cs else " *") (Date.date2 tim) (Date.time tim) ce cs intro ce
let brre = Str.regexp "\\([{}]\\)"
let toopastr = Str.global_replace brre "\\\\\\1"
(* Generate OCaml types *)
let type_ocaml_cte = function
| O.TypeString -> "string"
| O.TypeInt -> "int"
| O.TypeInt64 -> "int64"
| O.TypeFloat -> "float"
| O.TypeBool -> "bool"
| O.TypeUnit -> "unit"
let rec type_ocaml_te tyns = function
| O.TypeName ([te],["option"]) -> sprintf "(%s) option" (type_ocaml_te tyns te)
| O.TypeName ([te],["list"]) -> sprintf "(%s) list" (type_ocaml_te tyns te)
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(*eprintf "n: %s\n%!" n;
eprintf "tyns: %s\n%!" (string_of_tyexts tyns);*)
(match get_tyn tn tyns with
| InternalTyn tn
| ExternalTyn (tn,_) ->
if tes = []
then sprintf "%s" (str_of_tyn tn)
else sprintf "%s %s" (String.concat "," (List.map (type_ocaml_te tyns) tes)) (str_of_tyn tn)
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> type_ocaml_cte cte
| O.TypeTuple tes ->
let args = List.map (fun te -> type_ocaml_te tyns te) tes in
sprintf "%s" (String.concat " * " args)
| O.TypeRecord l ->
let els = List.map (fun (_,lab,te) -> sprintf "%s:%s" lab (type_ocaml_te tyns te)) l in
sprintf "{%s}" (String.concat "; " els)
| O.TypeConstructor cl ->
let cons = List.map (fun (name,teo) ->
match teo with
| Some te -> sprintf "%s of %s" name (type_ocaml_te tyns te)
| None -> sprintf "%s" name
) cl in
sprintf "%s" (String.concat " | " cons)
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Generate OCaml types *)
(* Generate OPA types *)
let type_opa_cte = function
| O.TypeString -> "string"
| O.TypeInt -> "int"
| O.TypeInt64 -> "int64"
| O.TypeFloat -> "float"
| O.TypeBool -> "bool"
| O.TypeUnit -> "void"
let rec type_opa_te tyns = function
| O.TypeName ([te],["option"]) -> sprintf "option(%s)" (type_opa_te tyns te)
| O.TypeName ([te],["list"]) -> sprintf "list(%s)" (type_opa_te tyns te)
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(*eprintf "type_opa_te: TypeName(%s,%s)\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;*)
(match get_tyn tn tyns with
| InternalTyn [tn] ->
if tes = []
then sprintf "%s.%s" !mns tn
else sprintf "%s.%s(%s)" !mns tn (String.concat "," (List.map (type_opa_te tyns) tes))
| InternalTyn [mn;tn] ->
let on = str_of_tyn (opa_tyn [mn;tn] tyns) in
if tes = []
then sprintf "%s" on
else sprintf "%s(%s)" on (String.concat "," (List.map (type_opa_te tyns) tes))
| ExternalTyn (_,ext) ->
(try List.assoc "opatype" ext
with Not_found -> failwith (sprintf "No OPA type defined for external type %s" n))
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> type_opa_cte cte
| O.TypeTuple tes ->
let args = List.map (fun te -> type_opa_te tyns te) tes in
sprintf "(%s)" (String.concat "," args)
| O.TypeRecord l ->
let els = List.map (fun (_,lab,te) -> sprintf "%s:%s" lab (type_opa_te tyns te)) l in
sprintf "{%s}" (String.concat "; " els)
| O.TypeConstructor cl ->
let cons = List.map (fun (name,teo) ->
match teo with
| Some te -> sprintf "{%s:%s}" name (type_opa_te tyns te)
| None -> sprintf "{%s}" name
) cl in
sprintf "%s" (String.concat " / " cons)
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Generate OPA types *)
(* Generate OPA arg types *)
let opa_arg_type_cte = function
| O.TypeString -> "opa[string]"
| O.TypeInt -> "opa[int]"
| O.TypeInt64 -> "opa[int]"
| O.TypeFloat -> "opa[float]"
| O.TypeBool -> "opa[bool]"
| O.TypeUnit -> "opa[void]"
let rec opa_arg_type_te name = function
| O.TypeConst cte -> opa_arg_type_cte cte
| _ -> sprintf "opa[%s_%s]" !mns name
(* End of Generate OPA arg types *)
(* Generate ServerLib types *)
let type_sl_cte = function
| O.TypeString -> "ServerLib.ty_string"
| O.TypeInt -> "ServerLib.ty_int"
| O.TypeInt64 -> "ServerLib.ty_int"
| O.TypeFloat -> "ServerLib.ty_float"
| O.TypeBool -> "ServerLib.ty_bool"
| O.TypeUnit -> "ServerLib.ty_void"
let rec type_sl_te tyns withmod = function
| O.TypeName ([te],["option"]) -> "ServerLib.ty_record"
| O.TypeName ([te],["list"]) -> "ServerLib.ty_record"
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(match get_tyn tn tyns with
| InternalTyn [tn] ->
let m = if withmod then (!_Mns)^"." else "" in
if tes = []
then sprintf "%ssl_%s" m tn
else sprintf "%ssl_%s(%s)" m tn (String.concat "," (List.map (type_sl_te tyns withmod) tes))
| InternalTyn [mn;tn] ->
let on = str_of_tyn (opa_tyn [mn;tn] tyns) in
if tes = []
then sprintf "sl_%s" on
else sprintf "sl_%s(%s)" on (String.concat "," (List.map (type_sl_te tyns withmod) tes))
| ExternalTyn (_,_) -> "ServerLib.ty_record"
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> type_sl_cte cte
| O.TypeTuple tes -> "ServerLib.ty_record"
| O.TypeRecord l -> "ServerLib.ty_record"
| O.TypeConstructor cl -> "ServerLib.ty_record"
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Generate ServerLib types *)
(* Encoding descriptor *)
type lang = {
make_some : string -> string;
make_none : string;
make_cons : string -> string option -> string;
map_list : string -> string -> string;
map_while_opt : string -> string -> string;
list_sep : string;
flush_str : encoding -> string -> string -> string;
output_s : encoding -> string -> string -> string -> string;
output_v : encoding -> string -> string -> string -> string -> string;
output_a : encoding -> string -> string -> string -> string;
output_f : encoding -> string -> string -> string -> string;
output_m : encoding -> string -> string -> string -> (string * (string -> string)) list -> string;
output_l : encoding -> string -> string -> string -> (string -> string -> string) -> (string -> string) -> string;
make_ext_fn : encoding -> tyexts -> tn -> string;
pat_tup : string list -> string;
tup_v : O.type_expr -> string;
pat_rec : encoding -> string list -> string list -> string;
pat_con0 : string -> string; pat_con1 : string -> string -> string;
error : string -> string;
mtch : encoding -> string -> (string * string) list -> string;
fnctn : encoding -> (string * string) list -> string;
app : encoding -> string -> string -> string;
}
(* TODO: use this... *)
(*and prepost = {
first_pre : encoding -> string;
pre : string;
make : string -> string;
void : string;
sep1 : string;
sep2 : string;
post : string;
last_post : string;
}*)
and enc = {
string_to_string : string*string;
int_to_string : string*string;
int64_to_string : string*string;
float_to_string : string*string;
bool_to_string : string*string;
unit_to_string : string*string;
option_pre : string; option_post : string;
list_pre : string; list_post : string;
tuple_pre : int -> string; tuple_post : string;
record_pre : encoding -> string; record_post : string;
cons_pre : string; cons_post : string;
con_pre : string; con_sep : string; con_post : string; make_con : string -> string;
rec_pre : string; rec_sep1 : string; rec_sep2 : string; rec_post : string; make_rec : string -> string; rec_void : string;
tup_pre : string; tup_sep1 : string; tup_sep2 : string; tup_post : string; make_tup : string -> string;
lst_pre : string; lst_sep1 : string; lst_sep2 : string; lst_post : string;
(*rcrd : prepost;*)
}
and prs = {
wrap_opt : bool ref;
succeed : encoding -> string -> string;
fail : encoding -> string -> string;
string_pat : string*string*string;
int_pat : string*string*string;
int64_pat : string*string*string;
float_pat : string*string*string;
bool_pat : string*string*string;
char_pat : string*string*string;
unit_pat : string*string*string;
opt_pat : string option -> string;
list_pat : string -> string;
tup_field : int -> string;
pre_tup : (encoding -> int -> string -> string) option;
tuple_pat : int -> string;
pre_rec : (encoding -> string -> string) option;
record_pat : string list -> string;
cons_pat : string -> string option -> (string option) * string;
input_v : encoding -> string * string * string -> string;
}
and encoding = {
(* Internal data structures *)
foldstrs : bool;
str : string ref;
modname : string;
(* Name prefix for generated functions *)
prefix : string;
(* Define host language constructs *)
lang : lang;
(* Define encoding *)
enc : enc;
(* Define input parser *)
prs : prs;
}
(* Generic support routines *)
let flush_str enc o t =
if enc.foldstrs && !(enc.str) <> ""
then
let t = enc.lang.flush_str enc o t in
enc.str := ""; t
else t
let make_ext enc o t tyexts tyn =
enc.lang.app enc (enc.lang.app enc (enc.lang.make_ext_fn enc tyexts tyn) (flush_str enc o t)) (var_of_tyn tyn)
let make_ext2 enc tyexts tyn t = enc.lang.app enc (enc.lang.make_ext_fn enc tyexts tyn) t
let make_ext3 enc o t tyexts tyn =
enc.lang.app enc (enc.lang.app enc o (flush_str enc o t))
(enc.lang.app enc (enc.lang.make_ext_fn enc tyexts tyn) (var_of_tyn tyn))
let make_ext4 enc tyexts tyn t =
enc.lang.app enc
(enc.lang.app enc "input_external" t)
(enc.lang.make_ext_fn enc tyexts tyn)
let make_ext5 enc o t tyexts tyn =
enc.lang.output_v enc (var_of_tyn tyn) o t (enc.lang.make_ext_fn enc tyexts tyn)
let output_br enc o t l r f a = enc.lang.output_s enc o (f (enc.lang.output_s enc o t l) a) r
let rec output_seq enc i o f sep t = function
| [] -> t
| [v] -> f i t v
| v::vs -> output_seq enc (i+1) o f sep (enc.lang.output_s enc o (f i t v) sep) vs
let make_tup enc name value _ =
sprintf "%s%s%s%s%s%s%s"
(enc.enc.tuple_pre 0) enc.enc.rec_pre (enc.enc.make_tup name) enc.enc.tup_sep1 value enc.enc.tup_post enc.enc.tuple_post
let make_tups enc nvs =
sprintf "%s%s%s"
(enc.enc.tuple_pre (List.length nvs))
(String.concat enc.enc.tup_sep2
(List.map (fun (name,value) ->
sprintf "%s%s%s%s%s" enc.enc.tup_pre (enc.enc.make_tup name) enc.enc.tup_sep1 value enc.enc.tup_post) nvs))
enc.enc.tuple_post
let make_rec enc name value _ =
sprintf "%s%s%s%s%s%s%s"
(enc.enc.record_pre enc) enc.enc.rec_pre (enc.enc.make_rec name) enc.enc.rec_sep1 value enc.enc.rec_post enc.enc.record_post
let make_recs enc nvs =
sprintf "%s%s%s"
(enc.enc.record_pre enc)
(String.concat enc.enc.rec_sep2
(List.map (fun (name,value) ->
sprintf "%s%s%s%s%s" enc.enc.rec_pre (enc.enc.make_rec name) enc.enc.rec_sep1 value enc.enc.rec_post) nvs))
enc.enc.record_post
let ocaml_input_pvs enc (p,v,s) =
if v = ""
then enc.lang.fnctn enc [(enc.lang.pat_con0 p,enc.prs.succeed enc s); ("_",enc.prs.fail enc p)]
else enc.lang.fnctn enc [(enc.lang.pat_con1 p v,enc.prs.succeed enc s); ("_",enc.prs.fail enc p)]
let ocaml_input_str enc (p,v,s) =
enc.lang.app enc p v
(* End of generic support routines *)
(* Wrappers for optional inputs *)
let wrap_opt_some enc res v =
let ro = enc.lang.app enc res v in
if !(enc.prs.wrap_opt)
then
enc.lang.mtch enc ro [
(enc.lang.make_some v, enc.lang.make_some (enc.lang.make_some v));
(enc.lang.make_none, enc.lang.make_none);
]
else enc.lang.make_some ro
let wrap_opt_none enc = if !(enc.prs.wrap_opt) then enc.lang.make_some enc.lang.make_none else enc.lang.make_none
let wrap_list enc res v = (if !(enc.prs.wrap_opt) then enc.lang.map_while_opt else enc.lang.map_list) res v
let wrap_tuple enc n ress =
if !(enc.prs.wrap_opt)
then
let vs = List.init n (fun i -> sprintf "__%d" i) in
let p = "("^String.concat ", " (List.map (fun v -> enc.lang.make_some v) vs)^")" in
let e = sprintf "(%s)" (String.concat ", " vs) in
enc.lang.mtch enc ress [
(p, enc.lang.make_some e);
("_", enc.lang.make_none);
]
else ress
let wrap_record enc names labs =
if !(enc.prs.wrap_opt)
then
let vs = List.map (fun l -> sprintf "__%s" l) names in
let p = sprintf "(%s)" (String.concat ", " (List.map (fun v -> enc.lang.make_some v) vs)) in
let e = sprintf "{%s}" (String.concat "; " (List.map (fun v -> sprintf "%s=__%s" v v) names)) in
enc.lang.mtch enc ("("^String.concat ",\n " labs^")") [
(p, enc.lang.make_some e);
("_", enc.lang.make_none);
]
else
sprintf "{%s}" (String.concat "; " (List.map2 (fun n l -> sprintf "%s=%s" n l) names labs))
let wrap_cons enc name reso =
if !(enc.prs.wrap_opt)
then
match reso with
| Some (te,res) ->
let v = enc.lang.tup_v te in
enc.lang.mtch enc res [(enc.lang.make_some v, enc.lang.make_some (enc.lang.make_cons name (Some v)));
("_", enc.lang.make_none);]
| None ->
enc.lang.make_some (enc.lang.make_cons name None)
else
enc.lang.make_cons name (Option.map snd reso)
(* End of wrappers for optional inputs *)
(* Abstract output *)
let tup_v = function
| O.TypeTuple ttes -> sprintf "(%s)" (String.concat "," (List.mapi (fun i _ -> sprintf "__v%d" i) ttes))
| _ -> "__v"
let abs_output_cte enc o t = function
| O.TypeString -> enc.lang.output_v enc (fst enc.enc.string_to_string) o t (snd enc.enc.string_to_string)
| O.TypeInt -> enc.lang.output_v enc (fst enc.enc.int_to_string) o t (snd enc.enc.int_to_string)
| O.TypeInt64 -> enc.lang.output_v enc (fst enc.enc.int64_to_string) o t (snd enc.enc.int64_to_string)
| O.TypeFloat -> enc.lang.output_v enc (fst enc.enc.float_to_string) o t (snd enc.enc.float_to_string)
| O.TypeBool -> enc.lang.output_v enc (fst enc.enc.bool_to_string) o t (snd enc.enc.bool_to_string)
| O.TypeUnit -> enc.lang.output_v enc (fst enc.enc.unit_to_string) o t (snd enc.enc.unit_to_string)
let rec abs_output_te enc o t tyns = function
| O.TypeName ([te],["option"]) ->
enc.lang.output_f enc o "__o"
(output_br enc o t enc.enc.option_pre enc.enc.option_post
(fun t te ->
enc.lang.output_m enc o t "__o"
[(enc.lang.make_some "__v",
(fun t ->
output_br enc o t (enc.enc.con_pre^(enc.enc.make_con "Some")^enc.enc.con_sep) enc.enc.con_post
(fun t te ->
enc.lang.output_a enc o (abs_output_te enc o t tyns te) "__v") te));
(enc.lang.make_none,
(fun t ->
enc.lang.output_s enc o t (enc.enc.con_pre^(enc.enc.make_con "None")^enc.enc.con_post)))]
) te)
| O.TypeName ([te],["list"]) ->
enc.lang.output_f enc o "__l"
(output_br enc o t enc.enc.list_pre enc.enc.list_post
(fun t te -> enc.lang.output_l enc o t "__l"
(fun t h ->
output_br enc o t enc.enc.lst_pre enc.enc.lst_post
(fun t te -> enc.lang.output_a enc o (abs_output_te enc o t tyns te) h)
te)
(fun t -> enc.lang.output_s enc o t enc.enc.lst_sep1)
) te)
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(match get_tyn tn tyns with
| InternalTyn tn ->
enc.lang.output_f enc o (var_of_tyn tn) (make_ext enc o t tyns tn)
| ExternalTyn (tn,_) ->
(*enc.lang.output_f enc o (var_of_tyn tn)*) (make_ext5 enc o t tyns tn)
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> abs_output_cte enc o t cte
| O.TypeTuple tes ->
let args = List.mapi (fun i _te -> sprintf "__%d" i) tes in
enc.lang.output_f enc o (enc.lang.pat_tup args)
(output_br enc o t (enc.enc.tuple_pre (List.length tes)) enc.enc.tuple_post
(fun t te ->
output_seq enc 0 o
(fun i t te ->
output_br enc o t enc.enc.tup_pre enc.enc.tup_post
(fun t te ->
enc.lang.output_a enc o (abs_output_te enc o t tyns te) (sprintf "__%d" i)) te)
enc.enc.tup_sep1 t tes) tes)
| O.TypeRecord l ->
let labs = List.map (fun (_,lab,_) -> lab) l in
enc.lang.output_f enc o (enc.lang.pat_rec enc labs labs)
(output_br enc o t (enc.enc.record_pre enc) enc.enc.record_post
(fun t l ->
output_seq enc 0 o
(fun _ t (_,lab,te) ->
output_br enc o t (sprintf "%s%s%s" enc.enc.rec_pre (enc.enc.make_rec lab) enc.enc.rec_sep1)
enc.enc.rec_post
(fun t te ->
enc.lang.output_a enc o (abs_output_te enc o t tyns te) lab) te) enc.enc.rec_sep2 t l) l)
| O.TypeConstructor cl ->
enc.lang.output_f enc o "__c"
(output_br enc o t enc.enc.cons_pre enc.enc.cons_post
(fun t cl ->
enc.lang.output_m enc o t "__c" (
List.map (fun (name,teo) ->
match teo with
| Some te ->
let v = enc.lang.tup_v te in
(enc.lang.pat_con1 name v,
(fun t ->
output_br enc o t (sprintf "%s%s%s" enc.enc.con_pre (enc.enc.make_con name) enc.enc.con_sep)
enc.enc.con_post
(fun t te -> enc.lang.output_a enc o (abs_output_te enc o t tyns te) v) te))
| None ->
(enc.lang.pat_con0 name,(fun t ->
enc.lang.output_s enc o t (sprintf "%s%s%s" enc.enc.con_pre (enc.enc.make_con name)
enc.enc.con_post)))
) cl
)
) cl)
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Abstract output *)
(* Abstract input2 *)
let abs_input2_cte enc = function
| O.TypeString -> enc.prs.input_v enc enc.prs.string_pat
| O.TypeInt -> enc.prs.input_v enc enc.prs.int_pat
| O.TypeInt64 -> enc.prs.input_v enc enc.prs.int64_pat
| O.TypeFloat -> enc.prs.input_v enc enc.prs.float_pat
| O.TypeBool -> enc.prs.input_v enc enc.prs.bool_pat
| O.TypeUnit -> enc.prs.input_v enc enc.prs.unit_pat
let input_fix enc str success =
if str = ""
then success
else sprintf "if input_fixed t \"%s\" then %s else %s" str success (enc.prs.fail enc str)
let make_list enc l = "["^String.concat enc.lang.list_sep l^"]"
let quote s = "\""^s^"\""
let input_rec enc recs =
let strs = List.map (fun (s,c) -> quote s) recs in
enc.lang.mtch enc
(enc.lang.app enc (enc.lang.app enc "input_fixeds" "t") (make_list enc strs))
((List.map (fun (s,c) -> (enc.lang.make_some (quote s),c)) recs)@[("_",enc.prs.fail enc (String.concat "," strs))])
let input_m enc v m s =
if !(enc.prs.wrap_opt)
then enc.lang.mtch enc m [((enc.lang.make_some v),s); ("_",enc.prs.fail enc m)]
else enc.lang.mtch enc m [(v,s)]
let input_seq enc pre sep post es output =
input_fix enc pre
(let rec aux l = function
| [] -> input_fix enc post (output (List.rev l))
| (v,e)::[] -> input_m enc v e (input_fix enc post (output (List.rev (v::l))))
| (v,e)::rest -> input_m enc v e (input_fix enc sep (aux (v::l) rest))
in
aux [] es)
let apps enc fs =
let rec aux = function
| [] -> assert false
| [a] -> a
| f::a::rest -> aux ((enc.lang.app enc f a)::rest)
in
aux fs
let rec abs_input2_te enc tyns = function
| O.TypeName ([te],["option"]) ->
input_fix enc enc.enc.option_pre
(input_fix enc enc.enc.con_pre
(input_rec enc
[(enc.enc.make_con "Some",
(input_fix enc enc.enc.con_sep
(input_m enc "__v" (abs_input2_te enc tyns te)
(input_fix enc enc.enc.con_post
(input_fix enc enc.enc.option_post
(enc.prs.succeed enc (enc.lang.make_some "__v")))))));
(enc.enc.make_con "None",
(input_fix enc enc.enc.con_post
(input_fix enc enc.enc.option_post (enc.prs.succeed enc enc.lang.make_none))))]))
| O.TypeName ([te],["list"]) ->
apps enc ["input_list"; (quote enc.enc.list_pre); (quote enc.enc.lst_sep1); (quote enc.enc.list_post);
(enc.lang.fnctn enc [("t",
(input_fix enc enc.enc.lst_pre
(if enc.enc.lst_post = ""
then (input_fix enc enc.enc.lst_pre
(abs_input2_te enc tyns te))
else (input_m enc "__v" (abs_input2_te enc tyns te)
(input_fix enc enc.enc.lst_post
(enc.prs.succeed enc "__v"))))))]); "t"]
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(match get_tyn tn tyns with
| InternalTyn tn ->
make_ext2 enc tyns tn "t"
| ExternalTyn (tn,_) ->
make_ext4 enc tyns tn "t"
| _ -> (eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> abs_input2_cte enc cte
| O.TypeTuple tes ->
let es = List.mapi (fun i te ->
let arg = sprintf "__%d" i in
arg,
(input_fix enc enc.enc.tup_pre
(input_m enc "__v" (abs_input2_te enc tyns te)
(input_fix enc enc.enc.tup_post
(enc.prs.succeed enc "__v"))))) tes in
input_seq enc (enc.enc.tuple_pre (List.length tes)) enc.enc.tup_sep1 enc.enc.tuple_post
es (fun s -> enc.prs.succeed enc (String.concat ", " s))
| O.TypeRecord l ->
let labs = List.map (fun (_,lab,_) -> lab) l in
let es = List.map (fun (_,lab,te) ->
"__"^lab,
(input_fix enc enc.enc.rec_pre
(input_fix enc (enc.enc.make_con lab)
(input_fix enc enc.enc.rec_sep1
(input_m enc "__v" (abs_input2_te enc tyns te)
(input_fix enc enc.enc.rec_post
(enc.prs.succeed enc "__v"))))))) l in
input_seq enc (enc.enc.record_pre enc) enc.enc.rec_sep2 enc.enc.record_post es
(fun ls -> enc.prs.succeed enc (enc.lang.pat_rec enc labs ls))
| O.TypeConstructor cl ->
input_fix enc enc.enc.cons_pre
(input_fix enc enc.enc.con_pre
(input_rec enc
(List.map (fun (name,teo) ->
match teo with
| Some te ->
let v = enc.lang.tup_v te in
((enc.enc.make_con name),
(input_fix enc enc.enc.con_sep
(input_m enc v (abs_input2_te enc tyns te)
(input_fix enc enc.enc.con_post
(input_fix enc enc.enc.cons_post
(enc.prs.succeed enc (enc.lang.make_cons name (Some v))))))))
| None ->
((enc.enc.make_con name),
(input_fix enc enc.enc.con_post
(input_fix enc enc.enc.cons_post (enc.prs.succeed enc (enc.lang.make_cons name None)))))) cl)))
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Abstract input2 *)
(* Abstract json output *)
(* Note: we only use Record and List here. *)
(* Note: we ignore the "o" and "t" parameters but we keep the same encoding function signatures. *)
let match_record enc v pes =
match pes, enc.prs.pre_rec with
| (pes, Some pr) -> enc.lang.output_f enc "" v (enc.lang.mtch enc (pr enc v) (pes@[("_",enc.lang.error "match_record")]))
| ([p,e], None) -> enc.lang.output_f enc "" p e
| (_, _) -> assert false
let match_tuple enc i v p e =
match enc.prs.pre_tup with
| Some pr -> enc.lang.output_f enc "" v (enc.lang.mtch enc (pr enc i v) [(p,e); ("_",enc.lang.error "match_tuple")])
| None -> enc.lang.output_f enc "" p e
let rec abs_tojson_te enc tyns = function
| O.TypeName ([te],["option"]) ->
enc.lang.output_m enc "" "" "__t"
[(enc.lang.make_some "__v", (make_rec enc "Some" (enc.lang.output_a enc "" (abs_tojson_te enc tyns te) "__v")));
(enc.lang.make_none, (make_rec enc "None" enc.enc.rec_void)); ]
| O.TypeName ([te],["list"]) ->
enc.lang.output_l enc "" "" "__l" (fun h _ -> enc.lang.output_a enc "" (abs_tojson_te enc tyns te) h) (fun x -> x)
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(match get_tyn tn tyns with
| InternalTyn tn | ExternalTyn (tn,_) ->
enc.lang.output_f enc "" (var_of_tyn tn) (make_ext2 enc tyns tn (var_of_tyn tn))
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> abs_output_cte enc "" "" cte
| O.TypeTuple tes ->
let args = List.mapi (fun i _te -> enc.prs.tup_field i) tes in
let nvs = List.mapi (fun i te -> (enc.prs.tup_field i,
sprintf "(%s(%s))" (abs_tojson_te enc tyns te) (enc.prs.tup_field i))) tes in (*FIXME!!!*)
enc.lang.output_f enc "" (enc.lang.pat_tup args) (make_tups enc nvs)
(*match_tuple enc (List.length tes) "__t" (enc.lang.pat_tup args) (make_tups enc nvs)*)
| O.TypeRecord l ->
let labs = List.map (fun (_,lab,_) -> lab) l in
let nvs = List.map (fun (_,lab,te) -> lab, sprintf "(%s(%s))" (abs_tojson_te enc tyns te) lab) l in
enc.lang.output_f enc "" "__r" (enc.lang.mtch enc "__r" [(enc.lang.pat_rec enc labs labs),(make_recs enc nvs)])
(*match_record enc "__r" [(enc.lang.pat_rec enc labs labs),(make_recs enc nvs)]*)
| O.TypeConstructor cl ->
enc.lang.output_m enc "" "" "__t"
(List.map (fun (name,teo) ->
match teo with
| Some te ->
let v = enc.lang.tup_v te in
(enc.lang.pat_con1 name v,
(make_rec enc name (enc.lang.output_a enc "" (abs_tojson_te enc tyns te) v)))
| None ->
(enc.lang.pat_con0 name,
(make_rec enc name enc.enc.rec_void))) cl)
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of abstract json output *)
(* Concrete wrap/unwrap output/input *)
let rec abs_un_wrap_te enc tyns = function
| O.TypeName ([te],["option"]) ->
(match enc.prefix with
| "wrap" -> sprintf "(fun __o -> wrap_opt %s __o)" (abs_un_wrap_te enc tyns te)
| "unwrap" -> sprintf "(fun __o -> (match unwrap_rcrd __o with [(\"some\",__v)] -> Some (%s __v) | [(\"none\",_)] -> None | _ -> raise (Failure \"match_option\")))" (abs_un_wrap_te enc tyns te)
| _ -> assert false)
| O.TypeName ([te],["list"]) ->
(match enc.prefix with
| "wrap" -> sprintf "(fun __l -> wrap_lst %s __l)" (abs_un_wrap_te enc tyns te)
| "unwrap" -> sprintf "(fun __l -> (match unwrap_lst %s __l with Some __l -> __l | _ -> raise (Failure \"match_list\")))"
(abs_un_wrap_te enc tyns te)
| _ -> assert false)
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(match get_tyn tn tyns with
| InternalTyn tn ->
enc.lang.output_f enc "" (var_of_tyn tn) (make_ext2 enc tyns tn (var_of_tyn tn))
| ExternalTyn (tn,_) ->
enc.lang.output_f enc "" (var_of_tyn tn) (make_ext2 enc tyns tn (var_of_tyn tn))
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> abs_output_cte enc "" "" cte
| O.TypeTuple tes ->
(match enc.prefix with
| "wrap" ->
enc.lang.fnctn enc
["("^(String.concat "," (List.mapi (fun i _te -> sprintf "f%d" (i+1)) tes))^")",
"ServerLib.make_record ("^
(snd (List.fold_left
(fun (i,t) te ->
(i+1,sprintf "(ServerLib.add_field %s (ServerLib.static_field_of_name \"f%d\") (%s f%d))"
t i (abs_un_wrap_te enc tyns te) i))
(1,"ServerLib.empty_record_constructor") tes))^")"]
| "unwrap" ->
let mtchs = List.mapi (fun i _te -> sprintf "ServerLib.dot __t (ServerLib.static_field_of_name \"f%d\")" (i+1)) tes in
let mtche = sprintf "(%s)" (String.concat "," mtchs) in
let vs = List.mapi (fun i te -> (te,sprintf "__v%d" (i+1))) tes in
let vps = List.map (fun (_,v) -> sprintf "Some %s" v) vs in
let vp = sprintf "(%s)" (String.concat "," vps) in
let ve = sprintf "(%s)" (String.concat "," (List.map (fun (te,v) -> sprintf "%s %s" (abs_un_wrap_te enc tyns te) v) vs)) in
enc.lang.fnctn enc ["__t",enc.lang.mtch enc mtche [(vp,ve); ("_","raise (Failure \"match_tuple\")")]]
| _ -> assert false)
| O.TypeRecord l ->
let mname = if enc.modname = "" then "" else (String.capitalize enc.modname)^". " in
(match enc.prefix with
| "wrap" ->
enc.lang.fnctn enc
["{"^mname^(String.concat ";" (List.map (fun (_,lab,_te) -> sprintf "%s=__%s" lab lab) l))^"}",
"ServerLib.make_record ("^
(List.fold_left
(fun t (_,lab,te) ->
sprintf "(ServerLib.add_field %s (ServerLib.static_field_of_name \"%s\") (%s __%s))"
t lab (abs_un_wrap_te enc tyns te) lab)
"ServerLib.empty_record_constructor" l)^")"]
| "unwrap" ->
let mtchs = List.map (fun (_,lab,_te) ->
sprintf "ServerLib.dot __r (ServerLib.static_field_of_name \"%s\")" lab) l in
let mtche = sprintf "(%s)" (String.concat "," mtchs) in
let vs = List.mapi (fun i (_,lab,_te) -> sprintf "__%s" lab) l in
let vps = List.map (fun v -> sprintf "Some %s" v) vs in
let vp = sprintf "(%s)" (String.concat "," vps) in
let ves = List.mapi (fun i (_,lab,te) -> sprintf "%s=(%s __%s)" lab (abs_un_wrap_te enc tyns te) lab) l in
let ve = sprintf "{%s%s}" mname (String.concat ";" ves) in
enc.lang.fnctn enc ["__r",enc.lang.mtch enc mtche [(vp,ve); ("_","raise (Failure \"match_record\")")]]
| _ -> assert false)
| O.TypeConstructor cl ->
(match enc.prefix with
| "wrap" ->
enc.lang.output_m enc "" "" "__t"
(List.map (fun (name,teo) ->
let mname = (if enc.modname = "" then name else (String.capitalize enc.modname)^"."^name) in
match teo with
| Some te ->
let v = enc.lang.tup_v te in
(enc.lang.pat_con1 mname v,
(make_rec enc name (enc.lang.output_a enc "" (abs_un_wrap_te enc tyns te) v)))
| None ->
(enc.lang.pat_con0 mname,
(make_rec enc name enc.enc.rec_void))) cl)
| "unwrap" ->
enc.lang.output_f enc "" "__t"
(enc.lang.mtch enc "unwrap_rcrd __t"
((List.map
(fun (name,teo) ->
let mname = (if enc.modname = "" then name else (String.capitalize enc.modname)^"."^name) in
match teo with
| Some te ->
let v = enc.lang.tup_v te in
sprintf "[(\"%s\",_)]" name,
sprintf "let %s = (%s (ServerLib.unsafe_dot __t (ServerLib.static_field_of_name \"%s\"))) in (%s %s)"
v (abs_un_wrap_te enc tyns te) name mname v
| None ->
sprintf "[(\"%s\",_)]" name, sprintf "%s" mname) cl)
@[("_",enc.lang.error "match_constructor")]))
| _ -> assert false)
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Concrete wrap/unwrap output/input *)
(* Abstract input *)
let abs_input_cte enc = function
| O.TypeString -> enc.prs.input_v enc enc.prs.string_pat
| O.TypeInt -> enc.prs.input_v enc enc.prs.int_pat
| O.TypeInt64 -> enc.prs.input_v enc enc.prs.int64_pat
| O.TypeFloat -> enc.prs.input_v enc enc.prs.float_pat
| O.TypeBool -> enc.prs.input_v enc enc.prs.bool_pat
| O.TypeUnit -> enc.prs.input_v enc enc.prs.unit_pat
let rec abs_input_te enc tyns = function
| O.TypeName ([te],["option"]) ->
enc.lang.fnctn enc [
(enc.prs.opt_pat (Some "__o"), wrap_opt_some enc (abs_input_te enc tyns te) "__o");
(enc.prs.opt_pat None, wrap_opt_none enc);
("_",enc.prs.fail enc (enc.prs.opt_pat None));
]
| O.TypeName ([te],["list"]) ->
enc.lang.fnctn enc [
(enc.prs.list_pat "__l", wrap_list enc (abs_input_te enc tyns te) "__l");
("_",enc.prs.fail enc (enc.prs.list_pat "list"));
]
| O.TypeName (tes,tn) ->
let n = str_of_tyn tn in
(match get_tyn tn tyns with
| InternalTyn tn | ExternalTyn (tn,_) ->
let v = var_of_tyn tn in
enc.lang.fnctn enc [(v,(make_ext2 enc tyns tn v))]
| _ ->
(eprintf "Unknown: %s %s\n%!" (String.concat " " (List.map Tools.str_of_type_expr tes)) n;
assert false))
| O.TypeConst cte -> abs_input_cte enc cte
| O.TypeTuple tes ->
let n = List.length tes in
let els = List.mapi (fun i te -> enc.lang.app enc (abs_input_te enc tyns te) (sprintf "__%d" i)) tes in
enc.lang.fnctn enc [(enc.prs.tuple_pat n),(wrap_tuple enc n ("("^String.concat ",\n " els^")"));
("_",enc.prs.fail enc (enc.prs.tuple_pat 0));
]
| O.TypeRecord l ->
let names = List.map (fun (_,lab,_) -> lab) l in
let labs = List.map (fun (_,lab,te) -> enc.lang.app enc (abs_input_te enc tyns te) ("__"^lab)) l in
enc.lang.fnctn enc [(enc.prs.record_pat names),(wrap_record enc names labs);
("_",enc.prs.fail enc (enc.prs.record_pat []));
]
| O.TypeConstructor cl ->
let mtches =
List.map
(fun (name,teo) ->
match teo with
| Some te ->
let v = enc.lang.tup_v te in
let vo, pat = enc.prs.cons_pat name (Some v) in
(pat,
wrap_cons enc name (Some (te,(enc.lang.app enc (abs_input_te enc tyns te) (Option.get vo)))))
| None ->
let _, pat = enc.prs.cons_pat name None in
(pat,
wrap_cons enc name None)
) cl in
let _, pat = enc.prs.cons_pat "label" (Some "value") in
enc.lang.fnctn enc (mtches@[("_",enc.prs.fail enc pat)])
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Abstract input *)
(* OPA input/output *)
let get_external_opa_function enc exts t =
let defnames =
match enc.prefix with
| "output" -> ["opastringof"]
| "input" -> ["opaofstring"]
| "tojson" -> ["opatojson"]
| "tojson_ll" -> ["opatojsonll"]
| "fromjson" -> ["opafromjson"]
| "fromjson_ll" -> ["opafromjsonll"]
| _ -> failwith (sprintf "Unknown encoding prefix '%s'" enc.prefix)
in
try
let extdefs = List.assoc t exts in
match List.find (fun (name,_) -> List.mem name defnames) extdefs with (_,code) -> code
with Not_found -> failwith (sprintf "Unable to find handler for %s %s" enc.prefix t)
let opa_lang = {
make_some = (fun s -> "{some="^s^"}");
make_none = "{none}";
make_cons = (fun l vo -> match vo with Some v -> sprintf "{%s=%s}" l v | None -> sprintf "{%s}" l);
map_list = (fun f l -> sprintf "List.map((%s),(%s))" f l);
map_while_opt = (fun f l -> sprintf "List.map_while_opt((%s),(%s))" f l);
list_sep = ", ";
flush_str = (fun enc o t -> sprintf "%s((%s),\"%s\")" o t !(enc.str));
output_s = (fun enc o t s -> if enc.foldstrs then (enc.str := (!(enc.str))^s; t) else sprintf "%s((%s),\"%s\")" o t s);
output_v = (fun enc vn o t to_s -> sprintf "(%s -> %s(%s,((%s -> %s(%s))(%s))))" vn o (flush_str enc o t) vn to_s vn vn);
output_a = (fun enc o f a -> sprintf "(%s(%s))" (flush_str enc o f) (flush_str enc o a));
output_f = (fun enc o p e -> sprintf "(%s -> %s)" p (flush_str enc o e));
output_m = (fun enc o t m pes ->
sprintf "((__t -> match %s with |%s)(%s))"
m (String.concat "| "
(List.map (fun (p,ef) ->
sprintf "%s -> %s" p (flush_str enc o (ef "__t"))) pes)) (flush_str enc o t));
output_l = (fun enc o t l ef sf ->
sprintf "\
((__l ->\n \
(rec aux(__t,__l) =\n \
match __l with\n \
| [] -> __t\n \
| [__h] -> aux((%s),[])\n \
| [__h|__rest] -> aux((%s),__rest)\n \
aux((%s),__l)))(%s))" (flush_str enc o (ef "__t" "__h"))
(flush_str enc o (sf (ef "__t" "__h")))
(flush_str enc o t) l);
make_ext_fn = (fun enc (tyns,exts) -> (function
| [n] -> sprintf "%s_%s" enc.prefix n
| [m;n] -> sprintf "%s_%s.%s_%s" enc.modname (lc1 m) enc.prefix n
| ("external"::t::tn) -> get_external_opa_function enc exts t
| _ -> assert false));
pat_tup = (fun args -> (sprintf "(%s)" (String.concat ", " args)));
tup_v = (fun _ -> "__v");
pat_rec = (fun _enc labs vals -> (sprintf "{ %s }" (String.concat "; " (List.map2 (fun l v -> l^"="^v) labs vals))));
pat_con0 = (fun s -> "{"^s^"}");
pat_con1 = (fun s v -> "{"^s^"="^v^"}");
error = (fun s -> sprintf "error(\"%s\")" (toopastr (String.escaped s)));
mtch = (fun enc e pes ->
sprintf "(match %s with %s)" e (String.concat " | " (List.map (fun (p,e) -> sprintf "%s -> %s" p e) pes)));
fnctn = (fun enc pes -> sprintf "(__a -> %s)" (enc.lang.mtch enc "__a" pes));
app = (fun enc f a -> sprintf "(%s(%s))" f a);
}
let opa_enc1 = {
string_to_string = "__s", "(__s -> \"\\\"\"^__s^\"\\\"\")";
int_to_string = "__i", "Int.to_string";
int64_to_string = "__i64", "Int.to_string";
float_to_string = "__f", "Float.to_string";
bool_to_string = "__b", "Bool.to_string";
unit_to_string = "__u", "(_ -> \"()\")";
list_pre = "\\{List=["; list_post = "]\\}"; lst_pre = "("; lst_sep1 = ";"; lst_sep2 = ""; lst_post = ")";
tuple_pre = (fun _ -> "\\{Tuple=["); tuple_post = "]\\}"; tup_pre = "("; tup_sep1 = ","; tup_sep2 = ","; tup_post = ")";
make_tup = (fun s -> "\\\""^s^"\\\"");
record_pre = (fun _ -> "\\{Record=["); record_post = "]\\}"; rec_pre = "("; rec_sep1 = ","; rec_sep2 = ","; rec_post = ")";
make_rec = (fun s -> "\\\""^s^"\\\""); rec_void = "{Void}";
option_pre = "\\{Option=["; option_post = "]\\}";
cons_pre = "\\{Cons=["; cons_post = "]\\}"; con_pre = "("; con_sep = ","; con_post = ")";
make_con = (fun s -> "\\\""^s^"\\\"");
}
let opa_enc2 = {
opa_enc1 with
unit_to_string = "__u", "(_ -> \"\\{\\}\")";
list_pre = "["; list_post = "]"; lst_pre = ""; lst_sep1 = ","; lst_sep2 = ""; lst_post = "";
tuple_pre = (fun _ -> "["); tuple_post = "]"; tup_pre = ""; tup_sep1 = ","; tup_sep2 = ","; tup_post = "";
make_tup = (fun s -> "\\\""^s^"\\\"");
record_pre = (fun _ -> "\\{"); record_post = "\\}"; rec_pre = ""; rec_sep1 = ":"; rec_sep2 = ","; rec_post = "";
option_pre = "\\{"; option_post = "\\}";
cons_pre = "\\{"; cons_post = "\\}"; con_pre = ""; con_sep = ":"; con_post = "";
}
let opa_prs = {
wrap_opt = opa_wrap_opt;
succeed = (fun enc s -> if !(enc.prs.wrap_opt) then "{some="^s^"}" else s);
fail = (fun enc s -> if !(enc.prs.wrap_opt) then "{none}" else sprintf "error(\"%s\")" (toopastr (String.escaped s)));
string_pat = "String", "__s", "__s";
int_pat = "Int", "__i", "__i";
int64_pat = "Int64", "__i64", "__i64";
float_pat = "Float", "__f", "__f";
bool_pat = "Bool", "__b", "__b";
char_pat = "Char", "__c", "__c";
unit_pat = "Void", "", "void";
opt_pat = (function Some s -> sprintf "{Record=[(\"Some\",%s)]}" s | None -> "{Record=[(\"None\",_)]}");
list_pat = (fun s -> sprintf "{List=%s}" s);
tup_field = (fun i -> sprintf "__%d" i);
pre_tup = None;
tuple_pat = (fun n -> sprintf "{Record=[%s]}" (String.concat ", " (List.init n (fun i -> sprintf "(\"__%d\",__%d)" i i))));
pre_rec = None;
record_pat = (fun ls -> sprintf "{Record=[%s]}" (String.concat ", " (List.map (fun l -> sprintf "(\"%s\",__%s)" l l) ls)));
cons_pat = (fun l vo -> vo, sprintf "{Record=[%s]}" (sprintf "(\"%s\",%s)" l (match vo with Some v -> v | None -> "_")));
input_v = ocaml_input_pvs;
}
let opa_encoding1 = {
foldstrs = true;
str = ref "";
modname = "STR";
prefix = "output";
lang = opa_lang;
enc = opa_enc1;
prs = opa_prs;
}
let opa_encoding2 = {
opa_encoding1 with enc = opa_enc2
}
let opa_encoding = ref ((*match !encoding_number with | 1 -> opa_encoding1 | 2 ->*) opa_encoding2 (*| _ -> assert false*))
let opa_prs3 = {
opa_prs with
string_pat = "input_string", "t", "";
int_pat = "input_int", "t", "";
int64_pat = "input_int", "t", "";
float_pat = "input_float", "t", "";
bool_pat = "input_bool", "t", "";
char_pat = "input_char", "t", "";
unit_pat = "input_unit(\"{}\")", "t", "";
input_v = ocaml_input_str;
}
(* End of OPA input/output *)
(* OCaml input/output *)
let get_external_function enc exts t =
let defnames =
match enc.prefix with
| "output" -> ["ocamlstringof"]
| "input" -> ["ocamlofstring"]
| "tojson" -> ["ocamltojson"]
| "fromjson" -> ["ocamlfromjson"]
| "wrap" -> ["bslwrap"]
| "unwrap" -> ["bslunwrap"]
| _ -> failwith (sprintf "Unknown encoding prefix '%s'" enc.prefix)
in
try
let extdefs = List.assoc t exts in
match List.find (fun (name,_) -> List.mem name defnames) extdefs with (_,code) -> code
with Not_found -> failwith (sprintf "Unable to find handler for %s %s" enc.prefix t)
let ocaml_lang = {
make_some = (fun s -> "(Some ("^s^"))");
make_none = "None";
make_cons = (fun l vo -> match vo with Some v -> sprintf "(%s %s)" l v | None -> l);
map_list = (fun f l -> sprintf "List.map (%s) (%s)" f l);
map_while_opt = (fun f l -> sprintf "map_while_opt (%s) (%s)" f l);
list_sep = "; ";
flush_str = (fun enc o t -> sprintf "(%s (%s) \"%s\")" o t !(enc.str));
output_s = (fun enc o t s -> if enc.foldstrs then (enc.str := (!(enc.str))^s; t) else sprintf "%s (%s) \"%s\"" o t s);
output_v = (fun enc vn o t to_s -> sprintf "(fun %s -> %s (%s) (%s %s))" vn o (flush_str enc o t) to_s vn);
output_a = (fun enc o f a -> sprintf "(%s %s)" (flush_str enc o f) (flush_str enc o a));
output_f = (fun enc o p e -> sprintf "(function %s -> %s)" p (flush_str enc o e));
output_m = (fun enc o t m pes ->
sprintf "((fun __t -> match %s with %s) (%s))"
m (String.concat "|"
(List.map (fun (p,ef) ->
sprintf "%s -> %s" p (flush_str enc o (ef "__t"))) pes)) (flush_str enc o t));
output_l = (fun enc o t l ef sf ->
sprintf "\
((fun __l ->\n \
(let rec aux __t = function\n \
| [] -> __t\n \
| [__h] -> aux (%s) []\n \
| __h::__rest -> aux (%s) __rest\n \
in\n \
aux (%s) __l)) (%s))" (flush_str enc o (ef "__t" "__h"))
(flush_str enc o (sf (ef "__t" "__h")))
(flush_str enc o t) l);
make_ext_fn = (fun enc (tyns,exts) -> (function
| [n] -> (sprintf "%s_%s" enc.prefix n)
| [mn;n] -> (sprintf "%s.%s_%s" mn enc.prefix n)
| ("external"::t::tn) -> get_external_function enc exts t
| _ -> assert false));
pat_tup = (fun args -> (sprintf "(%s)" (String.concat ", " args)));
tup_v = tup_v;
pat_rec = (fun enc labs vals -> (sprintf "{ %s%s }"
(if enc.modname = "" then "" else (String.capitalize enc.modname)^". ")
(String.concat "; " (List.map2 (fun l v -> l^"="^v) labs vals))));
pat_con0 = (fun s -> s);
pat_con1 = (fun s v -> s^" "^v);
error = (fun s -> sprintf "raise (Failure \"%s\")" (String.escaped s));
mtch = (fun enc e pes ->
sprintf "(match %s with %s)" e (String.concat " | " (List.map (fun (p,e) -> sprintf "%s -> %s" p e) pes)));
fnctn = (fun enc pes -> sprintf "(function %s)" (String.concat " | " (List.map (fun (p,e) -> sprintf "%s -> %s" p e) pes)));
app = (fun enc f a -> sprintf "((%s) (%s))" f a);
}
let ocaml_enc1 = {
string_to_string = "__s", "(fun __s -> \"\\\"\"^__s^\"\\\"\")";
int_to_string = "__i", "string_of_int";
int64_to_string = "__i64", "Int64.to_string";
float_to_string = "__f", "string_of_float";
bool_to_string = "__b", "string_of_bool";
unit_to_string = "__u", "(fun () -> \"()\")";
list_pre = "{List=["; list_post = "]}";
lst_pre = "("; lst_sep1 = ";"; lst_sep2 = ""; lst_post = ")";
tuple_pre = (fun _ -> "{Tuple=["); tuple_post = "]}";
tup_pre = "("; tup_sep1 = ","; tup_sep2 = ","; tup_post = ")";
make_tup = (fun s -> "\\\""^s^"\\\"");
record_pre = (fun _ -> "{Record=["); record_post = "]}";
rec_pre = "("; rec_sep1 = ","; rec_sep2 = ","; rec_post = ")"; make_rec = (fun s -> "\\\""^s^"\\\""); rec_void = "Void";
option_pre = "{Option=["; option_post = "]}";
cons_pre = "{Cons=["; cons_post = "]}";
con_pre = "("; con_sep = ","; con_post = ")"; make_con = (fun s -> "\\\""^s^"\\\"");
}
let ocaml_enc2 = {
ocaml_enc1 with
unit_to_string = "__u", "(fun () -> \"{}\")";
list_pre = "["; list_post = "]"; lst_pre = ""; lst_sep1 = ","; lst_sep2 = ""; lst_post = "";
tuple_pre = (fun _ -> "["); tuple_post = "]"; tup_pre = ""; tup_sep1 = ","; tup_sep2 = ","; tup_post = "";
make_tup = (fun s -> "\\\""^s^"\\\"");
record_pre = (fun _ -> "{"); record_post = "}"; rec_pre = ""; rec_sep1 = ":"; rec_sep2 = ","; rec_post = "";
option_pre = "{"; option_post = "}";
cons_pre = "{"; cons_post = "}"; con_pre = ""; con_sep = ":"; con_post = "";
}
let ocaml_prs1 = {
wrap_opt = ocaml_wrap_opt;
succeed = (fun enc s -> if !(enc.prs.wrap_opt) then "(Some ("^s^"))" else s);
fail = (fun enc s -> if !(enc.prs.wrap_opt) then "None" else sprintf "raise (Failure \"%s\")" (String.escaped s));
string_pat = "Parser.PT_String", "__s", "__s";
int_pat = "Parser.PT_Int", "__i", "__i";
int64_pat = "Parser.PT_Int64", "__i64", "__i64";
float_pat = "Parser.PT_Float", "__f", "__f";
bool_pat = "Parser.PT_Bool", "__b", "__b";
char_pat = "Parser.PT_Char", "__c", "__c";
unit_pat = "Parser.PT_Unit", "", "()";
opt_pat = (function Some s -> sprintf "Parser.PT_Option (Some (%s))" s | None -> "Parser.PT_Option None");
list_pat = (fun s -> sprintf "Parser.PT_List %s" s);
tup_field = (fun i -> sprintf "__%d" i);
pre_tup = None;
tuple_pat = (fun n -> sprintf "Parser.PT_Tuple [%s]" (String.concat "; " (List.init n (fun i -> sprintf "__%d" i))));
pre_rec = None;
record_pat = (fun ls -> sprintf "Parser.PT_Record [%s]"
(String.concat "; " (List.map (fun l -> sprintf "(\"%s\",__%s)" l l) ls)));
cons_pat = (fun l vo -> vo, sprintf "Parser.PT_Cons (\"%s\",%s)" l (match vo with Some v -> "Some "^v | None -> "None"));
input_v = ocaml_input_pvs;
}
let ocaml_prs2 = {
ocaml_prs1 with
string_pat = "Parser.PT_String", "__s", "__s";
int_pat = "Parser.PT_Int", "__i", "__i";
int64_pat = "Parser.PT_Int64", "__i64", "__i64";
float_pat = "Parser.PT_Float", "__f", "__f";
bool_pat = "Parser.PT_Bool", "__b", "__b";
char_pat = "Parser.PT_Char", "__c", "__c";
unit_pat = "Parser.PT_Unit", "", "()";
opt_pat = (function
| Some s -> sprintf "Parser.PT_Record [(\"Some\",Some %s)]" s
| None -> "Parser.PT_Record [(\"None\",None)]");
list_pat = (fun s -> sprintf "Parser.PT_ListTuple %s" s);
tup_field = (fun i -> sprintf "__%d" i);
pre_tup = None;
tuple_pat = (fun n -> sprintf "Parser.PT_ListTuple [%s]"
(String.concat "; " (List.init n (fun i -> sprintf "__%d" i))));
pre_rec = None;
record_pat = (fun ls -> sprintf "Parser.PT_Record [%s]"
(String.concat "; " (List.map (fun l -> sprintf "(\"%s\",Some __%s)" l l) ls)));
cons_pat = (fun l vo -> vo, sprintf "Parser.PT_Record [(\"%s\",%s)]" l (match vo with Some v -> "Some "^v | None -> "None"));
input_v = ocaml_input_pvs;
}
let ocaml_encoding1 = {
foldstrs = true;
str = ref "";
modname = "";
prefix = "output";
lang = ocaml_lang;
enc = ocaml_enc1;
prs = ocaml_prs1;
}
let ocaml_encoding2 = {
ocaml_encoding1 with enc = ocaml_enc2; prs = ocaml_prs2
}
let ocaml_encoding = ref ((*match !encoding_number with 1 -> ocaml_encoding1 | 2 ->*) ocaml_encoding2 (*| _ -> assert false*))
let ocaml_prs3 = {
ocaml_prs1 with
string_pat = "input_string", "t", "";
int_pat = "input_int", "t", "";
int64_pat = "input_int", "t", "";
float_pat = "input_float", "t", "";
bool_pat = "input_bool", "t", "";
char_pat = "input_char", "t", "";
unit_pat = "input_unit \"{}\"", "t", "";
input_v = ocaml_input_str;
}
(* End of OCaml input/output *)
(* OPA JSON output *)
let opa_tojson_encoding = {
foldstrs = false;
str = ref "";
modname = "JSON";
prefix = "tojson";
lang = {
opa_lang with
output_v = (fun enc vn o t to_j -> if vn = "" then sprintf "(_ -> %s)" to_j else sprintf "(%s -> {%s=(%s)})" vn to_j vn);
output_m = (fun enc o t m pes ->
sprintf "(__t -> match %s with %s)"
m (String.concat "| " (List.map (fun (p,ef) -> sprintf "%s -> %s" p ((ef "__t"))) pes)));
output_l = (fun enc o t l ef sf -> sprintf "(__l -> {List=(List.map((__e -> %s),__l))})" (ef "__e" ""));
};
enc = {
opa_enc1 with
string_to_string = "__s", "String";
int_to_string = "__i", "Int";
int64_to_string = "__i64", "Int";
float_to_string = "__f", "Float";
bool_to_string = "__b", "Bool";
unit_to_string = "", "{Void}";
tuple_pre = (fun _ -> "{Record=["); tuple_post = "]}";
tup_pre = "("; tup_sep1 = ","; tup_sep2 = ","; tup_post = ")"; make_tup = (fun s -> "\""^s^"\"");
record_pre = (fun _ -> "{Record=["); record_post = "]}";
rec_pre = "("; rec_sep1 = ","; rec_sep2 = ","; rec_post = ")"; make_rec = (fun s -> "\""^s^"\""); rec_void = "{Void}";
};
prs = opa_prs;
}
(* End of OPA JSON output *)
(* OPA JSON low-level output *)
let opa_tojson_ll_encoding = {
foldstrs = false;
str = ref "";
modname = "JSON";
prefix = "tojson_ll";
lang = {
opa_lang with
output_v = (fun enc vn o t to_j -> if vn = "" then sprintf "(_ -> %s)" to_j else sprintf "(%s -> (%s(%s)))" vn to_j vn);
output_m = (fun enc o t m pes ->
sprintf "(__t -> match %s with %s)"
m (String.concat "| " (List.map (fun (p,ef) -> sprintf "%s -> %s" p ((ef "__t"))) pes)));
output_l = (fun enc o t l ef sf -> sprintf "(__l -> opal2mll(List.rev_map((__e -> %s),__l)))" (ef "__e" ""));
};
enc = {
opa_enc1 with
string_to_string = "__s", "to_string";
int_to_string = "__i", "to_int";
int64_to_string = "__i64", "to_int";
float_to_string = "__f", "to_float";
bool_to_string = "__b", "to_bool";
unit_to_string = "", "to_void()";
tuple_pre = (fun _ -> "opar2mlr(["); tuple_post = "])";
tup_pre = "("; tup_sep1 = ","; tup_sep2 = ","; tup_post = ")"; make_tup = (fun s -> "\""^s^"\"");
record_pre = (fun _ -> "opar2mlr(["); record_post = "])";
rec_pre = "("; rec_sep1 = ","; rec_sep2 = ","; rec_post = ")"; make_rec = (fun s -> "\""^s^"\""); rec_void = "to_void()";
};
prs = opa_prs;
}
(* End of OPA JSON low-level output *)
(* OCaml JSON output *)
let ocaml_tojson_encoding = {
foldstrs = false;
str = ref "";
modname = "";
prefix = "tojson";
lang = {
ocaml_lang with
output_v = (fun enc vn o t to_j -> sprintf "(fun %s -> (%s %s))" vn to_j vn);
output_m = (fun enc o t m pes ->
sprintf "(fun __t -> match %s with %s)"
m (String.concat "|" (List.map (fun (p,ef) -> sprintf "%s -> %s" p ((ef "__t"))) pes)));
output_l = (fun enc o t l ef sf -> sprintf "(fun __l -> JsonTypes.Array (List.map (fun __e -> %s) __l))" (ef "__e" ""));
};
enc = {
opa_enc1 with
string_to_string = "__s", "JsonTypes.String";
int_to_string = "__i", "JsonTypes.Int";
int64_to_string = "__i64", "JsonTypes.Int";
float_to_string = "__f", "JsonTypes.Float";
bool_to_string = "__b", "JsonTypes.Bool";
unit_to_string = "__u", "(fun () -> JsonTypes.Void)";
tuple_pre = (fun _ -> "JsonTypes.Record ["); tuple_post = "]";
tup_pre = "("; tup_sep1 = ", "; tup_sep2 = "; "; tup_post = ")"; make_tup = (fun s -> "\""^s^"\"");
record_pre = (fun _ -> "JsonTypes.Record ["); record_post = "]";
rec_pre = "("; rec_sep1 = ", "; rec_sep2 = "; "; rec_post = ")"; make_rec = (fun s -> "\""^s^"\"");
rec_void = "JsonTypes.Void";
};
prs = ocaml_prs1;
}
(* End of OCaml JSON output *)
(* OCaml BSL output *)
let ocaml_wrap_encoding () = {
foldstrs = false;
str = ref "";
modname = !mns;
prefix = "wrap";
lang = {
ocaml_lang with
output_v = (fun enc vn o t to_j -> sprintf "(fun %s -> (%s %s))" vn to_j vn);
output_m = (fun enc o t m pes ->
sprintf "(fun __t -> match %s with %s)"
m (String.concat "|" (List.map (fun (p,ef) -> sprintf "%s -> %s" p ((ef "__t"))) pes)));
output_l = (fun enc o t l ef sf -> sprintf "(fun __l -> JsonTypes.Array (List.map (fun __e -> %s) __l))" (ef "__e" ""));
make_ext_fn = (fun enc (tyns,exts) -> (function
| [n] -> (sprintf "%s_%s" enc.prefix n)
| [mn;n] -> (sprintf "%s.%s_%s" ((Base.String.capitalize !bsl_prefix)^"_"^(String.lowercase mn)) enc.prefix n)
| ("external"::t::tn) -> get_external_function enc exts t
| _ -> assert false));
};
enc = {
opa_enc1 with
string_to_string = "__s", "ServerLib.wrap_string";
int_to_string = "__i", "ServerLib.wrap_int";
int64_to_string = "__i64", "ServerLib.wrap_int";
float_to_string = "__f", "ServerLib.wrap_float";
bool_to_string = "__b", "ServerLib.wrap_bool";
unit_to_string = "__u", "wrap_unit";
record_pre = (fun _ -> "wrap_rcrd ["); record_post = "]";
tuple_pre = (fun i -> sprintf "wrap_tuple%d(" i); tuple_post = ")";
tup_pre = "("; tup_sep1 = ""; tup_sep2 = ","; tup_post = ")";
make_tup = (fun _ -> "");
rec_pre = "("; rec_sep1 = ", "; rec_sep2 = "; "; rec_post = ")"; make_rec = (fun s -> "\""^s^"\"");
rec_void = "ServerLib.void";
};
prs = {
ocaml_prs1 with
tup_field = (fun i -> sprintf "f%d" (i+1));
};
}
let ocaml_unwrap_encoding () = {
foldstrs = false;
str = ref "";
modname = !mns;
prefix = "unwrap";
lang = {
ocaml_lang with
output_v = (fun enc vn o t to_j -> sprintf "(fun %s -> (%s %s))" vn to_j vn);
output_m = (fun enc o t m pes ->
sprintf "(fun __t -> match %s with %s)"
m (String.concat "|" (List.map (fun (p,ef) -> sprintf "%s -> %s" p ((ef "__t"))) pes)));
pat_rec = (fun enc labs vals -> (sprintf "[ %s ]"
(String.concat "; " (List.map2 (fun l v -> sprintf "(\"%s\",%s)" l v) labs vals))));
pat_tup = (fun args -> (sprintf "(Some(%s))" (String.concat ", " (List.map (fun a -> sprintf "(%s)" a) args))));
tup_v = tup_v;
make_ext_fn = (fun enc (tyns,exts) -> (function
| [n] -> (sprintf "%s_%s" enc.prefix n)
| [mn;n] -> (sprintf "%s.%s_%s" ((Base.String.capitalize !bsl_prefix)^"_"^(String.lowercase mn)) enc.prefix n)
| ("external"::t::tn) -> get_external_function enc exts t
| _ -> assert false));
};
enc = {
opa_enc1 with
string_to_string = "__s", "ServerLib.unwrap_string";
int_to_string = "__i", "ServerLib.unwrap_int";
int64_to_string = "__i64", "ServerLib.unwrap_int";
float_to_string = "__f", "ServerLib.unwrap_float";
bool_to_string = "__b", "ServerLib.unwrap_bool";
unit_to_string = "__u", "unwrap_unit";
tuple_pre = (fun _ -> "("); tuple_post = ")";
tup_pre = ""; tup_sep1 = ""; tup_sep2 = ", "; tup_post = ""; make_tup = (fun s -> "");
record_pre = (fun enc -> sprintf "{%s" (if enc.modname = "" then "" else " "^(String.capitalize enc.modname)^". "));
record_post = "}";
rec_pre = ""; rec_sep1 = "="; rec_sep2 = "; "; rec_post = ""; make_rec = (fun s -> s);
rec_void = "ServerLib.void";
};
prs = {
ocaml_prs1 with
pre_rec = Some (fun enc v -> sprintf "unwrap_rcrd %s" v);
pre_tup = Some (fun enc i v -> sprintf "unwrap_tuple%d %s" i v);
};
}
(* End of OCaml BSL output *)
(* OPA JSON input *)
(* Now abstract - common with opa output *)
(* End of OPA JSON input *)
(* OCaml JSON input *)
let ocaml_json_prs = {
ocaml_prs1 with
string_pat = "JsonTypes.String", "__s", "__s";
int_pat = "JsonTypes.Int", "__i", "__i";
int64_pat = "JsonTypes.Int", "__i64", "__i64";
float_pat = "JsonTypes.Float", "__f", "__f";
bool_pat = "JsonTypes.Bool", "__b", "__b";
char_pat = "JsonTypes.Char", "__c", "__c";
unit_pat = "JsonTypes.Void", "", "()";
opt_pat = (function
| Some s -> sprintf "JsonTypes.Record [(\"Some\",%s)]" s
| None -> "JsonTypes.Record [(\"None\",JsonTypes.Void)]");
list_pat = (fun s -> sprintf "JsonTypes.Array %s" s);
tup_field = (fun i -> sprintf "__%d" i);
pre_tup = None;
tuple_pat = (fun n -> sprintf "JsonTypes.Record [%s]"
(String.concat "; " (List.init n (fun i -> sprintf "(\"__%d\",__%d)" i i))));
pre_rec = None;
record_pat = (fun ls -> sprintf "JsonTypes.Record [%s]"
(String.concat "; " (List.map (fun l -> sprintf "(\"%s\",__%s)" l l) ls)));
cons_pat = (fun l vo ->
(Some "__v",
sprintf "JsonTypes.Record [(\"%s\",%s)]" l (match vo with Some v -> "__v" | None -> "JsonTypes.Void")));
}
(* End of OCaml JSON input *)
(* Create functions *)
let create_ocaml_type tyns = function
| O.TypeName (tes,tn) as te->
(match get_tyn tn tyns with
| InternalTyn tn -> str_of_tyn tn
| _ -> type_ocaml_te tyns te)
| te -> type_ocaml_te tyns te
let create_opa_type tyns = function
| O.TypeName (tes,tn) as te->
(match get_tyn tn tyns with
| InternalTyn tn -> str_of_tyn tn
| _ -> type_opa_te tyns te)
| te -> type_opa_te tyns te
let rec create_te_fn tyns name = function
| O.TypeName (tes,tn) -> [], [], [], ""
| O.TypeConst cte -> ["__"^name], [type_ocaml_cte cte], [type_opa_cte cte], ("__"^name)
| O.TypeTuple tes ->
let args = List.mapi (fun i _te -> sprintf "__%d" i) tes in
let typs = List.map (fun te -> create_ocaml_type tyns te) tes in
let opatyps = List.map (fun te -> create_opa_type tyns te) tes in
let els = List.mapi (fun i te -> sprintf "(__%d)" i) tes in
args, typs, opatyps, sprintf "( %s )" (String.concat "," els)
| O.TypeRecord l ->
let args = List.map (fun (_,lab,_) -> "__"^lab) l in
let typs = List.map (fun (_,_,te) -> create_ocaml_type tyns te) l in
let opatyps = List.map (fun (_,_,te) -> create_opa_type tyns te) l in
let tostrs = List.map (fun (_,lab,te) -> sprintf " %s=__%s " lab lab) l in
args, typs, opatyps, sprintf "{ %s }" (String.concat ";" tostrs)
| O.TypeConstructor cl -> [], [], [], ""
| O.TypeVar (*of string (* 'a *)*) _ -> assert false
| O.TypeRef (*of type_expr*) _ -> assert false
| O.TypeArrow (*of type_expr * type_expr*) _ -> assert false
| O.TypeLabel (*of bool (* optional *) * string * type_expr*) _ -> assert false
| O.TypeVerbatim (*of string*) _ -> assert false
(* End of Create functions *)
(* Headers and footers *)
let hdr_all = "\n\
let map_while_opt f l =\n \
let rec aux = function\n \
| [] -> Some []\n \
| h::t -> match f h with | Some v -> (match aux t with | Some l -> Some (v::l) | None -> None) | None -> None\n \
in aux l\n\n"
let hdr_out mdls = sprintf "\n\
module type OUT =\n\
sig\n \
type t\n \
val output : t -> string -> t\n \
end\n\n\
module MakeOutput ( Out : OUT ) =\n\
struct\n \
open Out\n \
type t = Out.t\n \
\n \
%s\n\
\n \
let output_quoted t s = output t (\"\\\"\"^s^\"\\\"\")\n\n \
\n\
" (String.concat "\n " (List.map (fun mdl -> sprintf "module %s = %s.MakeOutput(Out)" mdl mdl) mdls))
let hdr_in mdls =
(sprintf "\n\
module type IN =\n\
sig\n \
type t\n \
val s : string ref\n \
val p : int ref\n \
val input : t -> string\n\
end\n\n\
module MakeInput ( In : IN ) =\n\
struct\n \
open In\n \
type t = In.t\n\
\n \
%s\n" (String.concat "\n " (List.map (fun mdl -> sprintf "module %s = %s.MakeInput(In)" mdl mdl) mdls)))^
(if !native_parser
then "\
\n \
let rec next_s t =\n \
(*Printf.eprintf \"next_s: s=\\\"%s\\\" p=%d\\n%!\" !s !p;*)\n \
if !p >= (String.length !s)\n \
then (s := input t; p := 0; next_s t)\n \
else (incr p; (*Printf.eprintf \"next_s: c=%c\\n%!\" !s.[!p - 1];*) !s.[!p - 1])\n\
\n \
let rec peek_s t =\n \
(*Printf.eprintf \"peek_s: s=\\\"%s\\\" p=%d\\n%!\" !s !p;*)\n \
if !p >= (String.length !s)\n \
then (s := input t; p := 0; peek_s t)\n \
else ((*Printf.eprintf \"peek_s: c=%c\\n%!\" !s.[!p];*) !s.[!p])\n\
\n \
let rec lookahead_s t n =\n \
(*Printf.eprintf \"lookahead_s: s=\\\"%s\\\" p=%d\\n%!\" !s !p;*)\n \
if !p + n >= (String.length !s)\n \
then (s := (!s)^(input t); lookahead_s t n)\n \
else ((*Printf.eprintf \"lookahead_s: c=%c\\n%!\" !s.[!p+n];*) !s.[!p+n])\n\
\n \
let rec skip_s t = if !p >= (String.length !s) then (s := input t; p := 0; skip_s t) else incr p\n\
\n \
let rec skipn_s t n = if n > 0 then (skip_s t; skipn_s t (n-1))\n\
\n \
let rec clean_s () = if !p > 0 then (s := String.sub !s !p (String.length !s - !p); p := 0)\n\
\n \
let reset_s () = s := \"\"; p := 0\n\
\n \
let input_fixed_clean t str =\n \
(*Printf.eprintf \"input_fixed_clean: str=%s\\n%!\" str;*)\n \
let len = String.length str in\n \
let rec aux q =\n \
if q >= len\n \
then (skipn_s t len; clean_s (); true)\n \
else\n \
if (lookahead_s t q) <> str.[q]\n \
then false\n \
else (aux (q+1))\n \
in\n \
aux 0\n\
\n \
let input_fixed t str =\n \
(*Printf.eprintf \"input_fixed: str=%s\\n%!\" str;*)\n \
let len = String.length str in\n \
let rec aux q =\n \
if q >= len\n \
then true\n \
else\n \
if (peek_s t) <> str.[q]\n \
then false\n \
else (skip_s t; aux (q+1))\n \
in\n \
aux 0\n\
\n \
let input_fixed_ci t str =\n \
let len = String.length str in\n \
let rec aux q =\n \
if q >= len\n \
then true\n \
else\n \
if Char.lowercase (peek_s t) <> Char.lowercase str.[q]\n \
then false\n \
else (skip_s t; aux (q+1))\n \
in\n \
aux 0\n\
\n \
let input_fixeds t strs =\n \
let rec aux q = function\n \
| [] -> None\n \
| strs ->\n \
let rec aux2 acc = function\n \
| str::rest ->\n \
if q >= String.length str\n \
then Some str\n \
else\n \
if str.[q] = peek_s t\n \
then aux2 (str::acc) rest\n \
else aux2 acc rest\n \
| [] -> (skip_s t; aux (q+1) acc)\n \
in\n \
aux2 [] strs\n \
in\n \
aux 0 strs\n\
\n \
let input_unit s t = if input_fixed t s then "^(optS())^"() else "^(fail())^"\n\
\n \
let input_string t =\n \
let b = Buffer.create 1024 in\n \
if input_fixed t \"\\\"\" \n \
then\n \
let rec aux = function\n \
| '\"' -> Buffer.contents b\n \
| c -> Buffer.add_char b c; aux (next_s t)\n \
in\n \
"^(optS())^"(aux (next_s t))\n \
else "^(fail())^"\n\
\n \
let input_char t =\n \
if input_fixed t \"'\" \n \
then\n \
let c = next_s t in\n \
if input_fixed t \"'\" \n \
then "^(optS())^"c\n \
else "^(fail())^"\n \
else "^(fail())^"\n\
\n \
let acc_class t b f =\n \
let rec aux tf = function\n \
| c when f c -> skip_s t; Buffer.add_char b c; aux true (peek_s t)\n \
| _ -> tf\n \
in\n \
aux false (peek_s t)\n\
\n \
let acc_dec t b = acc_class t b (function '0'..'9' -> true | _ -> false)\n\
\n \
let acc_one t b f =\n \
match peek_s t with\n \
| c when f c -> skip_s t; Buffer.add_char b c; true\n \
| _ -> false\n\
\n \
let input_int t =\n \
let b = Buffer.create 1024 in\n \
try\n \
(ignore (acc_one t b (function '-' -> true | _ -> false));\n \
ignore (acc_dec t b);\n \
if Buffer.length b = 0\n \
then "^(fail())^"\n \
else try "^(optS())^"(int_of_string (Buffer.contents b)) with Failure \"int_of_string\" -> "^(fail())^")\n \
with End_of_file -> if Buffer.length b = 0 then "^(fail())^" else "^(optS())^"(int_of_string (Buffer.contents b))\n\
\n \
let input_float t =\n \
let b = Buffer.create 1024 in\n \
try\n \
(ignore (acc_one t b (function '-'|'+' -> true | _ -> false));\n \
ignore (acc_dec t b);\n \
if acc_one t b (function '.' -> true | _ -> false) then ignore (acc_dec t b);\n \
if acc_one t b (function 'e'|'E' -> true | _ -> false)\n \
then (ignore (acc_one t b (function '-' -> true | _ -> false));\n \
ignore (acc_dec t b));\n \
if Buffer.length b = 0\n \
then "^(fail())^"\n \
else try "^(optS())^"(float_of_string (Buffer.contents b)) with Failure \"float_of_string\" -> "^(fail())^")\n \
with End_of_file -> if Buffer.length b = 0 then "^(fail())^" else "^(optS())^"(float_of_string (Buffer.contents b))\n\
\n \
let input_bool t =\n \
match peek_s t with\n \
| 't'|'T' -> skip_s t; if input_fixed_ci t \"rue\" then "^(optS())^"true else "^(fail())^"\n \
| 'f'|'F' -> skip_s t; if input_fixed_ci t \"alse\" then "^(optS())^"false else "^(fail())^"\n \
| _ -> "^(fail())^"\n\
\n \
let input_list pre sep post _in t =\n \
if input_fixed t pre\n \
then\n \
let rec aux l =\n \
if input_fixed_clean t post\n \
then "^(optS())^"(List.rev l)\n \
else\n \
(match _in t with\n \
| "^(if !ocaml_wrap_opt then "Some" else "")^" v ->\n \
(match input_fixeds t [sep;post] with\n \
| Some s when s = sep -> aux (v::l)\n \
| Some s when s = post -> "^(optS())^" (List.rev (v::l))\n \
| _ -> "^(fail())^")\n"^
(if !ocaml_wrap_opt then " | None -> "^(fail())^")\n" else "")^
" in\n \
aux []\n \
else "^(fail())^"\n\
\n \
let input_external t input_ext =\n \
ignore (peek_s t);\n \
match input_ext !s !p with\n \
| Some (cnt,ext) -> (p := !p + cnt; Some ext)\n \
| None -> None\n\n\
"
else "")
let ftr_out () = "\n end\n\
\n"^(if !string_functions || !debug
then "\
module B = MakeOutput (\n \
struct\n \
type t = Buffer.t\n \
let output b str = Buffer.add_string b str; b\n \
end)\n\n"
else "")
let ftr_in () = "\n end\n\
\n"^(if !string_functions || !debug
then "\
module S = MakeInput (\n \
struct\n \
type t = string ref\n \
let (s, p) = ((ref \"\"), (ref 0))\n \
let input s = if !s = \"\" then raise End_of_file else let ss = !s in s := \"\"; ss\n \
end)\n\n"
else "")
let hdri_out = "\n\
module type OUT =\n \
sig type t\n \
val output : t -> string -> t\n \
end\n\
\n\
module MakeOutput :\n \
functor (Out : OUT) ->\n \
sig\n \
type t = Out.t\n"
let hdri_in = "\n\
module type IN =\n \
sig type t\n \
val s : string ref\n \
val p : int ref\n \
val input : t -> string\n\
end\n\
\n\
module MakeInput :\n \
functor (In : IN) ->\n \
sig\n \
type t = In.t\n"
let ftri = " end\n\n"
let hdr_dbg () =
(if !debug && (!string_functions || (!fromjson_functions && !tojson_functions))
then
"let test name tos froms v =\n \
let tf = (try ("^(optS())^" v) = (froms (tos v)) with _ -> false) in\n \
Printf.printf \"%s_good=%b\\n\" name tf;;\n\
let ip = Ip.Ip (127,0,0,1);;\n\
let rabbit = (123, false);;\n\
let dog1 = Some 123;;\n\
let dog2 = None;;\n\
let cat0 = [];;\n\
let cat1 = [true; false];;\n\
let gender1 = Female 123;;\n\
let gender2 = Male true;;\n\
let gender3 = Neuter;;\n\
let linnaean = Linnaean (123,\"abc\");;\n\
let date = create_date 1961 8 24;;\n\
let hare = Some date;;\n\
let profile = create_profile \"abc\" 123 1.23 \"def\" true (Some \"ghi\") [\"jkl\";\"mno\";\"pqr\"] (Some (Female 123)) (Some (create_date 1961 8 24)) (999,\"SOS\") (Testopentypes.create_horse \"dobbin\" 12.0) ip;;\n"
else "")^
(if !debug && !string_functions
then
"(test \"str_ip\" string_of_ip ip_of_string ip;\n\
test \"str_t0\" string_of_t0 t0_of_string ();\n\
test \"str_t1\" string_of_t1 t1_of_string 1234;\n\
test \"str_t2\" string_of_t2 t2_of_string 1234.;\n\
test \"str_t3\" string_of_t3 t3_of_string true;\n\
test \"str_rabbit\" string_of_rabbit rabbit_of_string rabbit;\n\
test \"str_dog1\" string_of_dog dog_of_string dog1;\n\
test \"str_dog2\" string_of_dog dog_of_string dog2;\n\
test \"str_cat0\" string_of_cat cat_of_string cat0;\n\
test \"str_cat1\" string_of_cat cat_of_string cat1;\n\
test \"str_gender1\" string_of_gender gender_of_string gender1;\n\
test \"str_gender2\" string_of_gender gender_of_string gender2;\n\
test \"str_gender3\" string_of_gender gender_of_string gender3;\n\
test \"str_linnaean\" string_of_linnaean linnaean_of_string linnaean;\n\
test \"str_date\" string_of_date date_of_string date;\n\
test \"str_hare\" string_of_hare hare_of_string hare;\n\
test \"str_profile\" string_of_profile profile_of_string profile);;\n\
" else "")^
(if !debug && !fromjson_functions && !tojson_functions
then
"(test \"json_ip\" tojson_ip fromjson_ip ip;\n\
test \"json_t0\" tojson_t0 fromjson_t0 ();\n\
test \"json_t1\" tojson_t1 fromjson_t1 1234;\n\
test \"json_t2\" tojson_t2 fromjson_t2 1234.;\n\
test \"json_json_t3\" tojson_t3 fromjson_t3 true;\n\
test \"json_rabbit\" tojson_rabbit fromjson_rabbit rabbit;\n\
test \"json_dog1\" tojson_dog fromjson_dog dog1;\n\
test \"json_dog2\" tojson_dog fromjson_dog dog2;\n\
test \"json_cat0\" tojson_cat fromjson_cat cat0;\n\
test \"json_cat1\" tojson_cat fromjson_cat cat1;\n\
test \"json_gender1\" tojson_gender fromjson_gender gender1;\n\
test \"json_gender2\" tojson_gender fromjson_gender gender2;\n\
test \"json_gender3\" tojson_gender fromjson_gender gender3;\n\
test \"json_linnaean\" tojson_linnaean fromjson_linnaean linnaean;\n\
test \"json_date\" tojson_date fromjson_date date;\n\
test \"json_hare\" tojson_hare fromjson_hare hare;\n\
test \"json_profile\" tojson_profile fromjson_profile profile);;\n"
else "")
let opa_debug_vals () =
if !debug
then "\
ip = {a=127;b=0;c=0;d=1}:(ipopa.ip)\n\
t0 = void\n\
t1 = 123\n\
t2 = 123.456\n\
t3 = false\n\
t4 = \"abc\"\n\
rabbit = (456,true):((int,bool))\n\
dog1 = {none}:(option(int))\n\
dog2 = {some=789}:(option(int))\n\
cat = [true,false]:(list(bool))\n\
gender1 = {Female=123}:("^(!mns)^".gender)\n\
gender2 = {Male=false}:("^(!mns)^".gender)\n\
gender3 = {Neuter}:("^(!mns)^".gender)\n\
linnaean = {Linnaean=(123,\"abc\")}\n\
date = {day=24;month=8;year=1961}:("^(!mns)^".date)\n\
hare = {some=date}:("^(!mns)^".hare)\n\
profile = {id=\"id\";id_num=123;credits=123.456;email=\"email\";email_validated=false;real_name={some=\"me\"};about_me=[\"a\",\"b\",\"c\"];gender={some={Female=123}};date_of_birth={some={day=24;month=8;year=1961}};code=(111,\"aaa\");dobbin={name=\"horse\";height=1.23};ip={a=127;b=0;c=0;d=1}}:("^(!mns)^".profile)\n\n\
test(fromf,tof,v,s) =\n \
vs = tof(v)\n \
vv = fromf(vs)\n \
good = ({some=v} == vv)\n \
do println(\"{s}={vv} good={good}\")\n \
void\n\n"
else ""
let hdr_ocbo_dbg () =
if !debug
then
(opa_debug_vals())^"\
_ =\n\
\n \
do test(ip_of_string,string_of_ip,ip,\"of_string/string_of_ip\")\n \
do test(t0_of_string,string_of_t0,t0,\"of_string/string_of_t0\")\n \
do test(t1_of_string,string_of_t1,t1,\"of_string/string_of_t1\")\n \
do test(t2_of_string,string_of_t2,t2,\"of_string/string_of_t2\")\n \
do test(t3_of_string,string_of_t3,t3,\"of_string/string_of_t3\")\n \
do test(t4_of_string,string_of_t4,t4,\"of_string/string_of_t4\")\n \
do test(rabbit_of_string,string_of_rabbit,rabbit,\"of_string/string_of_rabbit\")\n \
do test(dog_of_string,string_of_dog,dog1,\"of_string/string_of_dog\")\n \
do test(dog_of_string,string_of_dog,dog2,\"of_string/string_of_dog\")\n \
do test(cat_of_string,string_of_cat,cat,\"of_string/string_of_cat\")\n \
do test(gender_of_string,string_of_gender,gender1,\"of_string/string_of_gender\")\n \
do test(gender_of_string,string_of_gender,gender2,\"of_string/string_of_gender\")\n \
do test(gender_of_string,string_of_gender,gender3,\"of_string/string_of_gender\")\n \
do test(linnaean_of_string,string_of_linnaean,linnaean,\"of_string/string_of_linnaean\")\n \
do test(date_of_string,string_of_date,date,\"of_string/string_of_date\")\n \
do test(hare_of_string,string_of_hare,hare,\"of_string/string_of_hare\")\n \
do test(profile_of_string,string_of_profile,profile,\"of_string/string_of_profile\")\n \
void\n"
else ""
let hdr_bsl () = "\
let (@>) = Cps.Ops.(@>)\n\
let (|>) = Cps.Ops.(|>)\n\
\n\
let wrap_unit () = ServerLib.void\n\
let unwrap_unit (_:ServerLib.ty_void) = ()\n\
\n\
let wrap_opt wrap_a opt = ServerLib.wrap_option (match opt with Some a -> Some (wrap_a a) | None -> None)\n\
\n\
let unwrap_opt unwrap_a opt =\n \
match ServerLib.dot opt (ServerLib.static_field_of_name \"some\") with\n \
| Some a -> Some (Some (unwrap_a a))\n \
| None ->\n \
(match ServerLib.dot opt (ServerLib.static_field_of_name \"none\") with\n \
| Some _ -> Some None\n \
| None -> None)\n\
\n\
let wrap_lst wrap_a lst =\n \
let rec aux = function\n \
| [] ->\n \
ServerLib.make_record\n \
(ServerLib.add_field ServerLib.empty_record_constructor\n \
(ServerLib.static_field_of_name \"nil\") ServerLib.void)\n \
| (h::t) ->\n \
ServerLib.make_record\n \
(ServerLib.add_field\n \
(ServerLib.add_field ServerLib.empty_record_constructor\n \
(ServerLib.static_field_of_name \"tl\")\n \
(aux t))\n \
(ServerLib.static_field_of_name \"hd\")\n \
(wrap_a h))\n \
in\n \
aux lst\n\
\n\
let unwrap_lst unwrap_a l =\n \
let rec aux l =\n \
match ServerLib.dot l (ServerLib.static_field_of_name \"tl\") with\n \
| Some t ->\n \
(match ServerLib.dot l (ServerLib.static_field_of_name \"hd\") with\n \
| Some h ->\n \
(match aux t with\n \
| Some tt -> Some ((unwrap_a h)::tt)\n \
| None -> None)\n \
| None -> None)\n \
| None ->\n \
(match ServerLib.dot l (ServerLib.static_field_of_name \"nil\") with\n \
| Some _ -> Some []\n \
| None -> None)\n \
in\n \
aux l\n\
\n\
let wrap_rcrd fl =\n \
ServerLib.make_record\n \
(List.fold_right (fun (f,fv) r -> ServerLib.add_field r (ServerLib.static_field_of_name f) fv)\n \
fl ServerLib.empty_record_constructor)\n\
\n\
let unwrap_rcrd r =\n \
ServerLib.fold_record (fun f v acc -> match ServerLib.name_of_field f with | Some name -> (name, v)::acc | None -> acc) r []\n\
\n\
let wrap_tuple2 (wrap_a,wrap_b) (a,b) =\n \
ServerLib.make_record\n \
(ServerLib.add_field\n \
(ServerLib.add_field ServerLib.empty_record_constructor\n \
(ServerLib.static_field_of_name \"f2\") (wrap_b b))\n \
(ServerLib.static_field_of_name \"f1\") (wrap_a a))\n\
\n\
let unwrap_tuple2 (unwrap_a,unwrap_b) t =\n \
match (ServerLib.dot t (ServerLib.static_field_of_name \"f1\"),\n \
ServerLib.dot t (ServerLib.static_field_of_name \"f2\")) with\n \
| (Some v1,Some v2) -> Some (unwrap_a v1,unwrap_b v2)\n \
| _ -> None\n\
\n\
let wrap_tuple3 (wrap_a,wrap_b,wrap_c) (a,b,c) =\n \
ServerLib.make_record\n \
(ServerLib.add_field\n \
(ServerLib.add_field\n \
(ServerLib.add_field ServerLib.empty_record_constructor\n \
(ServerLib.static_field_of_name \"f3\") (wrap_c c))\n \
(ServerLib.static_field_of_name \"f2\") (wrap_b b))\n \
(ServerLib.static_field_of_name \"f1\") (wrap_a a))\n\
\n\
let unwrap_tuple3 (unwrap_a,unwrap_b,unwrap_c) t =\n \
match (ServerLib.dot t (ServerLib.static_field_of_name \"f1\"),\n \
ServerLib.dot t (ServerLib.static_field_of_name \"f2\"),\n \
ServerLib.dot t (ServerLib.static_field_of_name \"f3\")) with\n \
| (Some v1,Some v2,Some v3) -> Some (unwrap_a v1,unwrap_b v2,unwrap_c v3)\n \
| _ -> None\n\
\n\
let wrap_tuple4 (wrap_a,wrap_b,wrap_c,wrap_d) (a,b,c,d) =\n \
ServerLib.make_record\n \
(ServerLib.add_field\n \
(ServerLib.add_field\n \
(ServerLib.add_field\n \
(ServerLib.add_field ServerLib.empty_record_constructor\n \
(ServerLib.static_field_of_name \"f4\") (wrap_d d))\n \
(ServerLib.static_field_of_name \"f3\") (wrap_c c))\n \
(ServerLib.static_field_of_name \"f2\") (wrap_b b))\n \
(ServerLib.static_field_of_name \"f1\") (wrap_a a))\n\
\n\
let unwrap_tuple4 (unwrap_a,unwrap_b,unwrap_c,unwrap_d) t =\n \
match (ServerLib.dot t (ServerLib.static_field_of_name \"f1\"),\n \
ServerLib.dot t (ServerLib.static_field_of_name \"f2\"),\n \
ServerLib.dot t (ServerLib.static_field_of_name \"f3\"),\n \
ServerLib.dot t (ServerLib.static_field_of_name \"f4\")) with\n \
| (Some v1,Some v2,Some v3,Some v4) -> Some (unwrap_a v1,unwrap_b v2,unwrap_c v3,unwrap_d v4)\n \
| _ -> None\n\
\n\
let __idl_respond_client scheduler endpoint entrypoint_protocol userdata caml_client_cont caml_handler caml_final_cont =\n\
(Hlnet.open_channel scheduler endpoint entrypoint_protocol.Hlnet.client_spec\n \
@> fun principal_channel ->\n \
Hlnet.sendreceive principal_channel None\n \
@> (fun chan ->\n \
let rec aux (userdata,continue) =\n \
if continue then\n \
(match caml_client_cont userdata with\n \
| (userdata,Some msg,true) ->\n \
(Hlnet.sendreceive chan msg\n \
@> (fun reply -> caml_handler userdata reply |> aux))\n \
| (userdata,Some msg,false) ->\n \
(Hlnet.send chan msg; caml_final_cont userdata)\n \
| (userdata,None,true) ->\n \
(Hlnet.receive chan\n \
@> (fun reply -> caml_handler userdata reply |> aux))\n \
| (userdata,None,false) ->\n \
caml_final_cont userdata)\n \
else caml_final_cont userdata\n \
in\n \
ignore (aux (userdata,true))));\n \
ServerLib.void\n\n\
"
let hdr_bslo () = ""
let opa_hdr modname =
(opa_debug_vals())^(modname^" =\n\
{{\n\n \
output(t:'a, str:string) : 'a = t^str\n\n \
output_quoted(t:'a, s:string) :'a = output(t,(\"\\\"\"^s^\"\\\"\"))\n\n")
let opa_ftr () =
if !debug
then
"\n\
}}\n\
\n\
testout(out,v,n) =\n \
t = out(\"\")(v)\n \
do println(\"output_{n}({v})={t}\")\n \
void\n\
\n\
_ =\n \
do testout(STR_"^(!mns)^".output_ip,ip,\"ip\")\n \
do testout(STR_"^(!mns)^".output_t0,t0,\"t0\")\n \
do testout(STR_"^(!mns)^".output_t1,t1,\"t1\")\n \
do testout(STR_"^(!mns)^".output_t2,t2,\"t2\")\n \
do testout(STR_"^(!mns)^".output_t3,t3,\"t3\")\n \
do testout(STR_"^(!mns)^".output_t4,t4,\"t4\")\n \
do testout(STR_"^(!mns)^".output_rabbit,rabbit,\"rabbit\")\n \
do testout(STR_"^(!mns)^".output_dog,dog1,\"dog\")\n \
do testout(STR_"^(!mns)^".output_dog,dog1,\"dog\")\n \
do testout(STR_"^(!mns)^".output_cat,cat,\"cat\")\n \
do testout(STR_"^(!mns)^".output_gender,gender1,\"gender\")\n \
do testout(STR_"^(!mns)^".output_gender,gender2,\"gender\")\n \
do testout(STR_"^(!mns)^".output_gender,gender3,\"gender\")\n \
do testout(STR_"^(!mns)^".output_date,date,\"date\")\n \
do testout(STR_"^(!mns)^".output_linnaean,linnaean,\"linnaean\")\n \
do testout(STR_"^(!mns)^".output_hare,hare,\"hare\")\n \
do testout(STR_"^(!mns)^".output_profile,profile,\"profile\")\n \
void\n\n"
else
"\n}}\n\n"
let opa_json_hdr modname =
modname^" =\n{{\n\n \
to_int = %%BslJson.Json.json_repr_int%%\n \
to_float = %%BslJson.Json.json_repr_float%%\n \
to_string = %%BslJson.Json.json_repr_string%%\n \
to_bool = %%BslJson.Json.json_repr_bool%%\n \
to_void = %%BslJson.Json.json_repr_void%%\n \
to_array = %%BslJson.Json.json_repr_array%%\n \
to_record = %%BslJson.Json.json_repr_record%%\n \
json_list_empty = %%BslJson.Json.json_list_empty%%\n \
json_list_cons = %%BslJson.Json.json_list_cons%%\n \
json_record_empty = %%BslJson.Json.json_record_empty%%\n \
json_record_cons = %%BslJson.Json.json_record_cons%%\n \
of_json_repr = %% BslJson.Json.of_json_repr%%\n\n \
opal2mll = (l -> to_array(List.fold((e, a -> json_list_cons(e, a)), l, json_list_empty())))\n\n \
opar2mlr = (l -> to_record(List.fold(((ch, j), a -> json_record_cons(ch, j, a)), l, json_record_empty())))\n\n\
"
let opa_json_ftr wrap_opt =
if !debug
then
let _opt = if wrap_opt then "option" else "" in
sprintf
"\n}}\n\n\
_ =\n \
do test(JSON_"^(!mns)^".fromjson_ip,JSON_"^(!mns)^".tojson_ip,ip,\"from/tojson_ip\")\n \
do test(JSON_"^(!mns)^".fromjson_t0,JSON_"^(!mns)^".tojson_t0,t0,\"from/tojson_t0\")\n \
do test(JSON_"^(!mns)^".fromjson_t1,JSON_"^(!mns)^".tojson_t1,t1,\"from/tojson_t1\")\n \
do test(JSON_"^(!mns)^".fromjson_t2,JSON_"^(!mns)^".tojson_t2,t2,\"from/tojson_t2\")\n \
do test(JSON_"^(!mns)^".fromjson_t3,JSON_"^(!mns)^".tojson_t3,t3,\"from/tojson_t3\")\n \
do test(JSON_"^(!mns)^".fromjson_t4,JSON_"^(!mns)^".tojson_t4,t4,\"from/tojson_t4\")\n \
do test(JSON_"^(!mns)^".fromjson_rabbit,JSON_"^(!mns)^".tojson_rabbit,rabbit,\"from/tojson_rabbit\")\n \
do test(JSON_"^(!mns)^".fromjson_dog,JSON_"^(!mns)^".tojson_dog,dog1,\"from/tojson_dog1\")\n \
do test(JSON_"^(!mns)^".fromjson_dog,JSON_"^(!mns)^".tojson_dog,dog2,\"from/tojson_dog2\")\n \
do test(JSON_"^(!mns)^".fromjson_cat,JSON_"^(!mns)^".tojson_cat,cat,\"from/tojson_cat\")\n \
do test(JSON_"^(!mns)^".fromjson_gender,JSON_"^(!mns)^".tojson_gender,gender1,\"from/tojson_gender1\")\n \
do test(JSON_"^(!mns)^".fromjson_gender,JSON_"^(!mns)^".tojson_gender,gender2,\"from/tojson_gender2\")\n \
do test(JSON_"^(!mns)^".fromjson_gender,JSON_"^(!mns)^".tojson_gender,gender3,\"from/tojson_gender3\")\n \
do test(JSON_"^(!mns)^".fromjson_linnaean,JSON_"^(!mns)^".tojson_linnaean,linnaean,\"from/tojson_linnaean\")\n \
do test(JSON_"^(!mns)^".fromjson_date,JSON_"^(!mns)^".tojson_date,date,\"from/tojson_date\")\n \
do test(JSON_"^(!mns)^".fromjson_hare,JSON_"^(!mns)^".tojson_hare,hare,\"from/tojson_hare\")\n \
do test(JSON_"^(!mns)^".fromjson_profile,JSON_"^(!mns)^".tojson_profile,profile,\"from/tojson_profile\")\n \
/*do test(JSON_"^(!mns)^".fromjson_ll_ip,JSON_"^(!mns)^".tojson_ll_ip,ip,\"from/tojson_ll_ip\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_t0,JSON_"^(!mns)^".tojson_ll_t0,t0,\"from/tojson_ll_t0\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_t1,JSON_"^(!mns)^".tojson_ll_t1,t1,\"from/tojson_ll_t1\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_t2,JSON_"^(!mns)^".tojson_ll_t2,t2,\"from/tojson_ll_t2\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_t3,JSON_"^(!mns)^".tojson_ll_t3,t3,\"from/tojson_ll_t3\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_t4,JSON_"^(!mns)^".tojson_ll_t4,t4,\"from/tojson_ll_t4\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_rabbit,JSON_"^(!mns)^".tojson_ll_rabbit,rabbit,\"from/tojson_ll_rabbit\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_dog,JSON_"^(!mns)^".tojson_ll_dog,dog1,\"from/tojson_ll_dog\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_dog,JSON_"^(!mns)^".tojson_ll_dog,dog2,\"from/tojson_ll_dog\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_cat,JSON_"^(!mns)^".tojson_ll_cat,cat,\"from/tojson_ll_cat\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_gender,JSON_"^(!mns)^".tojson_ll_gender,gender1,\"from/tojson_ll_gender\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_gender,JSON_"^(!mns)^".tojson_ll_gender,gender2,\"from/tojson_ll_gender\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_gender,JSON_"^(!mns)^".tojson_ll_gender,gender3,\"from/tojson_ll_gender\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_linnaean,JSON_"^(!mns)^".tojson_ll_linnaean,linnaean,\"from/tojson_ll_linnaean\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_date,JSON_"^(!mns)^".tojson_ll_date,date,\"from/tojson_ll_date\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_hare,JSON_"^(!mns)^".tojson_ll_hare,hare,\"from/tojson_ll_hare\")\n \
do test(JSON_"^(!mns)^".fromjson_ll_profile,JSON_"^(!mns)^".tojson_ll_profile,profile,\"from/tojson_ll_profile\")*/\n \
void\n\
"
else
"\n}}\n\n"
(* End of Headers and footers *)
(* Useless because we can't define them in the mli file.*)
(*
module Pit = Parse_idltype\n\
module JT = JsonTypes\n\n
*)
let make_abbrevs oc =
fprintf oc "\n\
let (@>) = Cps.Ops.(@>)\n\
let (|>) = Cps.Ops.(|>)\n\n"
let make_type_ocaml oc oci ocb ocbo tyns name te =
let is_tyrec = (type_sl_te tyns false te) = "ServerLib.ty_record" in
fprintf oc "type %s = %s\n" name (type_ocaml_te tyns te);
if !bsl_file then fprintf oc "type sl_%s = %s\n\n" name (type_sl_te tyns false te);
fprintf oci "type %s = %s\n" name (type_ocaml_te tyns te);
if !bsl_file then fprintf oci "type sl_%s = %s\n\n" name (type_sl_te tyns false te);
if !bsl_file
then (if is_tyrec
then fprintf ocb "##opa-type %s.%s\n" !mns name
else fprintf ocb "##extern-type %s.%s = %s\n" !mns name (type_sl_te tyns true te);
fprintf ocb "##extern-type %s.%s = %s.%s\n\n" !bslmns name !_Mns name;
fprintf ocbo "type %s.%s = %s\n" !mns name (type_opa_te tyns te);
fprintf ocbo "type %s.%s = external\n\n" !bslmns name)
let make_type_opa oco tyns name te =
fprintf oco "type %s.%s = %s\n\n" !mns name (type_opa_te tyns te)
let make_output_ocaml ocaml_enc tynames oc oci name te =
fprintf oc "let %s_%s t =\n (*Printf.eprintf \"%s_%s\\n%%!\";*) %s\n\n"
ocaml_enc.prefix name ocaml_enc.prefix name (flush_str ocaml_enc "output" (abs_output_te ocaml_enc "output" "t" tynames te));
fprintf oci " val %s_%s : Out.t -> %s -> Out.t\n" ocaml_enc.prefix name name
let make_wrap_bsl enc tyns ocb ocbo name te =
let is_tyrec = (type_sl_te tyns false te) = "ServerLib.ty_record" in
let wrap_enc = ocaml_wrap_encoding () in
fprintf ocb "##register wrap_%s : %s -> opa[%s_%s]\n" name name !mns name;
if is_tyrec
then fprintf ocb "let %s_%s t = wrap_opa_%s_%s (%s t)\n\n" wrap_enc.prefix name !mns name (abs_un_wrap_te wrap_enc tyns te)
else fprintf ocb "let %s_%s = %s\n\n" wrap_enc.prefix name (abs_un_wrap_te wrap_enc tyns te) ;
fprintf ocbo "wrap_%s = %%%% %s.wrap_%s %%%% : %s.%s -> %s.%s\n" name !bslmns name !bslmns name !mns name;
let unwrap_enc = ocaml_unwrap_encoding () in
fprintf ocb "##register unwrap_%s : opa[%s_%s] -> %s\n" name !mns name name;
if is_tyrec
then fprintf ocb "let %s_%s t = %s (unwrap_opa_%s_%s t)\n\n"
unwrap_enc.prefix name (abs_un_wrap_te unwrap_enc tyns te) !mns name
else fprintf ocb "let %s_%s = %s\n\n" unwrap_enc.prefix name (abs_un_wrap_te unwrap_enc tyns te);
fprintf ocbo "unwrap_%s = %%%% %s.unwrap_%s %%%% : %s.%s -> %s.%s\n\n" name !bslmns name !mns name !bslmns name
let make_output_opa opa_enc tynames oco name te =
fprintf oco " %s_%s = (t -> %s)\n\n"
opa_enc.prefix name (flush_str opa_enc "output" (abs_output_te opa_enc "output" "t" tynames te))
let make_input tynames oc oci name te =
if !native_parser
then
let enc = { !ocaml_encoding with foldstrs=false; prefix="input"; prs=ocaml_prs3 } in
fprintf oc "let %s_%s t =\n (*Printf.eprintf \"%s_%s\\n\";*) %s\n\n" enc.prefix name enc.prefix name (abs_input2_te enc tynames te)
else
(fprintf oc "let _input_%s = %s\n\n" name (abs_input_te { !ocaml_encoding with prefix="_input" } tynames te);
fprintf oc "let input_%s t =\n \
let (_pos,pt) = parse_function (input t) in\n \
_input_%s pt\n\n" name name);
fprintf oci " val input_%s : In.t -> %s%s\n" name name (opt())
let make_input_opa tynames oco name te = ()
(*let enc = { !opa_encoding with foldstrs=false; prefix="input"; prs=opa_prs3 } in
fprintf oco "let %s_%s t =\n %s\n\n" enc.prefix name (abs_input2_te enc tynames te)*)
let make_jsonio_ocaml tynames oc oci name te =
if !tojson_functions
then (fprintf oc "let %s_%s = %s\n\n" ocaml_tojson_encoding.prefix name (abs_tojson_te ocaml_tojson_encoding tynames te);
fprintf oci "val tojson_%s : %s -> JsonTypes.json\n\n" name name);
if !fromjson_functions
then (let enc = {!ocaml_encoding with
prefix="fromjson";
lang={ !ocaml_encoding.lang with tup_v = tup_v };
prs=ocaml_json_prs;} in
fprintf oc "let fromjson_%s =\n %s\n\n" name (abs_input_te enc tynames te);
fprintf oci "val fromjson_%s : JsonTypes.json -> %s%s\n\n" name name (opt()))
let make_jsonio_opa tynames oco name te =
if !tojson_functions
then (fprintf oco " %s_%s = %s\n\n" opa_tojson_encoding.prefix name (abs_tojson_te opa_tojson_encoding tynames te);
(*fprintf oco " %s_%s = %s\n\n" opa_tojson_ll_encoding.prefix name (abs_tojson_te opa_tojson_ll_encoding tynames te)*));
if !fromjson_functions
then (fprintf oco " fromjson_%s = (__json -> ((%s)(__json)))\n\n"
name (abs_input_te {!opa_encoding with modname="JSON"; prefix="fromjson"} tynames te);
(*let err = if !opa_wrap_opt then "{none}" else "error(\"of_json_repr\")" in
fprintf oco
" fromjson_ll_%s = (__json -> match of_json_repr(__json) with | {some=__j} -> ((fromjson_%s)(__j)) | {none} -> %s)\n\n"
name name err*))
let make_create tyns oc oci _ocb _ocbo name te =
match create_te_fn tyns name te with
| [], [], [], "" -> ()
| args, typs, opatyps, cr ->
(fprintf oc "let create_%s %s =\n %s\n\n" name (String.concat " " args) cr;
fprintf oci "val create_%s : %s -> %s\n\n" name (String.concat " -> " typs) name(*;
We would have to wrap these. OPA can se debrouille.
if !bsl_file
then (fprintf ocb "##register create_%s : %s -> %s\n\n" name (String.concat " -> " opatyps) name
)*)
)
let make_string_of oc oci ocb ocbo name te =
fprintf oc "let string_of_%s __%s = Buffer.contents (B.output_%s (Buffer.create 1024) __%s)\n\n" name name name name;
fprintf oci "val string_of_%s : %s -> string\n\n" name name;
if !bsl_file
then (fprintf ocb "##register string_of_%s : %s -> opa[string]\n" name (opa_arg_type_te name te);
fprintf ocb "let string_of_%s __%s = ServerLib.wrap_string (let res = %s.string_of_%s (unwrap_%s __%s) in (*Printf.eprintf \"string_of_%s: %%s\\n%%!\" res;*) res)\n\n"
name name !_Mns name name name name;
fprintf ocbo "string_of_%s = %%%% %s.string_of_%s %%%% : %s.%s -> string\n\n" name !bslmns name !mns name)
let make_of_string oc oci ocb ocbo name te =
fprintf oc "let %s_of_string str = try (*Printf.eprintf \"%s_of_string: str='%%s'\\n%%!\" str;*) %sS.input_%s (ref str) with End_of_file -> %s\n\n" name name (if !native_parser then "S.reset_s(); " else "") name (fail());
fprintf oci "val %s_of_string : string -> %s%s\n\n" name name (opt());
if !bsl_file
then (fprintf ocb "##register %s_of_string : opa[string] -> opa[option(%s_%s)]\n" name !mns name;
fprintf ocb "let %s_of_string __s = wrap_opt wrap_%s (%s.%s_of_string (ServerLib.unwrap_string __s))\n\n"
name name !_Mns name;
fprintf ocbo "%s_of_string = %%%% %s.%s_of_string %%%% : string -> option(%s.%s)\n\n" name !bslmns name !mns name)
let sr_prefixes = ["sr_"; "sar"; "sndrcv"; "sendrecv"; "sendreceive"; "send_receive"; "sendandreceive"; "send_and_receive"]
let s_prefixes = ["s_"; "snd"; "send"]
let r_prefixes = ["r_"; "rcv"; "receive"]
let p_prefixes = ["p_"; "proto"; "protocol"]
let jp_prefixes = ["jp_"; "jproto"; "jsonprotocol"]
let rp_prefixes = ["rp_"; "rspnd"; "responder"]
let issrpfx = ispfx sr_prefixes
let isspfx = ispfx s_prefixes
let isrpfx = ispfx r_prefixes
let isppfx = ispfx p_prefixes
let isjppfx = ispfx jp_prefixes
let isrppfx = ispfx rp_prefixes
let make_sar_code oc base sars =
let srs,rest = List.partition (function PI.IDLSar (name,_,_) -> issrpfx name | _ -> false) sars in
let ss,rest = List.partition (function PI.IDLSar (name,_,_) -> isspfx name | _ -> false) rest in
let rs,rest = List.partition (function PI.IDLSar (name,_,_) -> isrpfx name | _ -> false) rest in
let ps,rest = List.partition (function PI.IDLSar (name,_,_) -> isppfx name | _ -> false) rest in
let jps,rest = List.partition (function PI.IDLSar (name,_,_) -> isjppfx name | _ -> false) rest in
let rps,rest = List.partition (function PI.IDLSar (name,_,_) -> isrppfx name | _ -> false) rest in
if List.length rest <> 0
then
let names = List.map (function PI.IDLSar (name,_,_) -> name | _ -> assert false) rest in
failwith (sprintf "Unknown Hlnet function prefix: %s" (String.concat ", " names))
else
let has_sar = List.length srs > 0 in
let has_s = List.length ss > 0 in
let has_r = List.length rs > 0 in
let has_p = List.length ps > 0 in
let has_jp = List.length jps > 0 in
let has_rp = List.length rps > 0 in
let get_log name =
if !hlnet_logging
then
((if name = "receive"
then sprintf "%s \"entering %s function\";\n " !logger_function name
else sprintf "%s \"entering %s function for %%s\" msg_out;\n " !logger_function name),
sprintf "%s \"received %%s\" msg_in;\n " !logger_function,
sprintf "%s \"sending %%s\" msg_out;\n " !logger_function,
sprintf "%s \"receiving ...\";\n " !logger_function,
sprintf ";\n %s \"sent %%s\" msg_out\n " !logger_function,
sprintf ";\n %s \"... received\"\n " !logger_function,
(if name = "receive"
then sprintf ";\n %s \"exiting %s function\"" !logger_function name
else sprintf ";\n %s \"exiting %s function for %%s\" msg_out" !logger_function name))
else ("","","","","","","")
in
if has_sar
then begin
let (l1,l2,l3,_,l5,_,l7) = get_log "sendreceive" in
fprintf oc "\
let __idl_sendrecv (to_string : 'a -> string) (from_string : string -> 'b%s)\n \
(sched : Scheduler.t) (endpoint : Hlnet.endpoint) (chan_spec :(string,string) Hlnet.channel_spec) \n \
?(on_disconnect=((fun () -> `abort):(unit -> [ `retry of Time.t | `abort ])))\n \
(msg : 'a) (cont : 'b%s -> unit) =\n \
let msg_out = to_string msg in\n %s\
let cont_s msg_in =\n %s\
cont (from_string msg_in)\n \
in\n \
(Hlnet.open_channel sched endpoint chan_spec ~on_disconnect) @> (\n \
fun chan ->\n %s\
Hlnet.sendreceive chan msg_out cont_s%s)%s\
\n\n" (opt()) (opt()) l1 l2 l3 l5 l7
end;
if has_s
then begin
let (l1,_,l3,_,l5,_,l7) = get_log "send" in
fprintf oc "\
let __idl_send (to_string : 'a -> string)\n \
(sched : Scheduler.t) (endpoint : Hlnet.endpoint) (chan_spec : (string,string) Hlnet.channel_spec) \n \
?(on_disconnect=((fun () -> `abort):(unit -> [ `retry of Time.t | `abort ])))\n \
(msg : 'a) =\n \
let msg_out = to_string msg in\n %s\
(Hlnet.open_channel sched endpoint chan_spec ~on_disconnect) @> (\n \
fun chan ->\n %s\
Hlnet.send chan msg_out%s)%s\
\n\n" l1 l3 l5 l7
end;
if has_r
then begin
let (l1,l2,_,l4,_,l6,l7) = get_log "receive" in
fprintf oc "\
let __idl_recv (from_string : string -> 'b%s)\n \
(sched : Scheduler.t) (endpoint : Hlnet.endpoint) (chan_spec :(string,string) Hlnet.channel_spec) \n \
?(on_disconnect=((fun () -> `abort):(unit -> [ `retry of Time.t | `abort ])))\n \
(cont : 'b%s -> unit) =\n \
%s\
let cont_s msg_in =\n %s\
cont (from_string msg_in)\n \
in\n \
(Hlnet.open_channel sched endpoint chan_spec ~on_disconnect) @> (\n \
fun chan ->\n %s\
Hlnet.receive chan cont_s%s)%s\
\n\n" (opt()) (opt()) l1 l2 l4 l6 l7
end;
if has_p || has_jp || has_rp
then begin
let gets v f =
if !hlnet_logging then sprintf "let s = %s in %s \"%s:%s '%%s'\" s; s" v !logger_function base f else v in
let getu v f =
if !hlnet_logging then sprintf "%s \"%s:%s '%%s'\" s; %s" !logger_function base f v else v in
let sq = gets "string_of_q q" "serialise_query" in
let uq = getu "q_of_string s" "unserialise_query" in
let sr = gets "string_of_r r" "serialise_response" in
let ur = getu "r_of_string s" "unserialise_response" in
fprintf oc "\
let __idl_make_protocol q_of_string string_of_q r_of_string string_of_r =\n \
Hlnet.Aux.easy_protocol\n \
~name:\"%s\" ~version:%d\n \
~serialise_query:(fun q -> %s)\n \
~unserialise_query: (fun _chan s -> %s)\n \
~serialise_response: (fun r -> %s)\n \
~unserialise_response: (fun _chan s -> %s)\n\n"
base !protocol_version sq uq sr ur
end;
if has_rp
then begin
fprintf oc "\
let __idl_make_entrypoint_protocol client_protocol : (unit option, ('a, 'b) Hlnet.channel) Hlnet.protocol =\n \
Hlnet.define_protocol\n \
~name:\"%s/entry\" ~version:%d\n \
~serialise_query: (fun _msg -> \"x\") (* FIXME: hlnet doesn't like \"\" *)\n \
~unserialise_query: (fun _chan _s _offset -> `data (None, 1))\n \
~serialise_response: (Hlnet.serialise_channel)\n \
~unserialise_response: (Hlnet.unserialise_remote_channel client_protocol.Hlnet.client_spec)\n\
\n\
let respond_server entrypoint_protocol client_protocol scheduler endpoint (init_ud_server,init_ud_conn) responder =\n \
let ud_server_ref = ref init_ud_server in\n \
Hlnet.accept scheduler endpoint entrypoint_protocol.Hlnet.server_spec\n \
@> fun channel ->\n \
Hlnet.setup_respond channel\n \
(fun _msg fout ->\n \
fout (Hlnet.Aux.respond_on_new_channel channel client_protocol.Hlnet.server_spec\n \
(let ud_conn_ref = ref init_ud_conn in\n \
(fun msg ffout ->\n \
let ud_server, ud_conn, reply_opt, continue = responder (!ud_server_ref,!ud_conn_ref) msg in\n \
ud_server_ref := ud_server; ud_conn_ref := ud_conn;\n \
Option.iter ffout reply_opt;\n \
if not continue then Hlnet.refuse scheduler endpoint))))\n\
\n\
let respond_client entrypoint_protocol scheduler endpoint userdata client_cont final_cont =\n \
Hlnet.open_channel scheduler endpoint entrypoint_protocol.Hlnet.client_spec\n \
@> fun principal_channel ->\n \
Hlnet.sendreceive principal_channel None\n \
@> fun chan ->\n \
let rec aux userdata = function\n \
| true ->\n \
client_cont userdata\n \
(fun userdata -> function\n \
| (Some msg,Some handler) -> Hlnet.sendreceive chan msg @> (fun str -> handler userdata str aux)\n \
| (Some msg,None) -> (Hlnet.send chan msg; final_cont userdata)\n \
| (None,Some handler) -> Hlnet.receive chan @> (fun str -> handler userdata str aux)\n \
| (None,None) -> final_cont userdata)\n \
| false -> final_cont userdata\n \
in\n \
aux userdata true\n\n"
base !protocol_version
end
let make_sar_code_opa oc base sars =
let srs,rest = List.partition (function PI.IDLSar (name,_,_) -> issrpfx name | _ -> false) sars in
let ss,rest = List.partition (function PI.IDLSar (name,_,_) -> isspfx name | _ -> false) rest in
let rs,rest = List.partition (function PI.IDLSar (name,_,_) -> isrpfx name | _ -> false) rest in
let ps,rest = List.partition (function PI.IDLSar (name,_,_) -> isppfx name | _ -> false) rest in
let jps,rest = List.partition (function PI.IDLSar (name,_,_) -> isjppfx name | _ -> false) rest in
let rps,rest = List.partition (function PI.IDLSar (name,_,_) -> isrppfx name | _ -> false) rest in
if List.length rest <> 0
then
let names = List.map (function PI.IDLSar (name,_,_) -> name | _ -> assert false) rest in
failwith (sprintf "Unknown Hlnet function prefix: %s" (String.concat ", " names))
else
let _has_sar = List.length srs > 0 in
let _has_s = List.length ss > 0 in
let _has_r = List.length rs > 0 in
let has_p = List.length ps > 0 in
let has_jp = List.length jps > 0 in
let has_rp = List.length rps > 0 in
let _get_log name =
if !hlnet_logging
then
((if name = "receive"
then sprintf "%s \"entering %s function\";\n " !logger_function name
else sprintf "%s \"entering %s function for %%s\" msg_out;\n " !logger_function name),
sprintf "%s \"received %%s\" msg_in;\n " !logger_function,
sprintf "%s \"sending %%s\" msg_out;\n " !logger_function,
sprintf "%s \"receiving ...\";\n " !logger_function,
sprintf ";\n %s \"sent %%s\" msg_out\n " !logger_function,
sprintf ";\n %s \"... received\"\n " !logger_function,
(if name = "receive"
then sprintf ";\n %s \"exiting %s function\"" !logger_function name
else sprintf ";\n %s \"exiting %s function for %%s\" msg_out" !logger_function name))
else ("","","","","","","")
in
(* if has_sar *)
(* then begin *)
(* let (l1,l2,l3,_,l5,_,l7) = get_log "sendreceive" in *)
(* fprintf oc "\ *)
(* __idl_sendrecv (to_string : 'a -> string) (from_string : string -> 'b%s)\n \ *)
(* (sched : Scheduler.t) (endpoint : Hlnet.endpoint) (chan_spec :(string,string) Hlnet.channel_spec) \n \ *)
(* ?(on_disconnect=((fun () -> `abort):(unit -> [ `retry of Time.t | `abort ])))\n \ *)
(* (msg : 'a) (cont : 'b%s -> unit) =\n \ *)
(* let msg_out = to_string msg in\n %s\ *)
(* let cont_s msg_in =\n %s\ *)
(* cont (from_string msg_in)\n \ *)
(* in\n \ *)
(* (Hlnet.open_channel sched endpoint chan_spec ~on_disconnect) @> (\n \ *)
(* fun chan ->\n %s\ *)
(* Hlnet.sendreceive chan msg_out cont_s%s)%s\ *)
(* \n\n" (opt()) (opt()) l1 l2 l3 l5 l7 *)
(* end; *)
(* if has_s *)
(* then begin *)
(* let (l1,_,l3,_,l5,_,l7) = get_log "send" in *)
(* fprintf oc "\ *)
(* let __idl_send (to_string : 'a -> string)\n \ *)
(* (sched : Scheduler.t) (endpoint : Hlnet.endpoint) (chan_spec : (string,string) Hlnet.channel_spec) \n \ *)
(* ?(on_disconnect=((fun () -> `abort):(unit -> [ `retry of Time.t | `abort ])))\n \ *)
(* (msg : 'a) =\n \ *)
(* let msg_out = to_string msg in\n %s\ *)
(* (Hlnet.open_channel sched endpoint chan_spec ~on_disconnect) @> (\n \ *)
(* fun chan ->\n %s\ *)
(* Hlnet.send chan msg_out%s)%s\ *)
(* \n\n" l1 l3 l5 l7 *)
(* end; *)
(* if has_r *)
(* then begin *)
(* let (l1,l2,_,l4,_,l6,l7) = get_log "receive" in *)
(* fprintf oc "\ *)
(* let __idl_recv (from_string : string -> 'b%s)\n \ *)
(* (sched : Scheduler.t) (endpoint : Hlnet.endpoint) (chan_spec :(string,string) Hlnet.channel_spec) \n \ *)
(* ?(on_disconnect=((fun () -> `abort):(unit -> [ `retry of Time.t | `abort ])))\n \ *)
(* (cont : 'b%s -> unit) =\n \ *)
(* %s\ *)
(* let cont_s msg_in =\n %s\ *)
(* cont (from_string msg_in)\n \ *)
(* in\n \ *)
(* (Hlnet.open_channel sched endpoint chan_spec ~on_disconnect) @> (\n \ *)
(* fun chan ->\n %s\ *)
(* Hlnet.receive chan cont_s%s)%s\ *)
(* \n\n" (opt()) (opt()) l1 l2 l4 l6 l7 *)
(* end; *)
if has_p || has_jp || has_rp
then begin
let gets v f = v in
let getu v f = v in
let sq = gets "string_of_q(q)" "serialise_query" in
let uq = getu "q_of_string(s)" "unserialise_query" in
let sr = gets "string_of_r(r)" "serialise_response" in
let ur = getu "r_of_string(s)" "unserialise_response" in
fprintf oc "\
__idl_make_protocol(q_of_string, string_of_q, r_of_string, string_of_r) =\n \
Hlnet.define_protocol(\"%s\",%d,(q -> %s),(_chan,s -> %s), ( r -> %s), ( _chan,s -> %s))\n\n"
base !protocol_version sq uq sr ur
end(* ; *)
(* if has_rp *)
(* then begin *)
(* fprintf oc "\ *)
(* let __idl_make_entrypoint_protocol client_protocol : (unit option, ('a, 'b) Hlnet.channel) Hlnet.protocol =\n \ *)
(* Hlnet.define_protocol\n \ *)
(* ~name:\"%s/entry\" ~version:%d\n \ *)
(* ~serialise_query: (fun _msg -> \"x\") (\* FIXME: hlnet doesn't like \"\" *\)\n \ *)
(* ~unserialise_query: (fun _chan _s _offset -> `data (None, 1))\n \ *)
(* ~serialise_response: (Hlnet.serialise_channel)\n \ *)
(* ~unserialise_response: (Hlnet.unserialise_remote_channel client_protocol.Hlnet.client_spec)\n\ *)
(* \n\ *)
(* let respond_server entrypoint_protocol client_protocol scheduler endpoint (init_ud_server,init_ud_conn) responder =\n \ *)
(* let ud_server_ref = ref init_ud_server in\n \ *)
(* Hlnet.accept scheduler endpoint entrypoint_protocol.Hlnet.server_spec\n \ *)
(* @> fun channel ->\n \ *)
(* Hlnet.setup_respond channel\n \ *)
(* (fun _msg fout ->\n \ *)
(* fout (Hlnet.Aux.respond_on_new_channel channel client_protocol.Hlnet.server_spec\n \ *)
(* (let ud_conn_ref = ref init_ud_conn in\n \ *)
(* (fun msg ffout ->\n \ *)
(* let ud_server, ud_conn, reply_opt, continue = responder (!ud_server_ref,!ud_conn_ref) msg in\n \ *)
(* ud_server_ref := ud_server; ud_conn_ref := ud_conn;\n \ *)
(* Option.iter ffout reply_opt;\n \ *)
(* if not continue then Hlnet.refuse scheduler endpoint))))\n\ *)
(* \n\ *)
(* let respond_client entrypoint_protocol scheduler endpoint userdata client_cont final_cont =\n \ *)
(* Hlnet.open_channel scheduler endpoint entrypoint_protocol.Hlnet.client_spec\n \ *)
(* @> fun principal_channel ->\n \ *)
(* Hlnet.sendreceive principal_channel None\n \ *)
(* @> fun chan ->\n \ *)
(* let rec aux userdata = function\n \ *)
(* | true ->\n \ *)
(* client_cont userdata\n \ *)
(* (fun userdata -> function\n \ *)