[r2003-11-26 16:22:19 by szach] added first related functions: first_of_particle,

first_of_model_group, is_in_first, nullable

Original author: szach
Date: 2003-11-26 16:22:19+00:00

schema/schema_common.ml

@@ -39,7 +39,7 @@ let name_of_attribute_use (_, (name, _, _), _) = name
 let name_of_attribute_group_definition = fst
 let name_of_model_group_definition = fst
 let name_of_particle = function
-  | (_, _, Elt elt_decl_ref) -> name_of_element_declaration !elt_decl_ref
+  | (_, _, Elt elt_decl_ref, _) -> name_of_element_declaration !elt_decl_ref
   | _ -> assert false
 let variety_of_simple_type_definition = function
   | (Primitive name) as st -> Atomic st
@@ -85,6 +85,23 @@ let rec normalize_white_space =
 let anySimpleType = Primitive (Encodings.Utf8.mk "xsd:anySimpleType")
 let anyType = AnyType
 
+let first_of_particle (_, _, _, first) = first
+let nullable p = List.mem None (first_of_particle p)
+let first_of_model_group = function
+  | All particles | Choice particles ->
+      List.concat (List.map first_of_particle particles)
+  | Sequence particles ->
+      let rec aux = function
+        | hd :: tl when nullable hd -> (first_of_particle hd) @ (aux tl)
+        | hd :: tl -> first_of_particle hd
+        | [] -> []
+      in
+      aux particles
+let rec is_in_first tag = function
+  | [] -> false
+  | Some tag' :: rest when Utf8.equal tag' tag -> true
+  | _ :: rest -> is_in_first tag rest
+
 let get_interval facets =
   (* ASSUMPTION:
    *  not (facets.minInclusive = Some _ && facets.minExclusive = Some _)
@@ -293,7 +310,7 @@ type to_be_visited =
 let stream_of_value v =
   let stack = ref [Fully v] in
   let f _ = (* lazy visit of a tree of CDuce XML values, stack keeps track of
-            what is still to be visited *)
+            what has still to be visited *)
     match !stack with
     | (Fully ((Value.Xml (Value.Atom atom, attrs, _)) as v)) :: tl ->
         stack := (Half v) :: tl;

schema/schema_common.mli

@@ -56,6 +56,11 @@ val iter_attribute_groups:
   schema -> (attribute_group_definition -> unit) -> unit
 val iter_model_groups: schema -> (model_group_definition -> unit) -> unit
 
+val first_of_particle: particle -> first
+val first_of_model_group: model_group -> first
+val is_in_first: Utf8.t -> first -> bool
+val nullable: particle -> bool
+
 (** {2 Facets} *)
 
 val merge_facets: facets -> facets -> facets
@@ -80,8 +85,8 @@ val get_interval: facets -> Intervals.t
   (** perform white space normalization according to XML recommendation *)
 val normalize_white_space: white_space_handling -> Utf8.t -> Utf8.t
 
-  (** event interface on top of CDuce values *)
-val stream_of_value: Value.t -> event Stream.t
+(** {2 event interface on top of CDuce values} *)
 
+val stream_of_value: Value.t -> event Stream.t
 val string_of_event: event -> string