[r2005-02-23 01:17:28 by afrisch] Print

Original author: afrisch
Date: 2005-02-23 01:17:29+00:00

compile/compile.ml

@@ -242,7 +242,6 @@ let namespace (tenv,cenv,codes) pr ns =
   (tenv,cenv,codes)
 
 let schema (tenv,cenv,codes) x sch =
-  ignore (Typer.get_schema sch); (* To raise the error here ... *)
   let tenv = Typer.enter_schema x sch tenv in
   (tenv,cenv,codes)
 

driver/cduce.ml

@@ -74,7 +74,7 @@ let directive_help ppf =
   #dump_value <expr>;;    dump an XML-ish representation of the resulting
                           value of a given expression
   #print_schema <name>;;
-  #print_type <name>;;
+  #print_type <type>;;
   #silent;;               turn off outputs from the toplevel
   #verbose;;              turn on outputs from the toplevel
 "
@@ -240,6 +240,7 @@ let debug ppf tenv cenv = function
 	) c;  *)
       Format.fprintf ppf "@."
 
+
 let flush_ppf ppf = Format.fprintf ppf "@."
 
 let directive ppf tenv cenv = function
@@ -254,12 +255,9 @@ let directive ppf tenv cenv = function
       let sch = Typer.get_schema uri in
       Schema_common.print_schema ppf sch;
       flush_ppf ppf
-  | `Print_type name ->
-      Typer.dump_type ppf tenv name;
-      flush_ppf ppf
-  | `Print_schema_type schema_ref ->
-      Typer.dump_schema_type ppf tenv schema_ref;
-      flush_ppf ppf
+  | `Print_type t ->
+      let t = Typer.typ tenv t in
+      Format.fprintf ppf "%a@." Types.Print.print_noname (Types.descr t)
   | `Reinit_ns ->
       Typer.set_ns_table_for_printer tenv
   | `Help ->

misc/pretty.ml

@@ -228,7 +228,8 @@ module Decompile(H : Hashtbl.S)(S : Set.OrderedType) = struct
     List.iter elim slots;
     let r = 
       List.fold_left 
-	(fun accu (s,t) -> if s == final then alt accu t else accu)
+	(fun accu (s,t) -> 
+	   if s == final then alt accu t else accu)
 	empty
 	initial.outg in
     regexp r

parser/ast.ml

@@ -32,8 +32,7 @@ and toplevel_directive =
   | `Help
   | `Dump of pexpr
   | `Print_schema of U.t
-  | `Print_schema_type of Schema_types.component_kind * U.t * U.t
-  | `Print_type of U.t
+  | `Print_type of ppat
   | `Debug of debug_directive
   | `Verbose
   | `Silent

parser/parser.ml

@@ -138,17 +138,8 @@ EXTEND
     | DIRECTIVE "#env" -> [ mk loc (Directive `Env) ]
     | DIRECTIVE "#print_schema"; name = IDENT ->
         [ mk loc (Directive (`Print_schema (U.mk name))) ]
-    | DIRECTIVE "#print_type"; name = IDENT;
-      schema_part = OPT [
-        "#"; typ = [ IDENT | keyword ];
-        kind = OPT [ "as"; k = schema_kind -> k] ->
-          (kind, typ)
-      ] ->
-        (match schema_part with
-        | None -> [ mk loc (Directive (`Print_type (U.mk name))) ]
-        | Some (kind, typ) ->
-            [ mk loc
-              (Directive (`Print_schema_type (kind, U.mk name, U.mk typ))) ])
+    | DIRECTIVE "#print_type"; t = pat ->
+        [ mk loc (Directive (`Print_type t)) ]
     | DIRECTIVE "#dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ]
     | DIRECTIVE "#reinit_ns" -> [ mk loc (Directive `Reinit_ns) ]
     | DIRECTIVE "#help" -> [ mk loc (Directive `Help) ]

runtime/eval.ml

@@ -229,8 +229,8 @@ and eval_branches_new env brs arg =
 and eval_ref env e t=
   Value.mk_ref (Types.descr t) (eval env e)
 
-and eval_validate env e kind schema_name name = 
-  let schema = Typer.get_schema schema_name in
+and eval_validate env e kind uri name = 
+  let schema = Typer.get_schema uri in
   try
     let validate =
       match Schema_common.get_component kind name schema with

types/types.ml

@@ -1366,10 +1366,23 @@ struct
   let register_global (name : U.t) d = 
     if equal { d with hash = 0; xml = BoolPair.empty } empty then 
       (let l = (*Product.merge_same_2*) (Product.get ~kind:`XML d) in
+       match l with
+	 | [(t1,t2)] -> 
+	     if DescrPairMap.mem (t1,t2) !named_xml then ()
+	     else
+	       named_xml := DescrPairMap.add (t1,t2) name !named_xml
+	 | _ -> ());
+    if DescrMap.mem d !named then ()
+    else named := DescrMap.add d name !named
+	
+  let unregister_global d =
+    if equal { d with hash = 0; xml = BoolPair.empty } empty then
+      (let l = Product.get ~kind:`XML d in
       match l with
-	| [(t1,t2)] -> named_xml := DescrPairMap.add (t1,t2) name !named_xml
-	| _ -> ());
-    named := DescrMap.add d name !named
+	 | [(t1,t2)] -> 
+	     named_xml := DescrPairMap.remove (t1,t2) !named_xml
+	 | _ -> ());
+    named := DescrMap.remove d !named
 
   let memo = DescrHash.create 63
   let counter = ref 0
@@ -1417,19 +1430,17 @@ struct
 	s
       with Not_found ->
 	if d.absent then alloc [Abs (prepare ({d with hash=0; absent=false}))]
-	else
-	if worth_complement d then 
-	  alloc [Neg (prepare (neg d))]
-	else
-	let slot = alloc [] in
+	else if worth_complement d 
+	then alloc [Neg (prepare (neg d))]
+	else let slot = alloc [] in
 	if not (worth_abbrev d) then slot.state <- `Expand;
 	DescrHash.add memo d slot;
 	let (seq,not_seq) =
 	  if (subtype { empty with hash = 0; times = d.times } seqs_descr) then
 	    (cap d seqs_descr, diff d seqs_descr)
-	  else
+	  else 
 	    (empty, d) in
-
+	
 	let add u = slot.def <- u :: slot.def in
 	if (non_empty seq) then
 	  add (Regexp (decompile seq));  
@@ -1441,16 +1452,16 @@ struct
 	     try 
 	       let n = DescrPairMap.find (t1,t2) !named_xml in
 	       add (Name n)
-	     with
-		 Not_found ->
-	     let tag = 
-	       match Atoms.print_tag t1.atoms with
-		 | Some a when is_empty { t1 with hash=0; atoms = Atoms.empty } -> `Tag a
-		 | _ -> `Type (prepare t1) in
-	     assert (equal { t2 with hash=0; times = empty.times } empty);
-	     List.iter
-	       (fun (ta,tb) -> add (Xml (tag, prepare ta, prepare tb)))
-	       (Product.get t2)
+	     with Not_found ->
+	       let tag = 
+		 match Atoms.print_tag t1.atoms with
+		   | Some a when is_empty { t1 with hash=0; atoms = Atoms.empty } -> `Tag a
+		   | _ -> `Type (prepare t1) in
+	       assert (equal { t2 with hash=0; times = empty.times } empty);
+	       List.iter
+		 (fun (ta,tb) -> 
+		    add (Xml (tag, prepare ta, prepare tb)))
+		 (Product.get t2);
 	  )
 	  ((*Product.merge_same_2*) (Product.get ~kind:`XML not_seq));
 	List.iter
@@ -1459,9 +1470,9 @@ struct
 	     add (Record (r,some,none)))
 	  (Record.get not_seq);
 	(match Chars.is_char not_seq.chars with
-	  | Some c -> add (Char c)
-	  | None ->
-	      List.iter (fun x -> add (Atomic x)) (Chars.print not_seq.chars));
+	   | Some c -> add (Char c)
+	   | None ->
+	       List.iter (fun x -> add (Atomic x)) (Chars.print not_seq.chars));
 	List.iter (fun x -> add (Atomic x)) (Intervals.print not_seq.ints);
 	List.iter (fun x -> add (Atomic x)) (Atoms.print not_seq.atoms);
 	List.iter (fun x -> add (Atomic x)) (Abstract.print not_seq.abstract);
@@ -1474,15 +1485,18 @@ struct
 	if not_seq.absent then add (Atomic (fun ppf -> Format.fprintf ppf "#ABSENT"));
 	slot.def <- List.rev slot.def;
 	slot
-	
-
+      
   and decompile d =
+    let r = 
     Decompile.decompile 
       (fun t -> 
-	 let tr = Product.get t in
+	 let tr = Product.get t in 
+	 let tr = Product.clean_normal tr in
+
 	 let tr = List.map (fun (l,t) -> prepare l, t) tr in
 	 tr, Atoms.contains nil_atom t.atoms)
-      d
+      d in
+    r
 
   let gen = ref 0
 
@@ -1532,7 +1546,7 @@ struct
     then Format.fprintf ppf "@[(%a)@]" aux def
     else aux ppf def
   and do_print pri ppf = function
-(*    | Neg { def = [] } -> Format.fprintf ppf "Any" *)
+    | Neg { def = [] } -> Format.fprintf ppf "Any"
     | Neg t -> Format.fprintf ppf "Any \\ (@[%a@])" (do_print_slot 0) t
     | Abs t -> Format.fprintf ppf "?(@[%a@])" (do_print_slot 0) t
     | Name n -> Format.fprintf ppf "%a" U.print n
@@ -1637,8 +1651,8 @@ struct
     | { state = `Named n } -> n
     | _ -> assert false
 
-  let print ppf d =
-    let t = prepare d in
+  let print ppf t =
+    let t = prepare t in
     assign_name t;
     Format.fprintf ppf "@[@[%a@]" (do_print_slot 0) t;
     (match List.rev !to_print with
@@ -1659,6 +1673,14 @@ struct
     to_print := [];
     DescrHash.clear memo
 
+  let print_noname ppf t =   
+    let old_named = !named in
+    let old_named_xml = !named_xml in
+    unregister_global t;
+    print ppf t;
+    named := old_named;
+    named_xml := old_named_xml
+
   let print_node ppf n = print ppf (descr n)
 
   let () = forward_print := print

types/types.mli

@@ -279,6 +279,9 @@ sig
   val print_const : Format.formatter -> const -> unit
   val print: Format.formatter -> t -> unit
   val print_node: Format.formatter -> Node.t -> unit
+
+  (* Don't try to find a global name at toplevel *)
+  val print_noname: Format.formatter -> t -> unit
 end
 
 

typing/typer.ml

@@ -58,6 +58,14 @@ let dump ppf _ = failwith "Typer.dump"
 let equal _ _ = failwith "Typer.equal"
 let check _ = failwith "Typer.check"
 
+
+let load_schema_fwd = ref (fun x uri -> assert false)
+
+let enter_schema x uri env =
+  !load_schema_fwd x uri;
+  { env with schemas = UEnv.add x uri env.schemas }
+
+
 (* TODO: filter out builtin defs ? *)
 let serialize_item s = function
   | Type t -> Serialize.Put.bits 1 s 0; Types.serialize s t
@@ -65,7 +73,11 @@ let serialize_item s = function
 
 let serialize s env =
   Serialize.Put.env Id.serialize serialize_item Env.iter s env.ids;
-  Ns.serialize_table s env.ns
+  Ns.serialize_table s env.ns;
+
+  let schs =
+    UEnv.fold (fun name uri accu -> (name,uri)::accu) env.schemas [] in
+  Serialize.Put.list (Serialize.Put.pair U.serialize Serialize.Put.string) s schs
 
 let deserialize_item s = match Serialize.Get.bits 1 s with
   | 0 -> Type (Types.deserialize s)
@@ -75,7 +87,12 @@ let deserialize_item s = match Serialize.Get.bits 1 s with
 let deserialize s =
   let ids = Serialize.Get.env Id.deserialize deserialize_item Env.add Env.empty s in
   let ns = Ns.deserialize_table s in
-  { ids = ids; ns = ns; cu = UEnv.empty; schemas = UEnv.empty }
+  let schs = 
+    Serialize.Get.list 
+      (Serialize.Get.pair U.deserialize Serialize.Get.string) s in
+  let env = 
+    { ids = ids; ns = ns; cu = UEnv.empty; schemas = UEnv.empty } in
+  List.fold_left (fun env (name,uri) -> enter_schema name uri env) env schs
 
 
 let empty_env = {
@@ -95,8 +112,6 @@ let find_cu x env =
   with Not_found -> Types.CompUnit.mk x
 
 
-let enter_schema x uri env =
-  { env with schemas = UEnv.add x uri env.schemas }
 let find_schema x env =
   try UEnv.find x env.schemas
   with Not_found -> raise (Error (Printf.sprintf "%s: no such schema" (U.get_str x)))
@@ -219,11 +234,14 @@ let schema_model_groups =
   State.ref "Typer.schema_model_groups" (Hashtbl.create 51)
 
 
-let get_schema_fwd = ref (fun _ -> assert false)
+(*
+let get_schema uri =
+  try Hashtbl.find !schemas uri
+  with Not_found -> assert false
+*)
 
 let find_schema_descr_uri kind uri (name : Ns.qname) =
   try
-    ignore (!get_schema_fwd uri);
     let elt () = Hashtbl.find !schema_elements (uri, name) in
     let typ () = Hashtbl.find !schema_types (uri, name) in
     let att () = Hashtbl.find !schema_attributes (uri, name) in
@@ -853,19 +871,6 @@ 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 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" (U.get_str name)))
-
-let dump_schema_type ppf env (k, s, n) =
-  let name = qname env noloc n in
-  let uri = find_schema s env in
-  let descr = find_schema_descr_uri k uri name in
-  Types.Print.print ppf descr
 
 let dump_ns ppf env =
   Ns.dump_table ppf env.ns
@@ -1716,58 +1721,63 @@ let get_schema_names env = UEnv.fold (fun n _ acc -> n :: acc) env.schemas []
 
 
 open Schema_types
-let get_schema uri =
-  try Hashtbl.find !schemas uri
-  with Not_found ->
-    let schema = Schema_parser.schema_of_uri uri in
-    let log_schema_component kind uri name cd_type =
-      if not (Schema_builtin.is_builtin name) then begin
-        Format.fprintf Format.std_formatter
-	  "Registering schema %s: %s # %s"
-	  kind uri (Ns.QName.to_string name);
-(*        if debug_schema then
-	  Types.Print.print Format.std_formatter cd_type; *)
-        Format.fprintf Format.std_formatter "@."
-      end 
-    in
-    Hashtbl.add !schemas uri schema;
-    List.iter (* Schema types -> CDuce types *)
-      (fun type_def ->
-         let name = Schema_common.name_of_type_definition type_def in
-         let cd_type = Schema_converter.cd_type_of_type_def ~schema 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.cd_type_of_att_decl ~schema 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.cd_type_of_elt_decl ~schema 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.cd_type_of_attr_uses ~schema 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.cd_type_of_model_group ~schema 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;
-    schema
 
 
+let get_schema uri =
+  Hashtbl.find !schemas uri
+
+let load_schema schema_name uri =
+  if Hashtbl.mem !schemas uri then ()
+  else (
+  let schema = Schema_parser.schema_of_uri uri in
+  let log_schema_component kind uri name cd_type =
+    if not (Schema_builtin.is_builtin name) then begin
+      let n = U.to_string schema_name ^ "#" ^ (Ns.QName.to_string name) in
+      Types.Print.register_global (U.mk_latin1 n) cd_type;
+      
+      Format.fprintf Format.std_formatter "Registering schema %s: %s" kind n;
+      (*        if debug_schema then
+		Types.Print.print Format.std_formatter cd_type; *)
+      Format.fprintf Format.std_formatter "@."
+    end 
+  in
+  Hashtbl.add !schemas uri schema;
+  List.iter (* Schema types -> CDuce types *)
+    (fun type_def ->
+       let name = Schema_common.name_of_type_definition type_def in
+       let cd_type = Schema_converter.cd_type_of_type_def ~schema 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.cd_type_of_att_decl ~schema 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.cd_type_of_elt_decl ~schema 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.cd_type_of_attr_uses ~schema 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.cd_type_of_model_group ~schema 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 () = get_schema_fwd := get_schema
 
+let () = load_schema_fwd := load_schema

typing/typer.mli

@@ -44,10 +44,6 @@ 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 -> U.t -> unit
-val dump_schema_type:
-  Format.formatter -> t -> (Schema_types.component_kind * U.t * U.t) -> unit
-
 val dump_ns: Format.formatter -> t -> unit
 val set_ns_table_for_printer: t -> unit
 
@@ -69,7 +65,6 @@ val flatten: (Types.t -> bool -> Types.t) -> (Types.t -> bool -> Types.t)
 (** {2 Schema stuff} *)
 
 val get_schema: string -> Schema_types.schema  (** lookup schema by uri *)
-
 val get_schema_names: t -> U.t list  (** registered schema names *)
 
 (* Operators *)