Commit 0e8a467a authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-06-12 15:09:46 by cvscast] Starting recursive types in Schema

Original author: cvscast
Date: 2003-06-12 15:09:46+00:00
parent 30f2aa98
......@@ -36,7 +36,7 @@ let get_maxOccurs n =
let content_type_of_def = function
| S def -> CT_simple def
| C (CBuilt_in _) -> assert false
| C (CUser_defined (_, _, _, _, ct)) -> ct
| C (CUser_defined (_, _, _, _, _, ct)) -> ct
;;
let parse_facet resolver base_type_def n =
......@@ -211,7 +211,7 @@ let attribute_uses_of_restriction ~resolver ~n ~base =
in
let from_base =
match base with
| C (CUser_defined (_, _, _, attribute_uses, _)) ->
| C (CUser_defined (_, _, _, _, attribute_uses, _)) ->
List.filter (* filters out attribute uses redefined and
prohibited in this type *)
(fun use ->
......@@ -231,12 +231,19 @@ let attribute_uses_of_extension ~resolver ~n ~base =
in
let from_base =
match base with
| C (CUser_defined (_, _, _, attribute_uses, _)) -> attribute_uses
| C (CUser_defined (_, _, _, _, attribute_uses, _)) -> attribute_uses
| _ -> []
in
filter_out_none embedded @ from_base
;;
let counter = ref 0
let cuser_defined name base derivation attribute_uses ct =
incr counter;
CUser_defined (!counter, name, base, derivation, attribute_uses, ct)
let rec parse_complex_type resolver n =
let name = try Some n#extension#name with Not_found -> None in
if n#extension#has_element "xsd:simpleContent" then begin
......@@ -250,7 +257,7 @@ let rec parse_complex_type resolver n =
in
let content_type =
(match !base with
| C (CUser_defined (_, _, _, _, (CT_simple base))) ->
| C (CUser_defined (_, _, _, _, _, (CT_simple base))) ->
let base =
try
parse_simple_type resolver
......@@ -260,7 +267,7 @@ let rec parse_complex_type resolver n =
CT_simple (restrict_simple_type base (get_facet_nodes n))
| _ -> assert false)
in
CUser_defined (name, base, Restriction, attribute_uses, content_type)
cuser_defined name base Restriction attribute_uses content_type
end else if content#extension#has_element "xsd:extension" then begin
(* simpleContent, extension *)
let extension = find_element "xsd:extension" content in
......@@ -270,11 +277,11 @@ let rec parse_complex_type resolver n =
in
let content_type =
(match !base with
| C (CUser_defined (_, _, _, _, (CT_simple base))) -> CT_simple base
| C (CUser_defined (_, _, _, _, _, (CT_simple base))) -> CT_simple base
| S simple_type_def -> CT_simple simple_type_def
| _ -> assert false)
in
CUser_defined (name, base, Extension, attribute_uses, content_type)
cuser_defined name base Extension attribute_uses content_type
end else
(* simpleContent, neither extension nor restriction *)
raise (XSD_validation_error "Neither <extension> nor <restriction> \
......@@ -300,7 +307,7 @@ let rec parse_complex_type resolver n =
(parse_particle resolver restriction#extension#find_term, mixed)
end
in
CUser_defined (name, base, Restriction, attribute_uses, content_type)
cuser_defined name base Restriction attribute_uses content_type
end else if content#extension#has_element "xsd:extension" then begin
(* complexContent, extension *)
let extension = find_element "xsd:extension" content in
......@@ -328,7 +335,7 @@ let rec parse_complex_type resolver n =
mixed)
| _ -> assert false
in
CUser_defined (name, base, Extension, attribute_uses, content_type)
cuser_defined name base Extension attribute_uses content_type
end else
(* complexContent, neither extension nor restriction *)
raise (XSD_validation_error "Neither <extension> nor <restriction> \
......@@ -348,7 +355,7 @@ let rec parse_complex_type resolver n =
CT_model (parse_particle resolver n#extension#find_term, mixed)
end
in
CUser_defined (name, base, Restriction, attribute_uses, content_type)
cuser_defined name base Restriction attribute_uses content_type
end
and parse_elt_decl resolver n =
......@@ -382,7 +389,7 @@ and parse_particle resolver n =
!(resolver#resolve_typ n#extension#typ)))
in
minOccurs, maxOccurs, Elt (ref (name, ref type_def, None))
| T_element "xsd:element" when n#extension#has_attribute "ref" ->
| T_element "xsd:element" (* when n#extension#has_attribute "ref" *)->
let elt_decl = resolver#resolve_elt n#extension#ref in
minOccurs, maxOccurs, (Elt elt_decl)
| T_element "xsd:all" ->
......
......@@ -63,6 +63,7 @@ and elt_decl = string * type_def ref * value_constraint option
and complex_type_def =
| CBuilt_in of string
| CUser_defined of
int *
string option * type_def ref * derivation *
attribute_use list * content_type
and type_def = S of simple_type_def | C of complex_type_def
......@@ -80,8 +81,8 @@ let name_of_type_def = function
| C (CBuilt_in name) -> name
| S (SUser_defined (Some name, _, _, _)) -> name
| S (SUser_defined (None, _, _, _)) -> "| UNNAMED |"
| C (CUser_defined (Some name, _, _, _, _)) -> name
| C (CUser_defined (None, _, _, _, _)) -> "| UNNAMED |"
| C (CUser_defined (_, Some name, _, _, _, _)) -> name
| C (CUser_defined (_, None, _, _, _, _)) -> "| UNNAMED |"
;;
let name_of_attribute_use (_, (n, _, _), _) = n ;;
......@@ -111,7 +112,7 @@ and print_type ppf = function
| C c -> fprintf ppf "@[%a@]" print_complex_type c
and print_complex_type ppf = function
| CBuilt_in n -> fprintf ppf "@[%s@]" n
| CUser_defined (_, _, _, _, ct) -> fprintf ppf "@[%a@]" print_ct ct
| CUser_defined (_,_, _, _, _, ct) -> fprintf ppf "@[%a@]" print_ct ct
and print_ct ppf = function
| CT_empty -> fprintf ppf "@[EMPTY@]"
| CT_simple s -> print_simple_type ppf s
......
......@@ -88,6 +88,7 @@ and elt_decl =
and complex_type_def =
| CBuilt_in of string
| CUser_defined of
int * (* Unique ID *)
string option * (* name *)
type_def ref * (* base *)
derivation *
......
......@@ -287,7 +287,7 @@ and validator_of_complex_type = function
((fun _ -> assert false),
(pcdata_wrapper (Schema_builtin.__validate_fun_of_builtin s),
First.empty))
| CUser_defined (_, _, _, attr_uses, ct) ->
| CUser_defined (_, _, _, _, attr_uses, ct) ->
let validate_attrs = validate_attrs_of_uses attr_uses in
let content_validator =
match ct with
......
......@@ -563,14 +563,16 @@ let register_global_types b =
let dump_global_types ppf =
TypeEnv.iter (fun v _ -> Format.fprintf ppf " %s" v) !glb
let typ p =
let s = compile_slot (derecurs !glb p) in
let do_typ loc r =
let s = compile_slot r in
flush_defs ();
flush_fv ();
if IdSet.is_empty (fv_slot s) then typ_node s
else raise_loc_generic p.loc "Capture variables are not allowed in types"
else raise_loc_generic loc "Capture variables are not allowed in types"
let typ p =
do_typ p.loc (derecurs !glb p)
let pat p =
let s = compile_slot (derecurs !glb p) in
......@@ -1017,31 +1019,33 @@ module Schema_converter =
(* auxiliary functions *)
(* build a regexp Elem from a Types.descr *)
let mk_re_elt descr = Ast.Elem (Location.mknoloc (Ast.Internal descr)) ;;
let mk_re_elt descr = PElem descr
(* conversion functions *)
let cd_type_of_simple_type = function
| SBuilt_in name -> Schema_builtin.cd_type_of_builtin name
| SBuilt_in name -> PType (Schema_builtin.cd_type_of_builtin name)
| SUser_defined (_, _, _, _) -> assert false (* TODO *)
;;
let complex_memo = Hashtbl.create 213
let rec regexp_of_term = function
| All _ -> assert false
| Choice [] -> Ast.Epsilon
| Choice [] -> PEpsilon
| Choice (hd :: tl) ->
List.fold_left
(fun acc particle -> Ast.Alt (acc, regexp_of_particle particle))
(fun acc particle -> PAlt (acc, regexp_of_particle particle))
(regexp_of_particle hd) tl
| Sequence [] -> Ast.Epsilon
| Sequence [] -> PEpsilon
| Sequence (hd :: tl) ->
List.fold_left
(fun acc particle -> Ast.Seq (acc, regexp_of_particle particle))
(fun acc particle -> PSeq (acc, regexp_of_particle particle))
(regexp_of_particle hd) tl
| Elt decl -> mk_re_elt (cd_type_of_elt_decl !decl)
and regexp_of_content_type = function
| CT_empty -> Ast.Epsilon
| CT_empty -> PEpsilon
| CT_simple st -> mk_re_elt (cd_type_of_simple_type st)
| CT_model (particle, mixed) ->
assert (not mixed); (* TODO mixed support *)
......@@ -1051,8 +1055,8 @@ module Schema_converter =
(* given a regexp re and a (non negative) integer n create a regexp
matching exactly n times re *)
let rec repeat_regexp re = function
| 0 -> Ast.Epsilon
| n when n > 0 -> Ast.Seq (re, repeat_regexp re (n - 1))
| 0 -> PEpsilon
| n when n > 0 -> PSeq (re, repeat_regexp re (n - 1))
| _ -> assert false
in
fun (min, max, term) ->
......@@ -1065,55 +1069,61 @@ module Schema_converter =
| 0 -> acc
| n ->
aux
(Ast.Alt (Ast.Epsilon, (Ast.Seq (term_regexp, acc))))
(PAlt (PEpsilon, (PSeq (term_regexp, acc))))
(n - 1)
in
Ast.Seq (min_regexp, aux Ast.Epsilon (max - min))
| None -> Ast.Seq (min_regexp, Ast.Star term_regexp)
PSeq (min_regexp, aux PEpsilon (max - min))
| None -> PSeq (min_regexp, PStar term_regexp)
(** @return a pair composed by a type for the attributes (a record) and a
type for the content model (a sequence) *)
and cd_type_of_complex_type' = function
| CBuilt_in name -> assert false
| CUser_defined (name, _, _, attr_uses, content) ->
let content_re = regexp_of_content_type content in
let content_ast_node =
Location.mknoloc (Ast.Regexp
(content_re, Location.mknoloc (Ast.Internal Sequence.nil_type)))
in
(cd_type_of_attr_uses attr_uses, (Types.descr (typ content_ast_node)))
| CUser_defined (id, name, _, _, attr_uses, content) ->
try PAlias (Hashtbl.find complex_memo id)
with Not_found ->
let slot = mk_slot noloc in
Hashtbl.add complex_memo id slot;
let content_re = regexp_of_content_type content in
let content_ast_node = PRegexp (content_re, PType Sequence.nil_type) in
slot.pdescr <- Some
(PTimes (cd_type_of_attr_uses attr_uses, content_ast_node));
PAlias slot
(** @return a closed record *)
and cd_type_of_attr_uses attr_uses =
Types.rec_of_list' ~opened:false
(List.fold_left
(fun fields (required, (name, st, _), _) ->
(not required, name, cd_type_of_simple_type !st) :: fields)
[] attr_uses)
let fields =
List.map
(fun (required, (name, st, _), _) ->
let r = cd_type_of_simple_type !st in
let r = if required then r else POptional r in
(LabelPool.mk (U.mk name), r)
) attr_uses in
PRecord (false, LabelMap.from_list_disj fields)
and cd_type_of_elt_decl (name, typ, _) =
let atom_type = Types.atom (Atoms.atom (Atoms.mk_ascii name)) in
(match !typ with
| S st ->
Types.xml' atom_type Types.empty_closed_record
(cd_type_of_simple_type st)
| C ct ->
let (attr_type, cont_type) = cd_type_of_complex_type' ct in
Types.xml' atom_type attr_type cont_type)
;;
let atom_type = PType (Types.atom (Atoms.atom (Atoms.mk (U.mk name)))) in
let content = match !typ with
| S st -> PTimes (PType Types.empty_closed_record, cd_type_of_simple_type st)
| C ct -> cd_type_of_complex_type' ct
in
PXml (atom_type, content)
let typ r = Types.descr (do_typ noloc r)
let cd_type_of_complex_type = function
| CBuilt_in name -> Schema_builtin.cd_type_of_builtin name
| ct ->
let (attr_type, cont_type) = cd_type_of_complex_type' ct in
Types.xml' Types.any attr_type cont_type
;;
| ct -> typ (PXml (PType Types.any, cd_type_of_complex_type' ct))
let cd_type_of_type_def = function
| S st -> cd_type_of_simple_type st
| S st -> typ (cd_type_of_simple_type st)
| C ct -> cd_type_of_complex_type ct
;;
let cd_type_of_elt_decl x =
typ (cd_type_of_elt_decl x)
end
;;
......
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