Skip to content

GitLab

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

[r2003-11-24 16:03:12 by szach] use Utf8 everywhere in schema support 

Original author: szach
Date: 2003-11-24 16:03:14+00:00
parent 7121a7e3
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 609 additions and 634 deletions
compile/lambda.ml
View file @ c5e7054e
......@@ -26,7 +26,7 @@ type expr =
| Transform of expr * branches
| Xtrans of expr * branches
| Try of expr * branches
| Validate of expr * schema_component_kind * string * string
| Validate of expr * schema_component_kind * U.t * U.t
| RemoveField of expr * label
| Dot of expr * label
| UnaryOp of int * expr
......
driver/cduce.ml
View file @ c5e7054e
......@@ -69,7 +69,7 @@ let dump_env ppf =
Format.fprintf ppf "Namespace prefixes used for pretty-printing:@.%t"
Ns.InternalPrinter.dump;
Format.fprintf ppf "Schemas: %s@."
(String.concat " " (Typer.get_schema_names ()));
(String.concat " " (List.map U.get_str (Typer.get_schema_names ())));
Format.fprintf ppf "Values:@.";
Typer.iter_values !typing_env
(fun x t -> dump_value ppf x t (get_global_value x))
......
parser/ast.ml
View file @ c5e7054e
......@@ -8,7 +8,7 @@ type pprog = pmodule_item list
and pmodule_item = pmodule_item' located
and pmodule_item' =
| TypeDecl of id * ppat
| SchemaDecl of string * Schema_types.schema (* name, schema *)
| SchemaDecl of U.t * Schema_types.schema (* name, schema *)
| LetDecl of ppat * pexpr
| FunDecl of pexpr
| Namespace of U.t * Ns.t
......@@ -30,9 +30,9 @@ and toplevel_directive =
| `Reinit_ns
| `Help
| `Dump of pexpr
| `Print_schema of string
| `Print_schema_type of Schema_types.component_kind * string * string
| `Print_type of string
| `Print_schema of U.t
| `Print_schema_type of Schema_types.component_kind * U.t * U.t
| `Print_type of U.t
]
......@@ -59,7 +59,7 @@ and pexpr =
| Map of pexpr * branches
| Transform of pexpr * branches
| Xtrans of pexpr * branches
| Validate of pexpr * Schema_types.component_kind * string * string
| Validate of pexpr * Schema_types.component_kind * U.t * U.t
(* exp, schema component kind, schema name, element name *)
| Dot of pexpr * label
| RemoveField of pexpr * label
......@@ -91,7 +91,7 @@ and ppat = ppat' located
and ppat' =
| PatVar of U.t
| SchemaVar of (* type/pattern schema variable *)
Schema_types.component_kind * string * string (* kind, schema, name *)
Schema_types.component_kind * U.t * U.t (* kind, schema, name *)
| Cst of pexpr
| NsT of U.t
| Recurs of ppat * (id * ppat) list
......
parser/parser.ml
View file @ c5e7054e
......@@ -114,7 +114,7 @@ EXTEND
| "schema"; name = IDENT; "="; uri = STRING2 ->
protect_op "schema";
let schema = Schema_parser.schema_of_file uri in
[ mk loc (SchemaDecl (name, schema)) ]
[ mk loc (SchemaDecl (U.mk name, schema)) ]
| (name,ns) = namespace_binding ->
[ mk loc (Namespace (name, ns)) ]
| (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
......@@ -127,7 +127,7 @@ EXTEND
| DIRECTIVE "#quit" -> [ mk loc (Directive `Quit) ]
| DIRECTIVE "#env" -> [ mk loc (Directive `Env) ]
| DIRECTIVE "#print_schema"; name = IDENT ->
[ mk loc (Directive (`Print_schema name)) ]
[ mk loc (Directive (`Print_schema (U.mk name))) ]
| DIRECTIVE "#print_type"; name = IDENT;
schema_part = OPT [
"#"; typ = [ IDENT | keyword ];
......@@ -135,9 +135,10 @@ EXTEND
(kind, typ)
] ->
(match schema_part with
| None -> [ mk loc (Directive (`Print_type name)) ]
| None -> [ mk loc (Directive (`Print_type (U.mk name))) ]
| Some (kind, typ) ->
[ mk loc (Directive (`Print_schema_type (kind, name, typ))) ])
[ mk loc
(Directive (`Print_schema_type (kind, U.mk name, U.mk typ))) ])
| DIRECTIVE "#dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ]
| DIRECTIVE "#reinit_ns" -> [ mk loc (Directive `Reinit_ns) ]
| DIRECTIVE "#help" -> [ mk loc (Directive `Help) ]
......@@ -483,7 +484,7 @@ EXTEND
schema_ref: [
[ schema = IDENT; "#"; typ = [ IDENT | keyword ];
kind = OPT [ "as"; k = schema_kind -> k] ->
(kind, schema, typ)
(kind, U.mk schema, U.mk typ)
]
];
......@@ -508,7 +509,7 @@ EXTEND
mk loc (Constant (ident a,c))
| schema = IDENT; "#"; typ = [ IDENT | keyword ];
kind = OPT [ "as"; k = schema_kind -> k] ->
mk loc (SchemaVar (kind, schema, typ))
mk loc (SchemaVar (kind, U.mk schema, U.mk typ))
| a = IDENT ->
mk loc (PatVar (U.mk a))
| i = INT ; "--"; j = INT ->
......
schema/schema_builtin.ml
View file @ c5e7054e
This diff is collapsed.
schema/schema_builtin.mli
View file @ c5e7054e
open Encodings
(** all schema simple type names used in this API are prefixed with
* Schema_xml.xsd_prefix *)
exception Schema_builtin_error of string
exception Schema_builtin_error of Utf8.t
val is_builtin: string -> bool
val get_builtin: string -> Schema_types.simple_type_definition
val is_builtin: Utf8.t -> bool
val get_builtin: Utf8.t -> Schema_types.simple_type_definition
val iter_builtin: (Schema_types.simple_type_definition -> unit) -> unit
val cd_type_of_builtin: string -> Types.descr
val cd_type_of_builtin: Utf8.t -> Types.descr
(** @raise Schema_builtin_error [name] in case of validation error, where
(** validate_builtin <builtin> <string>
* validates <string> against builtin type <builtin> and return the resulting
* cduce value
* @raise Schema_builtin_error [name] in case of validation error, where
* [name] is the name of a schema built in type prefixed with
* Schema_xml.xsd_prefix *)
val validate_builtin: string -> string -> Value.t
val validate_builtin: Utf8.t -> Utf8.t -> Value.t
schema/schema_common.ml
View file @ c5e7054e
open Printf
open Encodings
open Encodings.Utf8.Pcre
open Schema_types
let no_facets = {
......@@ -29,7 +31,7 @@ let name_of_complex_type_definition = function
| _, Some name, _, _, _, _ -> name
| _ -> raise (Invalid_argument "anonymous complex type definition")
let name_of_type_definition = function
| AnyType -> "xsd:anyType"
| AnyType -> Encodings.Utf8.mk "xsd:anyType"
| Simple st -> name_of_simple_type_definition st
| Complex ct -> name_of_complex_type_definition ct
let name_of_attribute_declaration (name, _, _) = name
......@@ -63,26 +65,24 @@ let iter_attribute_groups schema f = List.iter f schema.attribute_groups
let iter_model_groups schema f = List.iter f schema.model_groups
exception XSD_validation_error of string
exception XSI_validation_error of validation_context * string
let regexp' s = Pcre.regexp ~flags:[`UTF8] s
exception XSI_validation_error of string
let rec normalize_white_space =
let ws_RE = regexp' "[\t\r\n]" in
let spaces_RE = regexp' "[ ]+" in
let margins_RE = regexp' "^ (.*) $" in
let ws_RE = pcre_regexp "[\t\r\n]" in
let spaces_RE = pcre_regexp "[ ]+" in
let margins_RE = pcre_regexp "^ (.*) $" in
fun handling s ->
match handling with
| `Preserve -> s
| `Replace -> Pcre.replace ~rex:ws_RE ~templ:" " s
| `Replace -> pcre_replace ~rex:ws_RE ~templ:(Utf8.mk " ") s
| `Collapse ->
let s' =
Pcre.replace ~rex:spaces_RE ~templ:" "
pcre_replace ~rex:spaces_RE ~templ:(Utf8.mk " ")
(normalize_white_space `Replace s)
in
Pcre.replace ~rex:margins_RE ~templ:"$1" s'
pcre_replace ~rex:margins_RE ~templ:(Utf8.mk "$1") s'
let anySimpleType = Primitive "xsd:anySimpleType"
let anySimpleType = Primitive (Encodings.Utf8.mk "xsd:anySimpleType")
let anyType = AnyType
let get_interval facets =
......@@ -113,22 +113,27 @@ let get_interval facets =
| None, None -> Intervals.any
let print_simple_type fmt = function
| Primitive name -> Format.fprintf fmt "%s" name
| Derived (Some name, _, _, _) -> Format.fprintf fmt "%s'" name
| Primitive name -> Format.fprintf fmt "%a" Encodings.Utf8.dump name
| Derived (Some name, _, _, _) ->
Format.fprintf fmt "%a'" Encodings.Utf8.dump name
| Derived (None, _, _, _) -> Format.fprintf fmt "unnamed'"
let print_complex_type fmt = function
| (id, Some name, _, _, _, _) -> Format.fprintf fmt "%d:%s" id name
| (id, Some name, _, _, _, _) ->
Format.fprintf fmt "%d:%a" id Encodings.Utf8.dump name
| (id, None, _, _, _, _) -> Format.fprintf fmt "%d:unnamed'" id
let print_type fmt = function
| AnyType -> Format.fprintf fmt "xsd:anyType"
| Simple t -> Format.fprintf fmt "S:%a" print_simple_type t
| Complex t -> Format.fprintf fmt "C:%a" print_complex_type t
let print_attribute fmt (name, t, _) =
Format.fprintf fmt "@@%s:%a" name print_simple_type t
let print_element fmt (id, name, _, _) = Format.fprintf fmt "E:%d:<%s>" id name
Format.fprintf fmt "@@%a:%a" Utf8.dump name print_simple_type t
let print_element fmt (id, name, _, _) =
Format.fprintf fmt "E:%d:<%a>" id Utf8.dump name
let print_attributes fmt = List.iter (Format.fprintf fmt "%a" print_attribute)
let print_attribute_group fmt (name, _) = Format.fprintf fmt "{agroup:%s}" name
let print_model_group fmt (name, _) = Format.fprintf fmt "{mgroup:%s}" name
let print_attribute_group fmt (name, _) =
Format.fprintf fmt "{agroup:%a}" Utf8.dump name
let print_model_group fmt (name, _) =
Format.fprintf fmt "{mgroup:%a}" Utf8.dump name
let print_schema fmt schema =
let defined_types = (* filter out built-in types *)
List.filter
......@@ -277,4 +282,85 @@ let string_of_component_kind (kind: component_kind) =
| Some `Model_group -> "model group"
| None -> "component"
(** Events *)
type to_be_visited =
| Fully of Value.t (* xml values still to be visited *)
| Half of Value.t (* xml values half visited (i.e. E_start_tag generated) *)
| Other of Encodings.Utf8.t (* other values *)
| Backlog of event (* old events not yet delivered *)
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 *)
match !stack with
| (Fully ((Value.Xml (Value.Atom atom, attrs, _)) as v)) :: tl ->
stack := (Half v) :: tl;
let children = ref [] in (* TODO inefficient *)
let push v s = (s := v :: !s) in
Value.iter_xml
(fun pcdata -> push (Other pcdata) children)
(fun v ->
match v with
| (Value.Xml (_, _, _)) as v -> push (Fully v) children
| v -> raise (Invalid_argument "Schema_events.stream_of_value"))
v;
stack := (List.rev !children) @ !stack;
List.iter (* push attributes as events on the stack *)
(fun (qname, v) ->
push (Backlog (E_attribute (qname, fst (Value.get_string_utf8 v))))
stack)
(Value.get_fields attrs);
Some (E_start_tag (Atoms.V.value atom))
| (Half (Value.Xml (Value.Atom atom, _, _))) :: tl ->
stack := tl;
Some (E_end_tag (Atoms.V.value atom))
| (Fully (Value.Xml (_, _, _)))::_ | (Half (Value.Xml (_, _, _)))::_ ->
failwith "Schema_xml.pxp_stream_of_value: non-atom-tag xml value"
| (Backlog ev) :: tl -> (* consume backlog *)
stack := tl;
Some ev
| (Other v) :: tl ->
stack := tl;
Some (E_char_data v)
| [] -> None
| _ -> assert false
in
Stream.from f
let string_of_event = function
| E_start_tag qname -> sprintf "<%s>" (Ns.QName.to_string qname)
| E_end_tag qname -> sprintf "</%s>" (Ns.QName.to_string qname)
| E_attribute (qname, value) ->
sprintf "@%s=%s" (Ns.QName.to_string qname) (Utf8.to_string value)
| E_char_data value -> Utf8.to_string value
(*
let test v =
let s = stream_of_value v in
let rec aux () =
(match Stream.peek s with
| None -> ()
| Some (E_start_tag qname) ->
Ns.QName.print Format.std_formatter qname
| Some (E_end_tag qname) ->
Format.fprintf Format.std_formatter "/";
Ns.QName.print Format.std_formatter qname
| Some (E_attribute (qname, value)) ->
Format.fprintf Format.std_formatter "@@";
Ns.QName.print Format.std_formatter qname;
Format.fprintf Format.std_formatter " ";
Encodings.Utf8.print Format.std_formatter value
| Some (E_char_data value) ->
Encodings.Utf8.print Format.std_formatter value);
Format.fprintf Format.std_formatter "\n";
(match Stream.peek s with
| None -> ()
| _ ->
Stream.junk s;
aux ())
in
aux ()
*)
schema/schema_common.mli
View file @ c5e7054e
(** Schema common functionalities depending only on Schema_types *)
open Encodings
open Schema_types
(** {2 Exceptions} *)
exception XSD_validation_error of string
exception XSI_validation_error of validation_context * string
exception XSI_validation_error of string
(** {2 XSD printer *)
......@@ -22,15 +23,15 @@ val print_complex_type : Format.formatter -> complex_type_definition -> unit
(** {2 Deconstruction functions} *)
val name_of_element_declaration : element_declaration -> string
val name_of_type_definition : type_definition -> string
val name_of_simple_type_definition : simple_type_definition -> string
val name_of_complex_type_definition : complex_type_definition -> string
val name_of_attribute_declaration : attribute_declaration -> string
val name_of_attribute_use : attribute_use -> string
val name_of_attribute_group_definition : attribute_group_definition -> string
val name_of_model_group_definition : model_group_definition -> string
val name_of_particle : particle -> string
val name_of_element_declaration : element_declaration -> Utf8.t
val name_of_type_definition : type_definition -> Utf8.t
val name_of_simple_type_definition : simple_type_definition -> Utf8.t
val name_of_complex_type_definition : complex_type_definition -> Utf8.t
val name_of_attribute_declaration : attribute_declaration -> Utf8.t
val name_of_attribute_use : attribute_use -> Utf8.t
val name_of_attribute_group_definition : attribute_group_definition -> Utf8.t
val name_of_model_group_definition : model_group_definition -> Utf8.t
val name_of_particle : particle -> Utf8.t
val string_of_component_kind : component_kind -> string
......@@ -40,13 +41,13 @@ val simple_type_of_type : type_definition -> simple_type_definition
val complex_type_of_type : type_definition -> complex_type_definition
val content_type_of_type : type_definition -> content_type
val get_type: string -> schema -> type_definition
val get_attribute: string -> schema -> attribute_declaration
val get_element: string -> schema -> element_declaration
val get_attribute_group: string -> schema -> attribute_group_definition
val get_model_group: string -> schema -> model_group_definition
val get_type: Utf8.t -> schema -> type_definition
val get_attribute: Utf8.t -> schema -> attribute_declaration
val get_element: Utf8.t -> schema -> element_declaration
val get_attribute_group: Utf8.t -> schema -> attribute_group_definition
val get_model_group: Utf8.t -> schema -> model_group_definition
val get_component: component_kind -> string -> schema -> component
val get_component: component_kind -> Utf8.t -> schema -> component
val iter_types: schema -> (type_definition -> unit) -> unit
val iter_attributes: schema -> (attribute_declaration -> unit) -> unit
......@@ -61,7 +62,7 @@ val merge_facets: facets -> facets -> facets
(** restrict base new_facets new_name
* Implements simple type derivition by restriction *)
val restrict: simple_type_definition -> facets -> string option ->
val restrict: simple_type_definition -> facets -> Utf8.t option ->
simple_type_definition
(** {2 Miscellaneous} *)
......@@ -77,5 +78,10 @@ val anyType: type_definition
val get_interval: facets -> Intervals.t
(** perform white space normalization according to XML recommendation *)
val normalize_white_space: white_space_handling -> string -> string
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
val string_of_event: event -> string
schema/schema_parser.ml
View file @ c5e7054e
......@@ -2,6 +2,8 @@
open Printf
open Pxp_document
open Encodings
open Encodings.Utf8.Pcre
open Schema_common
open Schema_types
open Schema_validator
......@@ -18,9 +20,8 @@ let debug_print ?(n: pxp_node option) s =
prerr_endline (sprintf "[%d] %s" line s);
flush stderr)
let regexp' s = Pcre.regexp ~flags:[`UTF8] s
let space_RE = regexp' " "
let split s = Pcre.split ~rex:space_RE s
let space_RE = pcre_regexp " "
let split s = pcre_split ~rex:space_RE s
let hashtbl_deref tbl =
(* ASSUMPTION: no multiple bindings *)
let tbl' = Hashtbl.create 1024 in
......@@ -34,15 +35,15 @@ class type resolver =
@raise Osv_validation_error if the same node is seen twice *)
method see : pxp_node -> unit
method resolve_att: ?fix_ns:bool -> string -> attribute_declaration
method resolve_att: ?fix_ns:bool -> Utf8.t -> attribute_declaration
method resolve_elt:
?fix_ns:bool -> now:bool -> string -> element_declaration ref
?fix_ns:bool -> now:bool -> Utf8.t -> element_declaration ref
method resolve_typ:
?fix_ns:bool -> now:bool -> string -> type_definition ref
?fix_ns:bool -> now:bool -> Utf8.t -> type_definition ref
method resolve_att_group:
?fix_ns:bool -> string -> attribute_group_definition
method resolve_model_group: ?fix_ns:bool -> string -> model_group_definition
method resolve_simple_typ: ?fix_ns:bool -> string -> simple_type_definition
?fix_ns:bool -> Utf8.t -> attribute_group_definition
method resolve_model_group: ?fix_ns:bool -> Utf8.t -> model_group_definition
method resolve_simple_typ: ?fix_ns:bool -> Utf8.t -> simple_type_definition
end
module OrderedNode =
......@@ -73,11 +74,14 @@ let parse_facets base n =
debug_print ~n "Schema_parser.parse_facet";
let validate_base_type = Schema_validator.validate_simple_type base in
let validate_nonNegativeInteger =
Schema_builtin.validate_builtin "xsd:nonNegativeInteger"
Schema_builtin.validate_builtin
(Schema_xml.add_xsd_prefix (Utf8.mk "nonNegativeInteger"))
in
let facets = ref no_facets in
n#iter_nodes (fun n ->
let fixed = (_has_attribute "fixed" n) && (_attribute "fixed" n = "true") in
let fixed =
(_has_attribute "fixed" n) && (_attribute "fixed" n = Utf8.mk "true")
in
match n#node_type with
| T_element "xsd:length" ->
let value = _attribute "value" n in
......@@ -92,7 +96,7 @@ let parse_facets base n =
let length = integer_of_value_t (validate_nonNegativeInteger value) in
facets := { !facets with maxLength = Some (length, fixed) }
| T_element "xsd:enumeration" ->
let value = Value.string_latin1 (_attribute "value" n) in
let value = Value.string_utf8 (_attribute "value" n) in
let value = validate_base_type value in
let new_enumeration =
(match !facets.enumeration with
......@@ -101,7 +105,7 @@ let parse_facets base n =
in
facets := { !facets with enumeration = new_enumeration }
| T_element "xsd:whiteSpace" ->
let value = _attribute "value" n in
let value = Utf8.get_str (_attribute "value" n) in
facets := { !facets with whiteSpace =
((match value with
| "collapse" -> `Collapse
......@@ -110,19 +114,19 @@ let parse_facets base n =
| _ -> assert false),
fixed) }
| T_element "xsd:maxInclusive" ->
let value = Value.string_latin1 (_attribute "value" n) in
let value = Value.string_utf8 (_attribute "value" n) in
facets := { !facets with
maxInclusive = Some (validate_base_type value, fixed) }
| T_element "xsd:maxExclusive" ->
let value = Value.string_latin1 (_attribute "value" n) in
let value = Value.string_utf8 (_attribute "value" n) in
facets := { !facets with
maxExclusive = Some (validate_base_type value, fixed) }
| T_element "xsd:minInclusive" ->
let value = Value.string_latin1 (_attribute "value" n) in
let value = Value.string_utf8 (_attribute "value" n) in
facets := { !facets with
minInclusive = Some (validate_base_type value, fixed) }
| T_element "xsd:minExclusive" ->
let value = Value.string_latin1 (_attribute "value" n) in
let value = Value.string_utf8 (_attribute "value" n) in
facets := { !facets with
minExclusive = Some (validate_base_type value, fixed) }
| _ -> ());
......@@ -195,11 +199,11 @@ and find_member_types (resolver: resolver) n =
let parse_att_value_constraint stype_def n =
debug_print ~n "Schema_parser.parse_att_value_constraint";
if _has_attribute "default" n then
let value = Value.string_latin1 (_attribute "default" n) in
let value = Value.string_utf8 (_attribute "default" n) in
let value = validate_simple_type stype_def value in
Some (`Default value)
else if _has_attribute "fixed" n then
let value = Value.string_latin1 (_attribute "fixed" n) in
let value = Value.string_utf8 (_attribute "fixed" n) in
let value = validate_simple_type stype_def value in
Some (`Fixed value)
else
......@@ -212,14 +216,14 @@ let parse_elt_value_constraint type_def n =
match type_def with
| Simple st_def | Complex (_, _, _, _, _, CT_simple st_def) ->
validate_simple_type st_def
| _ -> validate_simple_type (Primitive "xsd:string")
| _ -> validate_simple_type (Primitive (Utf8.mk "xsd:string"))
in
if _has_attribute "default" n then
let value = Value.string_latin1 (_attribute "default" n) in
let value = Value.string_utf8 (_attribute "default" n) in
let value = validate_value value in
Some (`Default value)
else if _has_attribute "fixed" n then
let value = Value.string_latin1 (_attribute "fixed" n) in
let value = Value.string_utf8 (_attribute "fixed" n) in
let value = validate_value value in
Some (`Fixed value)
else
......@@ -246,7 +250,7 @@ let parse_att_decl (resolver: resolver) n =
let parse_attribute_use (resolver: resolver) n =
debug_print ~n "Schema_parser.parse_attribute_use";
let required =
(_has_attribute "use" n) && (_attribute "use" n = "required")
(_has_attribute "use" n) && (_attribute "use" n = Utf8.mk "required")
in
let (name, type_def, value_constr) as att_decl =
if _has_attribute "ref" n then
......@@ -291,11 +295,11 @@ let parse_attribute_uses (resolver: resolver) derivation_type base n =
let parse_min_max n =
((if _has_attribute "minOccurs" n then
Intervals.V.mk (_attribute "minOccurs" n)
Intervals.V.mk (Utf8.get_str (_attribute "minOccurs" n))
else
Intervals.V.one),
(if _has_attribute "maxOccurs" n then
match _attribute "maxOccurs" n with
match Utf8.get_str (_attribute "maxOccurs" n) with
| "unbounded" -> None
| s -> Some (Intervals.V.mk s)
else
......@@ -366,8 +370,9 @@ let rec parse_complex_type (resolver: resolver) n =
let base = resolver#resolve_typ ~now:true (_attribute "base" derivation) in
let uses = parse_attribute_uses resolver derivation_type !base derivation in
let mixed =
(_has_attribute "mixed" content && (_attribute "mixed" content = "true"))
|| (_has_attribute "mixed" n && (_attribute "mixed" n = "true"))
(_has_attribute "mixed" content &&
(_attribute "mixed" content = Utf8.mk "true"))
|| (_has_attribute "mixed" n && (_attribute "mixed" n = Utf8.mk "true"))
in
let particle_node = find_particle derivation in
let content_type =
......@@ -397,7 +402,9 @@ let rec parse_complex_type (resolver: resolver) n =
else (* neither simpleContent nor complexContent *)
let base = anyType in
let uses = parse_attribute_uses resolver `Restriction base n in
let mixed = _has_attribute "mixed" n && (_attribute "mixed" n = "true") in
let mixed =
_has_attribute "mixed" n && (_attribute "mixed" n = Utf8.mk "true")
in
let content_type =
match find_particle n with
| None -> CT_empty
......@@ -488,27 +495,29 @@ let parse_model_group_def (resolver: resolver) n =
(** @param root schema document root node *)
class lazy_resolver =
let fake_type_def =
Complex (~-1, Some " FAKE TYP ", AnyType, `Restriction, [], CT_empty)
Complex (~-1, Some (Utf8.mk " FAKE TYP "), AnyType, `Restriction, [],
CT_empty)
in
let fake_elt_decl = ~-2, " FAKE ELT ", ref fake_type_def, None in
let fake_elt_decl = ~-2, Utf8.mk " FAKE ELT ", ref fake_type_def, None in
let is_fake_type_def = (==) fake_type_def in
let is_fake_elt_decl = (==) fake_elt_decl in
let validation_error s = raise (XSD_validation_error s) in
let get_ns_prefix n =
match n#node_type with T_namespace p -> p | _ -> assert false
in
let (^^) x y = Utf8.concat x y in
fun root ->
object (self)
val typs: (string, type_definition ref) Hashtbl.t =
val typs: (Utf8.t, type_definition ref) Hashtbl.t =
Hashtbl.create 17