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

[r2003-06-13 10:03:21 by cvscast] zack: synced with new schema_types

Original author: cvscast
Date: 2003-06-13 10:03:21+00:00
parent 5c728dda
......@@ -35,13 +35,13 @@ let error loc msg = raise_loc loc (Error msg)
(* Schema datastructures *)
module StringSet = Set.Make (String)
let schemas = State.ref "Typer.schemas" StringSet.empty (* just to remember imported schemas *)
(* just to remember imported schemas *)
let schemas = State.ref "Typer.schemas" StringSet.empty
let schema_types = State.ref "Typer.schema_types" (Hashtbl.create 51)
let schema_elements = State.ref "Typer.schema_elements" (Hashtbl.create 51)
let schema_attributes : (string * string, Types.descr) Hashtbl.t ref =
State.ref "Typer.schema_attributes" (Hashtbl.create 51)
let schema_attributes = State.ref "Typer.schema_attributes" (Hashtbl.create 51)
(* Eliminate Recursion, propagate Sequence Capture Variables *)
......@@ -1006,15 +1006,15 @@ let report_unused_branches () =
(* Schema stuff from now on ... *)
let debug = true ;;
let debug = true
(** convertion from XML Schema types (including global elements and
attributes) to CDuce Types.descr *)
module Schema_converter =
struct
open Printf ;;
open Schema_types ;;
open Printf
open Schema_types
(* auxiliary functions *)
......@@ -1026,7 +1026,6 @@ module Schema_converter =
let cd_type_of_simple_type = function
| SBuilt_in name -> PType (Schema_builtin.cd_type_of_builtin name)
| SUser_defined (_, _, _, _) -> assert false (* TODO *)
;;
let complex_memo = Hashtbl.create 213
......@@ -1091,21 +1090,28 @@ module Schema_converter =
PAlias slot
(* TODO if constraint is Fixed we can give a more precise CDuce type *)
(** @return a closed record *)
and cd_type_of_attr_uses attr_uses =
let fields =
List.map
(fun (required, (name, st, _), _) ->
let r = cd_type_of_simple_type !st in
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_att_decl (name, st, _) =
let r = cd_type_of_simple_type st in
PRecord (false, LabelMap.from_list_disj [(LabelPool.mk (U.mk name), r)])
and cd_type_of_elt_decl (name, typ, _) =
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)
| 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)
......@@ -1119,17 +1125,14 @@ module Schema_converter =
let cd_type_of_type_def = function
| 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)
let cd_type_of_elt_decl x = typ (cd_type_of_elt_decl x)
let cd_type_of_att_decl x = typ (cd_type_of_att_decl x)
end
;;
let get_schema_validator (schema_name, elt_name) =
snd (Hashtbl.find !schema_elements (schema_name, elt_name))
;;
let register_schema schema_name schema =
if StringSet.mem schema_name !schemas then
......@@ -1143,7 +1146,11 @@ let register_schema schema_name schema =
(schema_name, Schema_types.name_of_type_def type_def)
cd_type)
schema.Schema_types.type_defs;
(* Schema attributes -> CDuce types TODO *)
List.iter (* Schema attributes -> CDuce types *)
(fun (att_name, _, _) as att_decl ->
let cd_type = Schema_converter.cd_type_of_att_decl att_decl in
Hashtbl.add !schema_attributes (schema_name, att_name) cd_type)
schema.Schema_types.att_decls;
List.iter (* Schema elements -> CDuce types * validators *)
(fun elt_decl ->
let cd_type = Schema_converter.cd_type_of_elt_decl elt_decl in
......@@ -1157,8 +1164,7 @@ let register_schema schema_name schema =
(cd_type, validator))
schema.Schema_types.elt_decls
end
;;
(* DEBUGGING ONLY *)
let get_schema_type x = fst (Hashtbl.find !schema_elements x) ;;
let get_schema_type x = fst (Hashtbl.find !schema_elements x)
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