Skip to content

GitLab

Commit 83f3cacc authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-06-29 20:28:52 by cvscast] Continuing namespaces : records and print_xml -- Alain 

Original author: cvscast
Date: 2003-06-29 20:28:53+00:00
parent 00c2cd22
Hide whitespace changes
Inline Side-by-side
Showing with 244 additions and 202 deletions
Makefile.distrib
View file @ 83f3cacc
......@@ -62,7 +62,7 @@ CLEAN_DIRS = $(DIRS) tools tests
OBJECTS = \
misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo \
misc/pretty.cmo \
misc/pretty.cmo misc/ns.cmo \
\
types/sortedList.cmo types/boolean.cmo types/ident.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo \
......
depend
View file @ 83f3cacc
......@@ -8,30 +8,34 @@ misc/bool.cmo: misc/q_symbol.cmo misc/bool.cmi
misc/bool.cmx: misc/q_symbol.cmo misc/bool.cmi
misc/pretty.cmo: misc/q_symbol.cmo misc/pretty.cmi
misc/pretty.cmx: misc/q_symbol.cmo misc/pretty.cmi
misc/ns.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi misc/state.cmi misc/ns.cmi
misc/ns.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx misc/state.cmx misc/ns.cmi
types/sortedList.cmo: misc/q_symbol.cmo types/sortedList.cmi
types/sortedList.cmx: misc/q_symbol.cmo types/sortedList.cmi
types/boolean.cmo: misc/q_symbol.cmo types/sortedList.cmi types/boolean.cmi
types/boolean.cmx: misc/q_symbol.cmo types/sortedList.cmx types/boolean.cmi
types/ident.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi types/sortedList.cmi
types/ident.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx types/sortedList.cmx
types/ident.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/ns.cmi misc/pool.cmi \
types/sortedList.cmi
types/ident.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/ns.cmx misc/pool.cmx \
types/sortedList.cmx
types/intervals.cmo: misc/q_symbol.cmo types/intervals.cmi
types/intervals.cmx: misc/q_symbol.cmo types/intervals.cmi
types/chars.cmo: misc/q_symbol.cmo types/chars.cmi
types/chars.cmx: misc/q_symbol.cmo types/chars.cmi
types/ns.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi types/ns.cmi
types/ns.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx types/ns.cmi
types/atoms.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/pool.cmi types/sortedList.cmi \
types/atoms.cmi
types/atoms.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/pool.cmx types/sortedList.cmx \
types/atoms.cmi
types/atoms.cmo: misc/q_symbol.cmo misc/encodings.cmi misc/ns.cmi misc/pool.cmi \
types/sortedList.cmi types/atoms.cmi
types/atoms.cmx: misc/q_symbol.cmo misc/encodings.cmx misc/ns.cmx misc/pool.cmx \
types/sortedList.cmx types/atoms.cmi
types/normal.cmo: misc/q_symbol.cmo types/normal.cmi
types/normal.cmx: misc/q_symbol.cmo types/normal.cmi
types/types.cmo: misc/q_symbol.cmo types/atoms.cmi misc/bool.cmi types/chars.cmi \
misc/encodings.cmi types/ident.cmo types/intervals.cmi types/normal.cmi \
misc/pretty.cmi types/sortedList.cmi misc/state.cmi types/types.cmi
misc/ns.cmi misc/pretty.cmi types/sortedList.cmi misc/state.cmi \
types/types.cmi
types/types.cmx: misc/q_symbol.cmo types/atoms.cmx misc/bool.cmx types/chars.cmx \
misc/encodings.cmx types/ident.cmx types/intervals.cmx types/normal.cmx \
misc/pretty.cmx types/sortedList.cmx misc/state.cmx types/types.cmi
misc/ns.cmx misc/pretty.cmx types/sortedList.cmx misc/state.cmx \
types/types.cmi
types/patterns.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/ident.cmo \
types/sortedList.cmi misc/state.cmi types/types.cmi types/patterns.cmi
types/patterns.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx types/ident.cmx \
......@@ -45,17 +49,17 @@ types/builtin_defs.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/
types/builtin_defs.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx types/intervals.cmx \
types/sequence.cmx types/types.cmx types/builtin_defs.cmi
runtime/value.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi types/sequence.cmi types/types.cmi \
runtime/value.cmi
types/ident.cmo types/intervals.cmi misc/ns.cmi types/sequence.cmi \
types/types.cmi runtime/value.cmi
runtime/value.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/intervals.cmx types/sequence.cmx types/types.cmx \
runtime/value.cmi
types/ident.cmx types/intervals.cmx misc/ns.cmx types/sequence.cmx \
types/types.cmx runtime/value.cmi
schema/schema_types.cmo: misc/q_symbol.cmo runtime/value.cmi schema/schema_types.cmi
schema/schema_types.cmx: misc/q_symbol.cmo runtime/value.cmx schema/schema_types.cmi
schema/schema_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi runtime/value.cmi \
schema/schema_xml.cmi
schema/schema_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx runtime/value.cmx \
schema/schema_xml.cmi
schema/schema_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi misc/ns.cmi \
runtime/value.cmi schema/schema_xml.cmi
schema/schema_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx misc/ns.cmx \
runtime/value.cmx schema/schema_xml.cmi
schema/schema_builtin.cmo: misc/q_symbol.cmo types/builtin_defs.cmi types/intervals.cmi \
schema/schema_types.cmi types/types.cmi runtime/value.cmi \
schema/schema_builtin.cmi
......@@ -78,36 +82,38 @@ parser/location.cmo: misc/q_symbol.cmo parser/location.cmi
parser/location.cmx: misc/q_symbol.cmo parser/location.cmi
parser/wlexer.cmo: misc/q_symbol.cmo misc/encodings.cmi parser/location.cmi
parser/wlexer.cmx: misc/q_symbol.cmo misc/encodings.cmx parser/location.cmx
parser/ast.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi schema/schema_types.cmi \
types/types.cmi
parser/ast.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx schema/schema_types.cmx \
types/types.cmx
parser/ast.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi misc/ns.cmi \
schema/schema_types.cmi types/types.cmi
parser/ast.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx misc/ns.cmx \
schema/schema_types.cmx types/types.cmx
parser/parser.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/chars.cmi \
misc/encodings.cmi types/ident.cmo types/intervals.cmi \
parser/location.cmi schema/schema_parser.cmi schema/schema_xml.cmi \
types/sequence.cmi types/types.cmi parser/wlexer.cmo parser/parser.cmi
parser/location.cmi misc/ns.cmi schema/schema_parser.cmi \
schema/schema_xml.cmi types/sequence.cmi types/types.cmi \
parser/wlexer.cmo parser/parser.cmi
parser/parser.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/chars.cmx \
misc/encodings.cmx types/ident.cmx types/intervals.cmx \
parser/location.cmx schema/schema_parser.cmx schema/schema_xml.cmx \
types/sequence.cmx types/types.cmx parser/wlexer.cmx parser/parser.cmi
parser/location.cmx misc/ns.cmx schema/schema_parser.cmx \
schema/schema_xml.cmx types/sequence.cmx types/types.cmx \
parser/wlexer.cmx parser/parser.cmi
typing/typed.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi types/patterns.cmi \
types/types.cmi runtime/value.cmi
typing/typed.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx types/patterns.cmx \
types/types.cmx runtime/value.cmx
typing/typer.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/chars.cmi \
types/ident.cmo parser/location.cmi types/patterns.cmi \
types/ident.cmo parser/location.cmi misc/ns.cmi types/patterns.cmi \
schema/schema_builtin.cmi schema/schema_types.cmi \
schema/schema_validator.cmi types/sequence.cmi misc/state.cmi \
typing/typed.cmo types/types.cmi typing/typer.cmi
typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/chars.cmx \
types/ident.cmx parser/location.cmx types/patterns.cmx \
types/ident.cmx parser/location.cmx misc/ns.cmx types/patterns.cmx \
schema/schema_builtin.cmx schema/schema_types.cmx \
schema/schema_validator.cmx types/sequence.cmx misc/state.cmx \
typing/typed.cmx types/types.cmx typing/typer.cmi
runtime/load_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi runtime/value.cmi runtime/load_xml.cmi
parser/location.cmi misc/ns.cmi runtime/value.cmi runtime/load_xml.cmi
runtime/load_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
parser/location.cmx runtime/value.cmx runtime/load_xml.cmi
parser/location.cmx misc/ns.cmx runtime/value.cmx runtime/load_xml.cmi
runtime/run_dispatch.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/patterns.cmi types/types.cmi runtime/value.cmi \
runtime/run_dispatch.cmi
......@@ -115,9 +121,11 @@ runtime/run_dispatch.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc
types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
runtime/run_dispatch.cmi
runtime/print_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
parser/location.cmi types/sequence.cmi runtime/value.cmi
parser/location.cmi misc/ns.cmi types/sequence.cmi typing/typer.cmi \
runtime/value.cmi
runtime/print_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
parser/location.cmx types/sequence.cmx runtime/value.cmx
parser/location.cmx misc/ns.cmx types/sequence.cmx typing/typer.cmx \
runtime/value.cmx
runtime/eval.cmo: misc/q_symbol.cmo types/ident.cmo types/patterns.cmi runtime/run_dispatch.cmi \
schema/schema_validator.cmi schema/schema_xml.cmi typing/typed.cmo \
typing/typer.cmi types/types.cmi runtime/value.cmi runtime/eval.cmi
......@@ -126,22 +134,22 @@ runtime/eval.cmx: misc/q_symbol.cmo types/ident.cmx types/patterns.cmx runtime/r
typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi
types/builtin.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
types/chars.cmi types/ident.cmo types/intervals.cmi runtime/load_xml.cmi \
parser/location.cmi runtime/print_xml.cmo types/sequence.cmi \
parser/location.cmi misc/ns.cmi runtime/print_xml.cmo types/sequence.cmi \
typing/typed.cmo typing/typer.cmi types/types.cmi runtime/value.cmi \
types/builtin.cmi
types/builtin.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
types/chars.cmx types/ident.cmx types/intervals.cmx runtime/load_xml.cmx \
parser/location.cmx runtime/print_xml.cmx types/sequence.cmx \
parser/location.cmx misc/ns.cmx runtime/print_xml.cmx types/sequence.cmx \
typing/typed.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
types/builtin.cmi
driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo runtime/eval.cmi types/ident.cmo \
parser/location.cmi parser/parser.cmi types/patterns.cmi types/sample.cmi \
misc/state.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
runtime/value.cmi parser/wlexer.cmo driver/cduce.cmi
parser/location.cmi misc/ns.cmi parser/parser.cmi types/patterns.cmi \
types/sample.cmi misc/state.cmi typing/typed.cmo typing/typer.cmi \
types/types.cmi runtime/value.cmi parser/wlexer.cmo driver/cduce.cmi
driver/cduce.cmx: misc/q_symbol.cmo parser/ast.cmx runtime/eval.cmx types/ident.cmx \
parser/location.cmx parser/parser.cmx types/patterns.cmx types/sample.cmx \
misc/state.cmx typing/typed.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx parser/wlexer.cmx driver/cduce.cmi
parser/location.cmx misc/ns.cmx parser/parser.cmx types/patterns.cmx \
types/sample.cmx misc/state.cmx typing/typed.cmx typing/typer.cmx \
types/types.cmx runtime/value.cmx parser/wlexer.cmx driver/cduce.cmi
driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo runtime/load_xml.cmi \
parser/location.cmi types/sequence.cmi misc/state.cmi runtime/value.cmi \
parser/wlexer.cmo
......@@ -152,9 +160,9 @@ driver/webiface.cmo: misc/q_symbol.cmo driver/cduce.cmi driver/examples.cmo pars
misc/state.cmi
driver/webiface.cmx: misc/q_symbol.cmo driver/cduce.cmx driver/examples.cmx parser/location.cmx \
misc/state.cmx
misc/ns.cmi: misc/q_symbol.cmo misc/encodings.cmi
types/boolean.cmi: misc/q_symbol.cmo types/sortedList.cmi
types/ns.cmi: misc/q_symbol.cmo misc/encodings.cmi
types/atoms.cmi: misc/q_symbol.cmo misc/encodings.cmi
types/atoms.cmi: misc/q_symbol.cmo misc/encodings.cmi misc/ns.cmi
types/types.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/ident.cmo \
types/intervals.cmi types/sortedList.cmi
types/patterns.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/ident.cmo \
......@@ -171,8 +179,8 @@ schema/schema_validator.cmi: misc/q_symbol.cmo schema/schema_types.cmi runtime/v
schema/schema_parser.cmi: misc/q_symbol.cmo schema/schema_types.cmi schema/schema_xml.cmi
parser/parser.cmi: misc/q_symbol.cmo parser/ast.cmo
typing/typer.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo parser/location.cmi \
schema/schema_types.cmi schema/schema_validator.cmi typing/typed.cmo \
types/types.cmi
misc/ns.cmi schema/schema_types.cmi schema/schema_validator.cmi \
typing/typed.cmo types/types.cmi
runtime/load_xml.cmi: misc/q_symbol.cmo runtime/value.cmi
runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi runtime/value.cmi
runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo typing/typed.cmo runtime/value.cmi
......
driver/cduce.ml
View file @ 83f3cacc
......@@ -44,7 +44,7 @@ let dump_env ppf =
)
!eval_env;
Format.fprintf ppf "Namespaces:@.";
Atoms.Ns.dump_prefix_table ppf
Ns.dump_prefix_table ppf
let rec print_exn ppf = function
......@@ -60,7 +60,7 @@ let rec print_exn ppf = function
U.print (Id.value v)
| Typer.WrongLabel (t,l) ->
Format.fprintf ppf "Wrong record selection; field %a "
U.print (LabelPool.value l);
Label.print (LabelPool.value l);
Format.fprintf ppf "not present in an expression of type:@.%a@."
print_norm t
| Typer.ShouldHave (t,msg) ->
......
parser/ast.ml
View file @ 83f3cacc
......@@ -13,7 +13,7 @@ and pmodule_item' =
| SchemaDecl of string * Schema_types.schema (* name, schema *)
| LetDecl of ppat * pexpr
| FunDecl of pexpr
| Namespace of U.t * Atoms.Ns.t
| Namespace of U.t * Ns.t
| EvalStatement of pexpr
| Debug of debug_directive
| Directive of toplevel_directive
......@@ -32,7 +32,7 @@ and toplevel_directive =
and pconst =
| Const_internal of Types.const
| Const_atom of U.t * U.t
| Const_atom of U.t
and pexpr =
| LocatedExpr of loc * pexpr
......@@ -65,7 +65,7 @@ and pexpr =
| Try of pexpr * branches
(* Other *)
| NamespaceIn of U.t * Atoms.Ns.t * pexpr
| NamespaceIn of U.t * Ns.t * pexpr
and abstr = {
fun_name : id option;
......@@ -82,7 +82,8 @@ and ppat' =
| PatVar of U.t
| SchemaVar of (* type/pattern schema variable *)
schema_item_kind * string * string
| AtomT of U.t * (U.t option)
| AtomT of U.t
| NsT of U.t
| Recurs of ppat * (U.t * ppat) list
| Internal of Types.descr
| Or of ppat * ppat
......
parser/parser.ml
View file @ 83f3cacc
......@@ -21,6 +21,7 @@ let parse_ident = U.mk_latin1
let id_dummy = ident (U.mk "$$$")
(*
let split_qname s =
try
let i = String.index s ':' in
......@@ -29,8 +30,10 @@ let split_qname s =
(parse_ident ns, parse_ident s)
with Not_found ->
(U.mk "", parse_ident s)
*)
let label s = LabelPool.mk (parse_ident s)
(* TODO: NS *)
let label s = LabelPool.mk (Ns.empty, parse_ident s)
let ident s = ident (parse_ident s)
let prog = Grammar.Entry.create gram "prog"
......@@ -121,7 +124,7 @@ EXTEND
let schema = Schema_parser.parse_schema schema_doc in
[ mk loc (SchemaDecl (name, schema))]
| (name,ns) = namespace_binding ->
Atoms.Ns.register_prefix name ns;
Ns.register_prefix name ns;
[ mk loc (Namespace (name, ns)) ]
| (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
let e = exp loc (NamespaceIn (name, ns, e2)) in
......@@ -293,15 +296,12 @@ EXTEND
];
tag: [ [ a = [ LIDENT | UIDENT | keyword ] ->
let (ns,l) = split_qname a in Const_atom (ns,l) ] ];
Const_atom (parse_ident a) ] ];
tag_type: [
[ LIDENT "_" -> mk loc (Internal (Types.atom Atoms.any))
| a = [ LIDENT | UIDENT | keyword ] ->
let (ns,l) = split_qname a in
mk loc (AtomT (ns, Some l))
| t = ANY_IN_NS ->
mk loc (AtomT (parse_ident t, None))
| a = [ LIDENT | UIDENT | keyword ] -> mk loc (AtomT (parse_ident a))
| t = ANY_IN_NS -> mk loc (NsT (parse_ident t))
]
];
......@@ -320,7 +320,7 @@ EXTEND
parse_ident name
| -> U.mk "" ];
uri = STRING2 ->
let ns = Atoms.Ns.mk (parse_ident uri) in
let ns = Ns.mk (parse_ident uri) in
(name,ns)
]
];
......@@ -464,9 +464,8 @@ EXTEND
| "`"; c = tag_type -> c
| c = const ->
(match c with
| Const_atom (ns,l) -> mk loc (AtomT (ns,Some l))
| Const_internal c ->
mk loc (Internal (Types.constant c))
| Const_atom l -> mk loc (AtomT l)
| Const_internal c -> mk loc (Internal (Types.constant c))
)
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
| "["; r = [ r = regexp -> r | -> Epsilon ];
......
runtime/load_xml.ml
View file @ 83f3cacc
......@@ -48,11 +48,12 @@ let string s q =
let attrib att =
let att = List.map (fun (l,v) -> LabelPool.mk (U.mk l), string v nil) att in
LabelMap.from_list (fun _ _ -> assert false) att
(* TODO: better error message *)
let att = List.map (fun (n,v) -> LabelPool.mk n, string_utf8 v) att in
LabelMap.from_list (fun _ _ -> failwith "Invalid XML document: uniqueness of attributes") att
let elem tag att child =
Xml (Atom (Atoms.mk Atoms.Ns.empty (U.mk tag)), Record (attrib att), child)
let elem (tag_ns,tag) att child =
Xml (Atom (Atoms.mk tag_ns tag), Record (attrib att), child)
(*
class warner = object method warn w = print_endline ("PXP WARNING: " ^ w) end
......@@ -60,24 +61,28 @@ class warner = object method warn w = print_endline ("PXP WARNING: " ^ w) end
type token =
| Element of Value.t
| Start of string * (string * string) list
| Start of Ns.qname * (Ns.qname * Utf8.t) list * Ns.table
| String of string
let stack = ref []
let ns_table = ref Ns.empty_table
let rec create_elt accu = function
| String s :: st -> create_elt (string s accu) st
| Element x :: st -> create_elt (Pair (x,accu)) st
| Start (name,att) :: st -> stack := Element (elem name att accu) :: st
| Start (name,att,table) :: st ->
stack := Element (elem name att accu) :: st;
ns_table := table
| [] -> assert false
let start_element_handler name att =
if not (only_ws txt.buffer txt.pos) then
stack := String (String.sub txt.buffer 0 txt.pos) :: !stack;
txt.pos <- 0;
stack := Start (name,att) :: !stack
txt.pos <- 0;
let (table,name,att) = Ns.process_start_tag !ns_table name att in
stack := Start (name,att,!ns_table) :: !stack;
ns_table := table
let end_element_handler _ =
let accu =
......@@ -171,7 +176,8 @@ let load_html s =
| Nethtml.Data data ->
if (only_ws data (String.length data)) then q else string data q
| Nethtml.Element (tag, att, child) ->
Pair (elem tag att (val_of_docs child), q)
let att = List.map (fun (n,v) -> ((Ns.empty, U.mk n), U.mk v)) att in
Pair (elem (Ns.empty,U.mk tag) att (val_of_docs child), q)
and val_of_docs = function
| [] -> nil
| h::t -> val_of_doc (val_of_docs t) h
......
runtime/print_xml.ml
View file @ 83f3cacc
......@@ -10,10 +10,11 @@ let exn_print_xml = CDuceExn (Pair (
Atom (Atoms.mk_ascii "Invalid_argument"),
string_latin1 "print_xml"))
let string_of_xml ~utf8 v=
let string_of_xml ~utf8 ns_table v =
let to_enc = if utf8 then `Enc_utf8 else `Enc_iso88591 in
let buffer = Buffer.create 127 in
let printer = Ns.Printer.printer ns_table in
let wms =
write_markup_string
......@@ -28,20 +29,51 @@ let string_of_xml ~utf8 v=
(`Out_buffer buffer)
(U.get_str s)
in
let write_att (n,v) = wms (" " ^ (U.get_str n) ^ "=\""); wds v; wms "\"" in
let element_start name attrs =
wms ("<" ^ (U.get_str name)); List.iter write_att attrs; wms ">"
and empty_element name attrs =
wms ("<" ^ (U.get_str name)); List.iter write_att attrs; wms "/>"
and element_end name = wms ("</" ^ (U.get_str name) ^ ">")
let write_att (n,v) =
wms (" " ^ (Ns.Printer.attr printer n) ^ "=\""); wds v; wms "\"" in
let write_xmlns (pr,ns) =
let pr = U.get_str pr in
if pr = "" then wms " xmlns"
else (wms " xmlns:"; wms pr);
wms "=\"";
wds (Ns.value ns);
wms "\"" in
let element_start n xmlns attrs =
wms ("<" ^ (Ns.Printer.tag printer n));
List.iter write_xmlns xmlns;
List.iter write_att attrs;
wms ">"
and empty_element n xmlns attrs =
wms ("<" ^ (Ns.Printer.tag printer n));
List.iter write_xmlns xmlns;
List.iter write_att attrs;
wms "/>"
and element_end n =
wms ("</" ^ (Ns.Printer.attr printer n) ^ ">")
and document_start () =
(* wms ("<?xml version='1.0' encoding='" ^
Netconversion.string_of_encoding to_enc ^
"'?>\n") *)
()
()
in
let rec print_elt = function
let rec register_elt = function
| Xml (Atom tag, Record attrs, content) ->
List.iter
(fun (n,_) -> Ns.Printer.register_attr printer (LabelPool.value n))
(LabelMap.get attrs);
Ns.Printer.register_tag printer (Atoms.value tag);
register_content content
| _ -> ()
and register_content = function
| String_utf8 (_,_,_,q)
| String_latin1 (_,_,_,q) -> register_content q
| Pair (x, q) -> register_elt x; register_content q
| _ -> ()
in
register_elt v;
let rec print_elt xmlns = function
| Xml (Atom tag, Record attrs, content) ->
let tag = Atoms.value tag in
let attrs = LabelMap.mapi_to_list
......@@ -49,13 +81,14 @@ let string_of_xml ~utf8 v=
if not (is_str v) then raise exn_print_xml;
let (s,q) = get_string_utf8 v in
match q with
| Atom a when a = Sequence.nil_atom -> LabelPool.value n, s
| Atom a when a = Sequence.nil_atom ->
(LabelPool.value n), s
| _ -> raise exn_print_xml
) attrs in
(match content with
| Atom a when a = Sequence.nil_atom -> empty_element tag attrs
| Atom a when a = Sequence.nil_atom -> empty_element tag xmlns attrs
| _ ->
element_start tag attrs;
element_start tag xmlns attrs;
print_content content;
element_end tag)
| _ -> raise exn_print_xml
......@@ -63,17 +96,17 @@ let string_of_xml ~utf8 v=
let (s,q) = get_string_utf8 v in
wds s;
match q with
| Pair (x, q) -> print_elt x; print_content q
| Pair (x, q) -> print_elt [] x; print_content q
| Atom a when a = Sequence.nil_atom -> ()
| _ -> raise exn_print_xml
in
document_start ();
print_elt v;
print_elt (Ns.Printer.prefixes printer) v;
Buffer.contents buffer
let print_xml ~utf8 s =
let print_xml ~utf8 ns_table s =
try
let s = string_of_xml ~utf8 s in
let s = string_of_xml ~utf8 ns_table s in
if utf8 then string_utf8 (U.mk s) else string_latin1 s
with exn ->
raise
......
runtime/value.ml
View file @ 83f3cacc
......@@ -25,14 +25,15 @@ let vtrue = Atom (Atoms.mk_ascii "true")
let vfalse = Atom (Atoms.mk_ascii "false")
let vbool x = if x then vtrue else vfalse
(* TODO: namespaces for the two following functions *)
let vrecord l =
let l = List.map (fun (l,v) -> LabelPool.mk (U.mk l), v) l in
let l = List.map (fun (l,v) -> LabelPool.mk (Ns.empty, U.mk l), v) l in
Record (LabelMap.from_list (fun _ _ -> assert false) l)
let get_fields = function
| Record map ->
LabelMap.mapi_to_list
(fun k v -> Utf8.to_string (LabelPool.value k), v)
(fun k v -> Utf8.to_string (snd (LabelPool.value k)), v)
map
| _ -> assert false
......@@ -192,7 +193,7 @@ and print_record ppf = function
| f :: rem -> Format.fprintf ppf " %a;%a" print_field f print_record rem
and print_field ppf (l,v) =
Format.fprintf ppf "%a=%a" U.print (LabelPool.value l) print v
Format.fprintf ppf "%a=%a" Label.print (LabelPool.value l) print v
let normalize_string_latin1 i j s q =
if i = j then q else
......
schema/schema_xml.ml
View file @ 83f3cacc
......@@ -151,7 +151,9 @@ let pxp_stream_of_value v =
what is still to be visited *)
(match !stack with
| (Fully ((Value.Xml (Value.Atom a, attrs, _)) as v)) :: tl ->
let tag_ascii = Encodings.Utf8.to_string (Atoms.value a) in
let (ns,a) = Atoms.value a in
assert( ns == Ns.empty );
let tag_ascii = Encodings.Utf8.to_string a in
let attrs_ascii =
List.map (fun (k, v) -> (k, Value.get_string_latin1 v))
(Value.get_fields attrs)
......@@ -170,7 +172,9 @@ let pxp_stream_of_value v =
stack := (List.rev !children) @ !stack;
event
| (Half (Value.Xml (Value.Atom a, _, _))) :: tl ->
let tag_ascii = Encodings.Utf8.to_string (Atoms.value a) in
let (ns,a) = Atoms.value a in
assert( ns == Ns.empty );
let tag_ascii = Encodings.Utf8.to_string a in
let event = Some (E_end_tag (tag_ascii, eid)) in
stack := tl;
event
......
types/atoms.ml
View file @ 83f3cacc
open Encodings
module Ns = struct
include Pool.Make(Utf8)
let prefixes_to_ns = State.ref "Ns.prefixes" (Hashtbl.create 63)
let ns_to_prefixes = State.ref "Ns.prefixes" (Hashtbl.create 63)
let register_prefix p ns =
if (Hashtbl.mem !prefixes_to_ns p) ||
(Hashtbl.mem !ns_to_prefixes ns)
then ()
else ( Hashtbl.add !ns_to_prefixes ns p;
Hashtbl.add !prefixes_to_ns p ns )
let counter = State.ref "Ns.prefixes" 0
let rec fresh_prefix () =
incr counter;
let s = Utf8.mk (Printf.sprintf "ns%i" !counter) in
if (Hashtbl.mem !prefixes_to_ns s) then fresh_prefix () else s
let prefix ns =
try Hashtbl.find !ns_to_prefixes ns
with Not_found ->
let p = fresh_prefix () in
register_prefix p ns;
p
let dump_prefix_table ppf =
Hashtbl.iter
(fun ns p ->
Format.fprintf ppf "%a=>%a@." Utf8.print p Utf8.print (value ns))
!ns_to_prefixes
let empty = mk (Utf8.mk "")
let _ = register_prefix (Utf8.mk "") empty
end
module Symbol = Pool.Make(Utf8)
type v = Ns.t * Symbol.t
......@@ -58,20 +21,10 @@ let mk ns x =
let mk_ascii s = mk Ns.empty (Utf8.mk s)
let value (ns,x) =
assert (ns == Ns.empty);
Symbol.value x
(* get rid of this function *)
let print_prefix ppf ns =
if ns == Ns.empty then () else
Format.fprintf ppf "%a:" Utf8.print (Ns.prefix ns)
let print_symbol ppf x =
Utf8.print ppf (Symbol.value x)
let value (ns,x) = (ns, Symbol.value x)
let vprint ppf ((ns,x) : v) =
Format.fprintf ppf "%a%a" print_prefix ns print_symbol x
Ns.print_qname ppf (ns, Symbol.value x)
let print_any_in_ns ppf ns =
let ns = Ns.prefix ns in
......