Skip to content

GitLab

Commit 573433e9 authored by Julien Lopez's avatar Julien Lopez
Browse files

[TESTS][TYPED] Add working suite; dummy sigmas added in files when needed

parent 0d03c12f
Hide whitespace changes
Inline Side-by-side
compile/operators.ml
View file @ 573433e9
......@@ -46,7 +46,7 @@ let register_cst op t v =
let register_fun op dom codom eval =
register_cst op
(Types.arrow (Types.cons dom) (Types.cons codom))
(Value.Abstraction (Some [(dom,codom)],eval))
(Value.Abstraction (Some [(dom,codom)],eval, `List([[]])))
let register_fun2 op dom1 dom2 codom eval =
let t2 = Types.arrow (Types.cons dom2) (Types.cons codom) in
......@@ -55,7 +55,7 @@ let register_fun2 op dom1 dom2 codom eval =
(Types.arrow (Types.cons dom1) (Types.cons t2))
(Value.Abstraction (Some [(dom1,t2)],(fun v1 ->
Value.Abstraction (iface2,
eval v1))))
eval v1, `List([[]]))), `List([[]])))
let register_op op ?(expect=Types.any) typ eval =
register_unary op
(fun tf _ _ -> let t = tf expect true in typ t)
......
runtime/load_xml.ml
View file @ 573433e9
......@@ -48,9 +48,9 @@ let attrib att =
let elem ns tag att child =
if !keep_ns then
XmlNs (Atom tag, Record (attrib att), child, ns)
XmlNs (Atom tag, Record (attrib att, `List([[]])), child, ns, `List([[]]))
else
Xml (Atom tag, Record (attrib att), child)
Xml (Atom tag, Record (attrib att, `List([[]])), child, `List([[]]))
type stack =
| Element of Value.t * stack
......@@ -64,7 +64,7 @@ let ns_table = ref Ns.empty_table
let rec create_elt accu = function
| String (s,st) -> create_elt (string s accu) st
| Element (x,st) -> create_elt (Pair (x,accu)) st
| Element (x,st) -> create_elt (Pair (x,accu, `List([[]]))) st
| Start (ns,name,att,old_table,st) ->
stack := Element (elem ns name att accu, st);
ns_table := old_table
......@@ -132,7 +132,7 @@ let load_html s =
| Nethtml.Element (tag, att, child) ->
let att = List.map (fun (n,v) -> (Label.mk (Ns.empty, U.mk n), U.mk v)) att in
Pair (elem Ns.empty_table (Atoms.V.mk (Ns.empty,U.mk tag) )
att (val_of_docs child), q)
att (val_of_docs child), q, `List([[]]))
and val_of_docs = function
| [] -> nil
| h::t -> val_of_doc (val_of_docs t) h
......
runtime/print_xml.ml
View file @ 573433e9
......@@ -59,7 +59,7 @@ module H = Hashtbl.Make(Ns.Uri)
let exn_print_xml = CDuceExn (Pair (
Atom (Atoms.V.mk_ascii "Invalid_argument"),
string_latin1 "print_xml"))
string_latin1 "print_xml", `List([[]])))
let blank = U.mk " "
let true_literal = U.mk "true"
......@@ -87,9 +87,9 @@ let rec schema_value ?(recurs=true) ~wds ~wcs v = match v with
and schema_values ~wds ~wcs v =
match v with
| Pair (hd, Atom a) when a = Sequence.nil_atom ->
| Pair (hd, Atom a, _) when a = Sequence.nil_atom ->
schema_value ~recurs:false ~wds ~wcs hd
| Pair (hd, tl) ->
| Pair (hd, tl, _) ->
schema_value ~recurs:false ~wds ~wcs hd;
wds blank;
schema_values ~wds ~wcs tl
......@@ -133,8 +133,8 @@ let to_buf ~utf8 buffer ns_table v subst =
in
let rec register_elt = function
| Xml (Atom q, Record attrs, content)
| XmlNs (Atom q, Record attrs, content, _) ->
| Xml (Atom q, Record (attrs, _), content, _)
| XmlNs (Atom q, Record (attrs, _), content, _, _) ->
Imap.iter
(fun n _ -> Ns.Printer.register_qname printer
(Label.value (Label.from_int n)))
......@@ -145,15 +145,15 @@ let to_buf ~utf8 buffer ns_table v subst =
and register_content = function
| String_utf8 (_,_,_,q)
| String_latin1 (_,_,_,q) -> register_content q
| Pair (x, q) -> register_elt x; register_content q
| Pair (x, q, _) -> register_elt x; register_content q
| Concat (x,y) -> register_content x; register_content y
| _ -> ()
in
register_elt v;
let rec print_elt xmlns = function
| Xml (Atom tag, Record attrs, content)
| XmlNs (Atom tag, Record attrs, content, _) ->
| Xml (Atom tag, Record (attrs, _), content, _)
| XmlNs (Atom tag, Record (attrs, _), content, _, _) ->
let attrs = Imap.map_elements
(fun n v ->
if is_str v then begin
......@@ -180,7 +180,7 @@ let to_buf ~utf8 buffer ns_table v subst =
let (s,q) = get_string_utf8 v in
wds s;
match q with
| Pair ((Xml _ | XmlNs _) as x, q) -> print_elt [] x; print_content q
| Pair ((Xml _ | XmlNs _) as x, q, _) -> print_elt [] x; print_content q
| Atom a when a = Sequence.nil_atom -> ()
| v -> schema_value ~wds ~wcs v
in
......
tests/lambda/src/compute.ml
View file @ 573433e9
......@@ -194,6 +194,7 @@ and parse_match_value env l list p toptype = match p with
let d1 = any, list, Patterns.Capture(lsize, mname) in
let t2 = type_of_ptype mtype in
let d2 = t2, [], Patterns.Constr(t2) in
Printf.eprintf "mtype:%s, toptype:%s\n" string
t2, Patterns.Cap(d1, d2), list, l, Types.subtype t2 (type_of_ptype toptype)
| MInt (_, i) ->
let t = constant (Integer(big_int_of_int i)) in
......
tests/typed/Makefile 0 → 100644
View file @ 573433e9
COMPILER ?= ocamlbuild
ROOTDIR ?= ../..
SRCDIR ?= src
EXTDIR ?= $(SRCDIR)/externals
INEXTFILES = misc/custom.ml misc/encodings.ml misc/upool.ml misc/ns.ml\
types/sortedList.ml types/ident.ml misc/html.ml types/sequence.ml\
types/patterns.ml parser/cduce_loc.mli parser/cduce_loc.ml typing/typed.ml\
types/builtin_defs.ml parser/ast.ml parser/ulexer.ml parser/parser.mli\
parser/parser.ml typing/typepat.mli typing/typepat.ml\
types/externals.mli types/externals.ml typing/typer.ml\
runtime/run_dispatch.ml runtime/explain.ml schema/schema_pcre.ml\
schema/schema_xml.mli schema/schema_xml.ml schema/schema_common.mli\
schema/schema_common.ml runtime/eval.mli runtime/eval.ml\
compile/compile.ml types/compunit.mli types/compunit.ml types/var.ml\
types/boolVar.ml misc/imap.ml types/atoms.ml types/intervals.ml\
types/chars.mli types/chars.ml misc/bool.mli misc/bool.ml types/types.mli\
misc/stats.mli misc/stats.ml types/normal.mli types/normal.ml misc/pretty.mli\
misc/pretty.ml types/types.ml compile/auto_pat.mli runtime/value.mli\
runtime/value.ml schema/schema_types.mli schema/schema_validator.mli\
schema/schema_builtin.mli schema/schema_builtin.ml schema/schema_validator.ml\
compile/lambda.ml compile/operators.ml parser/url.ml runtime/load_xml.mli\
runtime/load_xml.ml runtime/print_xml.ml types/builtin.mli types/builtin.ml
EXTFILES = $(INEXTFILES:%=$(ROOTDIR)/%)
RM ?= rm -f
OUT ?= main.native
OUTDEBUG ?= main.byte
.PHONY: clean check test _import
all: _import
$(COMPILER) -use-ocamlfind $(OUT)
debug: _import
$(COMPILER) -use-ocamlfind -tag debug $(OUTDEBUG)
_import:
@echo -n "Copying external files..."
@test -d $(EXTDIR) || mkdir $(EXTDIR)
@cp $(EXTFILES) $(EXTDIR)
@echo "done"
clean:
$(COMPILER) -clean
test $(EXTDIR) = "src" || test $(EXTDIR) = "." || $(RM) -r $(EXTDIR)
tests/typed/_tags 0 → 100644
View file @ 573433e9
<src>: include
<src/main*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str, oUnit, pcre, ulex, num, netstring)
<src/externals>: include
<src/externals/parse*>: package(ulex), package(netstring), syntax(camlp4o)
<src/externals/url*>: package(ulex), package(netstring), syntax(camlp4o)
<src/externals/load_xml*>: package(ulex), package(netstring), syntax(camlp4o)
<src/externals/print_xml*>: package(ulex), package(netstring), syntax(camlp4o)
<src/externals/schema_*>: package(pcre, netcgi2)
<src/externals/ulexer*>: package(ulex), package(netstring), syntax(camlp4o)
<src/externals/cduce_loc*>: package(ulex), syntax(camlp4o)
tests/typed/src/main.ml 0 → 100644
View file @ 573433e9
open OUnit2
let rec typed_to_string e = "{typ:" ^ (Types.Print.to_string e.Typed.exp_typ)
^ "; descr=" ^ (match e.Typed.exp_descr with
| Typed.Forget(e, _) -> "Forget(" ^ typed_to_string e ^ ")"
| Typed.Check(_, e, _) -> "Check(" ^ typed_to_string e ^ ")"
| Typed.Var(id, name) -> "Var(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ ")"
| Typed.ExtVar(_, (id, name), _) -> "ExtVar("
^ (string_of_int (Upool.int id)) ^ ", " ^ (Encodings.Utf8.to_string name)
^ ")"
| Typed.Apply(e1, e2) -> "(" ^ typed_to_string e1 ^ ").("
^ (typed_to_string e2) ^ ")"
| Typed.Abstraction(abstr) -> "Abstraction(" ^ (abst abstr) ^ ")"
| Typed.Cst(cst) -> const cst
| Typed.Pair(e1, e2) -> "(" ^ (typed_to_string e1) ^ ", "
^ (typed_to_string e2) ^ ")"
| Typed.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
| Typed.Match(e, b) -> "Match(" ^ (typed_to_string e) ^ "," ^ (branches b)
^ ")"
| _ -> assert false) ^ "}"
and const cst = match cst with
| Types.Integer(i) -> "Integer(" ^ (Intervals.V.to_string i) ^ ")"
| Types.Atom(a) -> "Atom(" ^ (Atoms.V.to_string a) ^ ")"
| Types.Char(c) -> "Char(" ^ (string_of_int (Chars.V.to_int c)) ^ ")"
| Types.Pair(c1, c2) -> "(" ^ const c1 ^ ", " ^ const c2 ^ ")"
| Types.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
| _ -> assert false
and abst abstr = (match abstr.Typed.fun_name with
| Some (id, name) -> "name:(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ ")"
| None -> "name:<none>") ^ ",\niface:[" ^ (iface abstr.Typed.fun_iface)
^ "],\nbody:[" ^ (branches abstr.Typed.fun_body) ^ "], "
^ "typ:" ^ (Types.Print.to_string abstr.Typed.fun_typ) ^ ", fv:["
^ (fv_to_string abstr.Typed.fun_fv) ^ "]"
and iface list = match list with
| (t1, t2) :: [] -> "(" ^ (Types.Print.to_string t1) ^ ", "
^ (Types.Print.to_string t2) ^ ")"
| (t1, t2) :: rest -> "(" ^ (Types.Print.to_string t1) ^ ", "
^ (Types.Print.to_string t2) ^ "),"
| [] -> ""
and branches brs = "typ:" ^ (Types.Print.to_string brs.Typed.br_typ)
^ ", accept:" ^ (Types.Print.to_string brs.Typed.br_accept) ^ ", branches:"
^ (branch brs.Typed.br_branches)
and branch brs = match brs with
| br :: [] -> "\n{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
^ (string_of_bool br.Typed.br_ghost) ^ "; br_vars_empty:["
^ (fv_to_string br.Typed.br_vars_empty) ^ "];\npat:{"
^ (node br.Typed.br_pat) ^ "};\nbody:{typ:"
^ (Types.Print.to_string br.Typed.br_body.Typed.exp_typ) ^ ", descr:"
^ (typed_to_string br.Typed.br_body) ^ "}}"
| br :: rest -> "\n{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
^ (string_of_bool br.Typed.br_ghost) ^ "; br_vars_empty:["
^ (fv_to_string br.Typed.br_vars_empty) ^ "];\npat:{"
^ (node br.Typed.br_pat) ^ "};\nbody:{typ:"
^ (Types.Print.to_string br.Typed.br_body.Typed.exp_typ) ^ ", descr:"
^ (typed_to_string br.Typed.br_body) ^ "}}," ^ (branch rest)
| [] -> ""
and node node = "id:" ^ (string_of_int node.Patterns.id) ^ "; descr:["
^ (descr node.Patterns.descr) ^ "]; accept:[id:"
^ (string_of_int (Types.id node.Patterns.accept)) ^ "; descr:"
^ (Types.Print.to_string (Types.descr node.Patterns.accept)) ^ "]; fv:["
^ (fv_to_string node.Patterns.fv) ^ "]"
and descr (t, fv, d) = (Types.Print.to_string t)
^ "; [" ^ (fv_to_string fv) ^ "]; " ^ descr2 d
and descr2 d = match d with
| Patterns.Constr(t) -> "Constr(" ^ (Types.Print.to_string t) ^ ")"
| Patterns.Cup(d1, d2) -> "Cup([" ^ (descr d1) ^ "], [" ^ (descr d2) ^ "])"
| Patterns.Cap(d1, d2) -> "Cap([" ^ (descr d1) ^ "], [" ^ (descr d2) ^ "])"
| Patterns.Times(n1, n2) -> "Times({" ^ (node n1) ^ "}, {" ^ (node n2) ^ "})"
| Patterns.Xml(n1, n2) -> "Xml({" ^ (node n1) ^ "}, {" ^ (node n2) ^ "})"
| Patterns.Record(l, n) -> "Record(" ^ (Ns.Label.string_of_tag l) ^ ", {"
^ (node n) ^ "})"
| Patterns.Capture((id, name)) -> "Capture(" ^ (string_of_int (Upool.int id))
^ ", " ^ (Encodings.Utf8.to_string name) ^ ")"
| Patterns.Constant((id, name), ct) -> "Constant(("
^ (string_of_int (Upool.int id)) ^ ", " ^ (Encodings.Utf8.to_string name)
^ "), " ^ const ct ^ ")"
| Patterns.Dummy -> "Dummy"
and fv_to_string fv = match fv with
| (id, name) :: [] -> "(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ ")"
| (id, name) :: rest -> "(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ "), " ^ (fv_to_string rest)
| [] -> ""
let run_test str =
try
let st = Stream.of_string str in
let astpat = Parser.expr st in
let nodepat = Typer.expr Builtin.env astpat in
typed_to_string nodepat
with e -> Printf.eprintf "Exception caught\n"; raise e
let tests = "CDuce runtime tests" >:::
[
"abstr" >:: ( fun test_ctxt ->
assert_equal ~msg:"Test CDuce.typed.abstr.identity failed"
~printer:(fun x -> x) ""
(run_test "(fun (Int -> Int) | x -> x)2");
);
]
let _ = run_test_tt_main tests
types/builtin.ml
View file @ 573433e9
......@@ -85,42 +85,42 @@ let exn_load_file_utf8 = lazy (
Value.CDuceExn (
Value.Pair (
Value.Atom (Atoms.V.mk_ascii "load_file_utf8"),
Value.string_latin1 "File is not a valid UTF-8 stream"))
Value.string_latin1 "File is not a valid UTF-8 stream", `List([[]])))
)
let exn_int_of = lazy (
Value.CDuceExn (
Value.Pair (
Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
Value.string_latin1 "int_of"))
Value.string_latin1 "int_of", `List([[]])))
)
let exn_char_of = lazy (
Value.CDuceExn (
Value.Pair (
Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
Value.string_latin1 "char_of"))
Value.string_latin1 "char_of", `List([[]])))
)
let exn_float_of = lazy (
Value.CDuceExn (
Value.Pair (
Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
Value.string_latin1 "float_of"))
Value.string_latin1 "float_of", `List([[]])))
)
let exn_namespaces = lazy (
Value.CDuceExn (
Value.Pair (
Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
Value.string_latin1 "namespaces"))
Value.string_latin1 "namespaces", `List([[]])))
)
let exn_cdata_of = lazy (
Value.CDuceExn (
Value.Pair (
Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
Value.string_latin1 "cdata_of"))
Value.string_latin1 "cdata_of", `List([[]])))
)
let eval_load_file ~utf8 e =
......@@ -301,7 +301,7 @@ register_fun "split_atom"
let (ns,l) = Atoms.V.value q in
Value.Pair(
Value.string_utf8 (Ns.Uri.value ns),
Value.string_utf8 l)
Value.string_utf8 l, `List([[]]))
| _ -> assert false);;
register_fun "make_atom"
......@@ -421,12 +421,12 @@ register_fun "raise" any Types.empty
register_fun "namespaces" any_xml
namespaces
(function
Value.XmlNs (_,_,_,ns) ->
Value.XmlNs (_,_,_,ns,s) ->
Value.sequence_rev
(List.map
(fun (pr,ns) ->
Value.Pair (Value.string_utf8 pr,
Value.string_utf8 (Ns.Uri.value ns)))
Value.string_utf8 (Ns.Uri.value ns), s))
(Ns.get_table ns))
| Value.Xml _ -> raise (Lazy.force exn_namespaces)
| _ -> assert false);;
......@@ -434,14 +434,14 @@ register_fun "namespaces" any_xml
register_fun2 "set_namespaces"
namespaces any_xml any_xml
(fun ns -> function
| Value.XmlNs(v1,v2,v3,_) | Value.Xml (v1,v2,v3) ->
| Value.XmlNs(v1,v2,v3,_,s) | Value.Xml (v1,v2,v3,s) ->
let ns = Value.get_sequence_rev ns in
let ns = List.map (fun v ->
let (pr,ns) = Value.get_pair v in
let pr,_ = Value.get_string_utf8 pr in
let ns,_ = Value.get_string_utf8 ns in
(pr,Ns.Uri.mk ns)) ns in
Value.XmlNs(v1,v2,v3,Ns.mk_table ns)
Value.XmlNs(v1,v2,v3,Ns.mk_table ns, s)
| _ -> assert false);;
(* Float *)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment