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

[r2003-11-20 11:40:08 by szach] - factorized code for schema types lookup

- added backend for #print_{type,schema} directives

Original author: szach
Date: 2003-11-20 11:40:08+00:00
parent 525092fe
......@@ -41,7 +41,8 @@ and texpr' =
| Map of texpr * branches
| Transform of texpr * branches
| Xtrans of texpr * branches
| Validate of texpr * string * string (* expression, schema, schema type *)
| Validate of texpr * Schema_types.component_kind * string * string
(* exp, schema component kind, schema name, element name *)
| RemoveField of texpr * label
| Dot of texpr * label
......
......@@ -8,6 +8,8 @@ open Location
open Ast
open Ident
let debug_schema = false
let warning loc msg =
Format.fprintf !Location.warning_ppf "Warning %a:@\n%a%s@."
Location.print_loc (loc,`Full)
......@@ -168,12 +170,8 @@ let raise_loc loc exn = raise (Location (loc,`Full,exn))
let raise_loc_str loc ofs exn = raise (Location (loc,`Char ofs,exn))
let error loc msg = raise_loc loc (Error msg)
(* Schema datastructures *)
module StringSet = Set.Make (String)
(* just to remember imported schemas *)
let schemas = State.ref "Typer.schemas" StringSet.empty
let schemas = State.ref "Typer.schemas" (Hashtbl.create 3)
let schema_types = State.ref "Typer.schema_types" (Hashtbl.create 51)
let schema_elements = State.ref "Typer.schema_elements" (Hashtbl.create 51)
......@@ -183,6 +181,37 @@ let schema_attribute_groups =
let schema_model_groups =
State.ref "Typer.schema_model_groups" (Hashtbl.create 51)
(* raise Not_found *)
let find_schema_descr kind schema name =
let elt () = Hashtbl.find !schema_elements (schema, name) in
let typ () = Hashtbl.find !schema_types (schema, name) in
let att () = Hashtbl.find !schema_attributes (schema, name) in
let att_group () = Hashtbl.find !schema_attribute_groups (schema, name) in
let mod_group () = Hashtbl.find !schema_model_groups (schema, name) in
let rec do_try n = function
| [] -> raise Not_found
| f :: rem -> (try f () with Not_found -> do_try n rem)
in
match kind with
| Some `Element -> do_try "element" [ elt ]
| Some `Type -> do_try "type" [ typ ]
| Some `Attribute -> do_try "atttribute" [ att ]
| Some `Attribute_group -> do_try "attribute group" [ att_group ]
| Some `Model_group -> do_try "model group" [ mod_group ]
| None ->
(* policy for unqualified schema component resolution. This order should
* be consistent with Schema_component.get_component *)
do_try "component" [ elt; typ; att; att_group; mod_group ]
(* as above, but raise Error *)
let find_schema_descr' k s n =
try
find_schema_descr k s n
with Not_found ->
raise (Error
(Printf.sprintf "No %s named '%s' found in schema '%s'"
(Schema_common.string_of_component_kind k) n s))
(* Eliminate Recursion, propagate Sequence Capture Variables *)
let rec seq_vars accu = function
......@@ -457,8 +486,8 @@ let rec derecurs env p = match p.descr with
with Not_found ->
raise_loc_generic p.loc
("Unbound external type " ^ cu ^ ":" ^ (U.to_string v)))
| SchemaVar (kind, schema, item) ->
PType (derecurs_schema env kind schema item)
| SchemaVar (kind, schema_name, component_name) ->
PType (derecurs_schema env kind schema_name component_name)
| Recurs (p,b) -> derecurs (derecurs_def env b) p
| Internal t -> PType t
| NsT ns -> PType (Types.atom (Atoms.any_in_ns (parse_ns env.penv_tenv p.loc ns)))
......@@ -504,26 +533,7 @@ and derecurs_def env b =
List.iter (fun (v,p,s) -> s.pdescr <- derecurs env p) b;
env
and derecurs_schema env kind schema item =
let elt () = Hashtbl.find !schema_elements (schema, item) in
let typ () = Hashtbl.find !schema_types (schema, item) in
let att () = Hashtbl.find !schema_attributes (schema, item) in
let att_group () = Hashtbl.find !schema_attribute_groups (schema, item) in
let mod_group () = Hashtbl.find !schema_model_groups (schema, item) in
let rec do_try n = function
| [] ->
let s = Printf.sprintf
"No %s named '%s' found in schema '%s'" n item schema in
failwith s
| f :: rem -> (try f () with Not_found -> do_try n rem) in
match kind with
| Some `Element -> do_try "element" [ elt ]
| Some `Type -> do_try "type" [ typ ]
| Some `Attribute -> do_try "atttribute" [ att ]
| Some `Attribute_group -> do_try "attribute group" [ att_group ]
| Some `Model_group -> do_try "model group" [ mod_group ]
| None -> do_try "item" [ elt; typ; att; att_group; mod_group ]
and derecurs_schema env = find_schema_descr
let rec fv_slot s =
match s.fv with
......@@ -753,6 +763,16 @@ let dump_types ppf env =
function
(Type _) -> Format.fprintf ppf " %a" Ident.print v
| _ -> ()) env.ids
let dump_type ppf env name =
try
(match Env.find (Ident.ident (Encodings.Utf8.mk name)) env.ids with
| Type t -> Types.Print.print ppf t
| _ -> raise Not_found)
with Not_found -> raise (Error (Printf.sprintf "Type %s not found" name))
let dump_schema_type ppf (k, s, n) =
let descr = find_schema_descr' k s n in
Types.Print.print ppf descr
let dump_ns ppf env =
Ns.dump_table ppf env.ns
......@@ -886,9 +906,9 @@ let rec expr env loc = function
let (fv1,e) = expr env loc e
and (fv2,b) = branches env b in
exp loc (Fv.cup fv1 fv2) (Typed.Xtrans (e, b))
| Validate (e,schema,elt) ->
| Validate (e,kind,schema,elt) ->
let (fv,e) = expr env loc e in
exp loc fv (Typed.Validate (e, schema, elt))
exp loc fv (Typed.Validate (e, kind, schema, elt))
| Try (e,b) ->
let (fv1,e) = expr env loc e
and (fv2,b) = branches env b in
......@@ -1100,9 +1120,9 @@ and type_check' loc env e constr precise = match e with
) t in
verify loc t constr
| Validate (e, schema_name, elt_name) ->
| Validate (e, kind, schema_name, name) ->
ignore (type_check env e Types.any false);
let t = Hashtbl.find !schema_elements (schema_name, elt_name) in
let t = find_schema_descr' kind schema_name name in
verify loc t constr
| Ref (e,t) ->
......@@ -1474,44 +1494,57 @@ module Schema_converter =
end
let debug = true
let get_schema name =
try
Hashtbl.find !schemas name
with Not_found -> raise (Error (Printf.sprintf "Schema '%s' not found" name))
let get_schema_names () = Hashtbl.fold (fun n _ acc -> n :: acc) !schemas []
let register_schema schema_name schema =
if StringSet.mem schema_name !schemas then
if Hashtbl.mem !schemas schema_name then
failwith ("Redefinition of schema " ^ schema_name)
else begin
schemas := StringSet.add schema_name !schemas;
let log_schema_component kind schema name cd_type =
if not (Schema_builtin.is_builtin name) then begin
Format.fprintf Format.std_formatter
"Registering schema %s: %s # %s" kind schema name;
if debug_schema then
Types.Print.print Format.std_formatter cd_type;
Format.fprintf Format.std_formatter "@."
end
in
Hashtbl.add !schemas schema_name schema;
List.iter (* Schema types -> CDuce types *)
(fun type_def ->
let cd_type = Schema_converter.cd_type_of_type_def type_def in
Hashtbl.add !schema_types
(schema_name, Schema_common.name_of_type_definition type_def)
cd_type)
let name = Schema_common.name_of_type_definition type_def in
log_schema_component "type" schema_name name cd_type;
Hashtbl.add !schema_types (schema_name, name) cd_type)
schema.Schema_types.types;
List.iter (* Schema attributes -> CDuce types *)
(fun (att_name, _, _) as att_decl ->
(fun (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)
log_schema_component "attribute" schema_name name cd_type;
Hashtbl.add !schema_attributes (schema_name, name) cd_type)
schema.Schema_types.attributes;
List.iter (* Schema elements -> CDuce types *)
(fun elt_decl ->
let cd_type = Schema_converter.cd_type_of_elt_decl elt_decl in
if debug then
(Types.Print.print Format.std_formatter cd_type;
Format.fprintf Format.std_formatter "\n";
Format.pp_print_flush Format.std_formatter ());
Hashtbl.add !schema_elements
(schema_name, Schema_common.name_of_element_declaration elt_decl)
cd_type)
let name = Schema_common.name_of_element_declaration elt_decl in
log_schema_component "element" schema_name name cd_type;
Hashtbl.add !schema_elements (schema_name, name) cd_type)
schema.Schema_types.elements;
List.iter (* Schema attribute groups -> CDuce types *)
(fun (name, uses) ->
let cd_type = Schema_converter.cd_type_of_attr_uses uses in
log_schema_component "attribute group" schema_name name cd_type;
Hashtbl.add !schema_attribute_groups (schema_name, name) cd_type)
schema.Schema_types.attribute_groups;
List.iter (* Schema model groups -> CDuce types *)
(fun (name, group) ->
let cd_type = Schema_converter.cd_type_of_model_group group in
log_schema_component "model group" schema_name name cd_type;
Hashtbl.add !schema_model_groups (schema_name, name) cd_type)
schema.Schema_types.model_groups;
end
......
......@@ -35,8 +35,9 @@ val typ: t -> Ast.ppat -> Types.Node.t
val pat: t -> Ast.ppat -> Patterns.node
val dump_types: Format.formatter -> t -> unit
val dump_type: Format.formatter -> t -> string -> unit
val dump_schema_type:
Format.formatter -> (Schema_types.component_kind * string * string) -> unit
val dump_ns: Format.formatter -> t -> unit
val set_ns_table_for_printer: t -> unit
......@@ -59,9 +60,14 @@ val flatten: loc ->
(** {2 Schema stuff} *)
(** register a schema *)
val register_schema: string -> Schema_types.schema -> unit
(** lookup schema by name *)
val get_schema: string -> Schema_types.schema
(** registered schema names *)
val get_schema_names: unit -> string list
(* Operators *)
type type_fun = Types.t -> bool -> Types.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