[r2003-06-12 13:15:56 by cvscast] Merging schema branch

Original author: cvscast
Date: 2003-06-12 13:16:00+00:00

.cvsignore

+cduce
+cduce.opt
+dtd2cduce
+webiface.opt
+validate
+*.cmi
+*.cmo
+*.cmx
+*.cma
+*.cmxa

Makefile.distrib

 include Makefile.conf
 VERSION = 0.0.91
 
-PACKAGES = -package "pxp-engine pxp-lex-iso88591 wlexing camlp4 num cgi"
+PACKAGES = -package "pxp-engine pxp-lex-iso88591 wlexing camlp4 num cgi pcre netstring"
 ifeq ($(PXP_WLEX), true)
   PACKAGES += -package pxp-wlex-utf8
 else
@@ -32,7 +32,7 @@ ifeq ($(PROFILE), true)
 	ifeq ($(NATIVE), false) 
          CAMLC_P = ocamlcp -p a
          SYNTAX_PARSER = 
-        endif
+	endif
 else
 	CAMLOPT_P = ocamlopt -inline 25
 endif
@@ -46,14 +46,15 @@ ifeq ($(NATIVE), true)
 	LINK = $(CAMLOPT) -linkpkg gramlib.cmxa
 else
 	EXTENSION = cmo
-	LINK = $(CAMLC) -custom -linkpkg gramlib.cma mlexpat.cma
+	LINK = $(CAMLC) -custom -linkpkg gramlib.cma
 endif
 
-all: cduce dtd2cduce local_website
+# all: cduce dtd2cduce local_website
+all: cduce dtd2cduce local_website validate
 
 # Source directories 
 
-DIRS = misc parser typing types runtime driver
+DIRS = misc parser schema typing types runtime driver
 CLEAN_DIRS = $(DIRS) tools tests
 
 # Objects to build
@@ -65,13 +66,18 @@ OBJECTS = \
  types/sortedList.cmo types/boolean.cmo types/ident.cmo \
  types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo \
  types/types.cmo types/patterns.cmo types/sequence.cmo \
- types/sample.cmo \
+ types/sample.cmo types/builtin_defs.cmo \
+ \
+ runtime/value.cmo \
+ \
+ schema/schema_types.cmo schema/schema_xml.cmo schema/schema_builtin.cmo \
+ schema/schema_validator.cmo schema/schema_parser.cmo \
  \
  parser/location.cmo parser/wlexer.cmo parser/ast.cmo parser/parser.cmo \
  \
  typing/typed.cmo typing/typer.cmo \
  \
- runtime/value.cmo runtime/load_xml.cmo runtime/run_dispatch.cmo \
+ runtime/load_xml.cmo runtime/run_dispatch.cmo \
  runtime/print_xml.cmo runtime/eval.cmo \
  \
  types/builtin.cmo driver/cduce.cmo
@@ -98,6 +104,9 @@ webiface: $(WEBIFACE:.cmo=.$(EXTENSION))
 dtd2cduce: $(DTD2CDUCE:.cmo=.$(EXTENSION))
 	$(LINK) $(INCLUDES) -o $@ $^
 
+validate: $(OBJECTS:.cmo=.$(EXTENSION)) tools/validate.ml
+	$(LINK) $(INCLUDES) -o $@ $^
+
 .PHONY: compute_depend
 compute_depend: misc/q_symbol.cmo
 	@echo "Computing dependencies ..."
@@ -115,7 +124,7 @@ clean:
 	rm -f `find . -name "*~"`
 	rm -f *.cmi *.cmo *.cma *.cmx *.a *.cmxa *.o *~
 	rm -f cduce ocamlprof.dump
-	rm -f dtd2cduce pool webiface
+	rm -f dtd2cduce pool webiface validate
 	rm -Rf prepro package
 	rm -f web/www/*.php web/www/*.html web/*~
 

depend

@@ -38,36 +38,68 @@ types/sequence.cmo: misc/q_symbol.cmo types/atoms.cmi types/types.cmi types/sequ
 types/sequence.cmx: misc/q_symbol.cmo types/atoms.cmx types/types.cmx types/sequence.cmi 
 types/sample.cmo: misc/q_symbol.cmo types/ident.cmo types/types.cmi types/sample.cmi 
 types/sample.cmx: misc/q_symbol.cmo types/ident.cmx types/types.cmx types/sample.cmi 
+types/builtin_defs.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/intervals.cmi \
+    types/sequence.cmi types/types.cmi types/builtin_defs.cmi 
+types/builtin_defs.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx types/intervals.cmx \
+    types/sequence.cmx types/types.cmx types/builtin_defs.cmi 
+runtime/value.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \
+    types/ident.cmo types/intervals.cmi types/sequence.cmi types/types.cmi \
+    runtime/value.cmi 
+runtime/value.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/encodings.cmx \
+    types/ident.cmx types/intervals.cmx types/sequence.cmx types/types.cmx \
+    runtime/value.cmi 
+schema/schema_types.cmo: misc/q_symbol.cmo runtime/value.cmi schema/schema_types.cmi 
+schema/schema_types.cmx: misc/q_symbol.cmo runtime/value.cmx schema/schema_types.cmi 
+schema/schema_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi runtime/value.cmi \
+    schema/schema_xml.cmi 
+schema/schema_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx runtime/value.cmx \
+    schema/schema_xml.cmi 
+schema/schema_builtin.cmo: misc/q_symbol.cmo types/builtin_defs.cmi types/intervals.cmi \
+    schema/schema_types.cmi types/types.cmi runtime/value.cmi \
+    schema/schema_builtin.cmi 
+schema/schema_builtin.cmx: misc/q_symbol.cmo types/builtin_defs.cmx types/intervals.cmx \
+    schema/schema_types.cmx types/types.cmx runtime/value.cmx \
+    schema/schema_builtin.cmi 
+schema/schema_validator.cmo: misc/q_symbol.cmo types/atoms.cmi schema/schema_builtin.cmi \
+    schema/schema_types.cmi schema/schema_xml.cmi runtime/value.cmi \
+    schema/schema_validator.cmi 
+schema/schema_validator.cmx: misc/q_symbol.cmo types/atoms.cmx schema/schema_builtin.cmx \
+    schema/schema_types.cmx schema/schema_xml.cmx runtime/value.cmx \
+    schema/schema_validator.cmi 
+schema/schema_parser.cmo: misc/q_symbol.cmo schema/schema_builtin.cmi schema/schema_types.cmi \
+    schema/schema_validator.cmi schema/schema_xml.cmi runtime/value.cmi \
+    schema/schema_parser.cmi 
+schema/schema_parser.cmx: misc/q_symbol.cmo schema/schema_builtin.cmx schema/schema_types.cmx \
+    schema/schema_validator.cmx schema/schema_xml.cmx runtime/value.cmx \
+    schema/schema_parser.cmi 
 parser/location.cmo: misc/q_symbol.cmo parser/location.cmi 
 parser/location.cmx: misc/q_symbol.cmo parser/location.cmi 
 parser/wlexer.cmo: misc/q_symbol.cmo misc/encodings.cmi parser/location.cmi 
 parser/wlexer.cmx: misc/q_symbol.cmo misc/encodings.cmx parser/location.cmx 
-parser/ast.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi types/types.cmi 
-parser/ast.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx types/types.cmx 
+parser/ast.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi schema/schema_types.cmi \
+    types/types.cmi 
+parser/ast.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx schema/schema_types.cmx \
+    types/types.cmx 
 parser/parser.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/chars.cmi \
     misc/encodings.cmi types/ident.cmo types/intervals.cmi \
-    parser/location.cmi types/sequence.cmi types/types.cmi parser/wlexer.cmo \
-    parser/parser.cmi 
+    parser/location.cmi schema/schema_parser.cmi schema/schema_xml.cmi \
+    types/sequence.cmi types/types.cmi parser/wlexer.cmo parser/parser.cmi 
 parser/parser.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/chars.cmx \
     misc/encodings.cmx types/ident.cmx types/intervals.cmx \
-    parser/location.cmx types/sequence.cmx types/types.cmx parser/wlexer.cmx \
-    parser/parser.cmi 
+    parser/location.cmx schema/schema_parser.cmx schema/schema_xml.cmx \
+    types/sequence.cmx types/types.cmx parser/wlexer.cmx parser/parser.cmi 
 typing/typed.cmo: misc/q_symbol.cmo types/ident.cmo parser/location.cmi types/patterns.cmi \
     types/types.cmi runtime/value.cmi 
 typing/typed.cmx: misc/q_symbol.cmo types/ident.cmx parser/location.cmx types/patterns.cmx \
     types/types.cmx runtime/value.cmx 
-typing/typer.cmo: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo parser/location.cmi \
-    types/patterns.cmi types/sequence.cmi misc/state.cmi typing/typed.cmo \
-    types/types.cmi typing/typer.cmi 
-typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/ident.cmx parser/location.cmx \
-    types/patterns.cmx types/sequence.cmx misc/state.cmx typing/typed.cmx \
-    types/types.cmx typing/typer.cmi 
-runtime/value.cmo: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \
-    types/ident.cmo types/intervals.cmi types/sequence.cmi types/types.cmi \
-    runtime/value.cmi 
-runtime/value.cmx: misc/q_symbol.cmo types/atoms.cmx types/chars.cmx misc/encodings.cmx \
-    types/ident.cmx types/intervals.cmx types/sequence.cmx types/types.cmx \
-    runtime/value.cmi 
+typing/typer.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/ident.cmo \
+    parser/location.cmi types/patterns.cmi schema/schema_builtin.cmi \
+    schema/schema_types.cmi schema/schema_validator.cmi types/sequence.cmi \
+    misc/state.cmi typing/typed.cmo types/types.cmi typing/typer.cmi 
+typing/typer.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/ident.cmx \
+    parser/location.cmx types/patterns.cmx schema/schema_builtin.cmx \
+    schema/schema_types.cmx schema/schema_validator.cmx types/sequence.cmx \
+    misc/state.cmx typing/typed.cmx types/types.cmx typing/typer.cmi 
 runtime/load_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi types/ident.cmo \
     parser/location.cmi runtime/value.cmi runtime/load_xml.cmi 
 runtime/load_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
@@ -83,17 +115,21 @@ runtime/print_xml.cmo: misc/q_symbol.cmo types/atoms.cmi misc/encodings.cmi type
 runtime/print_xml.cmx: misc/q_symbol.cmo types/atoms.cmx misc/encodings.cmx types/ident.cmx \
     parser/location.cmx types/sequence.cmx runtime/value.cmx 
 runtime/eval.cmo: misc/q_symbol.cmo types/ident.cmo types/patterns.cmi runtime/run_dispatch.cmi \
-    typing/typed.cmo types/types.cmi runtime/value.cmi runtime/eval.cmi 
+    schema/schema_validator.cmi schema/schema_xml.cmi typing/typed.cmo \
+    typing/typer.cmi types/types.cmi runtime/value.cmi runtime/eval.cmi 
 runtime/eval.cmx: misc/q_symbol.cmo types/ident.cmx types/patterns.cmx runtime/run_dispatch.cmx \
-    typing/typed.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi 
-types/builtin.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/chars.cmi \
-    types/ident.cmo types/intervals.cmi runtime/load_xml.cmi \
+    schema/schema_validator.cmx schema/schema_xml.cmx typing/typed.cmx \
+    typing/typer.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi 
+types/builtin.cmo: misc/q_symbol.cmo parser/ast.cmo types/atoms.cmi types/builtin_defs.cmi \
+    types/chars.cmi types/ident.cmo types/intervals.cmi runtime/load_xml.cmi \
     parser/location.cmi runtime/print_xml.cmo types/sequence.cmi \
-    typing/typed.cmo typing/typer.cmi types/types.cmi runtime/value.cmi 
-types/builtin.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/chars.cmx \
-    types/ident.cmx types/intervals.cmx runtime/load_xml.cmx \
+    typing/typed.cmo typing/typer.cmi types/types.cmi runtime/value.cmi \
+    types/builtin.cmi 
+types/builtin.cmx: misc/q_symbol.cmo parser/ast.cmx types/atoms.cmx types/builtin_defs.cmx \
+    types/chars.cmx types/ident.cmx types/intervals.cmx runtime/load_xml.cmx \
     parser/location.cmx runtime/print_xml.cmx types/sequence.cmx \
-    typing/typed.cmx typing/typer.cmx types/types.cmx runtime/value.cmx 
+    typing/typed.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
+    types/builtin.cmi 
 driver/cduce.cmo: misc/q_symbol.cmo parser/ast.cmo runtime/eval.cmi types/ident.cmo \
     parser/location.cmi parser/parser.cmi types/patterns.cmi types/sample.cmi \
     misc/state.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
@@ -108,10 +144,8 @@ driver/run.cmo: misc/q_symbol.cmo driver/cduce.cmi types/ident.cmo runtime/load_
 driver/run.cmx: misc/q_symbol.cmo driver/cduce.cmx types/ident.cmx runtime/load_xml.cmx \
     parser/location.cmx types/sequence.cmx misc/state.cmx runtime/value.cmx \
     parser/wlexer.cmx 
-driver/webiface.cmo: misc/q_symbol.cmo driver/cduce.cmi driver/examples.cmo parser/location.cmi \
-    misc/state.cmi 
-driver/webiface.cmx: misc/q_symbol.cmo driver/cduce.cmx driver/examples.cmx parser/location.cmx \
-    misc/state.cmx 
+driver/webiface.cmo: misc/q_symbol.cmo driver/cduce.cmi parser/location.cmi misc/state.cmi 
+driver/webiface.cmx: misc/q_symbol.cmo driver/cduce.cmx parser/location.cmx misc/state.cmx 
 types/boolean.cmi: misc/q_symbol.cmo types/sortedList.cmi 
 types/atoms.cmi: misc/q_symbol.cmo misc/encodings.cmi 
 types/types.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/ident.cmo \
@@ -120,11 +154,18 @@ types/patterns.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi types/iden
     types/types.cmi 
 types/sequence.cmi: misc/q_symbol.cmo types/atoms.cmi types/types.cmi 
 types/sample.cmi: misc/q_symbol.cmo types/types.cmi 
-parser/parser.cmi: misc/q_symbol.cmo parser/ast.cmo 
-typing/typer.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo parser/location.cmi \
-    typing/typed.cmo types/types.cmi 
+types/builtin_defs.cmi: misc/q_symbol.cmo types/atoms.cmi types/types.cmi 
 runtime/value.cmi: misc/q_symbol.cmo types/atoms.cmi types/chars.cmi misc/encodings.cmi \
     types/ident.cmo types/intervals.cmi types/types.cmi 
+schema/schema_types.cmi: misc/q_symbol.cmo runtime/value.cmi 
+schema/schema_xml.cmi: misc/q_symbol.cmo runtime/value.cmi 
+schema/schema_builtin.cmi: misc/q_symbol.cmo types/types.cmi runtime/value.cmi 
+schema/schema_validator.cmi: misc/q_symbol.cmo schema/schema_types.cmi runtime/value.cmi 
+schema/schema_parser.cmi: misc/q_symbol.cmo schema/schema_types.cmi schema/schema_xml.cmi 
+parser/parser.cmi: misc/q_symbol.cmo parser/ast.cmo 
+typing/typer.cmi: misc/q_symbol.cmo parser/ast.cmo types/ident.cmo parser/location.cmi \
+    schema/schema_types.cmi schema/schema_validator.cmi typing/typed.cmo \
+    types/types.cmi 
 runtime/load_xml.cmi: misc/q_symbol.cmo runtime/value.cmi 
 runtime/run_dispatch.cmi: misc/q_symbol.cmo types/patterns.cmi runtime/value.cmi 
 runtime/eval.cmi: misc/q_symbol.cmo types/ident.cmo typing/typed.cmo runtime/value.cmi 

driver/cduce.ml

@@ -165,6 +165,9 @@ let rec phrases ppf phs = match phs with
       phrases ppf (collect_funs ppf [] phs)
   | { descr = Ast.TypeDecl (_,_) } :: _ ->
       phrases ppf (collect_types ppf [] phs)
+  | { descr = Ast.SchemaDecl (name, schema) } :: rest ->
+      Typer.register_schema name schema;
+      phrases ppf rest
   | { descr = Ast.EvalStatement e } :: rest ->
       let (fv,e) = Typer.expr e in
       let t = Typer.type_check !typing_env e Types.any true in

expat/OCamlMakefile

@@ -5,7 +5,7 @@
 #                             For updates see:
 #                http://www.oefai.at/~markus/ocaml_sources
 #
-#        $Id: OCamlMakefile,v 1.1 2003/06/08 08:33:53 cvscast Exp $
+#        $Id: OCamlMakefile,v 1.2 2003/06/12 13:15:56 cvscast Exp $
 #
 ###########################################################################
 

expat/expat.ml

@@ -5,7 +5,7 @@
 (* LICENCE for details.                                                *)
 (***********************************************************************)
 
-(* $Id: expat.ml,v 1.2 2003/06/03 20:45:50 cvscast Exp $ *)
+(* $Id: expat.ml,v 1.3 2003/06/12 13:15:57 cvscast Exp $ *)
 
 type expat_parser
 

expat/expat.mli

@@ -5,7 +5,7 @@
 (* LICENCE for details.                                                *)
 (***********************************************************************)
 
-(* $Id: expat.mli,v 1.3 2003/06/08 08:33:54 cvscast Exp $ *)
+(* $Id: expat.mli,v 1.4 2003/06/12 13:15:57 cvscast Exp $ *)
 
 (** The Ocaml Expat library provides an interface to the Expat XML Parser.
 

expat/expat_stubs.c

@@ -5,7 +5,7 @@
 /* LICENCE for details.                                                */
 /***********************************************************************/
 
-/* $Id: expat_stubs.c,v 1.3 2003/06/03 20:45:50 cvscast Exp $ */
+/* $Id: expat_stubs.c,v 1.4 2003/06/12 13:15:57 cvscast Exp $ */
 
 /* Stub code to interface Ocaml with Expat */
 

parser/ast.ml

@@ -3,11 +3,14 @@
 open Location
 open Ident
 
+type schema_item_kind = [ `Type | `Element | `Attribute | `Any ]
+
 type pprog = pmodule_item list
 
 and pmodule_item = pmodule_item' located
 and pmodule_item' =
   | TypeDecl of string * ppat
+  | SchemaDecl of string * Schema_types.schema  (* name, schema *)
   | LetDecl of ppat * pexpr
   | FunDecl of pexpr
   | EvalStatement of pexpr
@@ -48,7 +51,8 @@ and pexpr =
   | Map of pexpr * branches
   | Transform of pexpr * branches
   | Xtrans of pexpr * branches
-  | Dot of pexpr* label
+  | Validate of pexpr * string * string (* exp, schema name, element name *)
+  | Dot of pexpr * label
   | RemoveField of pexpr * label
 
   (* Exceptions *)
@@ -67,6 +71,8 @@ and branches = (ppat * pexpr) list
 and ppat = ppat' located
 and ppat' =
   | PatVar of string
+  | SchemaVar of  (* type/pattern schema variable *)
+      schema_item_kind * string * string
   | Recurs of ppat * (string * ppat) list
   | Internal of Types.descr
   | Or of ppat * ppat
@@ -80,6 +86,7 @@ and ppat' =
   | Capture of id
   | Constant of id * Types.const
   | Regexp of regexp * ppat
+      (* regular expression, continuation: [ re ; cont ], e.g: [ re ; nil ] *)
 
 and regexp =
   | Epsilon
@@ -89,3 +96,16 @@ and regexp =
   | Star of regexp
   | WeakStar of regexp
   | SeqCapture of id * regexp
+
+open Printf
+
+(*
+let rec string_of_regexp = function
+  | Epsilon -> "e"
+  | Elem _ -> "ELEM"
+  | Seq (re1, re2) -> sprintf "(%s),(%s)" (string_of_regexp re1) (string_of_regexp re2)
+  | Alt (re1, re2) -> sprintf "(%s)|(%s)" (string_of_regexp re1) (string_of_regexp re2)
+  | Star re -> sprintf "(%s)*" (string_of_regexp re)
+  | WeakStar _ -> assert false
+  | SeqCapture _ -> assert false
+*)

parser/parser.ml

 open Location
 open Ast
 open Ident
+open Printf
 
 (*
 let ()  = Grammar.error_verbose := true
@@ -91,7 +92,6 @@ let char_list loc s =
   let s = seq_of_string loc s in
   List.map (fun (loc,c) -> exp loc (Cst (Types.Char (Chars.mk_int c)))) s
 
-
 let include_stack = ref []
 
 let protect_exn f g =
@@ -107,6 +107,7 @@ let is_fun_decl =
 	 | _ -> raise Stream.Failure
      )
 
+let dot_RE = Pcre.regexp "\\."
 
 EXTEND
   GLOBAL: top_phrases prog expr pat regexp const;
@@ -127,6 +128,10 @@ EXTEND
         [ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ]
     | "type"; x = UIDENT; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
     | "type"; x = LIDENT -> error loc "Type identifiers must be capitalized"
+    | "schema"; name = UIDENT; "="; uri = STRING2 ->
+        let schema_doc = Schema_xml.pxp_tree_of (get_string uri) in
+        let schema = Schema_parser.parse_schema schema_doc in
+        [ mk loc (SchemaDecl (name, schema))]
     | "debug"; d = debug_directive -> [ mk loc (Debug d) ]
     | DIRECTIVE "#quit" -> [ mk loc (Directive `Quit) ]
     | DIRECTIVE "#env" -> [ mk loc (Directive `Env) ]
@@ -176,7 +181,7 @@ EXTEND
 	| "if" | "then"	| "else"
 	| "transform" | "fun" | "in"
 	| "let" | "type" | "debug" | "include"
-        | "and"
+        | "and" | "validate" | "schema"
 	]
 	-> a
     ]
@@ -198,6 +203,9 @@ 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 = UIDENT; "#";
+      typ = [ UIDENT | LIDENT | keyword ] ->
+        exp loc (Validate (e, 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"->
@@ -400,6 +408,17 @@ EXTEND
       | a = LIDENT -> mk loc (Capture (ident a))
       | "("; a = LIDENT; ":="; c = const; ")" -> 
 	  mk loc (Constant (ident a,c))
+      | schema = UIDENT; "#"; typ = [ UIDENT | LIDENT | keyword ];
+        k = OPT [ "as"; k = [ "element" | "type" | "attribute" ] -> k ] ->
+          let kind =
+            match k with
+            | None -> `Any
+            | Some "element" -> `Element
+            | Some "type" -> `Type
+            | Some "attribute" -> `Attribute
+            | _ -> assert false
+          in
+          mk loc (SchemaVar (kind, schema, typ))
       | a = UIDENT -> mk loc (PatVar a)
       | i = INT ; "--"; j = INT -> 
           let i =  Intervals.mk i 

parser/wlexer.mll

@@ -100,7 +100,7 @@ rule token = parse
   | [ "<>=.,:;+-*/@&{}[]()|?`!" ]
   | "->" | "::" | ";;" | "--" | ":=" | "\\" | "++"
   | "{|" | "|}" | "<=" | ">=" | "<<" | ">>"
-  | ["?+*"] "?"
+  | ["?+*"] "?" | "#"
 	{ "",Lexing.lexeme lexbuf }
   | "#" lowercase+ { "DIRECTIVE",Lexing.lexeme lexbuf }
   | '"' | "'"

runtime/eval.ml

@@ -16,6 +16,7 @@ let get_accu = function
 
 (* Evaluation of expressions *)
 
+
 let rec eval env e0 = match e0.Typed.exp_descr with
   | Typed.Forget (e,_) -> eval env e
   | Typed.Var s -> (match Env.find s env with Value.Delayed x -> !x | x -> x)
@@ -35,7 +36,10 @@ let rec eval env e0 = match e0.Typed.exp_descr with
   | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
   | Typed.UnaryOp (o,e) -> o.Typed.un_op_eval (eval env e)
   | Typed.BinaryOp (o,e1,e2) -> o.Typed.bin_op_eval (eval env e1) (eval env e2)
-
+  | Typed.Validate (e, schema, name) ->
+      let validator = Typer.get_schema_validator (schema, name) in
+      Schema_validator.validate ~validator
+        (Schema_xml.pxp_stream_of_value (eval env e))
 
 and eval_try env arg brs =
   try eval env arg
@@ -62,7 +66,6 @@ and eval_abstraction env a =
 	self := a;
 	a
 
-
 and eval_apply f arg = match f with
   | Abstraction (_,clos) -> clos arg
   | _ -> assert false

runtime/value.ml

@@ -25,6 +25,17 @@ let vtrue = Atom (Atoms.mk_ascii "true")
 let vfalse = Atom (Atoms.mk_ascii "false")
 let vbool x = if x then vtrue else vfalse
 
+let vrecord l =
+  let l = List.map (fun (l,v) -> LabelPool.mk (U.mk l), v) l in
+  Record (LabelMap.from_list (fun _ _ -> assert false) l)
+
+let get_fields = function
+  | Record map ->
+      LabelMap.mapi_to_list
+        (fun k v -> Utf8.to_string (LabelPool.value k), v)
+        map
+  | _ -> assert false
+
 let rec sequence = function
   | [] -> nil
   | h::t -> Pair (h, sequence t)
@@ -81,6 +92,9 @@ let get_string_utf8 e =
   Buffer.clear buf;
   (Utf8.mk s, q)
 
+let get_int = function
+  | Integer i when Intervals.is_int i -> Intervals.get_int i
+  | _ -> raise (Invalid_argument "Value.get_int")
 
 let rec is_seq = function
   | Pair (_, y) when is_seq y -> true
@@ -155,10 +169,16 @@ and print_seq ppf = function
   | _ -> ()
 
 and print_xml ppf tag attr content =
-  Format.fprintf ppf "@[<hv2><%a%a>[@ %a@]]"
-    print_tag tag
-    print_attr attr
-    print_seq content
+  if is_seq content then
+    Format.fprintf ppf "@[<hv2><%a%a>[@ %a@]]"
+      print_tag tag
+      print_attr attr
+      print_seq content
+  else
+    Format.fprintf ppf "@[<hv2><%a%a>@ %a@]"
+      print_tag tag
+      print_attr attr
+      print content
 and print_tag ppf = function
   | Atom tag -> Utf8.print ppf (Atoms.value tag)
   | tag -> Format.fprintf ppf "(%a)" print tag
@@ -174,6 +194,13 @@ and print_record ppf = function
 and print_field ppf (l,v) = 
   Format.fprintf ppf "%a=%a" U.print (LabelPool.value l) print v  
 
+let explode_rev s =
+  let rec aux acc = function
+    | v when v = nil -> acc
+    | Pair (v, seq) -> aux (v::acc) seq
+    | v -> [v]
+  in
+  aux [] s
 
 let normalize_string_latin1 i j s q = 
   if i = j then q else

runtime/value.mli

@@ -36,7 +36,11 @@ val vtrue : t
 val vfalse : t
 val vbool : bool -> t
 
+  (** @return a Record value from an associative list of fields *)
+val vrecord : (string * t) list -> t
+
 val sequence : t list -> t
+val explode_rev : t -> t list (* tail recursive *)
 val concat : t -> t -> t
 val flatten : t -> t
 
@@ -44,4 +48,9 @@ val get_string_latin1 : t -> string
 val get_string_utf8 : t -> U.t * t
 val is_str : t -> bool
 
+val get_int : t -> int
+
+  (** @return an associative list of fields from a Record value *)
+val get_fields : t -> (string * t) list
+
 val compare : t -> t -> int

schema/regtest/test.sh

@@ -6,11 +6,12 @@ LOG="$ROOT/regtest.log"
 if [ -f "$ROOT/$1.xsd" ]; then
    $VALIDATE $ROOT/$1.xsd $ROOT/$1.xml
 else
-   > $LOG
+   touch $LOG
    date | tee $LOG
    for f in $ROOT/*.xsd; do
-      echo -n "$(basename $f) ... " | tee -a $LOG
-      if ($VALIDATE $f $(echo "$f" | sed 's/xsd$/xml/') &> /dev/null); then
+      echo -n "`basename $f` ... " | tee -a $LOG
+      if ($VALIDATE $f `echo "$f" | sed 's/xsd$/xml/'` > /dev/null 2>&1); 
+then
          echo "OK" | tee -a $LOG
       else
          echo "FAILURE" | tee -a $LOG

schema/schema_validator.ml

@@ -4,7 +4,6 @@ let debug = false ;;
 open Printf ;;
 open Pxp_yacc ;;
 open Schema_types ;;
-open Schema_validator ;;
 
 exception Stop ;; (* internal *)
 

tests/build_types.ml

+
+  (* some experiments with hand construction of CDuce types *)
+
+let xml =
+  Types.xml'
+    (Types.atom (Atoms.atom (Atoms.mk_ascii "xml")))
+    Types.empty_closed_record
+    Types.Int.any
+;;
+let choice =
+  Types.choice_of_list [ Builtin_defs.bool; Builtin_defs.string; Builtin_defs.int ]
+;;
+let seq =
+  Sequence.seq_of_list [ Builtin_defs.bool; Builtin_defs.string; Builtin_defs.int ]
+;;
+let reco =  (* closed record with two fields *)
+  Types.rec_of_list ~opened:false ["foo", Builtin_defs.int; "bar", Builtin_defs.bool]
+;;
+let opt_reco =  (* closed record with two required and one optional fields *)
+  Types.rec_of_list' ~opened:false [
+    false, "foo", Builtin_defs.int;
+    false, "bar", Builtin_defs.bool;
+    true, "baz", Builtin_defs.string;
+  ]
+;;
+let concat =  (* TODO ... ask Alain: how to concatenate two star types? *)
+  let int_star = (Sequence.star Builtin_defs.bool) in
+  let bool_star = (Sequence.star Builtin_defs.int) in
+(*   Sequence.concat int_star bool_star *)
+  Sequence.flatten (Sequence.seq_of_list [ int_star; bool_star ])
+;;
+let rex =
+  let elem = Ast.Elem (Location.mknoloc (Ast.Internal xml)) in
+  let nil = Location.mknoloc (Ast.Internal Sequence.nil_type) in
+  let rex =
+    (Ast.Seq ((Ast.Seq (Ast.Star elem, elem)), (Ast.Seq (elem, Ast.Star elem))))
+  in
+  let ast_rex = Location.mknoloc (Ast.Regexp (rex, nil)) in
+  print_endline (Ast.string_of_regexp rex);
+  Types.descr (Typer.typ ast_rex)
+(*   Typer.typ' (Typer.real_compile (Typer.derecurs Typer.TypeEnv.empty ast_rex)) *)
+;;
+
+let string = Sequence.star Types.Char.any ;;
+Types.Print.print Format.std_formatter rex;
+Format.fprintf Format.std_formatter "\n"
+

tools/validate.ml

+
+(* XML Schema validator *)
+
+open Printf ;;
+open Pxp_document ;;
+open Schema_types ;;
+
+let die_usage () =
+  prerr_endline
+    "Usage:   validate <schema_document> [ <instance_document> ...  ]";
+  exit 1
+;;
+
+let schema_file = try Sys.argv.(1) with Invalid_argument _ -> die_usage () ;;
+
+let main () =
+  let schema_doc = Schema_xml.pxp_tree_of schema_file in
+  let schema = Schema_parser.parse_schema schema_doc in
+  for i = 2 to Array.length Sys.argv - 1 do
+    let instance_stream = Schema_xml