[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

typing/typed.ml

@@ -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
       

typing/typer.ml

@@ -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

typing/typer.mli

@@ -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