Commit db932d00 authored by Pietro Abate's avatar Pietro Abate

[r2005-03-15 23:31:43 by afrisch] Namespaces bindings in data model

Original author: afrisch
Date: 2005-03-15 23:31:45+00:00
parent 89ab8897
......@@ -68,9 +68,11 @@ and compile_aux env tail = function
| Typed.Abstraction a -> compile_abstr env a
| Typed.Cst c -> Const c
| Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, None) ->
Xml (compile env false e1, compile env false e2, compile env tail e3)
| Typed.Xml (_,_) -> assert false
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, Some t) ->
XmlNs (compile env false e1, compile env false e2, compile env tail e3,t)
| Typed.Xml _ -> assert false
| Typed.RecordLitt r -> Record (LabelMap.map (compile env false) r)
| Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q)
| Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs)
......@@ -245,6 +247,10 @@ let namespace (tenv,cenv,codes) pr ns =
let tenv = Typer.type_ns tenv pr ns in
(tenv,cenv,codes)
let keep_ns (tenv,cenv,codes) k =
let tenv = Typer.type_keep_ns tenv k in
(tenv,cenv,codes)
let schema (tenv,cenv,codes) x sch =
let tenv = Typer.type_schema tenv x sch in
(tenv,cenv,codes)
......@@ -278,6 +284,8 @@ let rec phrases ~run ~show ~loading ~directive =
loop (schema accu name uri) rest
| { descr = Ast.Namespace (pr,ns) } :: rest ->
loop (namespace accu pr ns) rest
| { descr = Ast.KeepNs b } :: rest ->
loop (keep_ns accu b) rest
| { descr = Ast.Using (x,cu) } :: rest ->
let cu = find_cu accu cu in
loading cu;
......
......@@ -50,6 +50,7 @@ type expr =
| Const of Types.Const.t
| Pair of expr * expr
| Xml of expr * expr * expr
| XmlNs of expr * expr * expr * Ns.table
| Record of expr label_map
| String of U.uindex * U.uindex * U.t * expr
......@@ -164,7 +165,15 @@ module Put = struct
bits nbits s 5;
expr s e1;
expr s e2;
expr s e3
expr s e3;
bool s false
| XmlNs (e1,e2,e3,ns) ->
bits nbits s 5;
expr s e1;
expr s e2;
expr s e3;
bool s true;
Ns.serialize_table s ns
| Record r ->
bits nbits s 6;
LabelMap.serialize expr s r
......@@ -293,7 +302,11 @@ module Get = struct
let e1 = expr s in
let e2 = expr s in
let e3 = expr s in
Xml (e1,e2,e3)
if bool s then
let ns = Ns.deserialize_table s in
XmlNs (e1,e2,e3,ns)
else
Xml (e1,e2,e3)
| 6 -> Record (LabelMap.deserialize expr s)
| 7 ->
let st = U.deserialize s in
......
......@@ -22,6 +22,7 @@ type expr =
| Const of Types.Const.t
| Pair of expr * expr
| Xml of expr * expr * expr
| XmlNs of expr * expr * expr * Ns.table
| Record of expr label_map
| String of U.uindex * U.uindex * U.t * expr
......
......@@ -43,7 +43,7 @@ let mk ((typing,compile,code),types,ext) =
stub = None
}
let magic = "CDUCE:compunit:00004"
let magic = "CDUCE:compunit:00005"
let obj_path = ref [ "" ]
......
......@@ -3,6 +3,10 @@
Disallow: namespace xml="..."
*)
(* TODO:
It is very important to hash-cons table when
serializing/deserializing code with many XmlNs literals ... *)
module U = Encodings.Utf8
let empty_str = U.mk ""
......@@ -31,36 +35,76 @@ module Table = Map.Make(U)
type table = t Table.t
let empty_table =
List.fold_left
(fun table (pr,ns) -> Table.add (U.mk pr) ns table)
Table.empty
["", empty; "xml", xml_ns]
module TableData = Custom.List(Custom.Pair(U)(U))
module TableHash = Hashtbl.Make(TableData)
let get_table table : TableData.t =
Table.fold (fun prefix ns r ->
let std =
try equal (Table.find prefix empty_table) ns
with Not_found -> false in
if std then r else (prefix,value ns)::r) table []
let mk_table =
List.fold_left
(fun table (pr,ns) -> Table.add pr (mk ns) table)
empty_table
let ser_prop =
Serialize.Put.mk_property (fun t -> (ref 0, TableHash.create 17))
let serialize_table s table =
Table.iter
(fun prefix ns ->
Serialize.Put.bool s true;
U.serialize s prefix;
P.serialize s ns
) table;
Serialize.Put.bool s false
let (nb,tbl) = Serialize.Put.get_property ser_prop s in
let p = get_table table in
try
let i = TableHash.find tbl p in
Serialize.Put.int s i
with Not_found ->
let i = !nb in
incr nb;
TableHash.add tbl p i;
Serialize.Put.int s i;
TableData.serialize s p
let deser_prop =
Serialize.Get.mk_property (fun t -> ref [||])
let deserialize_table s =
let rec aux table =
if not (Serialize.Get.bool s) then table
else
let prefix = U.deserialize s in
let ns = P.deserialize s in
aux (Table.add prefix ns table)
let tbl = Serialize.Get.get_property deser_prop s in
let i = Serialize.Get.int s in
(if (i >= Array.length !tbl) then
let ntbl = Array.create (2 * i + 10) None in
Array.blit !tbl 0 ntbl 0 (Array.length !tbl);
tbl := ntbl);
let p = match !tbl.(i) with
| None ->
let p = TableData.deserialize s in
(!tbl).(i) <- Some p;
p
| Some p ->
p
in
aux Table.empty
mk_table p
(* TODO: avoid re-inserting the same hint for the same
namespace ==> otherwise memory leak with load_xml ... *)
let global_hints = State.ref "Ns.prefixes" (Hashtbl.create 63)
let empty_table =
let def_table =
List.fold_left
(fun table (pr,ns) -> Table.add (U.mk pr) ns table)
Table.empty
["", empty; "xml", xml_ns; "xsd", xsd_ns; "xsi", xsi_ns]
empty_table
["xsd", xsd_ns; "xsi", xsi_ns]
let add_prefix pr ns table =
if (U.get_str pr <> "") then Hashtbl.add !global_hints ns pr;
Table.add pr ns table
......@@ -222,7 +266,7 @@ end
module InternalPrinter =
struct
let p = State.ref "Ns.InternalPrinter" (Printer.printer empty_table)
let p = State.ref "Ns.InternalPrinter" (Printer.printer def_table)
let set_table t =
p := Printer.printer t
......
......@@ -9,6 +9,7 @@ val mk: Utf8.t -> t
val mk_ascii: string -> t
val value: t -> Utf8.t
val empty : t
val value: t -> Utf8.t
val xml_ns: t
......@@ -24,9 +25,12 @@ type table (* prefix => namespace *)
val serialize_table: table Serialize.Put.f
val deserialize_table: table Serialize.Get.f
val empty_table: table (* Contains only xml *)
val def_table: table (* Contains xml,xsd,xsi *)
val add_prefix: Utf8.t -> t -> table -> table
val dump_table: Format.formatter -> table -> unit
val get_table: table -> (Utf8.t * Utf8.t) list
val process_start_tag:
table -> string -> (string * string) list ->
table * qname * (qname * Utf8.t) list
......
......@@ -12,6 +12,7 @@ and pmodule_item' =
| LetDecl of ppat * pexpr
| FunDecl of pexpr
| Namespace of U.t * Ns.t
| KeepNs of bool
| Using of U.t * U.t
| EvalStatement of pexpr
| Directive of toplevel_directive
......@@ -71,6 +72,7 @@ and pexpr =
(* Other *)
| NamespaceIn of U.t * Ns.t * pexpr
| KeepNsIn of bool * pexpr
| Forget of pexpr * ppat
| Check of pexpr * ppat
| Ref of pexpr * ppat
......
......@@ -146,11 +146,18 @@ EXTEND
| "schema"; name = IDENT; "="; uri = STRING2 ->
protect_op "schema";
[ mk loc (SchemaDecl (U.mk name, uri)) ]
| (name,ns) = namespace_binding ->
[ mk loc (Namespace (name, ns)) ]
| (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
let e = exp loc (NamespaceIn (name, ns, e2)) in
[ mk loc (EvalStatement (exp loc e)) ]
| n = namespace_binding ->
let d = match n with
| `Prefix (name,ns) -> Namespace (name, ns)
| `Keep b -> KeepNs b in
[ mk loc d ]
| n = namespace_binding; "in"; e2 = expr LEVEL "top" ->
let e =
match n with
| `Prefix (name,ns) -> NamespaceIn (name, ns, e2)
| `Keep b -> KeepNsIn (b,e2)
in
[ mk loc (EvalStatement (exp loc e)) ]
| "debug"; d = debug_directive -> [ mk loc (Directive (`Debug d)) ]
| "#"; IDENT "verbose" -> [ mk loc (Directive `Verbose) ]
| "#"; IDENT "silent" -> [ mk loc (Directive `Silent) ]
......@@ -247,8 +254,10 @@ EXTEND
exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
exp loc (let_in e1 p e2)
| (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
exp loc (NamespaceIn (name, ns, e2))
| n = namespace_binding; "in"; e2 = expr LEVEL "top" ->
(match n with
| `Prefix (name,ns) -> exp loc (NamespaceIn (name, ns, e2))
| `Keep f -> exp loc (KeepNsIn (f,e2)))
| e = expr; ":"; p = pat ->
exp loc (Forget (e,p))
| e = expr; ":"; "?"; p = pat ->
......@@ -386,14 +395,16 @@ EXTEND
];
namespace_binding: [
[ "namespace";
name = [ name = [ IDENT | keyword ]; "=" ->
ident name
| -> U.mk "" ];
uri = STRING2 ->
let ns = Ns.mk (ident uri) in
(name,ns)
]
[ "namespace"; r = [
[ name =
[ name = [ IDENT | keyword ]; "=" -> ident name
| -> U.mk "" ];
uri = STRING2 ->
let ns = Ns.mk (ident uri) in
`Prefix (name,ns)
| IDENT "on" -> `Keep true
| IDENT "off" -> `Keep false ]
] -> r ]
];
......
......@@ -135,6 +135,11 @@ let rec eval env = function
let v2 = eval env e2 in
let v3 = eval env e3 in
Value.Xml (v1,v2,v3)
| XmlNs (e1,e2,e3,ns) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
let v3 = eval env e3 in
Value.XmlNs (v1,v2,v3,ns)
| Record r -> Value.Record (LabelMap.map (eval env) r)
| String (i,j,s,q) -> Value.substring_utf8 i j s (eval env q)
| Match (e,brs) -> eval_branches env brs (eval env e)
......@@ -313,6 +318,9 @@ and eval_xtrans_aux env brs acc = function
| Value.Xml (tag, attr, child) ->
let child = eval_xtrans env brs child in
Value.Xml (tag, attr, child)
| Value.XmlNs (tag, attr, child, ns) ->
let child = eval_xtrans env brs child in
Value.XmlNs (tag, attr, child, ns)
| x -> x in
let acc' = Value.Pair (x, Absent) in
set_cdr acc acc';
......
......@@ -4,6 +4,7 @@ open Value
open Ident
open Encodings
let keep_ns = ref true
type buf =
{ mutable buffer : string;
......@@ -43,12 +44,15 @@ let attrib att =
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_ns,tag) att child =
Xml (Atom (Atoms.V.mk tag_ns tag), Record (attrib att), child)
let elem ns (tag_ns,tag) att child =
if !keep_ns then
XmlNs (Atom (Atoms.V.mk tag_ns tag), Record (attrib att), child, ns)
else
Xml (Atom (Atoms.V.mk tag_ns tag), Record (attrib att), child)
type stack =
| Element of Value.t * stack
| Start of Ns.qname * (Ns.qname * Utf8.t) list * Ns.table * stack
| Start of Ns.table * Ns.qname * (Ns.qname * Utf8.t) list * Ns.table * stack
| String of string * stack
| Empty
......@@ -58,9 +62,9 @@ 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,table,st) ->
stack := Element (elem name att accu, st);
ns_table := table
| Start (ns,name,att,old_table,st) ->
stack := Element (elem ns name att accu, st);
ns_table := old_table
| Empty -> assert false
let start_element_handler name att =
......@@ -69,7 +73,7 @@ let start_element_handler name att =
txt.pos <- 0;
let (table,name,att) = Ns.process_start_tag !ns_table name att in
stack := Start (name,att,!ns_table, !stack);
stack := Start (table,name,att,!ns_table, !stack);
ns_table := table
let end_element_handler _ =
......@@ -86,8 +90,9 @@ let text_handler = add_string txt
let xml_parser = ref (fun s -> failwith "No XML parser available")
let load_xml s =
let load_xml ?(ns=false) s =
try
keep_ns := ns;
!xml_parser s;
match !stack with
| Element (x,Empty) -> stack := Empty; x
......@@ -102,7 +107,7 @@ let load_html s =
if (only_ws data (String.length data)) then q else string data q
| Nethtml.Element (tag, att, child) ->
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)
Pair (elem Ns.empty_table (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
......
val load_xml: string -> Value.t
val load_xml: ?ns:bool -> string -> Value.t
val load_html: string -> Value.t
......
......@@ -129,7 +129,8 @@ let string_of_xml ~utf8 ns_table v =
in
let rec register_elt = function
| Xml (Atom tag, Record attrs, content) ->
| Xml (Atom tag, Record attrs, content)
| XmlNs (Atom tag, Record attrs, content, _) ->
List.iter
(fun (n,_) -> Ns.Printer.register_attr printer (LabelPool.value n))
(LabelMap.get attrs);
......@@ -146,7 +147,8 @@ let string_of_xml ~utf8 ns_table v =
register_elt v;
let rec print_elt xmlns = function
| Xml (Atom tag, Record attrs, content) ->
| Xml (Atom tag, Record attrs, content)
| XmlNs (Atom tag, Record attrs, content, _) ->
let tag = Atoms.V.value tag in
let attrs = LabelMap.mapi_to_list
(fun n v ->
......@@ -174,7 +176,7 @@ let string_of_xml ~utf8 ns_table v =
let (s,q) = get_string_utf8 v in
wds s;
match q with
| Pair (Xml _ 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 -> ()
| v -> schema_value ~wds v
in
......
......@@ -190,7 +190,8 @@ let rec run_dispatcher d v =
and run_disp_kind actions v =
match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
| Xml (v1,v2,v3) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
| Xml (v1,v2,v3)
| XmlNs (v1,v2,v3,_) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
| Record r -> run_disp_record false v (LabelMap.get r) actions.record
| String_latin1 (i,j,s,q) ->
(* run_disp_kind actions (Value.normalize v) *)
......@@ -449,7 +450,8 @@ let rec run_dispatcher d v =
and run_disp_kind actions v =
match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.prod
| Xml (v1,v2,v3) -> run_disp_prod v v1 (Pair (v2,v3)) actions.xml
| Xml (v1,v2,v3) | XmlNs (v1,v2,v3,_) ->
run_disp_prod v v1 (Pair (v2,v3)) actions.xml
| Record r -> run_disp_record !cursor false v (LabelMap.get r) actions.record
| String_latin1 (i,j,s,q) ->
run_disp_kind actions (Value.normalize v)
......
......@@ -4,6 +4,7 @@ open Encodings
type t =
| Pair of t * t
| Xml of t * t * t
| XmlNs of t * t * t * Ns.table
| Record of t label_map
| Atom of Atoms.V.t
| Integer of Intervals.V.t
......@@ -81,7 +82,7 @@ let rec const = function
let rec inv_const = function
| Pair (x, y) -> Types.Pair (inv_const x, inv_const y)
| Xml (x, y, z) ->
| Xml (x, y, z) | XmlNs (x,y,z,_) ->
Types.Pair (inv_const x, Types.Pair (inv_const y, inv_const z))
| Record x -> Types.Record (LabelMap.map inv_const x)
| Atom a -> Types.Atom a
......@@ -251,7 +252,7 @@ let rec print ppf v =
else if is_seq v then Format.fprintf ppf "[ @[<hv>%a@]]" print_seq v
else match v with
| Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
| Xml (x,y,z) -> print_xml ppf x y z
| Xml (x,y,z) | XmlNs (x,y,z,_) -> print_xml ppf x y z
| Record l -> Format.fprintf ppf "{%a }" print_record (LabelMap.get l)
| Atom a -> Atoms.V.print_quote ppf a
| Integer i -> Intervals.V.print ppf i
......@@ -334,7 +335,7 @@ let dump_xml ppf v =
| Pair (x, y) ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<pair>@,%a@,%a@,</pair>@]" aux x aux y
| Xml (x, y, z) ->
| Xml (x, y, z) | XmlNs (x,y,z,_) ->
Format.fprintf ppf "@[<hv1>";
Format.fprintf ppf "<xml>@,%a@,%a@,%a@,</xml>@]" aux x aux y aux z
| Record x ->
......@@ -389,7 +390,8 @@ let rec compare x y =
| Pair (x1,x2), Pair (y1,y2) ->
let c = compare x1 y1 in if c <> 0 then c
else compare x2 y2
| Xml (x1,x2,x3), Xml (y1,y2,y3) ->
| (Xml (x1,x2,x3) | XmlNs (x1,x2,x3,_)),
(Xml (y1,y2,y3) | XmlNs(y1,y2,y3,_)) ->
let c = compare x1 y1 in if c <> 0 then c
else let c = compare x2 y2 in if c <> 0 then c
else compare x3 y3
......@@ -451,7 +453,8 @@ let rec compare x y =
| _, String_utf8 (i,j,s,q) -> compare x (normalize_string_utf8 i j s q)
| Pair (_,_), _ -> -1 | _, Pair(_,_) -> 1
| Xml (_,_,_),_ -> -1 | _, Xml(_,_,_) -> 1
| (Xml (_,_,_) | XmlNs (_,_,_,_)),_ -> -1
| _, (Xml(_,_,_) | XmlNs(_,_,_,_)) -> 1
| Record _,_ -> -1 | _, Record _ -> 1
| Atom _,_ -> -1 | _, Atom _ -> 1
| Integer _,_ -> -1 | _, Integer _ -> 1
......@@ -476,9 +479,10 @@ let iter_xml pcdata_callback other_callback =
| v -> raise (Invalid_argument "Value.iter_xml")
in
function
| Xml (_,_,cont) -> aux cont
| Xml (_,_,cont) | XmlNs (_,_,cont,_) -> aux cont
| _ -> raise (Invalid_argument "Value.iter_xml")
(*
let map_xml map_pcdata map_other =
let patch_string_utf8 cont = function
| String_utf8 (i, j, u, v) when compare v nil = 0 ->
......@@ -498,7 +502,7 @@ let map_xml map_pcdata map_other =
function
| Xml (tag,attrs,cont) -> Xml (tag, attrs, aux cont)
| _ -> raise (Invalid_argument "Value.map_xml")
*)
let tagged_tuple tag vl =
let ct = sequence vl in
......
......@@ -5,6 +5,7 @@ type t =
(* Canonical representation *)
| Pair of t * t
| Xml of t * t * t
| XmlNs of t * t * t * Ns.table
| Record of t label_map
| Atom of Atoms.V.t
| Integer of Intervals.V.t
......@@ -73,8 +74,10 @@ val mk_ext_ref : Types.t option -> (unit -> t) -> (t -> unit) -> t
character children; second callback is invoked on other children values *)
val iter_xml : (U.t -> unit) -> (t -> unit) -> t -> unit
(*
(* as above for map *)
val map_xml : (U.t -> U.t) -> (t -> t) -> t -> t
*)
val concat : t -> t -> t
val flatten : t -> t
......
......@@ -4,6 +4,9 @@ let eval = ref (fun ppf err s -> assert false)
(* Types *)
let namespaces =
Sequence.star (Types.times (Types.cons string) (Types.cons string))
let types =
[
"Empty", Types.empty;
......@@ -20,6 +23,7 @@ let types =
"Bool", bool;
"Float", float;
"AnyXml", any_xml;
"Namespaces", namespaces;
]
let env =
......@@ -88,6 +92,12 @@ let exn_float_of =
Value.Pair (
Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
Value.string_latin1 "float_of"))
let exn_namespaces =
Value.CDuceExn (
Value.Pair (
Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
Value.string_latin1 "namespaces"))
let eval_load_file ~utf8 e =
Location.protect_op "load_file";
......@@ -146,6 +156,12 @@ register_fun "load_xml"
string_latin1 any_xml
(fun v -> Location.protect_op "load_xml"; Load_xml.load_xml (Value.get_string_latin1 v));;
register_fun "!load_xml"
string_latin1 any_xml
(fun v -> Location.protect_op "load_xml"; Load_xml.load_xml ~ns:true
(Value.get_string_latin1 v));;
register_fun "load_html"
string_latin1 Sequence.any
(fun v -> Location.protect_op "load_html"; Load_xml.load_html (Value.get_string_latin1 v));;
......@@ -302,7 +318,18 @@ unary_op_gen "flatten"
register_fun "raise" any Types.empty
(fun v -> raise (Value.CDuceExn v));;
register_fun "namespaces" any_xml
namespaces
(function
Value.XmlNs (_,_,_,ns) ->
Value.sequence_rev
(List.map
(fun (pr,ns) ->
Value.Pair (Value.string_utf8 pr,
Value.string_utf8 ns))
(Ns.get_table ns))
| Value.Xml _ -> raise exn_namespaces
| _ -> assert false);;
(* Float *)
......
......@@ -45,3 +45,4 @@ val float_abs: Types.Abstract.abs
val any_xml : Types.t
val any_xml_with_tag: Atoms.t -> Types.t
......@@ -33,7 +33,7 @@ and texpr' =
(* Data constructors *)
| Cst of Types.const
| Pair of texpr * texpr
| Xml of texpr * texpr
| Xml of texpr * texpr * Ns.table option
| RecordLitt of texpr label_map
| String of U.uindex * U.uindex * U.t * texpr
......
......@@ -44,6 +44,7 @@ type t = {
ids : item Env.t;
ns: Ns.table;
cu: ext UEnv.t;
keep_ns: bool
}
let load_schema = ref (fun _ _ -> assert false)
......@@ -89,14 +90,15 @@ let deserialize s =
Serialize.Get.list
(Serialize.Get.pair U.deserialize Serialize.Get.string) s in
let env =
{ ids = ids; ns = ns; cu = UEnv.empty } in
{ ids = ids; ns = ns; cu = UEnv.empty; keep_ns = false } in