[r2003-11-20 11:37:57 by szach] added support for #print_{type,schema} directives

Original author: szach
Date: 2003-11-20 11:37:57+00:00

parser/ast.ml

@@ -3,9 +3,6 @@
 open Location
 open Ident
 
-type schema_item_kind =
-  [ `Type | `Element | `Attribute | `Attribute_group | `Model_group ] option
-
 type pprog = pmodule_item list
 
 and pmodule_item = pmodule_item' located
@@ -33,6 +30,9 @@ and toplevel_directive =
   | `Reinit_ns
   | `Help
   | `Dump of pexpr
+  | `Print_schema of string
+  | `Print_schema_type of Schema_types.component_kind * string * string
+  | `Print_type of string
   ]
 
 
@@ -59,7 +59,8 @@ and pexpr =
   | Map of pexpr * branches
   | Transform of pexpr * branches
   | Xtrans of pexpr * branches
-  | Validate of pexpr * string * string (* exp, schema name, element name *)
+  | Validate of pexpr * Schema_types.component_kind * string * string
+      (* exp, schema component kind, schema name, element name *)
   | Dot of pexpr * label
   | RemoveField of pexpr * label
 
@@ -90,7 +91,7 @@ and ppat = ppat' located
 and ppat' =
   | PatVar of U.t
   | SchemaVar of  (* type/pattern schema variable *)
-      schema_item_kind * string * string
+      Schema_types.component_kind * string * string (* kind, schema, name *)
   | Cst of pexpr
   | NsT of U.t
   | Recurs of ppat * (id * ppat) list

parser/parser.ml

@@ -118,6 +118,18 @@ EXTEND
     | DIRECTIVE "#ascii" -> Ulexer.enc := Ulexing.Ascii; [ ]
     | DIRECTIVE "#quit" -> [ mk loc (Directive `Quit) ]
     | DIRECTIVE "#env" -> [ mk loc (Directive `Env) ]
+    | DIRECTIVE "#print_schema"; name = IDENT ->
+        [ mk loc (Directive (`Print_schema 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 name)) ]
+        | Some (kind, typ) ->
+            [ mk loc (Directive (`Print_schema_type (kind, name, typ))) ])
     | DIRECTIVE "#dump_value"; e = expr -> [ mk loc (Directive (`Dump e)) ]
     | DIRECTIVE "#reinit_ns" -> [ mk loc (Directive `Reinit_ns) ]
     | DIRECTIVE "#help" -> [ mk loc (Directive `Help) ]
@@ -193,9 +205,8 @@ EXTEND
 	exp loc (Match (e, [p1,e1; p2,e2]))
     | "transform"; e = SELF; "with"; b = branches -> 
 	exp loc (Transform (e,b))
-    | "validate"; e = SELF; "with"; schema = IDENT; "#";
-      typ = [ IDENT | keyword ] ->
-        exp loc (Validate (e, schema, typ))
+    | "validate"; e = SELF; "with"; (kind, schema, typ) = schema_ref ->
+        exp loc (Validate (e, kind, schema, typ))
     | "fun"; (f,a,b) = fun_decl ->
 	exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
     | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
@@ -461,6 +472,13 @@ EXTEND
     ]
   ];
 
+  schema_ref: [
+    [ schema = IDENT; "#"; typ = [ IDENT | keyword ];
+      kind = OPT [ "as"; k = schema_kind -> k] ->
+        (kind, schema, typ)
+    ]
+  ];
+
   pat: [ 
       [ x = pat; IDENT "where"; 
         b = LIST1 [ a = IDENT; "="; y = pat -> (ident a,y) ] SEP "and"
@@ -482,7 +500,7 @@ EXTEND
 	  mk loc (Constant (ident a,c))
       | schema = IDENT; "#"; typ = [ IDENT | keyword ];
         kind = OPT [ "as"; k = schema_kind -> k] ->
-        mk loc (SchemaVar (kind, schema, typ))
+          mk loc (SchemaVar (kind, schema, typ))
       | a = IDENT -> 
 	  mk loc (PatVar (U.mk a))
       | i = INT ; "--"; j = INT ->