Commits

Anonymous committed 3c439e6

1.0.0

  • Participants
  • Parent commits 8d9aab3

Comments (0)

Files changed (14)

File META

-name="levenshtein"
-version="1.0.0"
-description="Levenshtein distance"
-requires="pa_ounit"
-archive(byte)="levenshtein.cma"
-archive(native)="levenshtein.cmxa"
-linkopts = ""
-OCAMLPACKS[]= oUnit pa_ounit
+# How-to-build using OMake
+#
+# cp OMakeroot.in OMakeroot # to create OMakeroot for the first time
 
-OCAMLDEPFLAGS= -syntax camlp4o -package pa_ounit.syntax -ppopt -pa-ounit-lib -ppopt Levenshtein
-OCAMLPPFLAGS= -syntax camlp4o -package pa_ounit.syntax -ppopt -pa-ounit-lib -ppopt Levenshtein
+# If OMakeroot is here, include OMyMakefile
+if $(file-exists OMakeroot)
+   include OMyMakefile
+   export
 
-LIBFILES[] =
-   levenshtein
+Subdirs()
 
-LIB = levenshtein
+setup.ml: _oasis
+	oasis setup
 
-MyOCamlLibrary($(LIB), $(LIBFILES))
-
-MyOCamlOUnitTest($(LIB))

File OMakefile.omc

Binary file added.

File OMakeroot.in

+open build/C
+open build/OCaml
+open build/LaTeX
+
+DefineCommandVars()
+
+.SUBDIRS: .
+OASISFormat: 0.2
+Name:        ocaml_levenshtein
+Version:     1.0.0
+Synopsis:    Levenshtein distance algorithm for general array.
+Authors:     Jun FURUSE
+License:     LGPL-2.0 with OCaml linking exception
+Plugins:      StdFiles (0.2)
+BuildType:    Custom (0.2)
+InstallType:    Custom (0.2)
+XCustomBuild:      cp OMakeroot.in OMakeroot; PREFIX=$prefix omake
+XCustomInstall:    cp OMakeroot.in OMakeroot; PREFIX=$prefix omake install
+XCustomUninstall:  cp OMakeroot.in OMakeroot; PREFIX=$prefix omake uninstall
+XCustomBuildClean: cp OMakeroot.in OMakeroot; PREFIX=$prefix omake clean
+BuildTools: omake

File levenshtein.ml

-(**
-
-   Levenshtein distance algorithm for general array.
-   
-   Author: jun.furuse@gmail.com
-   License: public domain
-
-*)
-
-(** Minimum of three integers *)
-let min3 (x:int) y z =
-  let m' (a:int) b = if a < b then a else b in
-  m' (m' x y) z
-
-(* Matrix initialization. 
-
-    ------- 2 ----------
-   | 0123456789...    m
-   | 1
-   1 2          0
-   | .              
-   | n
-*)
-let init_matrix n m =
-  let init_col = Array.init (m+1) in
-  Array.init (n+1) (function
-    | 0 -> init_col (function j -> j)
-    | i -> init_col (function 0 -> i | _ -> 0))
-
-module type S = sig
-  type t
-  val distance : ?upper_bound: int -> t -> t -> int
-  (** Calculate Levenshtein distance of 2 t's *)
-end
-
-module Make(A : sig 
-  type t
-  type elem
-  val compare : elem -> elem -> int
-  val get : t -> int -> elem
-  val size : t -> int
-end) = struct
-
-  type t = A.t
-
-  (* It is simply slow but nearest to the math *)
-  let slow_but_simple xs ys =
-    let rec d i j =
-      match i, j with
-      | 0, _ -> j
-      | _, 0 -> i
-      | _ -> 
-          let i' = i - 1 in
-          let j' = j - 1 in
-          min3 
-            (d i' j + 1)
-            (d i j' + 1)
-            (d i' j' + abs (A.compare (A.get xs i') (A.get ys j')))
-    in
-    d (A.size xs) (A.size ys)
-
-  (* slow_but_simple + memoization *)      
-  let memoized xs ys =
-    let cache = Array.init (A.size xs+1) (fun _ -> Array.create (A.size ys+1) (-1)) in
-    let rec d i j =
-      match i, j with
-      | 0, _ -> j
-      | _, 0 -> i
-      | _ -> 
-          let cache_i = Array.unsafe_get cache i in
-          match Array.unsafe_get cache_i j with
-          | -1 ->
-              let res = 
-                let i' = i - 1 in
-                let j' = j - 1 in
-                min3 
-                  (d i' j + 1)
-                  (d i j' + 1)
-                  (d i' j' + abs (A.compare (A.get xs i') (A.get ys j')))
-              in
-              Array.unsafe_set cache_i j res;
-              res
-          | res -> res
-    in
-    d (A.size xs) (A.size ys)
-
-  (* slow_but_simple + memoization + upperbound 
-
-     There is a property: d(i-1)(j-1) <= d(i)(j)
-     so if d(i-1)(j-1) >= upper_bound then we can immediately say
-     d(i)(j) >= upper_bound, and skip the calculation of d(i-1)(j) and d(i)(j-1)
-  *)
-  let distance ?(upper_bound=max_int) xs ys =
-    let size_xs = A.size xs 
-    and size_ys = A.size ys in
-    (* cache: d i j is stored at cache.(i-1).(j-1) *)
-    let cache = Array.init size_xs (fun _ -> Array.create size_ys (-1)) in
-    let rec d i j =
-      match i, j with
-      | 0, _ -> j
-      | _, 0 -> i
-      | _ -> 
-          let i' = i - 1 in
-          let cache_i = Array.unsafe_get cache i' in
-          let j' = j - 1 in
-          match Array.unsafe_get cache_i j' with
-          | -1 ->
-              let res = 
-                let upleft = d i' j' in
-                if upleft >= upper_bound then upper_bound
-                else 
-                  let cost = abs (A.compare (A.get xs i') (A.get ys j')) in
-                  let upleft' = upleft + cost in
-                  if upleft' >= upper_bound then upper_bound
-                  else
-                    (* This is not tail recursive *)
-                    min3 (d i' j + 1)
-                         (d i j' + 1)
-                         upleft'
-              in
-              Array.unsafe_set cache_i j' res;
-              res
-          | res -> res
-    in
-    min (d size_xs size_ys) upper_bound
-
-  (** http://en.wikibooks.org/wiki/Algorithm_Implementation/Strings/Levenshtein_distance *)
-  let wikibook xs ys =
-    let get = Array.unsafe_get in
-    match A.size xs, A.size ys with
-    | 0, n -> n
-    | m, 0 -> m
-    | m, n ->
-        let matrix = init_matrix m n in
-        (* d(0)(j) = j
-           d(i)(0) = i
-           d(i)(j) = min of d(i-1)(j  ) + 1
-                            d(i)  (j-1) + 1
-                            d(i-1)(j-1) + if x.[i-1] = y.[j-1] then 0 else 1
-        *)
-        for i = 1 to m do
-          let s = get matrix i and t = get matrix (i - 1) in
-          for j = 1 to n do
-            let cost = abs (A.compare (A.get xs (i - 1)) (A.get ys (j - 1))) in
-            Array.unsafe_set s j (min3 (get t j + 1) (get s (j - 1) + 1) (get t (j - 1) + cost))
-          done
-        done;
-        get (get matrix m) n
-end
-
-(** With inter-query cache by hashtbl *)
-
-type result = 
-  | Exact of int
-  | GEQ of int (* the result is culled by upper_bound. We know it is GEQ to this value *)
-
-exception No_cache 
-
-module type WithCache = sig
-  type t
-  module Cache : Hashtbl.S with type key = t * t
-  type cache = result Cache.t
-  val distance : result Cache.t -> ?upper_bound: int -> t -> t -> int
-end
-
-module MakeWithCache(A : sig 
-  type t
-  type elem
-  val compare : elem -> elem -> int
-  val get : t -> int -> elem
-  val size : t -> int
-    
-  module Pair : sig
-    val equal : (t*t) -> (t*t) -> bool
-    val hash : (t*t) -> int
-  end
-end) = struct
-
-  type t = A.t
-
-  module Cache = Hashtbl.Make(struct
-    type t = A.t * A.t
-    include A.Pair
-  end)
-
-  type cache = result Cache.t
-
-  module WithoutCache = Make(A)
-
-  let distance cache ?(upper_bound=max_int) xs ys =
-    (* This accesses the hashtbl twice with the same key,
-       but OCaml's stdlib provides no good way... 
-    *)
-    let k = (xs, ys) in
-    try
-      begin match try Some (Cache.find cache k) with Not_found -> None with
-      | Some (Exact res) when res > upper_bound -> GEQ upper_bound
-      | Some (Exact res) -> Exact res
-      | Some (GEQ res) when res >= upper_bound -> GEQ upper_bound
-      | None (* no cache *)
-      | Some (GEQ _) (* inaccurate with this upper_bound *) ->
-          let res = 
-            let res = WithoutCache.distance ~upper_bound xs ys in
-            if res >= upper_bound then GEQ upper_bound
-            else Exact res
-          in
-          Cache.add cache k res;
-          res
-      end 
-      |> function
-          | Exact n -> n
-          | GEQ n   -> n
-    with
-    | No_cache -> WithoutCache.distance ~upper_bound xs ys
-end
-
-module StringWithCache = MakeWithCache(struct
-  type t = string
-  type elem = char
-  let compare (c1 : char) c2 = compare c1 c2
-  let get = String.unsafe_get
-  let size = String.length
-  module Pair = struct
-    let equal = (=)
-    let hash = Hashtbl.hash
-  end
-end)
-
-module String = struct
-
-  include Make(struct
-    type t = string
-    type elem = char
-    let compare (c1 : char) c2 = compare c1 c2
-    let get = String.unsafe_get
-    let size = String.length
-  end)
-
-  TEST "Levenshtein.String slow_but_simple" =
-    slow_but_simple "xx" "xaaax" = 3
-
-  TEST "Levenshtein.String.distance" =
-    distance "xx" "xaaax" = 3
-
-  let random_char = 
-    let offset = Char.code 'A' in
-    let length = Char.code 'Z' - offset + 1 in
-    fun () -> Char.chr (Random.int length + offset)
-
-  let random len =
-    let s = String.create len in
-    for i = 0 to len - 1 do
-      String.unsafe_set s i (random_char ())
-    done;
-    s
-
-  let test ?(upper_bound=max_int) loop len dist dist' =
-    for i = 0 to loop do
-      if i mod (loop / 10) = 0 then Printf.eprintf "%d\n%!" i;
-      let l1 = Random.int len in
-      let l2 = Random.int len in
-      let s1 = random l1 in
-      let s2 = random l2 in
-      let d = dist s1 s2 in
-      let d' = dist' s1 s2 in
-      if d < upper_bound && d' < upper_bound && d <> d' then begin
-        Printf.eprintf "%s %s : %d %d\n" s1 s2 d d';
-        assert false
-      end
-    done
-
-  TEST_UNIT "wikibook correctness" =  
-    test 1000 10 slow_but_simple wikibook
-
-  TEST_UNIT "memoized and wikibook" =  
-    test 10000 20 memoized wikibook
-
-  TEST_UNIT "distance and wikibook" =  
-    test ~upper_bound:20 100000 30 (distance ~upper_bound:20) wikibook
-
-  TEST_UNIT "distance and wikibook performance check (it takes long time)" =  
-    let sample_size = 100000 in
-    for _i = 1 to 10 do
-      let samples = Array.init sample_size (fun _ -> random 30, random 30) in
-      let time name f v =
-        let () = Gc.full_major () in
-        let start = Unix.gettimeofday () in
-        f v;
-        let end_ = Unix.gettimeofday () in
-        Printf.eprintf "%s : %f\n%!" name (end_ -. start)
-      in
-      let bench d =
-        Array.iter (fun (s1,s2) -> ignore (d s1 s2)) samples
-      in
-      time "wikibook" bench wikibook;
-      time "distance ~upper_bound:20" bench (distance ~upper_bound:20)
-    done
-        
-end

File levenshtein.mli

-(**
-
-   Levenshtein distance algorithm for general array.
-
-   Author: jun.furuse@gmail.com
-   License: public domain
-
-*)
-
-module type S = sig
-  type t
-  val distance : ?upper_bound: int -> t -> t -> int
-  (** Calculate Levenshtein distance of 2 t's.
-      
-      If we are only interested in the distance if it is smaller than 
-      a threshold, specifying [upper_bound] greatly improves the performance
-      of [distance]. In that case, the distances over [upper_bound] is 
-      culled to [upper_bound].
-  *)
-end
-
-module Make(A : sig
-  type t
-  (** Type of arrays *)
-
-  type elem 
-  (** Type of the elements of arrays *)
-
-  val compare : elem -> elem -> int
-  val get : t -> int -> elem
-  val size : t -> int
-
-end) : S with type t = A.t
-
-(** With inter-query cache by hashtbl *)
-
-(** Cached result *)
-type result = 
-  | Exact of int
-  | GEQ of int (** the result is culled by upper_bound. We know it is GEQ to this value *)
-
-exception No_cache 
-(** An exception used to skip caching. See WithCache *)
-
-module type WithCache = sig
-  type t
-  module Cache : Hashtbl.S with type key = t * t
-  type cache = result Cache.t
-  val distance : result Cache.t -> ?upper_bound: int -> t -> t -> int
-end
-
-module MakeWithCache
-  (A : sig
-    (* these are the same as the Make's argument *)
-    type t
-    type elem
-    val compare : elem -> elem -> int
-    val get : t -> int -> elem
-    val size : t -> int
-
-    module Pair : sig
-      val equal : (t*t) -> (t*t) -> bool
-      val hash : (t*t) -> int
-    end
-  end) : WithCache with type t = A.t
-
-module String : S with type t = string
-
-module StringWithCache : WithCache with type t = string
+name="levenshtein"
+version="1.0.0"
+description="Levenshtein distance"
+requires="pa_ounit"
+archive(byte)="levenshtein.cma"
+archive(native)="levenshtein.cmxa"
+linkopts = ""

File lib/OMakefile

+OCAMLPACKS[]= oUnit pa_ounit
+
+OCAMLDEPFLAGS= -syntax camlp4o -package pa_ounit.syntax -ppopt -pa-ounit-lib -ppopt Levenshtein
+OCAMLPPFLAGS= -syntax camlp4o -package pa_ounit.syntax -ppopt -pa-ounit-lib -ppopt Levenshtein
+
+LIBFILES[] =
+   levenshtein
+
+LIB = levenshtein
+
+MyOCamlLibrary($(LIB), $(LIBFILES))
+
+MyOCamlOUnitTest($(LIB))

File lib/levenshtein.ml

+(**
+
+   Levenshtein distance algorithm for general array.
+   
+   Author: jun.furuse@gmail.com
+   License: public domain
+
+*)
+
+(** Minimum of three integers *)
+let min3 (x:int) y z =
+  let m' (a:int) b = if a < b then a else b in
+  m' (m' x y) z
+
+(* Matrix initialization. 
+
+    ------- 2 ----------
+   | 0123456789...    m
+   | 1
+   1 2          0
+   | .              
+   | n
+*)
+let init_matrix n m =
+  let init_col = Array.init (m+1) in
+  Array.init (n+1) (function
+    | 0 -> init_col (function j -> j)
+    | i -> init_col (function 0 -> i | _ -> 0))
+
+module type S = sig
+  type t
+  val distance : ?upper_bound: int -> t -> t -> int
+  (** Calculate Levenshtein distance of 2 t's *)
+end
+
+module Make(A : sig 
+  type t
+  type elem
+  val compare : elem -> elem -> int
+  val get : t -> int -> elem
+  val size : t -> int
+end) = struct
+
+  type t = A.t
+
+  (* It is simply slow but nearest to the math *)
+  let slow_but_simple xs ys =
+    let rec d i j =
+      match i, j with
+      | 0, _ -> j
+      | _, 0 -> i
+      | _ -> 
+          let i' = i - 1 in
+          let j' = j - 1 in
+          min3 
+            (d i' j + 1)
+            (d i j' + 1)
+            (d i' j' + abs (A.compare (A.get xs i') (A.get ys j')))
+    in
+    d (A.size xs) (A.size ys)
+
+  (* slow_but_simple + memoization *)      
+  let memoized xs ys =
+    let cache = Array.init (A.size xs+1) (fun _ -> Array.create (A.size ys+1) (-1)) in
+    let rec d i j =
+      match i, j with
+      | 0, _ -> j
+      | _, 0 -> i
+      | _ -> 
+          let cache_i = Array.unsafe_get cache i in
+          match Array.unsafe_get cache_i j with
+          | -1 ->
+              let res = 
+                let i' = i - 1 in
+                let j' = j - 1 in
+                min3 
+                  (d i' j + 1)
+                  (d i j' + 1)
+                  (d i' j' + abs (A.compare (A.get xs i') (A.get ys j')))
+              in
+              Array.unsafe_set cache_i j res;
+              res
+          | res -> res
+    in
+    d (A.size xs) (A.size ys)
+
+  (* slow_but_simple + memoization + upperbound 
+
+     There is a property: d(i-1)(j-1) <= d(i)(j)
+     so if d(i-1)(j-1) >= upper_bound then we can immediately say
+     d(i)(j) >= upper_bound, and skip the calculation of d(i-1)(j) and d(i)(j-1)
+  *)
+  let distance ?(upper_bound=max_int) xs ys =
+    let size_xs = A.size xs 
+    and size_ys = A.size ys in
+    (* cache: d i j is stored at cache.(i-1).(j-1) *)
+    let cache = Array.init size_xs (fun _ -> Array.create size_ys (-1)) in
+    let rec d i j =
+      match i, j with
+      | 0, _ -> j
+      | _, 0 -> i
+      | _ -> 
+          let i' = i - 1 in
+          let cache_i = Array.unsafe_get cache i' in
+          let j' = j - 1 in
+          match Array.unsafe_get cache_i j' with
+          | -1 ->
+              let res = 
+                let upleft = d i' j' in
+                if upleft >= upper_bound then upper_bound
+                else 
+                  let cost = abs (A.compare (A.get xs i') (A.get ys j')) in
+                  let upleft' = upleft + cost in
+                  if upleft' >= upper_bound then upper_bound
+                  else
+                    (* This is not tail recursive *)
+                    min3 (d i' j + 1)
+                         (d i j' + 1)
+                         upleft'
+              in
+              Array.unsafe_set cache_i j' res;
+              res
+          | res -> res
+    in
+    min (d size_xs size_ys) upper_bound
+
+  (** http://en.wikibooks.org/wiki/Algorithm_Implementation/Strings/Levenshtein_distance *)
+  let wikibook xs ys =
+    let get = Array.unsafe_get in
+    match A.size xs, A.size ys with
+    | 0, n -> n
+    | m, 0 -> m
+    | m, n ->
+        let matrix = init_matrix m n in
+        (* d(0)(j) = j
+           d(i)(0) = i
+           d(i)(j) = min of d(i-1)(j  ) + 1
+                            d(i)  (j-1) + 1
+                            d(i-1)(j-1) + if x.[i-1] = y.[j-1] then 0 else 1
+        *)
+        for i = 1 to m do
+          let s = get matrix i and t = get matrix (i - 1) in
+          for j = 1 to n do
+            let cost = abs (A.compare (A.get xs (i - 1)) (A.get ys (j - 1))) in
+            Array.unsafe_set s j (min3 (get t j + 1) (get s (j - 1) + 1) (get t (j - 1) + cost))
+          done
+        done;
+        get (get matrix m) n
+end
+
+(** With inter-query cache by hashtbl *)
+
+type result = 
+  | Exact of int
+  | GEQ of int (* the result is culled by upper_bound. We know it is GEQ to this value *)
+
+exception No_cache 
+
+module type WithCache = sig
+  type t
+  module Cache : Hashtbl.S with type key = t * t
+  type cache = result Cache.t
+  val distance : result Cache.t -> ?upper_bound: int -> t -> t -> int
+end
+
+module MakeWithCache(A : sig 
+  type t
+  type elem
+  val compare : elem -> elem -> int
+  val get : t -> int -> elem
+  val size : t -> int
+    
+  module Pair : sig
+    val equal : (t*t) -> (t*t) -> bool
+    val hash : (t*t) -> int
+  end
+end) = struct
+
+  type t = A.t
+
+  module Cache = Hashtbl.Make(struct
+    type t = A.t * A.t
+    include A.Pair
+  end)
+
+  type cache = result Cache.t
+
+  module WithoutCache = Make(A)
+
+  let distance cache ?(upper_bound=max_int) xs ys =
+    (* This accesses the hashtbl twice with the same key,
+       but OCaml's stdlib provides no good way... 
+    *)
+    let k = (xs, ys) in
+    try
+      begin match try Some (Cache.find cache k) with Not_found -> None with
+      | Some (Exact res) when res > upper_bound -> GEQ upper_bound
+      | Some (Exact res) -> Exact res
+      | Some (GEQ res) when res >= upper_bound -> GEQ upper_bound
+      | None (* no cache *)
+      | Some (GEQ _) (* inaccurate with this upper_bound *) ->
+          let res = 
+            let res = WithoutCache.distance ~upper_bound xs ys in
+            if res >= upper_bound then GEQ upper_bound
+            else Exact res
+          in
+          Cache.add cache k res;
+          res
+      end 
+      |> function
+          | Exact n -> n
+          | GEQ n   -> n
+    with
+    | No_cache -> WithoutCache.distance ~upper_bound xs ys
+end
+
+module StringWithCache = MakeWithCache(struct
+  type t = string
+  type elem = char
+  let compare (c1 : char) c2 = compare c1 c2
+  let get = String.unsafe_get
+  let size = String.length
+  module Pair = struct
+    let equal = (=)
+    let hash = Hashtbl.hash
+  end
+end)
+
+module String = struct
+
+  include Make(struct
+    type t = string
+    type elem = char
+    let compare (c1 : char) c2 = compare c1 c2
+    let get = String.unsafe_get
+    let size = String.length
+  end)
+
+  TEST "Levenshtein.String slow_but_simple" =
+    slow_but_simple "xx" "xaaax" = 3
+
+  TEST "Levenshtein.String.distance" =
+    distance "xx" "xaaax" = 3
+
+  let random_char = 
+    let offset = Char.code 'A' in
+    let length = Char.code 'Z' - offset + 1 in
+    fun () -> Char.chr (Random.int length + offset)
+
+  let random len =
+    let s = String.create len in
+    for i = 0 to len - 1 do
+      String.unsafe_set s i (random_char ())
+    done;
+    s
+
+  let test ?(upper_bound=max_int) loop len dist dist' =
+    for i = 0 to loop do
+      if i mod (loop / 10) = 0 then Printf.eprintf "%d\n%!" i;
+      let l1 = Random.int len in
+      let l2 = Random.int len in
+      let s1 = random l1 in
+      let s2 = random l2 in
+      let d = dist s1 s2 in
+      let d' = dist' s1 s2 in
+      if d < upper_bound && d' < upper_bound && d <> d' then begin
+        Printf.eprintf "%s %s : %d %d\n" s1 s2 d d';
+        assert false
+      end
+    done
+
+  TEST_UNIT "wikibook correctness" =  
+    test 1000 10 slow_but_simple wikibook
+
+  TEST_UNIT "memoized and wikibook" =  
+    test 10000 20 memoized wikibook
+
+  TEST_UNIT "distance and wikibook" =  
+    test ~upper_bound:20 100000 30 (distance ~upper_bound:20) wikibook
+
+  TEST_UNIT "distance and wikibook performance check (it takes long time)" =  
+    let sample_size = 100000 in
+    for _i = 1 to 10 do
+      let samples = Array.init sample_size (fun _ -> random 30, random 30) in
+      let time name f v =
+        let () = Gc.full_major () in
+        let start = Unix.gettimeofday () in
+        f v;
+        let end_ = Unix.gettimeofday () in
+        Printf.eprintf "%s : %f\n%!" name (end_ -. start)
+      in
+      let bench d =
+        Array.iter (fun (s1,s2) -> ignore (d s1 s2)) samples
+      in
+      time "wikibook" bench wikibook;
+      time "distance ~upper_bound:20" bench (distance ~upper_bound:20)
+    done
+        
+end

File lib/levenshtein.mli

+(**
+
+   Levenshtein distance algorithm for general array.
+
+   Author: jun.furuse@gmail.com
+   License: public domain
+
+*)
+
+module type S = sig
+  type t
+  val distance : ?upper_bound: int -> t -> t -> int
+  (** Calculate Levenshtein distance of 2 t's.
+      
+      If we are only interested in the distance if it is smaller than 
+      a threshold, specifying [upper_bound] greatly improves the performance
+      of [distance]. In that case, the distances over [upper_bound] is 
+      culled to [upper_bound].
+  *)
+end
+
+module Make(A : sig
+  type t
+  (** Type of arrays *)
+
+  type elem 
+  (** Type of the elements of arrays *)
+
+  val compare : elem -> elem -> int
+  val get : t -> int -> elem
+  val size : t -> int
+
+end) : S with type t = A.t
+
+(** With inter-query cache by hashtbl *)
+
+(** Cached result *)
+type result = 
+  | Exact of int
+  | GEQ of int (** the result is culled by upper_bound. We know it is GEQ to this value *)
+
+exception No_cache 
+(** An exception used to skip caching. See WithCache *)
+
+module type WithCache = sig
+  type t
+  module Cache : Hashtbl.S with type key = t * t
+  type cache = result Cache.t
+  val distance : result Cache.t -> ?upper_bound: int -> t -> t -> int
+end
+
+module MakeWithCache
+  (A : sig
+    (* these are the same as the Make's argument *)
+    type t
+    type elem
+    val compare : elem -> elem -> int
+    val get : t -> int -> elem
+    val size : t -> int
+
+    module Pair : sig
+      val equal : (t*t) -> (t*t) -> bool
+      val hash : (t*t) -> int
+    end
+  end) : WithCache with type t = A.t
+
+module String : S with type t = string
+
+module StringWithCache : WithCache with type t = string

File opam/template/descr

+Levenshtein distance algorithm for general array.
+Levenshtein distance algorithm for general array.

File opam/template/opam

+depends: [ 
+  "ocamlfind" 
+  "omake"
+  "pa_ounit" {>="109.53.02"}
+]
+ocaml-version: [>= "4.01.0"]
+(* setup.ml generated for the first time by OASIS v0.4.4 *)
+
+(* OASIS_START *)
+(* DO NOT EDIT (digest: 718384b9b7cc76f954c1a2f70af75018) *)
+(*
+   Regenerated by OASIS v0.4.4
+   Visit http://oasis.forge.ocamlcore.org for more information and
+   documentation about functions used in this file.
+*)
+module OASISGettext = struct
+(* # 22 "src/oasis/OASISGettext.ml" *)
+
+
+  let ns_ str =
+    str
+
+
+  let s_ str =
+    str
+
+
+  let f_ (str: ('a, 'b, 'c, 'd) format4) =
+    str
+
+
+  let fn_ fmt1 fmt2 n =
+    if n = 1 then
+      fmt1^^""
+    else
+      fmt2^^""
+
+
+  let init =
+    []
+
+
+end
+
+module OASISContext = struct
+(* # 22 "src/oasis/OASISContext.ml" *)
+
+
+  open OASISGettext
+
+
+  type level =
+    [ `Debug
+    | `Info
+    | `Warning
+    | `Error]
+
+
+  type t =
+    {
+      (* TODO: replace this by a proplist. *)
+      quiet:                 bool;
+      info:                  bool;
+      debug:                 bool;
+      ignore_plugins:        bool;
+      ignore_unknown_fields: bool;
+      printf:                level -> string -> unit;
+    }
+
+
+  let printf lvl str =
+    let beg =
+      match lvl with
+        | `Error -> s_ "E: "
+        | `Warning -> s_ "W: "
+        | `Info  -> s_ "I: "
+        | `Debug -> s_ "D: "
+    in
+      prerr_endline (beg^str)
+
+
+  let default =
+    ref
+      {
+        quiet                 = false;
+        info                  = false;
+        debug                 = false;
+        ignore_plugins        = false;
+        ignore_unknown_fields = false;
+        printf                = printf;
+      }
+
+
+  let quiet =
+    {!default with quiet = true}
+
+
+  let fspecs () =
+    (* TODO: don't act on default. *)
+    let ignore_plugins = ref false in
+    ["-quiet",
+     Arg.Unit (fun () -> default := {!default with quiet = true}),
+     s_ " Run quietly";
+
+     "-info",
+     Arg.Unit (fun () -> default := {!default with info = true}),
+     s_ " Display information message";
+
+
+     "-debug",
+     Arg.Unit (fun () -> default := {!default with debug = true}),
+     s_ " Output debug message";
+
+     "-ignore-plugins",
+     Arg.Set ignore_plugins,
+     s_ " Ignore plugin's field.";
+
+     "-C",
+     (* TODO: remove this chdir. *)
+     Arg.String (fun str -> Sys.chdir str),
+     s_ "dir Change directory before running."],
+    fun () -> {!default with ignore_plugins = !ignore_plugins}
+end
+
+module OASISString = struct
+(* # 22 "src/oasis/OASISString.ml" *)
+
+
+  (** Various string utilities.
+
+      Mostly inspired by extlib and batteries ExtString and BatString libraries.
+
+      @author Sylvain Le Gall
+    *)
+
+
+  let nsplitf str f =
+    if str = "" then
+      []
+    else
+      let buf = Buffer.create 13 in
+      let lst = ref [] in
+      let push () =
+        lst := Buffer.contents buf :: !lst;
+        Buffer.clear buf
+      in
+      let str_len = String.length str in
+        for i = 0 to str_len - 1 do
+          if f str.[i] then
+            push ()
+          else
+            Buffer.add_char buf str.[i]
+        done;
+        push ();
+        List.rev !lst
+
+
+  (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
+      separator.
+    *)
+  let nsplit str c =
+    nsplitf str ((=) c)
+
+
+  let find ~what ?(offset=0) str =
+    let what_idx = ref 0 in
+    let str_idx = ref offset in
+      while !str_idx < String.length str &&
+            !what_idx < String.length what do
+        if str.[!str_idx] = what.[!what_idx] then
+          incr what_idx
+        else
+          what_idx := 0;
+        incr str_idx
+      done;
+      if !what_idx <> String.length what then
+        raise Not_found
+      else
+        !str_idx - !what_idx
+
+
+  let sub_start str len =
+    let str_len = String.length str in
+    if len >= str_len then
+      ""
+    else
+      String.sub str len (str_len - len)
+
+
+  let sub_end ?(offset=0) str len =
+    let str_len = String.length str in
+    if len >= str_len then
+      ""
+    else
+      String.sub str 0 (str_len - len)
+
+
+  let starts_with ~what ?(offset=0) str =
+    let what_idx = ref 0 in
+    let str_idx = ref offset in
+    let ok = ref true in
+      while !ok &&
+            !str_idx < String.length str &&
+            !what_idx < String.length what do
+        if str.[!str_idx] = what.[!what_idx] then
+          incr what_idx
+        else
+          ok := false;
+        incr str_idx
+      done;
+      if !what_idx = String.length what then
+        true
+      else
+        false
+
+
+  let strip_starts_with ~what str =
+    if starts_with ~what str then
+      sub_start str (String.length what)
+    else
+      raise Not_found
+
+
+  let ends_with ~what ?(offset=0) str =
+    let what_idx = ref ((String.length what) - 1) in
+    let str_idx = ref ((String.length str) - 1) in
+    let ok = ref true in
+      while !ok &&
+            offset <= !str_idx &&
+            0 <= !what_idx do
+        if str.[!str_idx] = what.[!what_idx] then
+          decr what_idx
+        else
+          ok := false;
+        decr str_idx
+      done;
+      if !what_idx = -1 then
+        true
+      else
+        false
+
+
+  let strip_ends_with ~what str =
+    if ends_with ~what str then
+      sub_end str (String.length what)
+    else
+      raise Not_found
+
+
+  let replace_chars f s =
+    let buf = String.make (String.length s) 'X' in
+      for i = 0 to String.length s - 1 do
+        buf.[i] <- f s.[i]
+      done;
+      buf
+
+
+end
+
+module OASISUtils = struct
+(* # 22 "src/oasis/OASISUtils.ml" *)
+
+
+  open OASISGettext
+
+
+  module MapExt =
+  struct
+    module type S =
+    sig
+      include Map.S
+      val add_list: 'a t -> (key * 'a) list -> 'a t
+      val of_list: (key * 'a) list -> 'a t
+      val to_list: 'a t -> (key * 'a) list
+    end
+
+    module Make (Ord: Map.OrderedType) =
+    struct
+      include Map.Make(Ord)
+
+      let rec add_list t =
+        function
+          | (k, v) :: tl -> add_list (add k v t) tl
+          | [] -> t
+
+      let of_list lst = add_list empty lst
+
+      let to_list t = fold (fun k v acc -> (k, v) :: acc) t []
+    end
+  end
+
+
+  module MapString = MapExt.Make(String)
+
+
+  module SetExt  =
+  struct
+    module type S =
+    sig
+      include Set.S
+      val add_list: t -> elt list -> t
+      val of_list: elt list -> t
+      val to_list: t -> elt list
+    end
+
+    module Make (Ord: Set.OrderedType) =
+    struct
+      include Set.Make(Ord)
+
+      let rec add_list t =
+        function
+          | e :: tl -> add_list (add e t) tl
+          | [] -> t
+
+      let of_list lst = add_list empty lst
+
+      let to_list = elements
+    end
+  end
+
+
+  module SetString = SetExt.Make(String)
+
+
+  let compare_csl s1 s2 =
+    String.compare (String.lowercase s1) (String.lowercase s2)
+
+
+  module HashStringCsl =
+    Hashtbl.Make
+      (struct
+         type t = string
+
+         let equal s1 s2 =
+             (String.lowercase s1) = (String.lowercase s2)
+
+         let hash s =
+           Hashtbl.hash (String.lowercase s)
+       end)
+
+  module SetStringCsl =
+    SetExt.Make
+      (struct
+         type t = string
+         let compare = compare_csl
+       end)
+
+
+  let varname_of_string ?(hyphen='_') s =
+    if String.length s = 0 then
+      begin
+        invalid_arg "varname_of_string"
+      end
+    else
+      begin
+        let buf =
+          OASISString.replace_chars
+            (fun c ->
+               if ('a' <= c && c <= 'z')
+                 ||
+                  ('A' <= c && c <= 'Z')
+                 ||
+                  ('0' <= c && c <= '9') then
+                 c
+               else
+                 hyphen)
+            s;
+        in
+        let buf =
+          (* Start with a _ if digit *)
+          if '0' <= s.[0] && s.[0] <= '9' then
+            "_"^buf
+          else
+            buf
+        in
+          String.lowercase buf
+      end
+
+
+  let varname_concat ?(hyphen='_') p s =
+    let what = String.make 1 hyphen in
+    let p =
+      try
+        OASISString.strip_ends_with ~what p
+      with Not_found ->
+        p
+    in
+    let s =
+      try
+        OASISString.strip_starts_with ~what s
+      with Not_found ->
+        s
+    in
+      p^what^s
+
+
+  let is_varname str =
+    str = varname_of_string str
+
+
+  let failwithf fmt = Printf.ksprintf failwith fmt
+
+
+end
+
+module PropList = struct
+(* # 22 "src/oasis/PropList.ml" *)
+
+
+  open OASISGettext
+
+
+  type name = string
+
+
+  exception Not_set of name * string option
+  exception No_printer of name
+  exception Unknown_field of name * name
+
+
+  let () =
+    Printexc.register_printer
+      (function
+         | Not_set (nm, Some rsn) ->
+             Some
+               (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn)
+         | Not_set (nm, None) ->
+             Some
+               (Printf.sprintf (f_ "Field '%s' is not set") nm)
+         | No_printer nm ->
+             Some
+               (Printf.sprintf (f_ "No default printer for value %s") nm)
+         | Unknown_field (nm, schm) ->
+             Some
+               (Printf.sprintf
+                  (f_ "Field %s is not defined in schema %s") nm schm)
+         | _ ->
+             None)
+
+
+  module Data =
+  struct
+    type t =
+        (name, unit -> unit) Hashtbl.t
+
+    let create () =
+      Hashtbl.create 13
+
+    let clear t =
+      Hashtbl.clear t
+
+
+(* # 78 "src/oasis/PropList.ml" *)
+  end
+
+
+  module Schema =
+  struct
+    type ('ctxt, 'extra) value =
+        {
+          get:   Data.t -> string;
+          set:   Data.t -> ?context:'ctxt -> string -> unit;
+          help:  (unit -> string) option;
+          extra: 'extra;
+        }
+
+    type ('ctxt, 'extra) t =
+        {
+          name:      name;
+          fields:    (name, ('ctxt, 'extra) value) Hashtbl.t;
+          order:     name Queue.t;
+          name_norm: string -> string;
+        }
+
+    let create ?(case_insensitive=false) nm =
+      {
+        name      = nm;
+        fields    = Hashtbl.create 13;
+        order     = Queue.create ();
+        name_norm =
+          (if case_insensitive then
+             String.lowercase
+           else
+             fun s -> s);
+      }
+
+    let add t nm set get extra help =
+      let key =
+        t.name_norm nm
+      in
+
+        if Hashtbl.mem t.fields key then
+          failwith
+            (Printf.sprintf
+               (f_ "Field '%s' is already defined in schema '%s'")
+               nm t.name);
+        Hashtbl.add
+          t.fields
+          key
+          {
+            set   = set;
+            get   = get;
+            help  = help;
+            extra = extra;
+          };
+        Queue.add nm t.order
+
+    let mem t nm =
+      Hashtbl.mem t.fields nm
+
+    let find t nm =
+      try
+        Hashtbl.find t.fields (t.name_norm nm)
+      with Not_found ->
+        raise (Unknown_field (nm, t.name))
+
+    let get t data nm =
+      (find t nm).get data
+
+    let set t data nm ?context x =
+      (find t nm).set
+        data
+        ?context
+        x
+
+    let fold f acc t =
+      Queue.fold
+        (fun acc k ->
+           let v =
+             find t k
+           in
+             f acc k v.extra v.help)
+        acc
+        t.order
+
+    let iter f t =
+      fold
+        (fun () -> f)
+        ()
+        t
+
+    let name t =
+      t.name
+  end
+
+
+  module Field =
+  struct
+    type ('ctxt, 'value, 'extra) t =
+        {
+          set:    Data.t -> ?context:'ctxt -> 'value -> unit;
+          get:    Data.t -> 'value;
+          sets:   Data.t -> ?context:'ctxt -> string -> unit;
+          gets:   Data.t -> string;
+          help:   (unit -> string) option;
+          extra:  'extra;
+        }
+
+    let new_id =
+      let last_id =
+        ref 0
+      in
+        fun () -> incr last_id; !last_id
+
+    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
+      (* Default value container *)
+      let v =
+        ref None
+      in
+
+      (* If name is not given, create unique one *)
+      let nm =
+        match name with
+          | Some s -> s
+          | None -> Printf.sprintf "_anon_%d" (new_id ())
+      in
+
+      (* Last chance to get a value: the default *)
+      let default () =
+        match default with
+          | Some d -> d
+          | None -> raise (Not_set (nm, Some (s_ "no default value")))
+      in
+
+      (* Get data *)
+      let get data =
+        (* Get value *)
+        try
+          (Hashtbl.find data nm) ();
+          match !v with
+            | Some x -> x
+            | None -> default ()
+        with Not_found ->
+          default ()
+      in
+
+      (* Set data *)
+      let set data ?context x =
+        let x =
+          match update with
+            | Some f ->
+                begin
+                  try
+                    f ?context (get data) x
+                  with Not_set _ ->
+                    x
+                end
+            | None ->
+                x
+        in
+          Hashtbl.replace
+            data
+            nm
+            (fun () -> v := Some x)
+      in
+
+      (* Parse string value, if possible *)
+      let parse =
+        match parse with
+          | Some f ->
+              f
+          | None ->
+              fun ?context s ->
+                failwith
+                  (Printf.sprintf
+                     (f_ "Cannot parse field '%s' when setting value %S")
+                     nm
+                     s)
+      in
+
+      (* Set data, from string *)
+      let sets data ?context s =
+        set ?context data (parse ?context s)
+      in
+
+      (* Output value as string, if possible *)
+      let print =
+        match print with
+          | Some f ->
+              f
+          | None ->
+              fun _ -> raise (No_printer nm)
+      in
+
+      (* Get data, as a string *)
+      let gets data =
+        print (get data)
+      in
+
+        begin
+          match schema with
+            | Some t ->
+                Schema.add t nm sets gets extra help
+            | None ->
+                ()
+        end;
+
+        {
+          set   = set;
+          get   = get;
+          sets  = sets;
+          gets  = gets;
+          help  = help;
+          extra = extra;
+        }
+
+    let fset data t ?context x =
+      t.set data ?context x
+
+    let fget data t =
+      t.get data
+
+    let fsets data t ?context s =
+      t.sets data ?context s
+
+    let fgets data t =
+      t.gets data
+  end
+
+
+  module FieldRO =
+  struct
+    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
+      let fld =
+        Field.create ?schema ?name ?parse ?print ?default ?update ?help extra
+      in
+        fun data -> Field.fget data fld
+  end
+end
+
+module OASISMessage = struct
+(* # 22 "src/oasis/OASISMessage.ml" *)
+
+
+  open OASISGettext
+  open OASISContext
+
+
+  let generic_message ~ctxt lvl fmt =
+    let cond =
+      if ctxt.quiet then
+        false
+      else
+        match lvl with
+          | `Debug -> ctxt.debug
+          | `Info  -> ctxt.info
+          | _ -> true
+    in
+      Printf.ksprintf
+        (fun str ->
+           if cond then
+             begin
+               ctxt.printf lvl str
+             end)
+        fmt
+
+
+  let debug ~ctxt fmt =
+    generic_message ~ctxt `Debug fmt
+
+
+  let info ~ctxt fmt =
+    generic_message ~ctxt `Info fmt
+
+
+  let warning ~ctxt fmt =
+    generic_message ~ctxt `Warning fmt
+
+
+  let error ~ctxt fmt =
+    generic_message ~ctxt `Error fmt
+
+end
+
+module OASISVersion = struct
+(* # 22 "src/oasis/OASISVersion.ml" *)
+
+
+  open OASISGettext
+
+
+
+
+
+  type s = string
+
+
+  type t = string
+
+
+  type comparator =
+    | VGreater of t
+    | VGreaterEqual of t
+    | VEqual of t
+    | VLesser of t
+    | VLesserEqual of t
+    | VOr of  comparator * comparator
+    | VAnd of comparator * comparator
+
+
+
+  (* Range of allowed characters *)
+  let is_digit c =
+    '0' <= c && c <= '9'
+
+
+  let is_alpha c =
+    ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')
+
+
+  let is_special =
+    function
+      | '.' | '+' | '-' | '~' -> true
+      | _ -> false
+
+
+  let rec version_compare v1 v2 =
+    if v1 <> "" || v2 <> "" then
+      begin
+        (* Compare ascii string, using special meaning for version
+         * related char
+         *)
+        let val_ascii c =
+          if c = '~' then -1
+          else if is_digit c then 0
+          else if c = '\000' then 0
+          else if is_alpha c then Char.code c
+          else (Char.code c) + 256
+        in
+
+        let len1 = String.length v1 in
+        let len2 = String.length v2 in
+
+        let p = ref 0 in
+
+        (** Compare ascii part *)
+        let compare_vascii () =
+          let cmp = ref 0 in
+          while !cmp = 0 &&
+                !p < len1 && !p < len2 &&
+                not (is_digit v1.[!p] && is_digit v2.[!p]) do
+            cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]);
+            incr p
+          done;
+          if !cmp = 0 && !p < len1 && !p = len2 then
+            val_ascii v1.[!p]
+          else if !cmp = 0 && !p = len1 && !p < len2 then
+            - (val_ascii v2.[!p])
+          else
+            !cmp
+        in
+
+        (** Compare digit part *)
+        let compare_digit () =
+          let extract_int v p =
+            let start_p = !p in
+              while !p < String.length v && is_digit v.[!p] do
+                incr p
+              done;
+              let substr =
+                String.sub v !p ((String.length v) - !p)
+              in
+              let res =
+                match String.sub v start_p (!p - start_p) with
+                  | "" -> 0
+                  | s -> int_of_string s
+              in
+                res, substr
+          in
+          let i1, tl1 = extract_int v1 (ref !p) in
+          let i2, tl2 = extract_int v2 (ref !p) in
+            i1 - i2, tl1, tl2
+        in
+
+          match compare_vascii () with
+            | 0 ->
+                begin
+                  match compare_digit () with
+                    | 0, tl1, tl2 ->
+                        if tl1 <> "" && is_digit tl1.[0] then
+                          1
+                        else if tl2 <> "" && is_digit tl2.[0] then
+                          -1
+                        else
+                          version_compare tl1 tl2
+                    | n, _, _ ->
+                        n
+                end
+            | n ->
+                n
+      end
+    else
+      begin
+        0
+      end
+
+
+  let version_of_string str = str
+
+
+  let string_of_version t = t
+
+
+  let version_compare_string s1 s2 =
+    version_compare (version_of_string s1) (version_of_string s2)
+
+
+  let chop t =
+    try
+      let pos =
+        String.rindex t '.'
+      in
+        String.sub t 0 pos
+    with Not_found ->
+      t
+
+
+  let rec comparator_apply v op =
+    match op with
+      | VGreater cv ->
+          (version_compare v cv) > 0
+      | VGreaterEqual cv ->
+          (version_compare v cv) >= 0
+      | VLesser cv ->
+          (version_compare v cv) < 0
+      | VLesserEqual cv ->
+          (version_compare v cv) <= 0
+      | VEqual cv ->
+          (version_compare v cv) = 0
+      | VOr (op1, op2) ->
+          (comparator_apply v op1) || (comparator_apply v op2)
+      | VAnd (op1, op2) ->
+          (comparator_apply v op1) && (comparator_apply v op2)
+
+
+  let rec string_of_comparator =
+    function
+      | VGreater v  -> "> "^(string_of_version v)
+      | VEqual v    -> "= "^(string_of_version v)
+      | VLesser v   -> "< "^(string_of_version v)
+      | VGreaterEqual v -> ">= "^(string_of_version v)
+      | VLesserEqual v  -> "<= "^(string_of_version v)
+      | VOr (c1, c2)  ->
+          (string_of_comparator c1)^" || "^(string_of_comparator c2)
+      | VAnd (c1, c2) ->
+          (string_of_comparator c1)^" && "^(string_of_comparator c2)
+
+
+  let rec varname_of_comparator =
+    let concat p v =
+      OASISUtils.varname_concat
+        p
+        (OASISUtils.varname_of_string
+           (string_of_version v))
+    in
+      function
+        | VGreater v -> concat "gt" v
+        | VLesser v  -> concat "lt" v
+        | VEqual v   -> concat "eq" v
+        | VGreaterEqual v -> concat "ge" v
+        | VLesserEqual v  -> concat "le" v
+        | VOr (c1, c2) ->
+            (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2)
+        | VAnd (c1, c2) ->
+            (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2)
+
+
+  let rec comparator_ge v' =
+    let cmp v = version_compare v v' >= 0 in
+    function
+      | VEqual v
+      | VGreaterEqual v
+      | VGreater v -> cmp v
+      | VLesserEqual _
+      | VLesser _ -> false
+      | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2
+      | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2
+
+
+end
+
+module OASISLicense = struct
+(* # 22 "src/oasis/OASISLicense.ml" *)
+
+
+  (** License for _oasis fields
+      @author Sylvain Le Gall
+    *)
+
+
+
+
+
+  type license = string
+
+
+  type license_exception = string
+
+
+  type license_version =
+    | Version of OASISVersion.t
+    | VersionOrLater of OASISVersion.t
+    | NoVersion
+
+
+
+  type license_dep_5_unit =
+    {
+      license:   license;
+      excption:  license_exception option;
+      version:   license_version;
+    }
+
+
+
+  type license_dep_5 =
+    | DEP5Unit of license_dep_5_unit
+    | DEP5Or of license_dep_5 list
+    | DEP5And of license_dep_5 list
+
+
+  type t =
+    | DEP5License of license_dep_5
+    | OtherLicense of string (* URL *)
+
+
+
+end
+
+module OASISExpr = struct
+(* # 22 "src/oasis/OASISExpr.ml" *)
+
+
+
+
+
+  open OASISGettext
+
+
+  type test = string
+
+
+  type flag = string
+
+
+  type t =
+    | EBool of bool
+    | ENot of t
+    | EAnd of t * t
+    | EOr of t * t
+    | EFlag of flag
+    | ETest of test * string
+
+
+
+  type 'a choices = (t * 'a) list
+
+
+  let eval var_get t =
+    let rec eval' =
+      function
+        | EBool b ->
+            b
+
+        | ENot e ->
+            not (eval' e)
+
+        | EAnd (e1, e2) ->
+            (eval' e1) && (eval' e2)
+
+        | EOr (e1, e2) ->
+            (eval' e1) || (eval' e2)
+
+        | EFlag nm ->
+            let v =
+              var_get nm
+            in
+              assert(v = "true" || v = "false");
+              (v = "true")
+
+        | ETest (nm, vl) ->
+            let v =
+              var_get nm
+            in
+              (v = vl)
+    in
+      eval' t
+
+
+  let choose ?printer ?name var_get lst =
+    let rec choose_aux =
+      function
+        | (cond, vl) :: tl ->
+            if eval var_get cond then
+              vl
+            else
+              choose_aux tl
+        | [] ->
+            let str_lst =
+              if lst = [] then
+                s_ "<empty>"
+              else
+                String.concat
+                  (s_ ", ")
+                  (List.map
+                     (fun (cond, vl) ->
+                        match printer with
+                          | Some p -> p vl
+                          | None -> s_ "<no printer>")
+                     lst)
+            in
+              match name with
+                | Some nm ->
+                    failwith
+                      (Printf.sprintf
+                         (f_ "No result for the choice list '%s': %s")
+                         nm str_lst)
+                | None ->
+                    failwith
+                      (Printf.sprintf
+                         (f_ "No result for a choice list: %s")
+                         str_lst)
+    in
+      choose_aux (List.rev lst)
+
+
+end
+
+module OASISText = struct
+(* # 22 "src/oasis/OASISText.ml" *)
+
+
+
+  type elt =
+    | Para of string
+    | Verbatim of string
+    | BlankLine
+
+
+  type t = elt list
+
+end
+
+module OASISTypes = struct
+(* # 22 "src/oasis/OASISTypes.ml" *)
+
+
+
+
+
+  type name          = string
+  type package_name  = string
+  type url           = string
+  type unix_dirname  = string
+  type unix_filename = string
+  type host_dirname  = string
+  type host_filename = string
+  type prog          = string
+  type arg           = string
+  type args          = string list
+  type command_line  = (prog * arg list)
+
+
+  type findlib_name = string
+  type findlib_full = string
+
+
+  type compiled_object =
+    | Byte
+    | Native
+    | Best
+
+
+
+  type dependency =
+    | FindlibPackage of findlib_full * OASISVersion.comparator option
+    | InternalLibrary of name
+
+
+
+  type tool =
+    | ExternalTool of name
+    | InternalExecutable of name
+
+
+
+  type vcs =
+    | Darcs
+    | Git
+    | Svn
+    | Cvs
+    | Hg
+    | Bzr
+    | Arch
+    | Monotone
+    | OtherVCS of url
+
+
+
+  type plugin_kind =
+      [  `Configure
+       | `Build
+       | `Doc
+       | `Test
+       | `Install
+       | `Extra
+      ]
+
+
+  type plugin_data_purpose =
+      [  `Configure
+       | `Build
+       | `Install
+       | `Clean
+       | `Distclean
+       | `Install
+       | `Uninstall
+       | `Test
+       | `Doc
+       | `Extra
+       | `Other of string
+      ]
+
+
+  type 'a plugin = 'a * name * OASISVersion.t option
+
+
+  type all_plugin = plugin_kind plugin
+
+
+  type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list
+
+
+(* # 115 "src/oasis/OASISTypes.ml" *)
+
+
+  type 'a conditional = 'a OASISExpr.choices
+
+
+  type custom =
+      {
+        pre_command:  (command_line option) conditional;
+        post_command: (command_line option) conditional;
+      }
+
+
+
+  type common_section =
+      {
+        cs_name: name;
+        cs_data: PropList.Data.t;
+        cs_plugin_data: plugin_data;
+      }
+
+
+
+  type build_section =
+      {
+        bs_build:           bool conditional;
+        bs_install:         bool conditional;
+        bs_path:            unix_dirname;
+        bs_compiled_object: compiled_object;
+        bs_build_depends:   dependency list;
+        bs_build_tools:     tool list;
+        bs_c_sources:       unix_filename list;
+        bs_data_files:      (unix_filename * unix_filename option) list;
+        bs_ccopt:           args conditional;
+        bs_cclib:           args conditional;
+        bs_dlllib:          args conditional;
+        bs_dllpath:         args conditional;
+        bs_byteopt:         args conditional;
+        bs_nativeopt:       args conditional;
+      }
+
+
+
+  type library =
+      {
+        lib_modules:            string list;
+        lib_pack:               bool;
+        lib_internal_modules:   string list;
+        lib_findlib_parent:     findlib_name option;
+        lib_findlib_name:       findlib_name option;
+        lib_findlib_containers: findlib_name list;
+      }
+
+
+  type object_ =
+      {
+        obj_modules:            string list;
+        obj_findlib_fullname:   findlib_name list option;
+      }
+
+
+  type executable =
+      {
+        exec_custom:          bool;
+        exec_main_is:         unix_filename;
+      }
+
+
+  type flag =
+      {
+        flag_description:  string option;
+        flag_default:      bool conditional;
+      }
+
+
+  type source_repository =
+      {
+        src_repo_type:        vcs;
+        src_repo_location:    url;
+        src_repo_browser:     url option;
+        src_repo_module:      string option;
+        src_repo_branch:      string option;
+        src_repo_tag:         string option;
+        src_repo_subdir:      unix_filename option;
+      }
+
+
+  type test =
+      {
+        test_type:               [`Test] plugin;
+        test_command:            command_line conditional;
+        test_custom:             custom;
+        test_working_directory:  unix_filename option;
+        test_run:                bool conditional;
+        test_tools:              tool list;
+      }
+
+
+  type doc_format =
+    | HTML of unix_filename
+    | DocText
+    | PDF
+    | PostScript
+    | Info of unix_filename
+    | DVI
+    | OtherDoc
+
+
+
+  type doc =
+      {
+        doc_type:        [`Doc] plugin;
+        doc_custom:      custom;
+        doc_build:       bool conditional;
+        doc_install:     bool conditional;
+        doc_install_dir: unix_filename;
+        doc_title:       string;
+        doc_authors:     string list;
+        doc_abstract:    string option;
+        doc_format:      doc_format;
+        doc_data_files:  (unix_filename * unix_filename option) list;
+        doc_build_tools: tool list;
+      }
+
+
+  type section =
+    | Library    of common_section * build_section * library
+    | Object     of common_section * build_section * object_
+    | Executable of common_section * build_section * executable
+    | Flag       of common_section * flag
+    | SrcRepo    of common_section * source_repository
+    | Test       of common_section * test
+    | Doc        of common_section * doc
+
+
+
+  type section_kind =
+      [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ]
+
+
+  type package =
+      {
+        oasis_version:          OASISVersion.t;
+        ocaml_version:          OASISVersion.comparator option;
+        findlib_version:        OASISVersion.comparator option;
+        alpha_features:         string list;
+        beta_features:          string list;
+        name:                   package_name;
+        version:                OASISVersion.t;
+        license:                OASISLicense.t;
+        license_file:           unix_filename option;
+        copyrights:             string list;
+        maintainers:            string list;
+        authors:                string list;
+        homepage:               url option;
+        synopsis:               string;
+        description:            OASISText.t option;
+        categories:             url list;
+
+        conf_type:              [`Configure] plugin;
+        conf_custom:            custom;
+
+        build_type:             [`Build] plugin;
+        build_custom:           custom;
+
+        install_type:           [`Install] plugin;
+        install_custom:         custom;
+        uninstall_custom:       custom;
+
+        clean_custom:           custom;
+        distclean_custom:       custom;
+
+        files_ab:               unix_filename list;
+        sections:               section list;
+        plugins:                [`Extra] plugin list;
+        disable_oasis_section:  unix_filename list;
+        schema_data:            PropList.Data.t;
+        plugin_data:            plugin_data;
+      }
+
+
+end
+
+module OASISFeatures = struct
+(* # 22 "src/oasis/OASISFeatures.ml" *)
+
+  open OASISTypes
+  open OASISUtils
+  open OASISGettext
+  open OASISVersion
+
+  module MapPlugin =
+    Map.Make
+      (struct
+         type t = plugin_kind * name
+         let compare = Pervasives.compare
+       end)
+
+  module Data =
+  struct
+    type t =
+        {
+          oasis_version: OASISVersion.t;
+          plugin_versions: OASISVersion.t option MapPlugin.t;
+          alpha_features: string list;
+          beta_features: string list;
+        }
+
+    let create oasis_version alpha_features beta_features =
+      {
+        oasis_version = oasis_version;
+        plugin_versions = MapPlugin.empty;
+        alpha_features = alpha_features;
+        beta_features = beta_features
+      }
+
+    let of_package pkg =
+      create
+        pkg.OASISTypes.oasis_version
+        pkg.OASISTypes.alpha_features
+        pkg.OASISTypes.beta_features
+
+    let add_plugin (plugin_kind, plugin_name, plugin_version) t =
+      {t with
+           plugin_versions = MapPlugin.add
+                               (plugin_kind, plugin_name)
+                               plugin_version
+                               t.plugin_versions}
+
+    let plugin_version plugin_kind plugin_name t =
+      MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions
+
+    let to_string t =
+      Printf.sprintf
+        "oasis_version: %s; alpha_features: %s; beta_features: %s; \
+         plugins_version: %s"