Commit a7e0b530 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-02-22 16:14:40 by afrisch] Better implem for all-groups

Original author: afrisch
Date: 2005-02-22 16:14:40+00:00
parent a6d7e242
...@@ -29,15 +29,6 @@ let string_of_value value = ...@@ -29,15 +29,6 @@ let string_of_value value =
let foo_qname = Ns.empty, Utf8.mk "" let foo_qname = Ns.empty, Utf8.mk ""
let ptbl_of_particles particles =
let tbl = QTable.create 20 in
List.iter (* fill table *)
(* ASSUMPTION: firsts are disjoing as per UPA Schema constraint *)
(fun p ->
List.iter (fun tag -> QTable.add tbl tag p) (first_of_particle p))
particles;
tbl
(** Validation context *) (** Validation context *)
class type validation_context = class type validation_context =
object object
...@@ -254,6 +245,24 @@ let check_fixed ~context fixed value = ...@@ -254,6 +245,24 @@ let check_fixed ~context fixed value =
validation_error ~context (sprintf "Expected fixed value: %s; found %s" validation_error ~context (sprintf "Expected fixed value: %s; found %s"
(string_of_value fixed) (string_of_value value)) (string_of_value fixed) (string_of_value value))
let next_pcdata context =
let rec aux accu =
match context#peek with
| E_char_data utf8_data when context#mixed ->
context#junk;
aux (Value.concat accu (string_utf8 utf8_data))
| E_char_data utf8_data ->
validation_error ~context
(sprintf "Unexpected char data in non-mixed content: %s"
(Utf8.get_str utf8_data))
| _ -> accu
in
aux Value.nil
let next_tag context =
match context#peek with
| E_start_tag qname -> qname
| _ -> raise Not_found
let validate_attribute_uses context attr_uses = let validate_attribute_uses context attr_uses =
let tbl = QTable.create 11 in let tbl = QTable.create 11 in
...@@ -391,54 +400,57 @@ and validate_term context term = ...@@ -391,54 +400,57 @@ and validate_term context term =
| Model model_group -> | Model model_group ->
validate_model_group context model_group validate_model_group context model_group
(** @return (Value.t * Utf8.t) and validate_choice context particles =
* 2nd value is the key for tbl that return the particle effectively used for (* TODO: Handle case when one of the choices is nullable *)
* validation *) let tbl = QTable.create 20 in
and validate_choice context tbl = List.iter
let backlog = ref Value.nil in (fun p ->
let concat v = backlog := Value.concat !backlog v in List.iter (fun tag -> QTable.add tbl tag p) (first_of_particle p))
let rec next_tag () = particles;
match context#peek with let txt = next_pcdata context in
| E_char_data utf8_data when context#mixed ->
concat (string_utf8 utf8_data);
context#junk;
next_tag ()
| E_char_data utf8_data (* when not context#mixed *) ->
validation_error ~context
(sprintf "Unexpected char data in non-mixed content: %s"
(Utf8.get_str utf8_data))
| E_start_tag qname -> qname
| ev ->
validation_error ~context
(sprintf "Unexpected content: %s" (string_of_event ev))
in
let qname = next_tag () in
try try
let qname = next_tag context in
let particle = QTable.find tbl qname in let particle = QTable.find tbl qname in
(* BUG: should put the backlog back !!! *) Value.concat txt (validate_particle context particle)
Value.concat !backlog (validate_particle context particle), qname
with Not_found -> with Not_found ->
validation_error ~context (sprintf "Unexpected element %s" validation_error ~context (sprintf "Cannot choose branch of choice group")
(Ns.QName.to_string qname))
and validate_all_group context particles =
let tbl = QTable.create 20 in
let slots : (bool * Value.t option ref) list =
List.map
(fun p ->
let slot = ref None in
let first = first_of_particle p in
List.iter (fun tag -> QTable.add tbl tag (p,slot)) first;
(nullable p, slot)
) particles in
let contents = ref Value.nil in
let rec aux () =
let qname = next_tag context in
let p,slot = QTable.find tbl qname in
match !slot with
| Some x -> ()
| None -> slot := Some (validate_particle context p); aux ()
in
let txt = next_pcdata context in
(try aux () with Not_found -> ());
List.fold_left
(fun accu (nullable,slot) ->
match !slot with
| Some x -> Value.concat accu x
| None when nullable -> accu
| None ->
validation_error ~context
"One particle of the all group is missing"
) txt slots
and validate_model_group context model_group = and validate_model_group context model_group =
match model_group with match model_group with
| All particles -> | All particles -> validate_all_group context particles
(* BUG: reorder ! *) | Choice particles -> validate_choice context particles
let tbl = ptbl_of_particles particles in
let contents = ref Value.nil in
let rec aux () =
if qtable_is_empty tbl then !contents
else begin
let (content, key) = validate_choice context tbl in
contents := Value.concat !contents content;
QTable.remove tbl key;
aux ()
end
in
aux ()
| Choice particles ->
fst (validate_choice context (ptbl_of_particles particles))
| Sequence particles -> | Sequence particles ->
flatten (sequence (List.map (validate_particle context) particles)) flatten (sequence (List.map (validate_particle context) particles))
......
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