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

[r2005-02-25 10:35:06 by afrisch] Bind namespace prefix when loading a schema

Original author: afrisch
Date: 2005-02-25 10:35:06+00:00
parent 32a594cb
...@@ -241,8 +241,8 @@ let namespace (tenv,cenv,codes) pr ns = ...@@ -241,8 +241,8 @@ let namespace (tenv,cenv,codes) pr ns =
let tenv = Typer.enter_ns pr ns tenv in let tenv = Typer.enter_ns pr ns tenv in
(tenv,cenv,codes) (tenv,cenv,codes)
let schema (tenv,cenv,codes) x sch = let schema (tenv,cenv,codes) x sch prefix =
let tenv = Typer.enter_schema x sch tenv in let tenv = Typer.enter_schema ?prefix x sch tenv in
(tenv,cenv,codes) (tenv,cenv,codes)
let find_cu (tenv,_,_) cu = let find_cu (tenv,_,_) cu =
...@@ -270,8 +270,8 @@ let rec phrases ~run ~show ~loading ~directive = ...@@ -270,8 +270,8 @@ let rec phrases ~run ~show ~loading ~directive =
| { descr = Ast.TypeDecl (_,_) } :: _ -> | { descr = Ast.TypeDecl (_,_) } :: _ ->
let (typs,rest) = collect_types [] phs in let (typs,rest) = collect_types [] phs in
loop (type_defs accu typs) rest loop (type_defs accu typs) rest
| { descr = Ast.SchemaDecl (name, uri) } :: rest -> | { descr = Ast.SchemaDecl (name, uri, p) } :: rest ->
loop (schema accu name uri) rest loop (schema accu name uri p) rest
| { descr = Ast.Namespace (pr,ns) } :: rest -> | { descr = Ast.Namespace (pr,ns) } :: rest ->
loop (namespace accu pr ns) rest loop (namespace accu pr ns) rest
| { descr = Ast.Using (x,cu) } :: rest -> | { descr = Ast.Using (x,cu) } :: rest ->
......
...@@ -8,7 +8,7 @@ type pprog = pmodule_item list ...@@ -8,7 +8,7 @@ type pprog = pmodule_item list
and pmodule_item = pmodule_item' located and pmodule_item = pmodule_item' located
and pmodule_item' = and pmodule_item' =
| TypeDecl of id * ppat | TypeDecl of id * ppat
| SchemaDecl of U.t * string (* name, uri *) | SchemaDecl of U.t * string * U.t option (* name, uri, ns prefix *)
| LetDecl of ppat * pexpr | LetDecl of ppat * pexpr
| FunDecl of pexpr | FunDecl of pexpr
| Namespace of U.t * Ns.t | Namespace of U.t * Ns.t
......
...@@ -120,9 +120,11 @@ EXTEND ...@@ -120,9 +120,11 @@ EXTEND
| "type"; x = IDENT; "="; t = pat -> [ mk loc (TypeDecl (ident x,t)) ] | "type"; x = IDENT; "="; t = pat -> [ mk loc (TypeDecl (ident x,t)) ]
| "using"; name = IDENT; "="; cu = [ IDENT | STRING2 ] -> | "using"; name = IDENT; "="; cu = [ IDENT | STRING2 ] ->
[ mk loc (Using (U.mk name, U.mk cu)) ] [ mk loc (Using (U.mk name, U.mk cu)) ]
| "schema"; name = IDENT; "="; uri = STRING2 -> | "schema"; name = IDENT;
p = OPT [ "("; name = [ IDENT | keyword ]; ")" -> parse_ident name ];
"="; uri = STRING2 ->
protect_op "schema"; protect_op "schema";
[ mk loc (SchemaDecl (U.mk name, uri)) ] [ mk loc (SchemaDecl (U.mk name, uri, p)) ]
| (name,ns) = namespace_binding -> | (name,ns) = namespace_binding ->
[ mk loc (Namespace (name, ns)) ] [ mk loc (Namespace (name, ns)) ]
| (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" -> | (name,ns) = namespace_binding; "in"; e2 = expr LEVEL "top" ->
......
...@@ -60,9 +60,19 @@ let check _ = failwith "Typer.check" ...@@ -60,9 +60,19 @@ let check _ = failwith "Typer.check"
let load_schema_fwd = ref (fun x uri -> assert false) let load_schema_fwd = ref (fun x uri -> assert false)
let enter_schema x uri env = let enter_schema ?prefix x uri env =
!load_schema_fwd x uri; let sch,reg = !load_schema_fwd x uri in
{ env with schemas = UEnv.add x uri env.schemas } (* Set the namespace prefix before registration for better pretty
printing *)
let env =
{ env with
schemas = UEnv.add x uri env.schemas;
ns = (match prefix with
| Some p ->
Ns.add_prefix p sch.Schema_types.targetNamespace env.ns
| None -> env.ns) } in
reg ();
env
(* TODO: filter out builtin defs ? *) (* TODO: filter out builtin defs ? *)
...@@ -1728,7 +1738,8 @@ module Schema_converter = ...@@ -1728,7 +1738,8 @@ module Schema_converter =
let elt_decl x = typ (elt_decl x) let elt_decl x = typ (elt_decl x)
let att_decl x = typ (att_decl x) let att_decl x = typ (att_decl x)
let attr_uses x = typ (attr_uses x) let attr_uses x = typ (attr_uses x)
let model_group x = typ (model_group x) let model_group x = typ (model_group x.mg_def)
let attr_group ag = attr_uses ag.ag_def
end end
let get_schema_names env = UEnv.fold (fun n _ acc -> n :: acc) env.schemas [] let get_schema_names env = UEnv.fold (fun n _ acc -> n :: acc) env.schemas []
...@@ -1740,11 +1751,14 @@ open Schema_types ...@@ -1740,11 +1751,14 @@ open Schema_types
let get_schema uri = let get_schema uri =
Hashtbl.find !schemas uri Hashtbl.find !schemas uri
let load_schema schema_name uri = open Schema_types
if Hashtbl.mem !schemas uri then () open Schema_common
else ( open Schema_converter
let schema = Schema_parser.schema_of_uri uri in
let log_schema_component kind uri name cd_type =
let register_schema schema_name uri schema =
let log_schema_component kind name cd_type =
if not (Schema_builtin.is name) then begin if not (Schema_builtin.is name) then begin
let n = U.to_string schema_name ^ "#" ^ (Ns.QName.to_string name) in let n = U.to_string schema_name ^ "#" ^ (Ns.QName.to_string name) in
Types.Print.register_global (U.mk_latin1 n) cd_type; Types.Print.register_global (U.mk_latin1 n) cd_type;
...@@ -1753,44 +1767,33 @@ let load_schema schema_name uri = ...@@ -1753,44 +1767,33 @@ let load_schema schema_name uri =
Format.fprintf Format.std_formatter "@." Format.fprintf Format.std_formatter "@."
end end
in in
let defs kind name cd_type tbl lst =
List.iter
(fun def ->
let name = name def in
let cd_type = cd_type def in
log_schema_component kind name cd_type;
Hashtbl.add !tbl (uri,name) cd_type) lst
in
defs "type" name_of_type_definition type_def
schema_types schema.types;
defs "attribute" name_of_attribute_declaration att_decl
schema_attributes schema.attributes;
defs "element" name_of_element_declaration elt_decl
schema_elements schema.elements;
defs "attribute group" (fun ag -> ag.ag_name) attr_group
schema_attribute_groups schema.attribute_groups;
defs "model group" (fun mg -> mg.mg_name) model_group
schema_model_groups schema.model_groups
let real_load_schema schema_name uri =
let schema = Schema_parser.schema_of_uri uri in
Hashtbl.add !schemas uri schema; Hashtbl.add !schemas uri schema;
schema, (fun () -> register_schema schema_name uri schema)
List.iter (* Schema types -> CDuce types *) let load_schema name uri =
(fun type_def -> try (get_schema uri, fun () -> ())
let name = Schema_common.name_of_type_definition type_def in with Not_found -> real_load_schema name uri
let cd_type = Schema_converter.type_def type_def in
log_schema_component "type" uri name cd_type;
Hashtbl.add !schema_types (uri, name) cd_type)
schema.Schema_types.types;
List.iter (* Schema attributes -> CDuce types *)
(fun att_decl ->
let cd_type = Schema_converter.att_decl att_decl in
let name = Schema_common.name_of_attribute_declaration att_decl in
log_schema_component "attribute" uri name cd_type;
Hashtbl.add !schema_attributes (uri, name) cd_type)
schema.Schema_types.attributes;
List.iter (* Schema elements -> CDuce types *)
(fun elt_decl ->
let cd_type = Schema_converter.elt_decl elt_decl in
let name = Schema_common.name_of_element_declaration elt_decl in
log_schema_component "element" uri name cd_type;
Hashtbl.add !schema_elements (uri, name) cd_type)
schema.Schema_types.elements;
List.iter (* Schema attribute groups -> CDuce types *)
(fun ag ->
let cd_type = Schema_converter.attr_uses ag.ag_def
in
log_schema_component "attribute group" uri ag.ag_name cd_type;
Hashtbl.add !schema_attribute_groups (uri, ag.ag_name) cd_type)
schema.Schema_types.attribute_groups;
List.iter (* Schema model groups -> CDuce types *)
(fun mg ->
let cd_type =
Schema_converter.model_group mg.mg_def in
log_schema_component "model group" uri mg.mg_name cd_type;
Hashtbl.add !schema_model_groups (uri, mg.mg_name) cd_type)
schema.Schema_types.model_groups;
)
let () = load_schema_fwd := load_schema let () = load_schema_fwd := load_schema
...@@ -25,7 +25,7 @@ val get_ns_table : t -> Ns.table ...@@ -25,7 +25,7 @@ val get_ns_table : t -> Ns.table
val register_types : Types.CompUnit.t -> t -> unit val register_types : Types.CompUnit.t -> t -> unit
val enter_ns : U.t -> Ns.t -> t -> t val enter_ns : U.t -> Ns.t -> t -> t
val enter_schema: U.t -> string -> t -> t val enter_schema: ?prefix:U.t -> U.t -> string -> t -> t
val find_schema: U.t -> t -> string val find_schema: U.t -> t -> string
val enter_cu : U.t -> Types.CompUnit.t -> t -> t val enter_cu : U.t -> Types.CompUnit.t -> t -> t
val find_cu : U.t -> t -> Types.CompUnit.t val find_cu : U.t -> t -> Types.CompUnit.t
......
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