Commit 410fcd0c authored by Pietro Abate's avatar Pietro Abate
Browse files

Implementation of the Tallying problem

- revert a few chances I did before in the code
- add new unit tests functions for the Tallying problem
parent d3591e7e
......@@ -180,7 +180,9 @@ module Var (X : T) = struct
let compare t1 t2 =
match t1,t2 with
|`Atm x, `Atm y -> X.compare x y
|`Var x, `Var y -> String.compare x y
|`Var x, `Var y when x = y -> 0
(* HACK fix BoolVar.get to get variables in the correct order *)
|`Var x, `Var y -> if String.compare x y = -1 then 1 else -1
|`Var _, `Atm _ -> -1
|`Atm _, `Var _ -> 1
......
......@@ -3,9 +3,10 @@ open Ocamlbuild_plugin;;
Options.use_ocamlfind := true ;;
open Command ;;
(*
let _ = dispatch begin function
| After_rules ->
ocaml_lib ~extern:true ~dir:"_build" "typesOUnit"
| _ -> ()
end;;
*)
......@@ -40,12 +40,12 @@ and toplevel_directive =
| `Builtins
]
and pexpr =
| LocatedExpr of loc * pexpr
(* CDuce is a Lambda-calculus ... *)
| Var of U.t
(* this TVar must be moved to patt *)
| TVar of BoolVar.Vars.V.t
| Apply of pexpr * pexpr
| Abstraction of abstr
......@@ -80,7 +80,6 @@ and pexpr =
| Check of pexpr * ppat
| Ref of pexpr * ppat
(* CQL *)
| SelectFW of pexpr * (ppat * pexpr) list * pexpr list
......@@ -90,6 +89,14 @@ and abstr = {
fun_name : (Cduce_loc.loc * U.t) option;
fun_iface : (ppat * ppat) list;
fun_body : branches
(* add deco : (sigma) symbolic representation of set type substitutions *)
(* plus a flag that is true if interesection of the free varbialbes of S that are not intruduced
* by the lambda astractions are domain of sigma.
* if oldvar(S) ^ dom(sigma) = empty then s < t else s[eval(sigma, env)] < t
* (biginter_{sigma_i \in eval} s (sigma_i) ) < t
*
* see Evaluation, section 5.3 Article part 1
* *)
}
and branches = (ppat * pexpr) list
......
......@@ -62,7 +62,7 @@ let tuple_queue =
List.fold_right (fun x q -> Pair (x, q))
let char = mknoloc (Internal (Types.char (Types.BoolChars.atom (`Atm Chars.any))))
let char = mknoloc (Internal (Types.char Chars.any))
let string_regexp = Star (Elem char)
let seq_of_string s =
......@@ -298,7 +298,7 @@ EXTEND Gram
| e1 = expr; "&&"; e2 = expr -> exp _loc (logical_and e1 e2)
| e = expr; op = "/"; p = pat LEVEL "simple" ->
(* transform e with <(Atom)>[($$$::t|_)*] -> [$$$] *)
let tag = mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.any))))) in
let tag = mk _loc (Internal (Types.atom Atoms.any)) in
let att = mk _loc (Internal Types.Record.any) in
let any = mk _loc (Internal Types.any) in
let re = Star(Alt(SeqCapture(noloc,id_dummy,Elem p), Elem any)) in
......@@ -307,7 +307,7 @@ EXTEND Gram
exp _loc (Transform (e,[p, Var id_dummy]))
| e = expr; "/@"; a = ident_or_keyword ->
(* transform e with <(Atom) {a=$$$}>_ -> [$$$] *)
let tag = mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.any))))) in
let tag = mk _loc (Internal (Types.atom Atoms.any)) in
let any = mk _loc (Internal Types.any) in
let att = mk _loc (Record
(true, [(label a,
......@@ -330,7 +330,7 @@ EXTEND Gram
set_ref
(Var stk)
(concat (get_ref (Var stk)) (Pair (Var id_dummy,cst_nil))) in
let tag = mknoloc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.any))))) in
let tag = mknoloc (Internal (Types.atom Atoms.any)) in
let att = mknoloc (Internal Types.Record.any) in
let any = mknoloc (Internal Types.any) in
let re = (SeqCapture(noloc,y,Star(Elem(any)))) in
......@@ -403,7 +403,7 @@ EXTEND Gram
tag: [ [ a = ident_or_keyword -> exp _loc (Atom (ident a)) ] ];
tag_type: [
[ "_" -> mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.any)))))
[ "_" -> mk _loc (Internal (Types.atom Atoms.any))
| "$"; a = ident_or_keyword -> mk _loc (Cst (TVar a))
| a = ident_or_keyword -> mk _loc (Cst (Atom (ident a)))
| t = ANY_IN_NS -> mk _loc (NsT (ident t))
......@@ -569,13 +569,13 @@ EXTEND Gram
| i = STRING1; "--"; j = STRING1 ->
let i = Chars.V.mk_int (parse_char _loc i)
and j = Chars.V.mk_int (parse_char _loc j) in
Elem (mk _loc (Internal (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class i j))))))
Elem (mk _loc (Internal (Types.char (Chars.char_class i j))))
| s = STRING1 ->
List.fold_right
(fun c accu ->
let c = Chars.V.mk_int c in
let c = Chars.atom c in
Seq (Elem (mknoloc (Internal (Types.char (Types.BoolChars.atom (`Atm c))))), accu))
Seq (Elem (mknoloc (Internal (Types.char c))), accu))
(seq_of_string s)
Epsilon ]
| [ e = pat LEVEL "simple" -> Elem e
......@@ -619,20 +619,20 @@ EXTEND Gram
| i = INT ; "--"; j = INT ->
let i = Intervals.V.mk i
and j = Intervals.V.mk j in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.bounded i j)))))
mk _loc (Internal (Types.interval (Intervals.bounded i j)))
| i = INT ->
let i = Intervals.V.mk i in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.atom i)))))
mk _loc (Internal (Types.interval (Intervals.atom i)))
| "*"; "--"; j = INT ->
let j = Intervals.V.mk j in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.left j)))))
mk _loc (Internal (Types.interval (Intervals.left j)))
| i = INT; "--"; "*" ->
let i = Intervals.V.mk i in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.right i)))))
mk _loc (Internal (Types.interval (Intervals.right i)))
| i = char ->
mk _loc (Internal (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class i i)))))
mk _loc (Internal (Types.char (Chars.char_class i i)))
| i = char ; "--"; j = char ->
mk _loc (Internal (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class i j)))))
mk _loc (Internal (Types.char (Chars.char_class i j)))
| "`"; c = tag_type -> c
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod _loc l
| "["; r = [ r = regexp -> r | -> Epsilon ];
......@@ -657,9 +657,8 @@ EXTEND Gram
(fun c ->
mknoloc (Internal
(Types.char
(Types.BoolChars.atom (`Atm (
(Chars.atom
(Chars.V.mk_int c))))))))
(Chars.V.mk_int c)))))
(seq_of_string s) in
let s = s @ [mknoloc (Internal (Sequence.nil_type))] in
multi_prod _loc s
......
......@@ -480,7 +480,7 @@ let int_type (name,min,max) =
| None, None ->
Intervals.any
in
ignore (primitive name (Types.interval (Types.BoolIntervals.atom (`Atm ival))) (validate_interval ival name))
ignore (primitive name (Types.interval ival) (validate_interval ival name))
let () =
List.iter int_type [
......
......@@ -192,7 +192,7 @@ let simple_union name members =
let xsi_nil_atom = Atoms.V.mk (Schema_xml.xsi, Utf8.mk "nil")
let xsi_nil_type = Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom xsi_nil_atom)))
let xsi_nil_type = Types.atom (Atoms.atom xsi_nil_atom)
let xsi_nil_label = Ns.Label.mk (Schema_xml.xsi, Utf8.mk "nil")
let merge_attribute_uses l =
......
open OUnit
(* open Types *)
let parse_typ s =
let st = Stream.of_string s in
let astpat = Parser.pat st in
let nodepat = Typer.typ Builtin.env astpat in
Types.descr nodepat
;;
let norm_tests = [
"Int \\ (`$A | `$B)", [[(false,`Var "A",parse_typ "Int \\ `$B")]];
]
let test_norm =
"test tallying norm" >:::
List.map (fun (t,expected) ->
(Printf.sprintf " %s " t) >:: (fun _ ->
let ll = Types.Tallying.norm (parse_typ t) in
assert_equal ll expected
)
) norm_tests
;;
let all =
"all tests" >::: [
test_norm;
]
let main () =
OUnit.run_test_tt_main all
;;
main ()
......@@ -42,6 +42,8 @@ sig
val cap : t -> t -> t
val diff : t -> t -> t
val atom : elem -> t
(* vars a : return a bdd that is ( Any ^ Var a ) *)
val vars : Custom.var -> t
val iter: (elem-> unit) -> t -> unit
......@@ -196,7 +198,7 @@ struct
* of positive and negative elements on a branch *)
let get x =
let rec aux accu pos neg = function
| `True -> (pos,neg) :: accu
| `True -> (List.rev pos, List.rev neg) :: accu
| `False -> accu
| `Split (_,x, p,i,n) ->
(*OPT: can avoid creating this list cell when pos or neg =`False *)
......
......@@ -13,7 +13,7 @@ let types =
"Empty", Types.empty;
"Any", any;
"Int", int;
"Char", Types.char (Types.BoolChars.atom (`Atm ( Chars.any )));
"Char", Types.char Chars.any;
"Byte", char_latin1;
"Atom", atom;
"Pair", Types.Product.any;
......@@ -167,7 +167,7 @@ binary_op_cst ">"
(* I/O *)
register_fun "char_of_int"
int (Types.char (Types.BoolChars.atom (`Atm ( Chars.any ) )))
int (Types.char Chars.any)
(function
| Value.Integer x ->
(try Value.Char (Chars.V.mk_int (Intervals.V.get_int x))
......@@ -175,7 +175,7 @@ register_fun "char_of_int"
| _ -> assert false);;
register_fun "int_of_char"
(Types.char (Types.BoolChars.atom (`Atm ( Chars.any) ))) int
(Types.char Chars.any) int
(function
| Value.Char x ->
Value.Integer (Intervals.V.from_int (Chars.V.to_int x))
......@@ -342,7 +342,7 @@ binary_op_cst "dump_to_file_utf8"
let intop f x y =
let s = Types.BoolIntervals.leafconj x in
let t = Types.BoolIntervals.leafconj y in
Types.BoolIntervals.atom (`Atm (f s t))
(f s t)
;;
binary_op_gen "+"
......
open Encodings
let pos_int = Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.right (Intervals.V.mk "1"))))
let non_neg_int = Types.interval (Types.BoolIntervals.atom (`Atm(Intervals.right (Intervals.V.mk "0"))))
let neg_int = Types.interval (Types.BoolIntervals.atom (`Atm(Intervals.left (Intervals.V.mk "-1"))))
let non_pos_int = Types.interval (Types.BoolIntervals.atom (`Atm(Intervals.left (Intervals.V.mk "0"))))
let pos_int = Types.interval (Intervals.right (Intervals.V.mk "1"))
let non_neg_int = Types.interval (Intervals.right (Intervals.V.mk "0"))
let neg_int = Types.interval (Intervals.left (Intervals.V.mk "-1"))
let non_pos_int = Types.interval (Intervals.left (Intervals.V.mk "0"))
let mk_interval_type l r =
Types.interval (Types.BoolIntervals.atom (`Atm(Intervals.bounded (Intervals.V.mk l) (Intervals.V.mk r))))
Types.interval (Intervals.bounded (Intervals.V.mk l) (Intervals.V.mk r))
let long_int = mk_interval_type "-9223372036854775808" "9223372036854775807"
let int_int = mk_interval_type "-2147483648" "2147483647"
let short_int = mk_interval_type "-32768" "32767"
......@@ -17,58 +17,58 @@ let byte_int = mk_interval_type "0" "255"
let non_zero_int = Types.cup pos_int neg_int
let decimal_intstr =
Sequence.plus (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
Sequence.plus (Types.char (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '9')
)
)))
)
let octal_intstr =
Sequence.plus (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
Sequence.plus (Types.char (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '7')
)
)))
)
let binary_intstr =
Sequence.plus (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
Sequence.plus (Types.char (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '1')
)
)))
)
let hex_intstr =
Sequence.plus (
Types.cup
(Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
(Types.char (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '9')
)
)))
)
(Types.cup
(Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
(Types.char (Chars.char_class
(Chars.V.mk_char 'a')
(Chars.V.mk_char 'f')
)
)))
(Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
)
(Types.char (Chars.char_class
(Chars.V.mk_char 'A')
(Chars.V.mk_char 'F')
)
)))
)
)
)
let hex_str =
Types.times
(Types.cons (Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '0'))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char 'X')))))
(Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char 'x')))))
(Types.char (Chars.atom (Chars.V.mk_char 'X')))
(Types.char (Chars.atom (Chars.V.mk_char 'x')))
)
)
(Types.cons hex_intstr)
......@@ -77,13 +77,13 @@ let hex_str =
let oct_str =
Types.times
(Types.cons (Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '0'))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char 'O')))))
(Types.char (Types.BoolChars.atom (`Atm(Chars.atom (Chars.V.mk_char 'o')))))
(Types.char (Chars.atom (Chars.V.mk_char 'O')))
(Types.char (Chars.atom (Chars.V.mk_char 'o')))
)
)
(Types.cons octal_intstr)
......@@ -93,13 +93,13 @@ let oct_str =
let bin_str =
Types.times
(Types.cons (Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '0'))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char 'B')))))
(Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char 'b')))))
(Types.char (Chars.atom (Chars.V.mk_char 'B')))
(Types.char (Chars.atom (Chars.V.mk_char 'b')))
)
)
(Types.cons binary_intstr)
......@@ -111,7 +111,7 @@ let pos_intstr =
let neg_intstr =
Types.times
(Types.cons (Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char '-'))))))
(Types.cons (Types.char (Chars.atom (Chars.V.mk_char '-'))))
(Types.cons pos_intstr)
let intstr = Types.cup pos_intstr neg_intstr (* [ '-'? '0'--'9'+ ] *)
......@@ -119,8 +119,8 @@ let intstr = Types.cup pos_intstr neg_intstr (* [ '-'? '0'--'9'+ ] *)
let true_atom = Atoms.V.mk_ascii "true"
let false_atom = Atoms.V.mk_ascii "false"
let true_type = Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom true_atom)))
let false_type = Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom false_atom)))
let true_type = Types.atom (Atoms.atom true_atom)
let false_type = Types.atom (Atoms.atom false_atom)
let bool = Types.cup true_type false_type
let nil = Sequence.nil_type
......@@ -128,15 +128,15 @@ let string = Sequence.string
let char = Types.Char.any
let any = Types.any
let int = Types.Int.any
let atom = Types.atom (Types.BoolAtoms.atom (`Atm Atoms.any))
let atom = Types.atom Atoms.any
let char_latin1 = Types.char (Types.BoolChars.atom (`Atm (Chars.mk_classes [ (0,255) ])))
let char_latin1 = Types.char (Chars.mk_classes [ (0,255) ])
let string_latin1 = Sequence.star char_latin1
let time_kind =
List.fold_left (fun acc t -> Types.cup acc t) Types.empty
(List.map
(fun s -> Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom (Atoms.V.mk_ascii s)))))
(fun s -> Types.atom (Atoms.atom (Atoms.V.mk_ascii s)))
[ "duration"; "dateTime"; "time"; "date"; "gYearMonth"; "gYear";
"gMonthDay"; "gDay"; "gMonth" ])
......
......@@ -44,5 +44,5 @@ val float_abs: Types.Abstract.abs
val any_xml : Types.t
val any_xml_with_tag: Types.BoolAtoms.t -> Types.t
val any_xml_with_tag: Atoms.t -> Types.t
......@@ -6,7 +6,7 @@ exception Error of error
let nil_atom = Atoms.V.mk_ascii "nil"
let nil_type = Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom nil_atom)))
let nil_type = Types.atom (Atoms.atom nil_atom)
let nil_node = Types.cons nil_type
let nil_cst = Types.Atom nil_atom
......@@ -225,7 +225,7 @@ let seq_of_list l =
List.fold_right times' l nil_type
let char_latin1 = Types.char (Types.BoolChars.atom (`Atm (Chars.mk_classes [ (0,255) ])))
let char_latin1 = Types.char (Chars.mk_classes [ (0,255) ])
let string_latin1 = star char_latin1
......
......@@ -354,22 +354,22 @@ let record label t =
record = BoolRec.atom (`Atm (Rec.atom (true,LabelMap.singleton label t))) }
let record_fields x =
{ empty with record = BoolRec.atom (`Atm (Rec.atom x)) }
let atom a = { empty with atoms = a }
let atom a = { empty with atoms = BoolAtoms.atom (`Atm a) }
let vars a = {
(* Atm = Any ^ a *)
times = BoolPair.vars a;
xml = BoolPair.vars a;
arrow = BoolPair.vars a;
record= BoolRec.vars a;
ints = BoolIntervals.vars a;
atoms = BoolAtoms.vars a;
chars = BoolChars.vars a;
times = BoolPair.vars (`Var a);
xml = BoolPair.vars (`Var a);
arrow = BoolPair.vars (`Var a);
record= BoolRec.vars (`Var a);
ints = BoolIntervals.vars (`Var a);
atoms = BoolAtoms.vars (`Var a);
chars = BoolChars.vars (`Var a);
abstract = Abstract.any;
absent= false;
}
let char c = { empty with chars = c }
let interval i = { empty with ints = i }
let char c = { empty with chars = BoolChars.atom (`Atm c) }
let interval i = { empty with ints = BoolIntervals.atom (`Atm i) }
let abstract a = { empty with abstract = a }
let get_abstract t = t.abstract
......@@ -443,10 +443,10 @@ let internalize n = n
let id n = n.Node.id
let rec constant = function
| Integer i -> interval (BoolIntervals.atom (`Atm (Intervals.atom i)))
| Atom a -> atom (BoolAtoms.atom (`Atm (Atoms.atom a)))
| Var a -> vars (`Var a)
| Char c -> char (BoolChars.atom (`Atm (Chars.atom c)))
| Integer i -> interval (Intervals.atom i)
| Atom a -> atom (Atoms.atom a)
| Char c -> char (Chars.atom c)
| Var a -> vars a
| Pair (x,y) -> times (const_node x) (const_node y)
| Xml (x,y) -> xml (const_node x) (const_node y)
| Record x -> record_fields (false ,LabelMap.map const_node x)
......@@ -1000,31 +1000,30 @@ struct
let normal_aux = function
| ([] | [ _ ]) as d -> d
| d ->
let res = ref [] in
let add (t1,t2) =
let rec loop t1 t2 = function
| [] -> res := (ref (t1,t2)) :: !res
| ({contents = (d1,d2)} as r)::l ->
(*OPT*)
(* if equal_descr d1 t1 then r := (d1,cup d2 t2) else*)
let i = cap t1 d1 in
if is_empty i then loop t1 t2 l
else (
r := (i, cup t2 d2);
let k = diff d1 t1 in
if non_empty k then res := (ref (k,d2)) :: !res;
let j = diff t1 d1 in
if non_empty j then loop j t2 l
)
let res = ref [] in
let add (t1,t2) =
let rec loop t1 t2 = function
| [] -> res := (ref (t1,t2)) :: !res
| ({contents = (d1,d2)} as r)::l ->
(*OPT*)
(* if equal_descr d1 t1 then r := (d1,cup d2 t2) else*)
let i = cap t1 d1 in
if is_empty i then loop t1 t2 l
else (
r := (i, cup t2 d2);
let k = diff d1 t1 in
if non_empty k then res := (ref (k,d2)) :: !res;
let j = diff t1 d1 in
if non_empty j then loop j t2 l
)
in
loop t1 t2 !res
in
loop t1 t2 !res
in
List.iter add d;
List.map (!) !res
List.iter add d;
List.map (!) !res
(* Partitioning:
......@@ -1065,6 +1064,11 @@ struct
| `Normal -> get_aux any d.times
| `XML -> get_aux any_pair d.xml
let getpair ?(kind=`Normal) d =
match kind with
| `Normal -> d.times
| `XML -> d.xml
let pi1 = List.fold_left (fun acc (t1,_) -> cup acc t1) empty
let pi2 = List.fold_left (fun acc (_,t2) -> cup acc t2) empty
let pi2_restricted restr =
......@@ -1128,7 +1132,6 @@ struct
any
n