[r2006-04-21 15:53:55 by afrisch] Compute witnesses during subtyping

Original author: afrisch
Date: 2006-04-21 15:53:56+00:00

driver/cduce.ml

@@ -191,7 +191,8 @@ let debug ppf tenv cenv = function
       Format.fprintf ppf "[DEBUG:sample]@.";
       (try
 	 let t = Types.descr (Typer.typ tenv t) in
-	 Format.fprintf ppf "%a@." print_sample (Sample.get t)
+	 Format.fprintf ppf "%a@." print_sample (Sample.get t);
+	 Format.fprintf ppf "witness: %a@." Types.print_witness (Types.witness t);
        with Not_found ->
 	 Format.fprintf ppf "Empty type : no sample !@.")
   | `Filter (t,p) -> 

types/atoms.ml

@@ -95,3 +95,12 @@ let mk_map l =
   let mtags = Imap.create (Array.of_list !all_tags) in
   let mns = Imap.create (Array.of_list !all_ns) in
   (mtags,mns,!def)
+
+type sample = (Ns.Uri.t * Ns.Label.t option) option
+
+let contains_sample s t =
+  match s,(get t) with
+    | None, `Cofinite _ -> true
+    | None, `Finite _ -> false
+    | Some (_,Some tag),_ -> contains tag t
+    | Some (ns, None),_ -> is_empty (diff (any_in_ns ns) t)

types/atoms.mli

@@ -32,6 +32,10 @@ val print_tag : t -> (Format.formatter -> unit) option
 
 val single : t -> V.t
 
+type sample = (Ns.Uri.t * Ns.Label.t option) option
+val sample : t -> sample
+val contains_sample: sample -> t -> bool
+
 type 'a map
 val mk_map: (t * 'a) list -> 'a map
 val get_map: V.t -> 'a map -> 'a

types/sequence.ml

@@ -45,7 +45,7 @@ let mapping f t queue =
 let aux_concat = mapping (fun t v -> V.times (V.ty t) v)
 let aux_flatten t = mapping aux_concat t (V.ty nil_type)
 let aux_map f t = 
-  let f = memoize f in
+  let f = memoize f in 
   mapping (fun t v -> V.times (V.ty (f t)) v) t (V.ty nil_type)
 
 let solve x = Types.descr (V.solve x)

types/sortedList.ml

@@ -410,6 +410,7 @@ module type FiniteCofinite = sig
   val contains: elem -> t -> bool
   val disjoint: t -> t -> bool
   val is_empty: t -> bool
+  val sample: t -> elem option
 end
 
 module FiniteCofinite(X : Custom.T) = struct
@@ -438,6 +439,11 @@ module FiniteCofinite(X : Custom.T) = struct
     | Finite s -> Format.fprintf ppf "Finite[%a]" SList.dump s
     | Cofinite s -> Format.fprintf ppf "Cofinite[%a]" SList.dump s
 
+  let sample = function
+    | Finite (x::_) -> Some x
+    | Finite [] -> raise Not_found
+    | Cofinite _ -> None
+
 
   let empty = Finite []
   let any = Cofinite []
@@ -491,6 +497,12 @@ struct
   module T = T0.Map
   type t = Finite of TMap.t | Cofinite of TMap.t
 
+  let sample = function
+    | Cofinite _ -> None
+    | Finite l -> (match T.get l with 
+		     | [] -> raise Not_found
+		     | (x,y)::_ -> Some (x, SymbolSet.sample y))
+
   let get = function
     | Finite l -> `Finite (T.get l)
     | Cofinite l -> `Cofinite (T.get l)

types/sortedList.mli

@@ -91,6 +91,8 @@ module type FiniteCofinite = sig
   val contains: elem -> t -> bool
   val disjoint: t -> t -> bool
   val is_empty: t -> bool
+
+  val sample: t -> elem option
 end
 
 module FiniteCofinite(X : Custom.T) : FiniteCofinite with type elem = X.t
@@ -114,4 +116,7 @@ sig
 
   val get: t -> [ `Finite of (X.t * SymbolSet.t) list 
 		| `Cofinite of (X.t * SymbolSet.t) list ]
+
+  val sample: t -> (X.t * SymbolSet.elem option) option
+
 end

types/types.mli

@@ -277,3 +277,14 @@ sig
 end
 
 
+type witness
+val witness: t -> witness
+val print_witness: Format.formatter -> witness -> unit
+
+module Cache: sig
+  type 'a cache
+  val emp: 'a cache
+  val find: (t -> 'a) -> t -> 'a cache -> 'a cache * 'a
+
+  val memo: (t -> 'a) -> (t -> 'a)
+end

web/site.cd

@@ -33,10 +33,13 @@ let [<site>[ <title>site
              (<footer>footer | /(footer:=[])) 
              extra_head::H.script*
              main_page ] ] = 
+(* match load_include input with
+   [ Site ] & x -> x
+ | _ -> exit 2 *)
  try (load_include input :? [ Site ])
  with err & Latin1 -> 
    print ['Invalid input document:\n' !err '\n']; 
-   exit 2 
+   exit 2
 
 (* Highlighting text between {{...}} *)