Skip to content

GitLab

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

Adapt Types.Descr.t to use the new BDD base data structure

parent 1c1ca633
Expand all Hide whitespace changes
Inline Side-by-side
_tags
View file @ a2da41f0
......@@ -8,8 +8,8 @@ true: -traverse
<compile>: include
<schema>: include
<runtime>: include
#<{misc,types,typing,schema,compile,runtime}/*.cmx>: for-pack(Cduce_test)
<{misc,types}/*.cmx>: for-pack(Cduce_test)
<{misc,types,typing,schema,compile,runtime}/*.cmx>: for-pack(Cduce_test)
#<{misc,types}/*.cmx>: for-pack(Cduce_test)
<{misc,types}/*.cmx>: for-pack(Cduce_boolvar)
<parser/**>: package(ulex), package(netstring), syntax(camlp4o)
......
cduce_boolvar.mlpack
View file @ a2da41f0
......@@ -17,4 +17,3 @@ Normal
Pretty
Stats
BoolVar
Types
cduce_test.mlpack
View file @ a2da41f0
......@@ -10,6 +10,7 @@ SortedList
Atoms
Bool
Chars
BoolVar
Ident
Intervals
Inttbl
......@@ -23,7 +24,6 @@ Parser
Builtin_defs
Cduce_loc
Sequence
Sample
Patterns
Lambda
Value
......
misc/custom.ml
View file @ a2da41f0
......@@ -170,21 +170,22 @@ module Sum(X : T)(Y : T) = struct
| Right t -> Format.fprintf ppf "R%a" Y.dump t
end
type 'a pairvar = Atm of 'a | Var of String.t
type var = [ `Var of String.t ]
type 'a pairvar = [ `Atm of 'a | var ]
module Var (X : T) = struct
type t = X.t pairvar
let hash = function Atm t -> X.hash t | Var s -> String.hash s
let check = function Atm t -> X.check t | Var _ -> ()
let hash = function `Atm t -> X.hash t | `Var s -> (* String.hash s *) Hashtbl.hash (`Var s)
let check = function `Atm t -> X.check t | `Var _ -> ()
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 _, Atm _ -> -1
|Atm _, Var _ -> 1
|`Atm x, `Atm y -> X.compare x y
|`Var x, `Var y -> String.compare x y
|`Var _, `Atm _ -> -1
|`Atm _, `Var _ -> 1
let equal t1 t2 = (compare t1 t2) = 0
let dump ppf = function
|Atm x -> X.dump ppf x
|Var x -> String.dump ppf x
|`Atm x -> X.dump ppf x
|`Var x -> String.dump ppf x
end
parser/ast.ml
View file @ a2da41f0
......@@ -46,7 +46,7 @@ and pexpr =
(* CDuce is a Lambda-calculus ... *)
| Var of U.t
| TVar of Types.Vars.V.t
| TVar of BoolVar.Vars.V.t
| Apply of pexpr * pexpr
| Abstraction of abstr
......
parser/parser.ml
View file @ a2da41f0
......@@ -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 (Custom.Atm Chars.any))))
let char = mknoloc (Internal (Types.char (Types.BoolChars.atom (`Atm 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 (Custom.Atm (Atoms.any))))) in
let tag = mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (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 (Custom.Atm (Atoms.any))))) in
let tag = mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (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 (Custom.Atm (Atoms.any))))) in
let tag = mknoloc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (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 (Custom.Atm (Atoms.any)))))
[ "_" -> mk _loc (Internal (Types.atom (Types.BoolAtoms.atom (`Atm (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 (Custom.Atm (Chars.char_class i j))))))
Elem (mk _loc (Internal (Types.char (Types.BoolChars.atom (`Atm (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 (Custom.Atm c))))), accu))
Seq (Elem (mknoloc (Internal (Types.char (Types.BoolChars.atom (`Atm 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 (Custom.Atm (Intervals.bounded i j)))))
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.bounded i j)))))
| i = INT ->
let i = Intervals.V.mk i in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.atom i)))))
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.atom i)))))
| "*"; "--"; j = INT ->
let j = Intervals.V.mk j in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.left j)))))
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.left j)))))
| i = INT; "--"; "*" ->
let i = Intervals.V.mk i in
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.right i)))))
mk _loc (Internal (Types.interval (Types.BoolIntervals.atom (`Atm (Intervals.right i)))))
| i = char ->
mk _loc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class i i)))))
mk _loc (Internal (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class i i)))))
| i = char ; "--"; j = char ->
mk _loc (Internal (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class i j)))))
mk _loc (Internal (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class i j)))))
| "`"; c = tag_type -> c
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod _loc l
| "["; r = [ r = regexp -> r | -> Epsilon ];
......@@ -657,7 +657,7 @@ EXTEND Gram
(fun c ->
mknoloc (Internal
(Types.char
(Types.BoolChars.atom (Custom.Atm (
(Types.BoolChars.atom (`Atm (
(Chars.atom
(Chars.V.mk_int c))))))))
(seq_of_string s) in
......
schema/schema_builtin.ml
View file @ a2da41f0
......@@ -480,7 +480,7 @@ let int_type (name,min,max) =
| None, None ->
Intervals.any
in
ignore (primitive name (Types.interval (Types.BoolIntervals.atom (Custom.Atm ival))) (validate_interval ival name))
ignore (primitive name (Types.interval (Types.BoolIntervals.atom (`Atm ival))) (validate_interval ival name))
let () =
List.iter int_type [
......
schema/schema_common.ml
View file @ a2da41f0
......@@ -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 (Custom.Atm (Atoms.atom xsi_nil_atom)))
let xsi_nil_type = Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom xsi_nil_atom)))
let xsi_nil_label = Ns.Label.mk (Schema_xml.xsi, Utf8.mk "nil")
let merge_attribute_uses l =
......
tests/libtest/tests-boolvar.ml
View file @ a2da41f0
......@@ -7,22 +7,28 @@ module type S = sig
val mk_atm : string -> t
end
module BoolChars : S = struct
module BoolChars : S with type s = Chars.t = struct
include BoolVar.Make(Chars)
let mk_var s = atom (Custom.Var s)
let mk_atm c = atom (Custom.Atm (Chars.atom (Chars.V.mk_char c.[0] )))
let mk_var s = atom (`Var s)
let mk_atm c = atom (`Atm (Chars.atom (Chars.V.mk_char c.[0] )))
end
module BoolAtoms : S with type bt = Atoms.t = struct
module BoolAtoms : S with type s = Atoms.t = struct
include BoolVar.Make(Atoms)
let mk_var s = atom (Custom.Var s)
let mk_atm s = atom (Custom.Atm (Atoms.atom (Atoms.V.mk_ascii s)))
let mk_var s = atom (`Var s)
let mk_atm s = atom (`Atm (Atoms.atom (Atoms.V.mk_ascii s)))
end
module BoolIntervals : S = struct
module BoolIntervals : S with type s = Intervals.t = struct
include BoolVar.Make(Intervals)
let mk_var s = atom (Custom.Var s)
let mk_atm s = atom (Custom.Atm (Intervals.atom (Intervals.V.mk s)))
let mk_var s = atom (`Var s)
let mk_atm s = atom (`Atm (Intervals.atom (Intervals.V.mk s)))
end
module BoolVars : S with type s = BoolVar.Vars.t = struct
include BoolVar.BoolVars
let mk_var s = atom (`Var s)
let mk_atm s = failwith "AA"
end
module ExprParser (B : S) = struct
......@@ -58,6 +64,7 @@ end
module BCP = ExprParser(BoolChars)
module BAP = ExprParser(BoolAtoms)
module BIP = ExprParser(BoolIntervals)
module BVP = ExprParser(BoolVars)
(*
XXX this needs much more infrastructure as in types.ml
......@@ -73,14 +80,59 @@ let atoms_tests = [
"associativity union", BAP.os "(atm foo v atm bar) v atm baz", BAP.os "atm foo v (atm bar v atm baz)";
"difference", BAP.os "(atm foo ^ atm bar) v var alpha", BAP.os "var alpha";
"difference empty", BAP.os "atm foo ^ atm bar", BAP.os "Empty";
"splitvar vars empty", fst(BoolAtoms.splitvars (BAP.os "atm foo")), BAP.os "Empty";
"splitvar atm empty", snd(BoolAtoms.splitvars (BAP.os "var alpha")), BAP.os "Empty";
"splitvar vars 1 ", fst(BoolAtoms.splitvars (BAP.os "var alpha v (atm foo ^ var beta) v var gamma")), BAP.os "var alpha v var gamma";
"splitvar atm 1", snd(BoolAtoms.splitvars (BAP.os "var alpha v (atm foo ^ var beta) v var gamma")), BAP.os "atm foo ^ var beta";
"splitvar atm 2", snd(BoolAtoms.splitvars (BAP.os "var alpha v atm foo")), BAP.os "atm foo";
"splitvar vars 2", fst(BoolAtoms.splitvars (BAP.os "var alpha v atm foo")), BAP.os "var alpha";
];;
let atoms_splitvar_vars =
"vars splitvar" >:::
List.map (fun (descr, s1,s2) ->
(Printf.sprintf "test %s" descr) >:: (fun _ ->
assert_equal (BoolVar.BoolVars.equal ( s1 :> BoolVar.BoolVars.t ) s2) true
)
) [
"vars empty", fst(BoolAtoms.extractvars (BAP.os "atm foo")), BVP.os "Empty";
"vars 1 ", fst(BoolAtoms.extractvars (BAP.os "var alpha v (atm foo ^ var beta) v var gamma")), BVP.os "var alpha v var gamma";
"vars 2", fst(BoolAtoms.extractvars (BAP.os "var alpha v atm foo")), BVP.os "var alpha";
"vars 2", fst(BoolAtoms.extractvars (BAP.os "var alpha v atm foo")), fst(BoolChars.extractvars (BCP.os "var alpha v atm c"));
]
;;
let atoms_splitvar_atm =
"atoms splitvar" >:::
List.map (fun (descr, s1,s2) ->
(Printf.sprintf "test %s" descr) >:: (fun _ ->
assert_equal (BoolAtoms.equal s1 s2) true
)
) [
"atm empty", snd(BoolAtoms.extractvars (BAP.os "var alpha")), BAP.os "Empty";
"atm 1", snd(BoolAtoms.extractvars (BAP.os "var alpha v (atm foo ^ var beta) v var gamma")), BAP.os "atm foo ^ var beta";
"atm 2", snd(BoolAtoms.extractvars (BAP.os "var alpha v atm foo")), BAP.os "atm foo";
]
;;
let splitvar_mixed_union_var =
"splitvar union" >:::
List.map (fun (descr, s1,s2,r) ->
(Printf.sprintf "test %s" descr) >:: (fun _ ->
assert_equal (BoolVar.BoolVars.equal (BoolVar.BoolVars.cup s1 s2) r) true
)
) [
"atoms/chars", fst(BoolAtoms.extractvars (BAP.os "atm foo")), fst(BoolChars.extractvars (BCP.os "var alpha v atm x")), BVP.os "var alpha";
"atoms/chars", fst(BoolAtoms.extractvars (BAP.os "var alpha v atm foo")), fst(BoolChars.extractvars (BCP.os "var alpha v atm c")), BVP.os "var alpha";
]
;;
let splitvar_mixed_union_atm =
"splitvar union" >:::
List.map (fun (descr, s1,s2,r) ->
(Printf.sprintf "test %s" descr) >:: (fun _ ->
assert_equal (BoolAtoms.equal (BoolAtoms.cup s1 s2) r) true
)
) [
"atoms/chars", snd(BoolAtoms.extractvars (BAP.os "atm foo")), fst(BoolChars.extractvars (BCP.os "var alpha v atm x")), BAP.os "var alpha v atm foo";
]
;;
let atoms_structure =
"atoms structure" >:::
List.map (fun (descr, s1,s2) ->
......@@ -115,6 +167,11 @@ let atoms_contains =
let all =
"all tests" >::: [
atoms_structure;
atoms_contains;
atoms_splitvar_atm;
atoms_splitvar_vars;
splitvar_mixed_union_atm;
splitvar_mixed_union_var
]
let main () =
......
tests/libtest/tests.ml
View file @ a2da41f0
......@@ -17,7 +17,15 @@ Types.subtype t1 t2 ;;
let subtype_tests = [
"Int" , "Any", true;
"`a | Int" , "`a", false;
"`A | Int" , "`A", false;
"`A | ( 0--* | *--0)" , "`A", false;
"42 | Int" , "42", false;
"Int" , "Empty", false;
"'c' | Int" , "1", false;
"`A | Char" , "`A", false;
"`A | (`A,`B)" , "`A", false;
"`A -> `B | Int" , "`A -> `B", false;
"(`A,`B) | Int" , "(`A,`B)", false;
"Any" , "Any", true;
"Empty" , "Empty", true;
"Empty" , "Any", true;
......@@ -28,17 +36,16 @@ let subtype_tests = [
"1--5" , "1--*", true;
"1--5" , "1--5", true;
"Any -> `a" , "Any", true;
"`a -> `b | Int" , "`a -> `b", false;
"Any -> `A" , "Any", true;
"`a -> `b" , "`a -> `b", true;
"`A -> `B" , "`A -> `B", true;
"Any -> `a" , "Any -> Any", true;
"`a -> `b" , "Empty -> Any", true;
"(`a -> `c) | (`b -> `c)" , "(`a & `b) -> `c", true;
"(`a & `b) | (`a & `c)" , "`a & (`b | `c)", true;
"`a & (`b | `c)" , "(`a & `b) | (`a & `c)", true;
"(`a,`b) | (`c,`d)" , "((`a | `c) , (`b | `d))", true;
"(`a , `b & `c)" , "(`a,`b) & (`a,`c)", true;
"`A -> `B" , "Empty -> Any", true;
"(`A -> `C) | (`B -> `C)" , "(`A & `B) -> `C", true;
"(`A & `B) | (`A & `C)" , "`A & (`B | `C)", true;
"`A & (`B | `C)" , "(`A & `B) | (`A & `C)", true;
"(`A,`B) | (`C,`D)" , "((`A | `C) , (`B | `D))", true;
"(`A , `B & `C)" , "(`A,`B) & (`A,`C)", true;
(*
"mu x . Int -> (Nat , x)" , "mu x . Nat -> (Int , x)", true;
"mu x . (a,x)" , "mu y . (a,y)", true;
......@@ -46,16 +53,21 @@ let subtype_tests = [
"Any" , "Int", false ;
"Any" , "Empty", false ;
"`a -> `b" , "`a", false ;
"Any -> `a" , "Empty", false ;
"Any -> `a" , "Any -> Empty", false ;
"`a -> `b" , "`a -> `c", false ;
"`A -> `B" , "`A", false ;
"Any -> `A" , "Empty", false ;
"Any -> `A" , "Any -> Empty", false ;
"`A -> `B" , "`A -> `C", false ;
"Int" , "0--*", false ;
"1--5" , "1--4", false ;
"Int" , "0--*", false ;
"`$X" , "Any", true;
"`$X | Int" , "Any", true;
"Any", "`$X | (Any \\ `$X)", true;
"Any", "(42 & `$X) | (Any \\ (42 & `$X))", true;
"Any", "(41 & `$X) | (Any \\ (42 & `$X))", false;
"Any", "Any \\ Char", false;
];;
let test_subtype =
......@@ -64,7 +76,7 @@ let test_subtype =
(Printf.sprintf " %s <: %s " s1 s2) >:: (fun _ ->
let t1 = parse_typ s1 in
let t2 = parse_typ s2 in
let result = Types.subtype t1 t2 in
let result = Types.subtype t1 t2 in
if result <> expected then
begin
(* Printf.printf "subtyping error %s <: %s\n" s1 s2; *)
......
types/boolVar.ml
View file @ a2da41f0
This diff is collapsed.
types/builtin.ml
View file @ a2da41f0
......@@ -13,7 +13,7 @@ let types =
"Empty", Types.empty;
"Any", any;
"Int", int;
"Char", Types.char (Types.BoolChars.atom (Custom.Atm ( Chars.any )));
"Char", Types.char (Types.BoolChars.atom (`Atm ( 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 (Custom.Atm ( Chars.any ) )))
int (Types.char (Types.BoolChars.atom (`Atm ( 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 (Custom.Atm ( Chars.any) ))) int
(Types.char (Types.BoolChars.atom (`Atm ( 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.get x in
let t = Types.BoolIntervals.get y in
Types.BoolIntervals.atom (Custom.Atm (f s t))
Types.BoolIntervals.atom (`Atm (f s t))
;;
binary_op_gen "+"
......
types/builtin_defs.ml
View file @ a2da41f0
open Encodings
let pos_int = Types.interval (Types.BoolIntervals.atom (Custom.Atm (Intervals.right (Intervals.V.mk "1"))))
let non_neg_int = Types.interval (Types.BoolIntervals.atom (Custom.Atm(Intervals.right (Intervals.V.mk "0"))))
let neg_int = Types.interval (Types.BoolIntervals.atom (Custom.Atm(Intervals.left (Intervals.V.mk "-1"))))
let non_pos_int = Types.interval (Types.BoolIntervals.atom (Custom.Atm(Intervals.left (Intervals.V.mk "0"))))
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 mk_interval_type l r =
Types.interval (Types.BoolIntervals.atom (Custom.Atm(Intervals.bounded (Intervals.V.mk l) (Intervals.V.mk r))))
Types.interval (Types.BoolIntervals.atom (`Atm(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,21 +17,21 @@ 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 (Custom.Atm (Chars.char_class
Sequence.plus (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '9')
)
)))
let octal_intstr =
Sequence.plus (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class
Sequence.plus (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '7')
)
)))
let binary_intstr =
Sequence.plus (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class
Sequence.plus (Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '1')
)
......@@ -40,18 +40,18 @@ let binary_intstr =
let hex_intstr =
Sequence.plus (
Types.cup
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class
(Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
(Chars.V.mk_char '0')
(Chars.V.mk_char '9')
)
)))
(Types.cup
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class
(Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
(Chars.V.mk_char 'a')
(Chars.V.mk_char 'f')
)
)))
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.char_class
(Types.char (Types.BoolChars.atom (`Atm (Chars.char_class
(Chars.V.mk_char 'A')
(Chars.V.mk_char 'F')
)
......@@ -62,13 +62,13 @@ let hex_intstr =
let hex_str =
Types.times
(Types.cons (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons (Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char 'X')))))
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char 'x')))))
(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.cons hex_intstr)
......@@ -77,13 +77,13 @@ let hex_str =
let oct_str =
Types.times
(Types.cons (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons (Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char 'O')))))
(Types.char (Types.BoolChars.atom (Custom.Atm(Chars.atom (Chars.V.mk_char 'o')))))
(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.cons octal_intstr)
......@@ -93,13 +93,13 @@ let oct_str =
let bin_str =
Types.times
(Types.cons (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons (Types.char (Types.BoolChars.atom (`Atm (Chars.atom (Chars.V.mk_char '0'))))))
(Types.cons(
Types.times
(Types.cons(
Types.cup
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char 'B')))))
(Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char 'b')))))
(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.cons binary_intstr)
......@@ -111,7 +111,7 @@ let pos_intstr =
let neg_intstr =
Types.times
(Types.cons (Types.char (Types.BoolChars.atom (Custom.Atm (Chars.atom (Chars.V.mk_char '-'))))))
(Types.cons (Types.char (Types.BoolChars.atom (`Atm (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 (Custom.Atm (Atoms.atom true_atom)))
let false_type = Types.atom (Types.BoolAtoms.atom (Custom.Atm (Atoms.atom false_atom)))
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 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 (Custom.Atm Atoms.any))
let atom = Types.atom (Types.BoolAtoms.atom (`Atm Atoms.any))
let char_latin1 = Types.char (Types.BoolChars.atom (Custom.Atm (Chars.mk_classes [ (0,255) ])))
let char_latin1 = Types.char (Types.BoolChars.atom (`Atm (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 (Custom.Atm (Atoms.atom (Atoms.V.mk_ascii s)))))
(fun s -> Types.atom (Types.BoolAtoms.atom (`Atm (Atoms.atom (Atoms.V.mk_ascii s)))))
[ "duration"; "dateTime"; "time"; "date"; "gYearMonth"; "gYear";