Commit 069fd5aa authored by Pietro Abate's avatar Pietro Abate
Browse files

clean up

parent ae22ade3
Since 0.5.6
* Allow reference to named OCaml types (by Pietro Abate)
0.5.0 0.5.0
* Port to OCaml 3.10, with the help of Nicolas Pouillard * Port to OCaml 3.10, with the help of Nicolas Pouillard
......
...@@ -4,5 +4,4 @@ ...@@ -4,5 +4,4 @@
*.cma *.cma
*.cmxa *.cmxa
cmi2ml cmi2ml
asttypes.ml asttypes.ml
ocaml_files \ No newline at end of file
...@@ -684,8 +684,6 @@ let to_cd_dyn = function ...@@ -684,8 +684,6 @@ let to_cd_dyn = function
let register () = let register () =
Typer.has_ocaml_unit := Typer.has_ocaml_unit :=
(fun cu -> Mltypes.has_cmi (U.get_str cu)); (fun cu -> Mltypes.has_cmi (U.get_str cu));
Typer.cduce_conv :=
(fun v -> typ_descr (Mltypes.find_type v).def);
Librarian.stub_ml := stub_ml; Librarian.stub_ml := stub_ml;
Externals.register := register; Externals.register := register;
Externals.ext_info := (fun () -> Obj.magic !exts); Externals.ext_info := (fun () -> Obj.magic !exts);
......
...@@ -223,14 +223,6 @@ let unfold ty = ...@@ -223,14 +223,6 @@ let unfold ty =
vars := []; vars := [];
(t,n) (t,n)
let unfold_type p =
vars := [];
Hashtbl.clear constr_table;
let t = unfold_constr { seen = IntSet.empty; constrs = StringSet.empty;
vars = IntMap.empty } p [] in
assert (!vars = []);
t
(* Reading .cmi *) (* Reading .cmi *)
let unsupported s = let unsupported s =
...@@ -241,7 +233,6 @@ let has_cmi name = ...@@ -241,7 +233,6 @@ let has_cmi name =
try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true try ignore (Misc.find_in_path_uncap !Config.load_path (name ^ ".cmi")); true
with Not_found -> false with Not_found -> false
(* find the cduce type associated to an ocaml value *)
let find_value v = let find_value v =
Config.load_path := Config.standard_library :: !Loc.obj_path; Config.load_path := Config.standard_library :: !Loc.obj_path;
let li = Longident.parse v in let li = Longident.parse v in
...@@ -249,14 +240,6 @@ let find_value v = ...@@ -249,14 +240,6 @@ let find_value v =
let (_,vd) = Env.lookup_value li Env.initial in let (_,vd) = Env.lookup_value li Env.initial in
unfold vd.val_type unfold vd.val_type
(* find the cduce type associated to an ocaml type *)
let find_type t =
Config.load_path := Config.standard_library :: !Loc.obj_path;
let li = Longident.parse t in
ocaml_env := Env.initial;
let (p,_) = Env.lookup_type li Env.initial in
unfold_type p
let values_of_sig name sg = let values_of_sig name sg =
List.fold_left List.fold_left
(fun accu v -> match v with (fun accu v -> match v with
......
...@@ -31,4 +31,4 @@ val print_ocaml : Format.formatter -> Types.type_expr -> unit ...@@ -31,4 +31,4 @@ val print_ocaml : Format.formatter -> Types.type_expr -> unit
val find_value: string -> t * int val find_value: string -> t * int
val find_type : string -> t
...@@ -66,9 +66,13 @@ let false_literal = U.mk "false" ...@@ -66,9 +66,13 @@ let false_literal = U.mk "false"
(* @raise exn_print_xml in case of failure. Rationale: schema printing is (* @raise exn_print_xml in case of failure. Rationale: schema printing is
* the last attempt to print a value, others have already failed *) * the last attempt to print a value, others have already failed *)
let rec schema_value ?(recurs=true) ~wds v = match v with let rec schema_value ?(recurs=true) ~wds ~wcs v = match v with
| Abstract ("float",f) -> | Abstract ("float",o) ->
wds (U.mk (string_of_float (Obj.magic f : float))) wds (U.mk (string_of_float (Obj.magic o : float)))
| Abstract ("cdata",o) ->
wcs (U.mk "<![CDATA[");
wcs (U.mk (U.get_str (Obj.magic o : U.t)));
wcs (U.mk "]]>")
| Record _ as v -> | Record _ as v ->
(try (try
wds (Schema_builtin.string_of_time_type (Value.get_fields v)) wds (Schema_builtin.string_of_time_type (Value.get_fields v))
...@@ -76,18 +80,18 @@ let rec schema_value ?(recurs=true) ~wds v = match v with ...@@ -76,18 +80,18 @@ let rec schema_value ?(recurs=true) ~wds v = match v with
| Integer i -> wds (U.mk (Intervals.V.to_string i)) | Integer i -> wds (U.mk (Intervals.V.to_string i))
| v when Value.equal v Value.vtrue -> wds true_literal | v when Value.equal v Value.vtrue -> wds true_literal
| v when Value.equal v Value.vfalse -> wds false_literal | v when Value.equal v Value.vfalse -> wds false_literal
| Pair _ as v when recurs -> schema_values ~wds v | Pair _ as v when recurs -> schema_values ~wds ~wcs v
| String_utf8 _ | String_latin1 _ as v -> wds (fst (get_string_utf8 v)) | String_utf8 _ | String_latin1 _ as v -> wds (fst (get_string_utf8 v))
| _ -> raise exn_print_xml | _ -> raise exn_print_xml
and schema_values ~wds v = and schema_values ~wds ~wcs v =
match v with match v with
| Pair (hd, Atom a) when a = Sequence.nil_atom -> | Pair (hd, Atom a) when a = Sequence.nil_atom ->
schema_value ~recurs:false ~wds hd schema_value ~recurs:false ~wds ~wcs hd
| Pair (hd, tl) -> | Pair (hd, tl) ->
schema_value ~recurs:false ~wds hd; schema_value ~recurs:false ~wds ~wcs hd;
wds blank; wds blank;
schema_values ~wds tl schema_values ~wds ~wcs tl
| _ -> raise exn_print_xml | _ -> raise exn_print_xml
let to_buf ~utf8 buffer ns_table v = let to_buf ~utf8 buffer ns_table v =
...@@ -97,6 +101,7 @@ let to_buf ~utf8 buffer ns_table v = ...@@ -97,6 +101,7 @@ let to_buf ~utf8 buffer ns_table v =
let wms = write_markup_string ~to_enc buffer let wms = write_markup_string ~to_enc buffer
and wds s = write_data_string ~to_enc buffer (U.get_str s) and wds s = write_data_string ~to_enc buffer (U.get_str s)
and wcs s = buffer (U.get_str s) in
in in
let write_att (n,v) = let write_att (n,v) =
wms (" " ^ (Ns.Printer.attr printer (Label.value n)) ^ "=\""); wds v; wms "\"" in wms (" " ^ (Ns.Printer.attr printer (Label.value n)) ^ "=\""); wds v; wms "\"" in
...@@ -160,7 +165,7 @@ let to_buf ~utf8 buffer ns_table v = ...@@ -160,7 +165,7 @@ let to_buf ~utf8 buffer ns_table v =
end else begin end else begin
let buf = Buffer.create 20 in let buf = Buffer.create 20 in
let wds s = Buffer.add_string buf (U.get_str s) in let wds s = Buffer.add_string buf (U.get_str s) in
schema_value ~wds v; schema_value ~wds ~wcs:wds v;
(Label.from_int n, U.mk (Buffer.contents buf)) (Label.from_int n, U.mk (Buffer.contents buf))
end end
) attrs in ) attrs in
...@@ -177,7 +182,7 @@ let to_buf ~utf8 buffer ns_table v = ...@@ -177,7 +182,7 @@ let to_buf ~utf8 buffer ns_table v =
match q with match q with
| Pair ((Xml _ | XmlNs _) as x, q) -> print_elt [] x; print_content q | Pair ((Xml _ | XmlNs _) as x, q) -> print_elt [] x; print_content q
| Atom a when a = Sequence.nil_atom -> () | Atom a when a = Sequence.nil_atom -> ()
| v -> schema_value ~wds v | v -> schema_value ~wds ~wcs v
in in
document_start (); document_start ();
print_elt (Ns.Printer.prefixes printer) v print_elt (Ns.Printer.prefixes printer) v
......
...@@ -284,6 +284,11 @@ let rec print ppf v = ...@@ -284,6 +284,11 @@ let rec print ppf v =
Format.fprintf ppf "<concat:%a;%a>" print x print y Format.fprintf ppf "<concat:%a;%a>" print x print y
| Abstract ("float",o) -> | Abstract ("float",o) ->
Format.fprintf ppf "%f" (Obj.magic o : float) Format.fprintf ppf "%f" (Obj.magic o : float)
| Abstract ("cdata",o) ->
let s = Utf8.get_str (Obj.magic o : Utf8.t) in
Format.fprintf ppf "'%s'" s
(* Format.fprintf ppf "%s" (Utf8.get_str (Obj.magic o :
* Encodings.Utf8.t)) *)
| Abstract (s,_) -> | Abstract (s,_) ->
Format.fprintf ppf "<abstract=%s>" s Format.fprintf ppf "<abstract=%s>" s
| Absent -> | Absent ->
...@@ -417,8 +422,12 @@ let rec compare x y = ...@@ -417,8 +422,12 @@ let rec compare x y =
raise (CDuceExn (string_latin1 "comparing functional values")) raise (CDuceExn (string_latin1 "comparing functional values"))
| Abstract (s1,v1), Abstract (s2,v2) -> | Abstract (s1,v1), Abstract (s2,v2) ->
let c = Types.Abstract.T.compare s1 s2 in if c <> 0 then c let c = Types.Abstract.T.compare s1 s2 in if c <> 0 then c
else Pervasives.compare (Obj.magic v1 : float) (Obj.magic v2 : float) else begin
(* raise (CDuceExn (string_latin1 "comparing abstract values")) *) match s1 with
|"float" -> Pervasives.compare (Obj.magic v1 : float) (Obj.magic v2 : float)
|"cdata" -> Pervasives.compare (Obj.magic v1 : Encodings.Utf8.t) (Obj.magic v2 : Encodings.Utf8.t)
|_ -> raise (CDuceExn (string_latin1 "comparing abstract values"))
end
| Absent,_ | _,Absent -> | Absent,_ | _,Absent ->
Format.fprintf Format.std_formatter Format.fprintf Format.std_formatter
"ERR: Compare %a %a@." print x print y; "ERR: Compare %a %a@." print x print y;
...@@ -713,6 +722,9 @@ let print_utf8 v = ...@@ -713,6 +722,9 @@ let print_utf8 v =
let float n = let float n =
Abstract ("float", Obj.repr n) Abstract ("float", Obj.repr n)
let cdata n =
Abstract ("cdata", Obj.repr n)
let cduce2ocaml_option f v = let cduce2ocaml_option f v =
match normalize v with match normalize v with
| Pair (x,y) -> Some (f x) | Pair (x,y) -> Some (f x)
......
...@@ -83,6 +83,7 @@ val flatten : t -> t ...@@ -83,6 +83,7 @@ val flatten : t -> t
val append : t -> t -> t val append : t -> t -> t
val float: float -> t val float: float -> t
val cdata: string -> t
val get_string_latin1 : t -> string val get_string_latin1 : t -> string
val get_string_utf8 : t -> U.t * t val get_string_utf8 : t -> U.t * t
......
...@@ -116,6 +116,12 @@ let exn_namespaces = lazy ( ...@@ -116,6 +116,12 @@ let exn_namespaces = lazy (
Value.string_latin1 "namespaces")) Value.string_latin1 "namespaces"))
) )
let exn_cdata_of = lazy (
Value.CDuceExn (
Value.Pair (
Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
Value.string_latin1 "cdata_of"))
)
let eval_load_file ~utf8 e = let eval_load_file ~utf8 e =
Cduce_loc.protect_op "load_file"; Cduce_loc.protect_op "load_file";
...@@ -439,3 +445,11 @@ register_fun "float_of" string float ...@@ -439,3 +445,11 @@ register_fun "float_of" string float
let (s,_) = Value.get_string_utf8 v in let (s,_) = Value.get_string_utf8 v in
try Value.float (float_of_string (U.get_str s)) try Value.float (float_of_string (U.get_str s))
with Failure _ -> raise (Lazy.force exn_float_of));; with Failure _ -> raise (Lazy.force exn_float_of));;
(* cdata *)
register_fun "cdata_of" string string
(fun v ->
let (s,_) = Value.get_string_utf8 v in
try Value.cdata (U.get_str s)
with Failure _ -> raise (Lazy.force exn_cdata_of));;
...@@ -131,12 +131,7 @@ let find_id env0 env loc head x = ...@@ -131,12 +131,7 @@ let find_id env0 env loc head x =
with Not_found when head -> with Not_found when head ->
try ECDuce (!load_comp_unit x) try ECDuce (!load_comp_unit x)
with Not_found -> with Not_found ->
if ((match (U.get_str x).[0] with 'A'..'Z' -> true | _ -> false) error loc "Cannot resolve this identifier"
&& !has_ocaml_unit x)
then EOCaml (U.get_str x)
else
error loc ("Cannot resolve this identifier " ^
(Ns.QName.to_string id))
let find_id_comp env0 env loc x = let find_id_comp env0 env loc x =
if ((match (U.get_str x).[0] with 'A'..'Z' -> true | _ -> false) if ((match (U.get_str x).[0] with 'A'..'Z' -> true | _ -> false)
...@@ -246,16 +241,11 @@ let type_ns env loc p ns = ...@@ -246,16 +241,11 @@ let type_ns env loc p ns =
ns = Ns.add_prefix p ns env.ns; ns = Ns.add_prefix p ns env.ns;
ids = Env.add (Ns.empty,p) (ENamespace ns) env.ids } ids = Env.add (Ns.empty,p) (ENamespace ns) env.ids }
let cduce_conv = ref (fun _ -> failwith "cduce conv not initialized")
let find_global_type env loc ids = let find_global_type env loc ids =
match find_global env loc ids with match find_global env loc ids with
| Type t | ESchemaComponent (t,_) -> t | Type t | ESchemaComponent (t,_) -> t
| EOCamlComponent s ->
let t = !cduce_conv s in
let v = ident env loc (U.mk s) in
Types.Print.register_global "" v t ;
t
| _ -> error loc "This path does not refer to a type" | _ -> error loc "This path does not refer to a type"
let find_global_schema_component env loc ids = let find_global_schema_component env loc ids =
......
...@@ -69,4 +69,3 @@ val has_static_external: (string -> bool) ref ...@@ -69,4 +69,3 @@ val has_static_external: (string -> bool) ref
val load_schema: val load_schema:
(string -> string -> Ns.Uri.t * (Types.t * Schema_validator.t) Ident.Env.t) ref (string -> string -> Ns.Uri.t * (Types.t * Schema_validator.t) Ident.Env.t) ref
val cduce_conv : (string -> Types.t) ref
...@@ -43,27 +43,57 @@ project. ...@@ -43,27 +43,57 @@ project.
Do you want to see <local href="img">what we look like</local> ? Do you want to see <local href="img">what we look like</local> ?
</p> </p>
<section title="CDuce @ Gallium (INRIA Rocquencourt)">
<p>
Research group: <a href="http://cristal.inria.fr">Gallium project</a>.
</p>
<ul> <ul>
<li> <li>
<a href="http://alain.frisch.fr/"> <a href="http://www.eleves.ens.fr/home/frisch/">
Alain Frisch Alain Frisch
</a> (now at <a href="http://www.lexifi.com">LexiFi</a>): <i>project </a> (Research associate): <i>project leader, main developer</i>.
leader, main developer</i>.
</li> </li>
</ul>
</section>
<section title="CDuce @ ENS (Paris)">
<p>
Research group: <a
href="http://www.di.ens.fr/~castagna/EQUIPE/">Language group</a>.
</p>
<ul>
<li> <li>
<a href="http://www.di.ens.fr/~castagna/"> <a href="http://www.di.ens.fr/~castagna/">
Giuseppe Castagna Giuseppe Castagna
</a> (CNRS researcher, PPS laboratory): <i>project leader</i>. </a> (CNRS researcher): <i>project leader</i>.
</li>
<li>
<a href="http://www.di.ens.fr/~gesbert">
Nils Gesbert</a> (Post Doc): <i>concurrency for CDuce</i>.
</li> </li>
</ul>
</section>
<section title="CDuce @ LRI (Orsay)">
<p>
Research group: <a
href="http://www.lri.fr/bd/introduction.en.shtml">Database group</a>.
</p>
<ul>
<li> <li>
<a href="http://www.lri.fr/~benzaken/"> <a href="http://www.lri.fr/~benzaken/">
Vronique Benzaken Vronique Benzaken
</a> (Prof. Univ. Paris 11): <i>project leader</i>. </a> (Prof. Univ. Paris 11): <i>project leader</i>.
</li> </li>
<li>
<a href="http://www.di.ens.fr/~gesbert">
Nils Gesbert</a> (Post Doc): <i>concurrency for CDuce</i>.
</li>
<li> <li>
<a href="http://www.lri.fr/~burelle/"> <a href="http://www.lri.fr/~burelle/">
Marwan Burelle Marwan Burelle
...@@ -84,24 +114,7 @@ Do you want to see <local href="img">what we look like</local> ? ...@@ -84,24 +114,7 @@ Do you want to see <local href="img">what we look like</local> ?
</li> </li>
</ul> </ul>
<p> </section>
Our work on CDuce was supported by the following research
groups:
</p>
<ul>
<li>
<a href="http://www.di.ens.fr/~castagna/EQUIPE/">Language group</a>,
ENS Paris.
</li>
<li>
<a href="http://www.lri.fr/bd/introduction.en.shtml">Database
group</a>, Paris-Sud 11 University.
</li>
<li><a href="http://gallium.inria.fr">Gallium project</a>, INRIA Rocquencourt.
</li>
<li><a href="http://www.pps.jussieu.fr/">PPS laboratory</a>, Paris 7 University.
</li>
</ul>
<section title="Former interns and students"> <section title="Former interns and students">
<ul> <ul>
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment