Refactor the Bool/BoolVar code so that they share the same interface. Give...

Refactor the Bool/BoolVar code so that they share the same interface. Give access to the underlying atom module in BoolVar.

depend

@@ -42,8 +42,10 @@ types/var.cmo : misc/utils.cmo types/sortedList.cmi types/ident.cmo \
     misc/custom.cmo types/var.cmi
 types/var.cmx : misc/utils.cmx types/sortedList.cmx types/ident.cmx \
     misc/custom.cmx types/var.cmi
-types/boolVar.cmo : types/var.cmi misc/custom.cmo types/boolVar.cmi
-types/boolVar.cmx : types/var.cmx misc/custom.cmx types/boolVar.cmi
+types/boolVar.cmo : types/var.cmi misc/custom.cmo misc/bool.cmi \
+    types/boolVar.cmi
+types/boolVar.cmx : types/var.cmx misc/custom.cmx misc/bool.cmx \
+    types/boolVar.cmi
 types/types.cmo : types/var.cmi misc/utils.cmo misc/stats.cmi \
     types/sortedList.cmi misc/pretty.cmi misc/ns.cmi types/normal.cmi \
     types/intervals.cmi types/ident.cmo misc/encodings.cmi misc/custom.cmo \
@@ -367,12 +369,13 @@ misc/html.cmi :
 types/compunit.cmi :
 types/sortedList.cmi : misc/custom.cmo
 misc/bool.cmi : misc/custom.cmo
-types/intervals.cmi : misc/custom.cmo
-types/chars.cmi : misc/custom.cmo
-types/atoms.cmi : misc/ns.cmi misc/encodings.cmi misc/custom.cmo
+types/intervals.cmi : misc/custom.cmo misc/bool.cmi
+types/chars.cmi : misc/custom.cmo misc/bool.cmi
+types/atoms.cmi : misc/ns.cmi misc/encodings.cmi misc/custom.cmo \
+    misc/bool.cmi
 types/normal.cmi :
 types/var.cmi : types/sortedList.cmi misc/custom.cmo
-types/boolVar.cmi : types/var.cmi misc/custom.cmo
+types/boolVar.cmi : types/var.cmi misc/custom.cmo misc/bool.cmi
 types/types.cmi : types/var.cmi misc/ns.cmi types/intervals.cmi \
     types/ident.cmo misc/custom.cmo types/chars.cmi types/boolVar.cmi \
     types/atoms.cmi

misc/bool.ml

@@ -8,7 +8,6 @@ sig
   include Custom.T
 
   val get: t -> (elem list * elem list) list
-  val get': t -> (elem list * (elem list) list) list
 
   val empty : t
   val full  : t

misc/bool.mli

@@ -4,7 +4,6 @@ sig
   type elem
 
   val get: t -> (elem list * elem list) list
-  val get': t -> (elem list * (elem list) list) list
 
   val empty : t
   val full  : t
@@ -15,15 +14,10 @@ sig
 
   val iter: (elem-> unit) -> t -> unit
 
-  val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b) 
+  val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
     -> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
     atom:(elem -> 'b) -> t -> 'b
 
-(*
-  val print: string -> (Format.formatter -> elem -> unit) -> t ->
-    (Format.formatter -> unit) list
-*)
-
   val trivially_disjoint : t -> t -> bool
 end
 

runtime/value.mli

@@ -74,7 +74,7 @@ val get_field_ascii : t -> string -> t
 
 val get_variant : t -> string * t option
 
-val abstract : Types.Abstracts.abs -> 'a -> t
+val abstract : Types.Abstracts.T.t -> 'a -> t
 val get_abstract : t -> 'a
 
 val mk_ref : Types.t -> t -> t

schema/schema_builtin.ml

@@ -183,7 +183,7 @@ let validate_token_list s =
   Value.sequence (List.map validate_token (split_xml_S s))
 
 let validate_interval interval type_name s =
-  let integer =   
+  let integer =
     let s = Utf8.get_str s in
     if (String.length s = 0) then simple_type_error "integer"
     else
@@ -401,7 +401,7 @@ let restrict name (base,_,_) facets cd v =
   let b = (t,cd,v) in
   reg name b;
   b
-  
+
 let list name (item,_,_) cd v =
   let name = add_xsd_prefix name in
   let t = simple_list (Some name) item in
@@ -410,7 +410,7 @@ let list name (item,_,_) cd v =
   b
 
 
-let primitive name cd v = 
+let primitive name cd v =
   let name = add_xsd_prefix name in
   let rec t =
     { st_name = Some name;
@@ -425,37 +425,37 @@ let alias name b =
   let name = add_xsd_prefix name in
   reg name b
 
-let any_simple_type = 
+let any_simple_type =
   primitive "anySimpleType" Builtin_defs.string validate_string
 let string =
   primitive "string" Builtin_defs.string validate_string
-let _ = 
+let _ =
   primitive "boolean" Builtin_defs.bool validate_bool
-let _ = 
+let _ =
   primitive "hexBinary" Builtin_defs.string validate_hexBinary
-let _ = 
+let _ =
   primitive "base64Binary" Builtin_defs.string validate_base64Binary
-let _ = 
+let _ =
   primitive "anyURI" Builtin_defs.string validate_anyURI
-let _ = 
+let _ =
   primitive "duration" duration_type validate_duration
-let _ = 
+let _ =
   primitive "dateTime" dateTime_type validate_dateTime
-let _ = 
+let _ =
   primitive "time" time_type validate_time
-let _ = 
+let _ =
   primitive "date" date_type validate_date
-let _ = 
+let _ =
   primitive "gYearMonth" gYearMonth_type validate_gYearMonth
-let _ = 
+let _ =
   primitive "gYear" gYear_type validate_gYear
-let _ = 
+let _ =
   primitive "gMonthDay" gMonthDay_type validate_gMonthDay
-let _ = 
+let _ =
   primitive "gDay" gDay_type validate_gDay
-let _ = 
+let _ =
   primitive "gMonth" gMonth_type validate_gMonth
-let decimal = 
+let decimal =
   primitive "decimal" Builtin_defs.float validate_decimal
 
 let _ =
@@ -463,10 +463,10 @@ let _ =
   alias "double" decimal
 
 
-let _ = 
+let _ =
   List.iter (fun n -> alias n string) unsupported
 
-let int_type (name,min,max) = 
+let int_type (name,min,max) =
   let ival = match min,max with
     | Some min, Some max ->
 	let min = Intervals.V.mk min and max = Intervals.V.mk max  in
@@ -478,17 +478,17 @@ let int_type (name,min,max) =
 	let min = Intervals.V.mk min  in
 	Intervals.right min
     | None, None ->
-	Intervals.any 
+	Intervals.full
   in
   ignore (primitive name (Types.interval ival) (validate_interval ival name))
 
 let () =
-  List.iter int_type [ 
+  List.iter int_type [
     "integer", None, None;
     "nonPositiveInteger", None, Some "0";
     "negativeInteger", None, Some "-1";
     "long", Some "-9223372036854775808", Some "9223372036854775807";
-    "int", Some "-2147483648", Some "2147483647"; 
+    "int", Some "-2147483648", Some "2147483647";
     "short", Some "-32768", Some "32767";
     "byte", Some "-128", Some "127";
     "nonNegativeInteger", Some "0", None;
@@ -496,16 +496,16 @@ let () =
     "unsignedInt", Some "0", Some "4294967295";
     "unsignedShort", Some "0", Some "65535";
     "unsignedByte", Some "0", Some "255";
-    "positiveInteger", Some "1", None 
+    "positiveInteger", Some "1", None
   ]
-    
 
 
-let normalized_string = 
+
+let normalized_string =
   restrict "normalizedString" string
     { no_facets with whiteSpace = `Replace, false }
   Builtin_defs.string validate_normalizedString
-let token = 
+let token =
   restrict "token" normalized_string
     { no_facets with whiteSpace = `Collapse, false }
     Builtin_defs.string validate_token
@@ -695,5 +695,3 @@ let validate (_,_,v) = v
 let of_st = function
   | { st_name = Some n } -> get n
   | _ -> assert false
-
-

types/atoms.ml

@@ -14,11 +14,11 @@ let rec iter_sep sep f = function
   | [] -> ()
   | [ h ] -> f h
   | h :: t -> f h; sep (); iter_sep sep f t
-      
+
 let print_symbolset ns ppf = function
-  | SymbolSet.Finite l -> 
-      iter_sep 
-	(fun () -> Format.fprintf ppf " |@ ") 
+  | SymbolSet.Finite l ->
+      iter_sep
+	(fun () -> Format.fprintf ppf " |@ ")
 	(V.print_quote ppf) l
   | SymbolSet.Cofinite t ->
       Format.fprintf ppf "@[`%a" Ns.InternalPrinter.print_any_ns ns;
@@ -41,37 +41,37 @@ let single s = match get s with
   | _ -> raise Exit
 
 let print_tag s = match get s with
-  | `Finite [_, SymbolSet.Finite [a]] -> 
+  | `Finite [_, SymbolSet.Finite [a]] ->
       Some (fun ppf -> Ns.InternalPrinter.print_tag ppf (V.value a))
-  | `Finite [ns, SymbolSet.Cofinite []] -> 
+  | `Finite [ns, SymbolSet.Cofinite []] ->
       Some (fun ppf -> Ns.InternalPrinter.print_any_ns ppf ns)
   | `Cofinite [] ->
       Some (fun ppf -> Format.fprintf ppf "_")
   | _ -> None
 
 let print s = match get s with
-  | `Finite l -> 
+  | `Finite l ->
       List.map (fun (ns,s) ppf -> print_symbolset ns ppf s) l
   | `Cofinite [] ->
       [ fun ppf -> Format.fprintf ppf "Atom" ]
   | `Cofinite l ->
       [ fun ppf ->
 	  Format.fprintf ppf "Atom";
-	  List.iter 
-	    (fun (ns,s) -> 
+	  List.iter
+	    (fun (ns,s) ->
 	       Format.fprintf ppf " \\@ (%a)" (print_symbolset ns) s)
 	    l ]
 
 type 'a map = 'a Imap.t * 'a Imap.t * 'a option
 
 let map_map f (m1,m2,o) =
-  Imap.map f m1, Imap.map f m2, 
+  Imap.map f m1, Imap.map f m2,
   (match o with Some x -> Some (f x) | None -> None)
 
 (* TODO: optimize this get_map *)
-let get_map q (mtags,mns,def) =   
+let get_map q (mtags,mns,def) =
   try Imap.find mtags (Upool.int q)
-  with Not_found -> 
+  with Not_found ->
     try Imap.find mns (Upool.int (fst (V.value q)))
     with Not_found -> match def with
       | None -> assert false
@@ -81,14 +81,14 @@ let mk_map l =
   let all_ns = ref [] in
   let all_tags = ref [] in
   let def = ref None in
-  List.iter 
+  List.iter
     (function (s,x) ->
        match get s with
-       | `Finite s -> 
-	   List.iter 
-	     (function 
+       | `Finite s ->
+	   List.iter
+	     (function
 		| (_, SymbolSet.Finite t) ->
-		   List.iter 
+		   List.iter
 		     (fun tag -> all_tags := (Upool.int tag,x)::!all_tags) t
 		| (ns, _) ->
 		    all_ns := (Upool.int ns,x)::!all_ns
@@ -108,3 +108,9 @@ let contains_sample s t =
     | None, `Finite _ -> false
     | Some (_,Some tag),_ -> contains tag t
     | Some (ns, None),_ -> is_empty (diff (any_in_ns ns) t)
+
+let trivially_disjoint = disjoint
+
+let compute ~empty ~full ~cup ~cap ~diff ~atom b = assert false
+let get _ = assert false
+let iter _ = assert false

types/atoms.mli

@@ -13,11 +13,9 @@ module V : sig
   val to_string: t -> string
 end
 
-include Custom.T
+include Bool.S with type elem = V.t
 val print : t -> (Format.formatter -> unit) list
 
-type elem = V.t
-
 val empty : t
 val any   : t
 val full  : t (* same as any *)

types/boolVar.mli

-module type E = sig
-  type elem
-  include Custom.T
-
-  val empty : t
-  val full  : t
-  val cup   : t -> t -> t
-  val cap   : t -> t -> t
-  val diff  : t -> t -> t
-  val atom  : elem -> t
-
-end
-
 module type S = sig
 
-  type s
-  type elem = s Var.var_or_atom
-  include Custom.T
+  module Atom : Bool.S
 
-  (** returns the union of all leaves in the BDD *)
-  val leafconj: t -> s
-
-  val get: t -> (elem list * elem list) list
-(*  val build : (elem list * elem list) list -> t *)
-  val empty : t
-  val full  : t
-  (* same as full, but we keep it for the moment to avoid chaging the code everywhere *)
-  val any  : t
-  val cup   : t -> t -> t
-  val cap   : t -> t -> t
-  val diff  : t -> t -> t
-  val atom  : elem -> t
+  include Bool.S with type elem = Atom.t Var.var_or_atom
 
-  val trivially_disjoint: t -> t -> bool
+  val var : Var.t -> t
 
-  (** vars a : return a bdd that is ( Any ^ Var a ) *)
-  val vars  : Var.var -> t
-
-  val iter: (elem-> unit) -> t -> unit
+  (** returns the union of all leaves in the BDD *)
 
-  val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
-    -> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
-    atom:(elem -> 'b) -> t -> 'b
+  val leafconj: t -> Atom.t
 
   val is_empty : t -> bool
 
@@ -50,5 +18,4 @@ module type S = sig
 
 end
 
-module type MAKE = functor (T : E) -> S with type s = T.t
-module Make : MAKE
+module Make : functor (T : Bool.S) -> S with module Atom = T and type elem = T.t Var.var_or_atom

types/builtin_defs.mli

@@ -40,9 +40,8 @@ val mk_ref: get:'a -> set:'a -> 'a Ident.label_map
 val ref_type: Types.Node.t -> Types.t
 
 val float: Types.t
-val float_abs: Types.Abstracts.abs
+val float_abs: Types.Abstracts.T.t
 
 val any_xml : Types.t
 
 val any_xml_with_tag: Atoms.t -> Types.t
-

types/chars.ml

@@ -5,14 +5,14 @@ let max_char = 0x10FFFF
 
 let check i = assert(i >= 0); assert(i <= max_char)
 
-let mk_int c = 
-  if (c < 0) || (c > max_char) then 
+let mk_int c =
+  if (c < 0) || (c > max_char) then
     failwith "Chars.mk_int: code point out of bound";
   c
 
 let mk_char c =
   Char.code c
-    
+
 let to_int c = c
 
 let to_char c =
@@ -34,17 +34,17 @@ let print ppf c =
   Format.fprintf ppf "'%a'" print_in_string c
 end
 open V
-      
+
 include Custom.List(Custom.Pair(V)(V))
 
 let rec check = function
   | [] -> ()
   | (a,b)::((c,d)::_ as tl) -> assert (a <= b); assert (b < c - 1); check tl
-  | [(a,b)] -> assert (a <= b)  
+  | [(a,b)] -> assert (a <= b)
 
 
-let from_int c = 
-  if (c < 0) || (c > V.max_char) then 
+let from_int c =
+  if (c < 0) || (c > V.max_char) then
     failwith "Chars.from_int: code point out of bound";
   c
 
@@ -62,13 +62,13 @@ let char_class a b = if a<=b then [a,b] else empty
 let atom a = [a,a]
 
 let rec add l ((a,b) as i) = match l with
-  | [] -> 
+  | [] ->
       [i]
-  | ((a1,_) :: _) as l when (b < a1 - 1) -> 
+  | ((a1,_) :: _) as l when (b < a1 - 1) ->
       i::l
-  | ((a1,b1) as i' :: l') when (a > b1 + 1) -> 
+  | ((a1,b1) as i' :: l') when (a > b1 + 1) ->
       i'::(add l' i)
-  | (a1,b1) :: l' -> 
+  | (a1,b1) :: l' ->
       add l' (min a a1, max b b1)
 
 
@@ -118,12 +118,12 @@ let is_char = function
   | _ -> None
 
 let print =
-  List.map 
+  List.map
     (fun (a,b) ->
-       if a = b 
-       then fun ppf -> 
+       if a = b
+       then fun ppf ->
 	 V.print ppf a
-       else fun ppf -> 
+       else fun ppf ->
 	 if a = 0 && b = max_char then Format.fprintf ppf "Char" else
 	 Format.fprintf ppf "%a--%a" V.print a V.print b
     )
@@ -132,7 +132,7 @@ let dump ppf t =
   match print t with
     | [] -> Format.fprintf ppf "()"
     | hd::tl -> hd ppf; List.iter (fun x -> Format.fprintf ppf "|"; x ppf) tl
-  
+
 
 type 'a map = (int * 'a) list
 
@@ -144,13 +144,13 @@ let map_map f l = List.map (fun (i,x) -> (i, f x)) l
 *)
 
 let mk_map l =
-  let m = 
-    List.fold_left 
-      (fun accu (i,x) -> 
+  let m =
+    List.fold_left
+      (fun accu (i,x) ->
 	 List.fold_left (fun accu (a,b) -> (b,x)::accu) accu i) [] l in
-  let m = 
-    List.sort 
-      (fun (b1,x1) (b2,x2) -> 
+  let m =
+    List.sort
+      (fun (b1,x1) (b2,x2) ->
 	 if (b1 : int) < b2 then -1 else if b1 = b2 then 0 else 1)
       m in
   m
@@ -159,3 +159,9 @@ let rec get_map c = function
   | [_,x] -> x
   | (b,x)::rem -> if (c : int) <= b then x else get_map c rem
   | [] -> assert false
+
+let trivially_disjoint = disjoint
+
+let compute ~empty ~full ~cup ~cap ~diff ~atom b = assert false
+let get _ = assert false
+let iter _ = assert false

types/chars.mli

@@ -9,12 +9,10 @@ module V : sig
   val print_in_string : Format.formatter -> t -> unit
 end
 
-include Custom.T
+include Bool.S with type elem = V.t
 val print : t -> (Format.formatter -> unit) list
 val dump: Format.formatter -> t -> unit
 
-type elem = V.t
-
 val empty : t
 val any   : t
 val full  : t (* same as any *)

types/intervals.ml

@@ -17,7 +17,7 @@ let check i = ()
 
 let from_int i = big_int_of_int i
 let from_bigint i = i
-  
+
 let mk = big_int_of_string
 let to_string = string_of_big_int
 let get_int = int_of_big_int
@@ -46,7 +46,7 @@ let to_int32 i = Int32.of_string (to_string i)
 let to_int64 i = Int64.of_string (to_string i)
 end
 
-type interval = 
+type interval =
   | Bounded of big_int * big_int
   | Left of big_int
   | Right of big_int
@@ -70,20 +70,20 @@ let rec compare l1 l2 =
     | [],_ -> -1
     | _,[] -> 1
     | Bounded (a1,b1) :: l1, Bounded (a2,b2) :: l2 ->
-	let c = V.compare a1 a2 in if c <> 0 then c 
+	let c = V.compare a1 a2 in if c <> 0 then c
 	else let c = V.compare b1 b2 in if c <> 0 then c
 	else compare l1 l2
     | Bounded (_,_) :: _, _ -> -1
     | _, Bounded (_,_) :: _ -> 1
 
     | Left a1 :: l1, Left a2 :: l2 ->
-	let c = V.compare a1 a2 in if c <> 0 then c 
+	let c = V.compare a1 a2 in if c <> 0 then c
 	else compare l1 l2
     | Left _ :: _, _ -> -1
     | _, Left _ :: _ -> 1
 
     | Right a1 :: l1, Right a2 :: l2 ->
-	let c = V.compare a1 a2 in if c <> 0 then c 
+	let c = V.compare a1 a2 in if c <> 0 then c
 	else compare l1 l2
     | Right _ :: _, _ -> -1
     | _, Right _ :: _ -> 1
@@ -138,9 +138,9 @@ let atom a = bounded a a
 let rec iadd_left l b = match l with
   | [] -> [Left b]
   | (Bounded (a1,_) | Right a1) :: _
-      when (lt_big_int b (pred_big_int a1)) -> 
+      when (lt_big_int b (pred_big_int a1)) ->
       Left b :: l
-  | Bounded (_,b1) :: l' -> 
+  | Bounded (_,b1) :: l' ->
       iadd_left l' (max_big_int b b1)
   | Left b1 :: _ when le_big_int b b1-> l
   | Left _ :: l' ->
@@ -148,15 +148,15 @@ let rec iadd_left l b = match l with
   | _ -> any
 
 let rec iadd_bounded l a b = match l with
-  | [] -> 
+  | [] ->
       [Bounded (a,b)]
   | (Bounded (a1,_) | Right a1) :: _
-      when (lt_big_int b (pred_big_int a1)) -> 
+      when (lt_big_int b (pred_big_int a1)) ->
       Bounded (a,b) :: l
-  | ((Bounded (_,b1) | Left b1) as i') :: l' 
-      when (lt_big_int (succ_big_int b1) a) -> 
+  | ((Bounded (_,b1) | Left b1) as i') :: l'
+      when (lt_big_int (succ_big_int b1) a) ->
       i'::(iadd_bounded l' a b)
-  | Bounded (a1,b1) :: l' -> 
+  | Bounded (a1,b1) :: l' ->
       iadd_bounded l' (min_big_int a a1) (max_big_int b b1)
   | Left b1 :: l' ->
       iadd_left l' (max_big_int b b1)
@@ -165,10 +165,10 @@ let rec iadd_bounded l a b = match l with
 
 let rec iadd_right l a = match l with
   | [] -> [Right a]
-  | ((Bounded (_,b1) | Left b1) as i') :: l' 
-      when (lt_big_int (succ_big_int b1) a) -> 
+  | ((Bounded (_,b1) | Left b1) as i') :: l'
+      when (lt_big_int (succ_big_int b1) a) ->
       i'::(iadd_right l' a)
-  | (Bounded (a1,_) | Right a1) :: _ -> 
+  | (Bounded (a1,_) | Right a1) :: _ ->
       [Right (min_big_int a a1)]
   | _ -> any
 
@@ -180,7 +180,7 @@ let iadd l = function
 
 let rec neg' start l = match l with
   | [] -> [Right start]
-  | Bounded (a,b) :: l' -> 
+  | Bounded (a,b) :: l' ->
       Bounded (start, pred_big_int a) :: (neg' (succ_big_int b) l')
   | Right a :: l' ->
       [Bounded (start, pred_big_int a)]
@@ -237,29 +237,29 @@ let sample = function
   | (Left x | Right x | Bounded (x,_)) :: _ -> x
   | Any :: _ -> zero_big_int
   | [] -> raise Not_found
-  
+
 let single = function
   | [ Bounded (x,y) ] when eq_big_int x y -> x
   | [] -> raise Not_found
   | _ -> raise Exit
 
 let print =
-  List.map 
+  List.map
     (fun x ppf -> match x with
        | Any ->
 	   Format.fprintf ppf "Int"
-       | Left b -> 
-	   Format.fprintf ppf "*--%s" 
+       | Left b ->
+	   Format.fprintf ppf "*--%s"
 	     (string_of_big_int b)
-       | Right a -> 
-	   Format.fprintf ppf "%s--*" 
+       | Right a ->
+	   Format.fprintf ppf "%s--*"
 	     (string_of_big_int a)
-       | Bounded (a,b) when eq_big_int a b -> 
-	   Format.fprintf ppf "%s" 
+       | Bounded (a,b) when eq_big_int a b ->
+	   Format.fprintf ppf "%s"
 	     (string_of_big_int a)
        | Bounded (