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

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

Original author: cvscast
Date: 2003-06-12 13:16:00+00:00
parent 2da3d5a2
Makefile.conf
cduce
cduce.opt
dtd2cduce
webiface.opt
webiface
validate
evaluator
cdo2ml
mlcduce_wrapper
*.cmi
*.cmo
*.cmx
*.cma
*.cmxa
META
configure.log
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/*~
......
......@@ -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
......
......@@ -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
......
......@@ -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 $
#
###########################################################################
......
......@@ -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
......
......@@ -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.
......
......@@ -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 */
......
......@@ -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
*)
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
......
......@@ -100,7 +100,7 @@ rule token = parse
| [ "<>=.,:;+-*/@&{}[]()|?`!" ]
| "->" | "::" | ";;" | "--" | ":=" | "\\" | "++"
| "{|" | "|}" | "<=" | ">=" | "<<" | ">>"
| ["?+*"] "?"
| ["?+*"] "?" | "#"
{ "",Lexing.lexeme lexbuf }
| "#" lowercase+ { "DIRECTIVE",Lexing.lexeme lexbuf }
| '"' | "'"
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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
......
......@@ -4,7 +4,6 @@ let debug = false ;;
open Printf ;;
open Pxp_yacc ;;
open Schema_types ;;
open Schema_validator ;;
exception Stop ;; (* internal *)
......
(* 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"
(* XML Schema validator *)