[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

schema/schema_validator.ml

@@ -29,15 +29,6 @@ let string_of_value value =
 
 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 *)
 class type validation_context =
   object
@@ -254,6 +245,24 @@ let check_fixed ~context fixed value =
     validation_error ~context (sprintf "Expected fixed value: %s; found %s"
       (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 tbl = QTable.create 11 in
@@ -391,54 +400,57 @@ and validate_term context term =
   | Model model_group -> 
       validate_model_group context model_group
 
-  (** @return (Value.t * Utf8.t)
-   * 2nd value is the key for tbl that return the particle effectively used for
-   * validation *)
-and validate_choice context tbl =
-  let backlog = ref Value.nil in
-  let concat v = backlog := Value.concat !backlog v in
-  let rec next_tag () =
-    match context#peek with
-    | 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
+and validate_choice context particles =
+(* TODO: Handle case when one of the choices is nullable *)
+  let tbl = QTable.create 20 in
+  List.iter
+    (fun p -> 
+       List.iter (fun tag -> QTable.add tbl tag p) (first_of_particle p))
+    particles;
+  let txt = next_pcdata context in
   try
+    let qname = next_tag context in
     let particle = QTable.find tbl qname in
-(* BUG: should put the backlog back !!! *)
-    Value.concat !backlog (validate_particle context particle), qname
+    Value.concat txt (validate_particle context particle)
   with Not_found ->
-    validation_error ~context (sprintf "Unexpected element %s"
-				 (Ns.QName.to_string qname))
+    validation_error ~context (sprintf "Cannot choose branch of choice group")
+
+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 =
   match model_group with
-  | All particles ->
-(* BUG: reorder ! *)
-      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))
+  | All particles -> validate_all_group context particles
+  | Choice particles -> validate_choice context particles
   | Sequence particles ->
       flatten (sequence (List.map (validate_particle context) particles))