From 1f506eb2431ee304d9d6329ea7082a16592b7bb0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 7 Aug 2014 13:14:12 +0200 Subject: [PATCH 01/16] fix doc --- core/CCError.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/CCError.mli b/core/CCError.mli index d054296d..4181ed55 100644 --- a/core/CCError.mli +++ b/core/CCError.mli @@ -85,7 +85,7 @@ val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd t -(** {2 APplicative} *) +(** {2 Applicative} *) val pure : 'a -> 'a t From e703a3f65530070c02e657b5ae313e6be5ff929a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 7 Aug 2014 13:14:23 +0200 Subject: [PATCH 02/16] CCOrd.map --- core/CCOrd.ml | 2 ++ core/CCOrd.mli | 8 ++++++++ 2 files changed, 10 insertions(+) diff --git a/core/CCOrd.ml b/core/CCOrd.ml index 8474e12e..7e05bf3f 100644 --- a/core/CCOrd.ml +++ b/core/CCOrd.ml @@ -89,3 +89,5 @@ let array_ ord a1 a2 = then aux (i+1) else c in aux 0 + +let map f ord a b = ord (f a) (f b) diff --git a/core/CCOrd.mli b/core/CCOrd.mli index 90e929d8..45d24259 100644 --- a/core/CCOrd.mli +++ b/core/CCOrd.mli @@ -64,3 +64,11 @@ val list_ : 'a t -> 'a list t (** Lexicographic combination on lists *) val array_ : 'a t -> 'a array t + +val map : ('a -> 'b) -> 'b t -> 'a t +(** [map f ord] is the comparison function that, given objects [x] and [y], + projects [x] and [y] using [f] (e.g. using a record field) and then + compares those projections with [ord]. + Example: + [map fst CCInt.compare] compares values of type [(int * 'a)] by their + first component. *) From f2d027ac19cf5839ab40d0173f1b086344a4b955 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 7 Aug 2014 13:25:38 +0200 Subject: [PATCH 03/16] fix tests for containers.thread --- _oasis | 6 +++--- tests/threads/test_future.ml | 9 +++++---- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/_oasis b/_oasis index db498281..67e1812b 100644 --- a/_oasis +++ b/_oasis @@ -176,12 +176,12 @@ Executable test_lwt BuildDepends: containers,lwt,lwt.unix,oUnit,containers.lwt Executable test_threads - Path: tests/lwt/ + Path: tests/threads/ Install: false CompiledObject: best Build$: flag(tests) && flag(thread) - MainIs: test_Future.ml - BuildDepends: containers,threads,oUnit,containers.lwt + MainIs: test_future.ml + BuildDepends: containers,threads,oUnit,containers.thread Test all Command: make test-all diff --git a/tests/threads/test_future.ml b/tests/threads/test_future.ml index ce7420b4..becf7f52 100644 --- a/tests/threads/test_future.ml +++ b/tests/threads/test_future.ml @@ -3,6 +3,8 @@ open OUnit +module Future = CCFuture + let test_mvar () = let box = Future.MVar.empty () in let f = Future.spawn (fun () -> Future.MVar.take box + 1) in @@ -13,10 +15,9 @@ let test_mvar () = () let test_parallel () = - let open Gen.Infix in - let l = 1 -- 300 - |> Gen.map (fun _ -> Future.spawn (fun () -> Thread.delay 0.1; 1)) - |> Gen.to_list in + let l = CCSequence.(1 -- 300) + |> CCSequence.map (fun _ -> Future.spawn (fun () -> Thread.delay 0.1; 1)) + |> CCSequence.to_list in let l' = List.map Future.get l in OUnit.assert_equal 300 (List.fold_left (+) 0 l'); () From b878909d3c655ce51aa754601559a40037897b43 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 7 Aug 2014 13:42:55 +0200 Subject: [PATCH 04/16] udpate readme --- README.md | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index a0ace7c7..c556bc39 100644 --- a/README.md +++ b/README.md @@ -119,8 +119,15 @@ There is a QuickCheck-like library called `QCheck` (now in its own repo). ## Build -There are no dependencies (`Sequence` is included). -The `Bij` module requires OCaml `>= 4.00` because of GADTs. Type: +You will need OCaml >= 4.01.0. + +### Via opam + +The prefered way to install is through [opam](http://opam.ocaml.org/). + + $ opam install containers + +### From Sources $ make From f1f88424362b5da445aa5955578db3972b0435cf Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 7 Aug 2014 14:15:08 +0200 Subject: [PATCH 05/16] specialize some comparison functions --- core/CCBool.ml | 4 ++-- core/CCInt.ml | 4 ++-- core/CCString.ml | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/core/CCBool.ml b/core/CCBool.ml index b890edeb..0712e58b 100644 --- a/core/CCBool.ml +++ b/core/CCBool.ml @@ -26,9 +26,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type t = bool -let equal a b = a=b +let equal (a:bool) b = a=b -let compare a b = Pervasives.compare a b +let compare (a:bool) b = Pervasives.compare a b let negate x = not x diff --git a/core/CCInt.ml b/core/CCInt.ml index a5689aa5..57e0c2dc 100644 --- a/core/CCInt.ml +++ b/core/CCInt.ml @@ -26,9 +26,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type t = int -let equal a b = a=b +let equal (a:int) b = a=b -let compare a b = Pervasives.compare a b +let compare (a:int) b = Pervasives.compare a b let hash i = i land max_int diff --git a/core/CCString.ml b/core/CCString.ml index 1128093a..96023ea0 100644 --- a/core/CCString.ml +++ b/core/CCString.ml @@ -50,7 +50,7 @@ end type t = string -let equal a b = a=b +let equal (a:string) b = a=b let compare = String.compare From d298791477cb5e443627d582e0b44c4e42a54496 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 7 Aug 2014 14:15:19 +0200 Subject: [PATCH 06/16] enrich documentation --- core/CCBool.mli | 4 ++++ core/CCVector.mli | 31 +++++++++++++++++++------------ 2 files changed, 23 insertions(+), 12 deletions(-) diff --git a/core/CCBool.mli b/core/CCBool.mli index e0cc63bc..25e09dba 100644 --- a/core/CCBool.mli +++ b/core/CCBool.mli @@ -29,14 +29,18 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type t = bool val compare : t -> t -> int +(** Total ordering on booleans, similar to {!Pervasives.compare} *) val equal : t -> t -> bool val negate : t -> t +(** Negation on booleans (functional version of [not]) *) type 'a printer = Buffer.t -> 'a -> unit type 'a formatter = Format.formatter -> 'a -> unit val pp : t printer +(** Printer for booleans *) + val print : t formatter diff --git a/core/CCVector.mli b/core/CCVector.mli index 26ba90c3..d3b7a7d3 100644 --- a/core/CCVector.mli +++ b/core/CCVector.mli @@ -110,25 +110,28 @@ val member : ?eq:('a -> 'a -> bool) -> 'a -> ('a, _) t -> bool (** is the element a member of the vector? *) val sort : ('a -> 'a -> int) -> ('a, _) t -> ('a, 'mut) t -(** Sort the vector *) +(** Sort the vector, returning a copy of it that is sorted + w.r.t the given ordering. The vector itself is unchanged. *) val sort' : ('a -> 'a -> int) -> ('a, rw) t -> unit -(** Sort the vector in place *) +(** Sort the vector in place (modifying it). *) val uniq_sort : ('a -> 'a -> int) -> ('a, rw) t -> unit -(** Sort the array and remove duplicates, in place*) +(** Sort the array and remove duplicates, in place (e.e. modifying + the vector itself) *) val iter : ('a -> unit) -> ('a,_) t -> unit -(** iterate on the vector *) +(** iterate on the vector's content *) val iteri : (int -> 'a -> unit) -> ('a,_) t -> unit -(** iterate on the vector with indexes *) +(** iterate on the vector, with indexes *) val map : ('a -> 'b) -> ('a,_) t -> ('b, 'mut) t -(** map elements of the vector *) +(** map elements of the vector, yielding a new vector *) val filter : ('a -> bool) -> ('a,_) t -> ('a, 'mut) t -(** filter elements from vector *) +(** filter elements from the vector. [filter p v] leaves [v] unchanged but + returns a new vector that only contains elements of [v] satisfying [p]. *) val filter' : ('a -> bool) -> ('a, rw) t -> unit (** Filter elements in place. Does {b NOT} preserve the order @@ -138,10 +141,10 @@ val fold : ('b -> 'a -> 'b) -> 'b -> ('a,_) t -> 'b (** fold on elements of the vector *) val exists : ('a -> bool) -> ('a,_) t -> bool -(** existential test *) +(** existential test (is there an element that satisfies the predicate?) *) val for_all : ('a -> bool) -> ('a,_) t -> bool -(** universal test *) +(** universal test (do all the elements satisfy the predicate?) *) val find : ('a -> bool) -> ('a,_) t -> 'a option (** Find an element that satisfies the predicate *) @@ -160,15 +163,17 @@ val flat_map' : ('a -> 'b sequence) -> ('a,_) t -> ('b, 'mut) t (** Like {!flat_map}, but using {!sequence} for intermediate collections *) val (>>=) : ('a,_) t -> ('a -> ('b,_) t) -> ('b, 'mut) t +(** Infix version of {!flat_map} *) val (>|=) : ('a,_) t -> ('a -> 'b) -> ('b, 'mut) t +(** Infix version of {!map} *) val get : ('a,_) t -> int -> 'a -(** access element, or +(** access element by its index, or @raise Failure if bad index *) val set : ('a, rw) t -> int -> 'a -> unit -(** access element, or +(** modify element at given index, or @raise Failure if bad index *) val remove : ('a, rw) t -> int -> unit @@ -196,7 +201,9 @@ val unsafe_get_array : ('a, rw) t -> 'a array index than [size v] are undefined (do not access!). *) val (--) : int -> int -> (int, 'mut) t -(** Range of integers (both included) *) +(** Range of integers, either ascending or descending (both included, + therefore the result is never empty). + Example: [1 -- 10] returns the vector [[1;2;3;4;5;6;7;8;9;10]] *) val of_array : 'a array -> ('a, 'mut) t val of_list : 'a list -> ('a, 'mut) t From 8f466306344c56b52bba30f85b00d8b9c8d05875 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 7 Aug 2014 15:14:10 +0200 Subject: [PATCH 07/16] better Format printers (using break hints) --- core/CCArray.ml | 2 +- core/CCBool.ml | 2 +- core/CCError.ml | 4 ++-- core/CCInt.ml | 2 +- core/CCKList.ml | 6 +++++- core/CCList.ml | 5 ++++- core/CCPersistentHashtbl.ml | 3 ++- core/CCVector.ml | 6 +++--- 8 files changed, 19 insertions(+), 11 deletions(-) diff --git a/core/CCArray.ml b/core/CCArray.ml index 6932c0e6..8d09c7b0 100644 --- a/core/CCArray.ml +++ b/core/CCArray.ml @@ -234,7 +234,7 @@ let _pp_i ~sep pp_item buf a i j = let _print ~sep pp_item fmt a i j = for k = i to j - 1 do - if k > i then Format.pp_print_string fmt sep; + if k > i then (Format.pp_print_string fmt sep; Format.pp_print_cut fmt ()); pp_item fmt a.(k) done diff --git a/core/CCBool.ml b/core/CCBool.ml index 0712e58b..ac61291f 100644 --- a/core/CCBool.ml +++ b/core/CCBool.ml @@ -36,4 +36,4 @@ type 'a printer = Buffer.t -> 'a -> unit type 'a formatter = Format.formatter -> 'a -> unit let pp buf = Printf.bprintf buf "%B" -let print fmt = Format.fprintf fmt "%B" +let print fmt = Format.pp_print_bool fmt diff --git a/core/CCError.ml b/core/CCError.ml index 851cd5c1..eb8990f6 100644 --- a/core/CCError.ml +++ b/core/CCError.ml @@ -230,5 +230,5 @@ let pp pp_x buf e = match e with | `Error s -> Printf.bprintf buf "error(%s)" s let print pp_x fmt e = match e with - | `Ok x -> Format.fprintf fmt "ok(%a)" pp_x x - | `Error s -> Format.fprintf fmt "error(%s)" s + | `Ok x -> Format.fprintf fmt "@[ok(@,%a)@]" pp_x x + | `Error s -> Format.fprintf fmt "@[error(@,%s)@]" s diff --git a/core/CCInt.ml b/core/CCInt.ml index 57e0c2dc..29a898e3 100644 --- a/core/CCInt.ml +++ b/core/CCInt.ml @@ -46,4 +46,4 @@ let random_small = random 100 let random_range i j st = i + random (j-i) st let pp buf = Printf.bprintf buf "%d" -let print fmt = Format.fprintf fmt "%d" +let print fmt = Format.pp_print_int fmt diff --git a/core/CCKList.ml b/core/CCKList.ml index 2b22e399..4e253a1a 100644 --- a/core/CCKList.ml +++ b/core/CCKList.ml @@ -361,7 +361,11 @@ let pp ?(sep=",") pp_item buf l = let print ?(sep=",") pp_item fmt l = let rec pp fmt l = match l() with | `Nil -> () - | `Cons (x,l') -> Format.pp_print_string fmt sep; pp_item fmt x; pp fmt l' + | `Cons (x,l') -> + Format.pp_print_string fmt sep; + Format.pp_print_cut fmt (); + pp_item fmt x; + pp fmt l' in match l() with | `Nil -> () diff --git a/core/CCList.ml b/core/CCList.ml index ddb0fa5c..64d93a0c 100644 --- a/core/CCList.ml +++ b/core/CCList.ml @@ -679,8 +679,11 @@ let print ?(start="[") ?(stop="]") ?(sep=", ") pp_item fmt l = | x::((y::xs) as l) -> pp_item fmt x; Format.pp_print_string fmt sep; + Format.pp_print_cut fmt (); print fmt l | x::[] -> pp_item fmt x | [] -> () in - Format.fprintf fmt "@[%s%a%s@]" start print l stop + Format.pp_print_string fmt start; + print fmt l; + Format.pp_print_string fmt stop diff --git a/core/CCPersistentHashtbl.ml b/core/CCPersistentHashtbl.ml index 71c1610c..70c4df91 100644 --- a/core/CCPersistentHashtbl.ml +++ b/core/CCPersistentHashtbl.ml @@ -343,7 +343,8 @@ module Make(H : HashedType) : S with type key = H.t = struct let first = ref true in iter t (fun k v -> - if !first then first:=false else Format.pp_print_string fmt ", "; + if !first then first:=false + else (Format.pp_print_string fmt ", "; Format.pp_print_cut fmt ()); Format.fprintf fmt "%a -> %a" pp_k k pp_v v ); Format.pp_print_string fmt "}" diff --git a/core/CCVector.ml b/core/CCVector.ml index d4809056..e9675f23 100644 --- a/core/CCVector.ml +++ b/core/CCVector.ml @@ -486,10 +486,10 @@ let pp ?(start="[") ?(stop="]") ?(sep=", ") pp_item buf v = Buffer.add_string buf stop let print ?(start="[") ?(stop="]") ?(sep=", ") pp_item fmt v = - Format.fprintf fmt "@[%s" start; + Format.pp_print_string fmt start; iteri (fun i x -> - if i > 0 then Format.pp_print_string fmt sep; + if i > 0 then (Format.pp_print_string fmt sep; Format.pp_print_cut fmt()); pp_item fmt x ) v; - Format.fprintf fmt "%s@]" stop + Format.pp_print_string fmt stop From 7c9eb7dfab66346d62abd1adb76ff524b72fa533 Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 8 Aug 2014 17:54:47 +0200 Subject: [PATCH 08/16] Add List.findi, Array.findi and Array.find_idx. --- core/CCArray.ml | 22 ++++++++++++++++++++-- core/CCArray.mli | 7 +++++++ core/CCList.ml | 23 +++++++++++------------ core/CCList.mli | 11 +++++++---- 4 files changed, 45 insertions(+), 18 deletions(-) diff --git a/core/CCArray.ml b/core/CCArray.ml index 8d09c7b0..d91f555b 100644 --- a/core/CCArray.ml +++ b/core/CCArray.ml @@ -68,6 +68,13 @@ module type S = sig (** [find f a] returns [Some y] if there is an element [x] such that [f x = Some y], else it returns [None] *) + val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option + (** Like {!find}, but also pass the index to the predicate function. *) + + val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option + (** [find p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], + and [p x] holds. Otherwise returns [None] *) + val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option (** Lookup the index of some value in a sorted array. @return [None] if the key is not present, or @@ -160,7 +167,7 @@ let rec _compare cmp a1 i1 j1 a2 i2 j2 = let rec _find f a i j = if i = j then None - else match f a.(i) with + else match f i a.(i) with | Some _ as res -> res | None -> _find f a (i+1) j @@ -290,8 +297,14 @@ let reverse_in_place a = *) let find f a = + _find (fun _ -> f ) a 0 (Array.length a) + +let findi f a = _find f a 0 (Array.length a) +let find_idx p a = + _find (fun i x -> if p x then Some (i,x) else None) a 0 (Array.length a) + let filter_map f a = let rec aux acc i = if i = Array.length a @@ -494,7 +507,12 @@ module Sub = struct Sub.reverse_in_place s; a = [| 1; 2; 5; 4; 3; 6 |] *) - let find f a = _find f a.arr a.i a.j + let find f a = _find (fun _ -> f) a.arr a.i a.j + + let findi f a = _find (fun i -> f (i-a.i)) a.arr a.i a.j + + let find_idx p a = + _find (fun i x -> if p x then Some (i,x) else None) a.arr a.i a.j let lookup_exn ?(cmp=Pervasives.compare) k a = _lookup_exn ~cmp k a.arr a.i (a.j-1) diff --git a/core/CCArray.mli b/core/CCArray.mli index 9025221c..ab975073 100644 --- a/core/CCArray.mli +++ b/core/CCArray.mli @@ -70,6 +70,13 @@ module type S = sig (** [find f a] returns [Some y] if there is an element [x] such that [f x = Some y], else it returns [None] *) + val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option + (** Like {!find}, but also pass the index to the predicate function. *) + + val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option + (** [find p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], + and [p x] holds. Otherwise returns [None] *) + val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option (** Lookup the index of some value in a sorted array. @return [None] if the key is not present, or diff --git a/core/CCList.ml b/core/CCList.ml index 64d93a0c..cddb1911 100644 --- a/core/CCList.ml +++ b/core/CCList.ml @@ -234,19 +234,18 @@ let last n l = let len = List.length l in if len < n then l else drop (len-n) l -let find_idx p l = - let rec search i l = match l with - | [] -> None - | x::_ when p x -> Some (i, x) - | _::xs -> search (i+1) xs - in search 0 l +let findi f l = + let rec aux f i = function + | [] -> None + | x::l' -> + match f i x with + | Some _ as res -> res + | None -> aux f (i+1) l' + in aux f 0 l -let rec find f l = match l with - | [] -> None - | x::l' -> - match f x with - | Some _ as res -> res - | None -> find f l' +let find f l = findi (fun _ -> f) l + +let find_idx p l = findi (fun i x -> if p x then Some (i, x) else None) l (*$T find (fun x -> if x=3 then Some "a" else None) [1;2;3;4] = Some "a" diff --git a/core/CCList.mli b/core/CCList.mli index bd3c0ad7..f3c5f7af 100644 --- a/core/CCList.mli +++ b/core/CCList.mli @@ -88,15 +88,18 @@ val last : int -> 'a t -> 'a t (** [last n l] takes the last [n] elements of [l] (or less if [l] doesn't have that many elements *) -val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option -(** [find p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], - and [p x] holds. Otherwise returns [None] *) - val find : ('a -> 'b option) -> 'a t -> 'b option (** [find f l] traverses [l], applying [f] to each element. If for some element [x], [f x = Some y], then [Some y] is returned. Otherwise the call returns [None] *) +val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option +(** Like {!find}, but also pass the index to the predicate function. *) + +val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option +(** [find p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], + and [p x] holds. Otherwise returns [None] *) + val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** Map and remove elements at the same time *) From d2abd46d13917e552589aaf21b081261dfb6f9cc Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 8 Aug 2014 19:24:25 +0200 Subject: [PATCH 09/16] add @since tags --- core/CCArray.mli | 6 ++++-- core/CCList.mli | 6 ++++-- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/core/CCArray.mli b/core/CCArray.mli index ab975073..78a0e40b 100644 --- a/core/CCArray.mli +++ b/core/CCArray.mli @@ -71,11 +71,13 @@ module type S = sig that [f x = Some y], else it returns [None] *) val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option - (** Like {!find}, but also pass the index to the predicate function. *) + (** Like {!find}, but also pass the index to the predicate function. + @since NEXT_RELEASE *) val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option (** [find p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], - and [p x] holds. Otherwise returns [None] *) + and [p x] holds. Otherwise returns [None] + @since NEXT_RELEASE *) val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option (** Lookup the index of some value in a sorted array. diff --git a/core/CCList.mli b/core/CCList.mli index f3c5f7af..9f5115d8 100644 --- a/core/CCList.mli +++ b/core/CCList.mli @@ -94,11 +94,13 @@ val find : ('a -> 'b option) -> 'a t -> 'b option the call returns [None] *) val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option -(** Like {!find}, but also pass the index to the predicate function. *) +(** Like {!find}, but also pass the index to the predicate function. + @since NEXT_RELEASE *) val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option (** [find p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], - and [p x] holds. Otherwise returns [None] *) + and [p x] holds. Otherwise returns [None] + @since NEXT_RELEASE *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** Map and remove elements at the same time *) From 46ebb559fea346e30b1580630e439f3ba5a548e1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 8 Aug 2014 19:33:08 +0200 Subject: [PATCH 10/16] readme (and new file, HOWTO.md) --- HOWTO.md | 11 +++++++++++ README.md | 14 ++++++++++++++ 2 files changed, 25 insertions(+) create mode 100644 HOWTO.md diff --git a/HOWTO.md b/HOWTO.md new file mode 100644 index 00000000..116ca78d --- /dev/null +++ b/HOWTO.md @@ -0,0 +1,11 @@ + +## Make a release + +1. `make test-all` +2. merge into `stable` (from now on, proceed on branch `stable`) +3. update version in `_oasis` +4. `make update_next_tag` (to update `@since` comments) +5. update `CHANGELOG.md` (see its end to find the right git command) +6. commit, tag, and push both to github +7. new opam package + diff --git a/README.md b/README.md index c556bc39..9e9fa580 100644 --- a/README.md +++ b/README.md @@ -129,6 +129,9 @@ The prefered way to install is through [opam](http://opam.ocaml.org/). ### From Sources +On the branch `master` you will need `oasis` to build the library. On the +branch `stable` it is not necessary. + $ make To build and run tests (requires `oUnit` and `qtest`): @@ -147,3 +150,14 @@ To build the small benchmarking suite (requires `benchmark`): $ opam install benchmark $ make bench $ ./benchs.native + +## Contributing + +PRs on github are welcome (patches by email too, if you prefer so). + +A few guidelines: + +- no dependencies between basic modules (even just for signatures) +- add `@since` tags for new functions +- add tests if possible (using `qtest`) + From 579a135829f1087f8163fe59674e98d72668f5ca Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 8 Aug 2014 19:45:32 +0200 Subject: [PATCH 11/16] CCOpt.guard --- core/CCOpt.ml | 2 ++ core/CCOpt.mli | 8 ++++++++ 2 files changed, 10 insertions(+) diff --git a/core/CCOpt.ml b/core/CCOpt.ml index 07be2451..a1dd5395 100644 --- a/core/CCOpt.ml +++ b/core/CCOpt.ml @@ -110,6 +110,8 @@ let sequence_l l = sequence_l [] = Some [] *) +let guard f x = try Some (f x) with Not_found -> None + let to_list o = match o with | None -> [] | Some x -> [x] diff --git a/core/CCOpt.mli b/core/CCOpt.mli index 2c0e1d4f..e067a097 100644 --- a/core/CCOpt.mli +++ b/core/CCOpt.mli @@ -65,6 +65,14 @@ val get_exn : 'a t -> 'a @raise Invalid_argument if the option is [None] *) val sequence_l : 'a t list -> 'a list t +(** [sequence_l [x1; x2; ...; xn]] returns [Some [y1;y2;...;yn]] if + every [xi] is [Some yi]. Otherwise, if the list contains at least + one [None], the result is [None]. *) + +val guard : ('a -> 'b) -> 'a -> 'b option +(** [guard f x] calls [f x] and returns [Some y] if [f x = y]. If [f x] raises + any exception, the result is [None]. This can be useful to wrap functions + such as [Map.S.find]. *) (** {2 Applicative} *) From edfadba1efc5ec3cdc10f11e0d7069ac3ffecae9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 8 Aug 2014 20:06:44 +0200 Subject: [PATCH 12/16] rename CCOpt.guard into CCOpt.wrap, add an optional handler, add CCOpt.wrap2 --- core/CCOpt.ml | 10 +++++++++- core/CCOpt.mli | 11 ++++++++--- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/core/CCOpt.ml b/core/CCOpt.ml index a1dd5395..cc087ca2 100644 --- a/core/CCOpt.ml +++ b/core/CCOpt.ml @@ -110,7 +110,15 @@ let sequence_l l = sequence_l [] = Some [] *) -let guard f x = try Some (f x) with Not_found -> None +let wrap ?(handler=fun _ -> true) f x = + try Some (f x) + with e -> + if handler e then None else raise e + +let wrap2 ?(handler=fun _ -> true) f x y = + try Some (f x y) + with e -> + if handler e then None else raise e let to_list o = match o with | None -> [] diff --git a/core/CCOpt.mli b/core/CCOpt.mli index e067a097..cd783f77 100644 --- a/core/CCOpt.mli +++ b/core/CCOpt.mli @@ -69,10 +69,15 @@ val sequence_l : 'a t list -> 'a list t every [xi] is [Some yi]. Otherwise, if the list contains at least one [None], the result is [None]. *) -val guard : ('a -> 'b) -> 'a -> 'b option -(** [guard f x] calls [f x] and returns [Some y] if [f x = y]. If [f x] raises +val wrap : ?handler:(exn -> bool) -> ('a -> 'b) -> 'a -> 'b option +(** [wrap f x] calls [f x] and returns [Some y] if [f x = y]. If [f x] raises any exception, the result is [None]. This can be useful to wrap functions - such as [Map.S.find]. *) + such as [Map.S.find]. + @param handler the exception handler, which returns [true] if the + exception is to be caught. *) + +val wrap2 : ?handler:(exn -> bool) -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c option +(** [wrap2 f x y] is similar to {!wrap1} but for binary functions. *) (** {2 Applicative} *) From c8413080b4a82aa850ad320f063825a1db701783 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 8 Aug 2014 20:13:51 +0200 Subject: [PATCH 13/16] remove erroneous @since tag in CCList.find_idx --- core/CCList.mli | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/core/CCList.mli b/core/CCList.mli index 9f5115d8..5cc53b90 100644 --- a/core/CCList.mli +++ b/core/CCList.mli @@ -99,8 +99,7 @@ val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option (** [find p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], - and [p x] holds. Otherwise returns [None] - @since NEXT_RELEASE *) + and [p x] holds. Otherwise returns [None] *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t (** Map and remove elements at the same time *) From c8d834b722a95b9feedf17f91511d138662c6d6f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 8 Aug 2014 20:16:15 +0200 Subject: [PATCH 14/16] Squashed 'sequence/' content from commit e5625c6 git-subtree-dir: sequence git-subtree-split: e5625c69301e344abb971ad47ba618387346dc22 --- .gitignore | 9 + .merlin | 8 + .ocamlinit | 5 + CHANGELOG.md | 70 + LICENSE | 22 + META | 21 + Makefile | 67 + README.md | 50 + _oasis | 88 + _tags | 39 + bench/bench_persistent.ml | 128 + bench/bench_persistent_read.ml | 139 + bench/benchs.ml | 34 + bench/simple_bench.ml | 11 + configure | 27 + examples/sexpr.ml | 305 ++ examples/sexpr.mli | 132 + examples/test_sexpr.ml | 131 + invert/.merlin | 2 + invert/invert.mldylib | 4 + invert/invert.mllib | 4 + invert/sequenceInvert.ml | 62 + invert/sequenceInvert.mli | 32 + myocamlbuild.ml | 610 +++ sequence.ml | 771 ++++ sequence.mldylib | 4 + sequence.mli | 587 +++ sequence.mllib | 4 + sequence.odocl | 4 + setup.ml | 7205 ++++++++++++++++++++++++++++++++ tests/run_tests.ml | 9 + tests/test_sequence.ml | 220 + 32 files changed, 10804 insertions(+) create mode 100644 .gitignore create mode 100644 .merlin create mode 100644 .ocamlinit create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 META create mode 100644 Makefile create mode 100644 README.md create mode 100644 _oasis create mode 100644 _tags create mode 100644 bench/bench_persistent.ml create mode 100644 bench/bench_persistent_read.ml create mode 100644 bench/benchs.ml create mode 100644 bench/simple_bench.ml create mode 100755 configure create mode 100644 examples/sexpr.ml create mode 100644 examples/sexpr.mli create mode 100644 examples/test_sexpr.ml create mode 100644 invert/.merlin create mode 100644 invert/invert.mldylib create mode 100644 invert/invert.mllib create mode 100644 invert/sequenceInvert.ml create mode 100644 invert/sequenceInvert.mli create mode 100644 myocamlbuild.ml create mode 100644 sequence.ml create mode 100644 sequence.mldylib create mode 100644 sequence.mli create mode 100644 sequence.mllib create mode 100644 sequence.odocl create mode 100644 setup.ml create mode 100644 tests/run_tests.ml create mode 100644 tests/test_sequence.ml diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..96cadb3a --- /dev/null +++ b/.gitignore @@ -0,0 +1,9 @@ +.*.swp +_build +*.native +*.docdir +*.html +man/ +sequence.install +setup.log +setup.data diff --git a/.merlin b/.merlin new file mode 100644 index 00000000..385d4698 --- /dev/null +++ b/.merlin @@ -0,0 +1,8 @@ +S . +S bench/ +S tests/ +B _build +B _build/tests/ +B _build/bench/ +PKG oUnit +PKG benchmark diff --git a/.ocamlinit b/.ocamlinit new file mode 100644 index 00000000..b54780c5 --- /dev/null +++ b/.ocamlinit @@ -0,0 +1,5 @@ +#directory "_build";; +#load "sequence.cma";; +open Sequence.Infix;; +(* vim:syntax=ocaml +*) diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 00000000..1e311bb9 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,70 @@ +# Changelog + +## 0.5.1 + +- `Sequence.IO` module, a very very simple way to read/write files +- options: `to_opt/of_opt/head/head_exn` + +## 0.5 + +- conversion with `klist` +- add monadic, choice and applicative infix operators and `>|=` +- add several functions: + * `product2` + * `find`, `mem` + * `doubleton`, `cons`, `snoc` + * `drop_while`, `take_while`... + * `concat_str` +- aliases to existing functions +- use `delimcc` in a new module, `SequenceInvert`, in order to reverse the + control flow (here with conversion to Gen) +- fix examples, tests and doc (about `product`) +- reading benchmark for persistent sequences. +- replace `Bench` with `Benchmark` + +## 0.4.1 + +- `persistent_lazy` +- use bin_annot + +## 0.4 + +- API change for `persistent` +- more efficient implementation for `persistent` +- remove `TypeClass` +- API change for `min`/`max` (in case the sequence is empty) +- conversion with `Gen` +- use Oasis + +## 0.3.7 + +- decreasing int range +- printing functions + +## 0.3.6.1 + +- documentation +- bugfixes + +## 0.3.6 + +- `fmap` +- functors to adapt `Set` and `Map` + +## 0.3.5 + +- tests and benchmarks +- `join` combinator +- optimization for `Sequence.persistent` + +## 0.3.4 + +- `sort`, `uniq`, `group` and `sort_uniq` combinators implemented +- some conversion functions that use `Sequence.t2` +- infix operators in `Sequence.Infix` +- `Sequence.t2` type for efficient iteration on pairs of elements +- some combinators are adapted to `Sequence.t2` +- `zip`, `unzip` and `zip_i` to convert between `t` and `t2` +- added `scan` combinator + +note: git log --no-merges previous_version..HEAD --pretty=%s diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..7e29992c --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2012, Simon Cruanes +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. Redistributions in binary +form must reproduce the above copyright notice, this list of conditions and +the following disclaimer in the documentation and/or other materials +provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/META b/META new file mode 100644 index 00000000..5fc1bff7 --- /dev/null +++ b/META @@ -0,0 +1,21 @@ +# OASIS_START +# DO NOT EDIT (digest: 3b9ebef180f5e4bdb720d2103ba95667) +version = "0.5.1" +description = "Simple sequence (iterator) datatype and combinators" +archive(byte) = "sequence.cma" +archive(byte, plugin) = "sequence.cma" +archive(native) = "sequence.cmxa" +archive(native, plugin) = "sequence.cmxs" +exists_if = "sequence.cma" +package "invert" ( + version = "0.5.1" + description = "Simple sequence (iterator) datatype and combinators" + requires = "sequence delimcc" + archive(byte) = "invert.cma" + archive(byte, plugin) = "invert.cma" + archive(native) = "invert.cmxa" + archive(native, plugin) = "invert.cmxs" + exists_if = "invert.cma" +) +# OASIS_STOP + diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..cdc0e22e --- /dev/null +++ b/Makefile @@ -0,0 +1,67 @@ +# OASIS_START +# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) + +SETUP = ocaml setup.ml + +build: setup.data + $(SETUP) -build $(BUILDFLAGS) + +doc: setup.data build + $(SETUP) -doc $(DOCFLAGS) + +test: setup.data build + $(SETUP) -test $(TESTFLAGS) + +all: + $(SETUP) -all $(ALLFLAGS) + +install: setup.data + $(SETUP) -install $(INSTALLFLAGS) + +uninstall: setup.data + $(SETUP) -uninstall $(UNINSTALLFLAGS) + +reinstall: setup.data + $(SETUP) -reinstall $(REINSTALLFLAGS) + +clean: + $(SETUP) -clean $(CLEANFLAGS) + +distclean: + $(SETUP) -distclean $(DISTCLEANFLAGS) + +setup.data: + $(SETUP) -configure $(CONFIGUREFLAGS) + +configure: + $(SETUP) -configure $(CONFIGUREFLAGS) + +.PHONY: build doc test all install uninstall reinstall clean distclean configure + +# OASIS_STOP + +run-tests: + ./run_tests.native + +examples: + ocamlbuild examples/test_sexpr.native + +push_doc: all doc + scp -r sequence.docdir/* cedeela.fr:~/simon/root/software/sequence/ + +push_stable: all + git checkout stable + git merge master -m 'merge from master' + oasis setup + git commit -a -m 'oasis files' + git push origin + git checkout master + +VERSION=$(shell awk '/^Version:/ {print $$2}' _oasis) + +update_next_tag: + @echo "update version to $(VERSION)..." + sed -i "s/NEXT_VERSION/$(VERSION)/g" *.ml *.mli + sed -i "s/NEXT_RELEASE/$(VERSION)/g" *.ml *.mli + +.PHONY: benchs tests examples update_next_tag push_doc push_stable diff --git a/README.md b/README.md new file mode 100644 index 00000000..0ca32192 --- /dev/null +++ b/README.md @@ -0,0 +1,50 @@ +Sequence +======== + +Simple sequence abstract datatype, intended to transfer a finite number of +elements from one data structure to another. Some transformations on sequences, +like `filter`, `map`, `take`, `drop` and `append` can be performed before the +sequence is iterated/folded on. + +Sequence is not designed to be as general-purpose or flexible as, say, +Batteries' `Enum.t`. Rather, it aims at providing a very simple and efficient +way of iterating on a finite number of values, only allocating (most of the time) +one intermediate closure to do so. For instance, iterating on keys, or values, +of a `Hashtbl.t`, without creating a list. + +Documentation +============= + +See [the online API](http://cedeela.fr/~simon/software/sequence/Sequence.html). + +Build +===== + +1. via opam `opam install sequence` +2. manually (need OCaml >= 3.12): `make all install` + +If you have `OUnit` installed, you can build and run tests with + + $ make tests + $ ./run_tests.native + +If you have `Bench` installed, you can build and run benchmarks with + + $ make benchs + $ ./benchs.native + +To see how to use the library, check the `examples` directory. +`tests.ml` has a few examples of how to convert basic data structures into +sequences, and conversely. + +Examples +======== + +The module `examples/sexpr.mli` exposes the interface of the S-expression +example library. It requires OCaml>=4.0 to compile, because of the GADT +structure used in the monadic parser combinators part of `examples/sexpr.ml`. + +License +======= + +Sequence is available under the BSD license. diff --git a/_oasis b/_oasis new file mode 100644 index 00000000..d1452f2e --- /dev/null +++ b/_oasis @@ -0,0 +1,88 @@ +OASISFormat: 0.4 +Name: sequence +Version: 0.5.1 +Homepage: https://github.com/c-cube/sequence +Authors: Simon Cruanes +License: BSD-2-clause +LicenseFile: LICENSE +Plugins: META (0.3), DevFiles (0.3) +BuildTools: ocamlbuild + +Synopsis: Simple sequence (iterator) datatype and combinators +Description: + Simple sequence datatype, intended to transfer a finite number of + elements from one data structure to another. Some transformations on sequences, + like `filter`, `map`, `take`, `drop` and `append` can be performed before the + sequence is iterated/folded on. + +Flag bench + Description: enable benchmarks (require library Benchmark) + Default: false + +Flag invert + Description: build sequence.invert (requires Delimcc) + Default: false + +Library "sequence" + Path: . + Modules: Sequence + +Library "invert" + Path: invert + Build$: flag(invert) + Install$: flag(invert) + Modules: SequenceInvert + FindlibName: invert + FindlibParent: sequence + BuildDepends: sequence,delimcc + +Document sequence + Title: Sequence docs + Type: ocamlbuild (0.3) + BuildTools+: ocamldoc + Install: true + XOCamlbuildPath: . + XOCamlbuildLibraries: sequence + +Test all + Type: custom + Command: make run-tests + TestTools: run_tests + Run$: flag(tests) + +Executable run_tests + Path: tests/ + Install: false + CompiledObject: native + MainIs: run_tests.ml + Build$: flag(tests) + BuildDepends: sequence,oUnit + +Executable benchs + Path: bench + Install: false + CompiledObject: native + Build$: flag(bench) + BuildDepends: sequence,benchmark + MainIs: benchs.ml + +Executable bench_persistent + Path: bench + Install: false + CompiledObject: native + Build$: flag(bench) + BuildDepends: sequence,benchmark + MainIs: bench_persistent.ml + +Executable bench_persistent_read + Path: bench + Install: false + CompiledObject: native + Build$: flag(bench) + BuildDepends: sequence,benchmark + MainIs: bench_persistent_read.ml + +SourceRepository head + Type: git + Location: https://github.com/c-cube/sequence + Browser: https://github.com/c-cube/sequence/tree/master/src diff --git a/_tags b/_tags new file mode 100644 index 00000000..699130f7 --- /dev/null +++ b/_tags @@ -0,0 +1,39 @@ +# OASIS_START +# DO NOT EDIT (digest: e8d5fe31ff471d3c0ec54943fe50d011) +# Ignore VCS directories, you can use the same kind of rule outside +# OASIS_START/STOP if you want to exclude directories that contains +# useless stuff for the build process +<**/.svn>: -traverse +<**/.svn>: not_hygienic +".bzr": -traverse +".bzr": not_hygienic +".hg": -traverse +".hg": not_hygienic +".git": -traverse +".git": not_hygienic +"_darcs": -traverse +"_darcs": not_hygienic +# Library sequence +"sequence.cmxs": use_sequence +# Library invert +"invert/invert.cmxs": use_invert +: pkg_delimcc +: use_sequence +# Executable run_tests +"tests/run_tests.native": pkg_oUnit +"tests/run_tests.native": use_sequence +: pkg_oUnit +: use_sequence +# Executable benchs +"bench/benchs.native": pkg_benchmark +"bench/benchs.native": use_sequence +# Executable bench_persistent +"bench/bench_persistent.native": pkg_benchmark +"bench/bench_persistent.native": use_sequence +# Executable bench_persistent_read +"bench/bench_persistent_read.native": pkg_benchmark +"bench/bench_persistent_read.native": use_sequence +: pkg_benchmark +: use_sequence +# OASIS_STOP +true: bin_annot diff --git a/bench/bench_persistent.ml b/bench/bench_persistent.ml new file mode 100644 index 00000000..022b6b37 --- /dev/null +++ b/bench/bench_persistent.ml @@ -0,0 +1,128 @@ +module MList = struct + type 'a t = { + content : 'a array; (* elements of the node *) + mutable len : int; (* number of elements in content *) + mutable tl : 'a t; (* tail *) + } (** A list that contains some elements, and may point to another list *) + + let _empty () : 'a t = Obj.magic 0 + (** Empty list, for the tl field *) + + let make n = + assert (n > 0); + { content = Array.make n (Obj.magic 0); + len = 0; + tl = _empty (); + } + + let rec is_empty l = + l.len = 0 && (l.tl == _empty () || is_empty l.tl) + + let rec iter f l = + for i = 0 to l.len - 1 do f l.content.(i); done; + if l.tl != _empty () then iter f l.tl + + let iteri f l = + let rec iteri i f l = + for j = 0 to l.len - 1 do f (i+j) l.content.(j); done; + if l.tl != _empty () then iteri (i+l.len) f l.tl + in iteri 0 f l + + let rec iter_rev f l = + (if l.tl != _empty () then iter_rev f l.tl); + for i = l.len - 1 downto 0 do f l.content.(i); done + + let length l = + let rec len acc l = + if l.tl == _empty () then acc+l.len else len (acc+l.len) l.tl + in len 0 l + + (** Get element by index *) + let rec get l i = + if i < l.len then l.content.(i) + else if i >= l.len && l.tl == _empty () then raise (Invalid_argument "MList.get") + else get l.tl (i - l.len) + + (** Push [x] at the end of the list. It returns the block in which the + element is inserted. *) + let rec push x l = + if l.len = Array.length l.content + then begin (* insert in the next block *) + (if l.tl == _empty () then + let n = Array.length l.content in + l.tl <- make (n + n lsr 1)); + push x l.tl + end else begin (* insert in l *) + l.content.(l.len) <- x; + l.len <- l.len + 1; + l + end + + (** Reverse list (in place), and returns the new head *) + let rev l = + let rec rev prev l = + (* reverse array *) + for i = 0 to (l.len-1) / 2 do + let x = l.content.(i) in + l.content.(i) <- l.content.(l.len - i - 1); + l.content.(l.len - i - 1) <- x; + done; + (* reverse next block *) + let l' = l.tl in + l.tl <- prev; + if l' == _empty () then l else rev l l' + in + rev (_empty ()) l + + (** Build a MList of elements of the Seq. The optional argument indicates + the size of the blocks *) + let of_seq ?(size=8) seq = + (* read sequence into a MList.t *) + let start = make size in + let l = ref start in + seq (fun x -> l := push x !l); + start + + let to_seq l = + fun k -> iter k l +end + +(** Store content of the seqerator in an enum *) +let persistent_mlist seq = + let l = MList.of_seq seq in + MList.to_seq l + +let bench_mlist n = + for i = 0 to 100 do + let _ = persistent_mlist Sequence.(1 -- n) in + () + done + +let bench_naive n = + for i = 0 to 100 do + let l = Sequence.to_rev_list Sequence.(1 -- n) in + let _ = Sequence.of_list (List.rev l) in + () + done + +let bench_current n = + for i = 0 to 100 do + let _ = Sequence.persistent Sequence.(1 -- n) in + () + done + +let () = + let bench_n n = + Printf.printf "BENCH for %d\n" n; + let res = Benchmark.throughputN 5 + [ "mlist", bench_mlist, n + ; "naive", bench_naive, n + ; "current", bench_current, n + ] + in Benchmark.tabulate res + in + bench_n 100; + bench_n 100_000; + () + +(* vim:Use benchmark: *) diff --git a/bench/bench_persistent_read.ml b/bench/bench_persistent_read.ml new file mode 100644 index 00000000..8e0dea66 --- /dev/null +++ b/bench/bench_persistent_read.ml @@ -0,0 +1,139 @@ +module MList = struct + type 'a t = { + content : 'a array; (* elements of the node *) + mutable len : int; (* number of elements in content *) + mutable tl : 'a t; (* tail *) + } (** A list that contains some elements, and may point to another list *) + + let _empty () : 'a t = Obj.magic 0 + (** Empty list, for the tl field *) + + let make n = + assert (n > 0); + { content = Array.make n (Obj.magic 0); + len = 0; + tl = _empty (); + } + + let rec is_empty l = + l.len = 0 && (l.tl == _empty () || is_empty l.tl) + + let rec iter f l = + for i = 0 to l.len - 1 do f l.content.(i); done; + if l.tl != _empty () then iter f l.tl + + let iteri f l = + let rec iteri i f l = + for j = 0 to l.len - 1 do f (i+j) l.content.(j); done; + if l.tl != _empty () then iteri (i+l.len) f l.tl + in iteri 0 f l + + let rec iter_rev f l = + (if l.tl != _empty () then iter_rev f l.tl); + for i = l.len - 1 downto 0 do f l.content.(i); done + + let length l = + let rec len acc l = + if l.tl == _empty () then acc+l.len else len (acc+l.len) l.tl + in len 0 l + + (** Get element by index *) + let rec get l i = + if i < l.len then l.content.(i) + else if i >= l.len && l.tl == _empty () then raise (Invalid_argument "MList.get") + else get l.tl (i - l.len) + + (** Push [x] at the end of the list. It returns the block in which the + element is inserted. *) + let rec push x l = + if l.len = Array.length l.content + then begin (* insert in the next block *) + (if l.tl == _empty () then + let n = Array.length l.content in + l.tl <- make (n + n lsr 1)); + push x l.tl + end else begin (* insert in l *) + l.content.(l.len) <- x; + l.len <- l.len + 1; + l + end + + (** Reverse list (in place), and returns the new head *) + let rev l = + let rec rev prev l = + (* reverse array *) + for i = 0 to (l.len-1) / 2 do + let x = l.content.(i) in + l.content.(i) <- l.content.(l.len - i - 1); + l.content.(l.len - i - 1) <- x; + done; + (* reverse next block *) + let l' = l.tl in + l.tl <- prev; + if l' == _empty () then l else rev l l' + in + rev (_empty ()) l + + (** Build a MList of elements of the Seq. The optional argument indicates + the size of the blocks *) + let of_seq ?(size=8) seq = + (* read sequence into a MList.t *) + let start = make size in + let l = ref start in + seq (fun x -> l := push x !l); + start + + let to_seq l = + fun k -> iter k l +end + +(** Store content of the seqerator in an enum *) +let persistent_mlist seq = + let l = MList.of_seq seq in + MList.to_seq l + +let bench_mlist n = + persistent_mlist Sequence.(1 -- n) + +let bench_list n = + let l = Sequence.to_rev_list Sequence.(1 -- n) in + Sequence.of_list (List.rev l) + +let bench_naive n = + let s = Sequence.(1 -- n) in + Sequence.iter ignore s ; + s + +let bench_current n = + Sequence.persistent Sequence.(1 -- n) + +let bench_array n = + let a = Sequence.to_array Sequence.(1 -- n) in + Sequence.of_array a + +let read s = + Sequence.map (fun x -> x + 1) s + +let () = + let bench_n n = + Printf.printf "BENCH for %d\n" n; + let res = + let mlist = bench_mlist n in + let list = bench_list n in + let current = bench_current n in + let array = bench_current n in + let naive = bench_naive n in + Benchmark.throughputN 5 + [ "mlist", read, mlist + ; "list", read, list + ; "current", read, current + ; "array", read, array + ; "naive", read, naive + ] + in Benchmark.tabulate res + in + bench_n 100; + bench_n 100_000; + () + +(* vim:Use benchmark: *) diff --git a/bench/benchs.ml b/bench/benchs.ml new file mode 100644 index 00000000..af8b5db9 --- /dev/null +++ b/bench/benchs.ml @@ -0,0 +1,34 @@ + +module S = Sequence +open Sequence.Infix + +let small = [10;20;50;100;500] +let medium = small @ [1000;10_000;100_000] +let big = medium @ [500_000; 1_000_000; 2_000_000] + +let bench_fold n = + 0 -- n |> S.fold (+) 0 |> ignore + +let bench_flatmap n = + 0 -- n |> S.flatMap (fun i -> i -- (i+5)) |> (fun _ -> ()) + +let bench_product n = + S.product (0 -- n) (0 -- n) (fun (i,j) -> ()) + +let _ = + List.iter + (fun (name,bench,sizes) -> + Format.printf "-------------------------------------------------------@."; + Format.printf "bench %s@." name; + List.iter + (fun n -> + let name = name ^ " on " ^ string_of_int n in + let res = Benchmark.throughput1 2 ~name bench n in + Benchmark.tabulate res; + ) sizes + ) + [ "fold", bench_fold, big + ; "flatmap", bench_flatmap, medium + ; "product", bench_product, small + ]; + () diff --git a/bench/simple_bench.ml b/bench/simple_bench.ml new file mode 100644 index 00000000..96611d7b --- /dev/null +++ b/bench/simple_bench.ml @@ -0,0 +1,11 @@ + +open Sequence.Infix + +let _ = + let n = int_of_string Sys.argv.(1) in + let seq = 0 -- n in + let start = Unix.gettimeofday () in + seq |> Sequence.persistent |> Sequence.fold (+) 0 |> ignore; + let stop = Unix.gettimeofday () in + Format.printf "iter on %d: %.4f@." n (stop -. start); + () diff --git a/configure b/configure new file mode 100755 index 00000000..6acfaeb9 --- /dev/null +++ b/configure @@ -0,0 +1,27 @@ +#!/bin/sh + +# OASIS_START +# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) +set -e + +FST=true +for i in "$@"; do + if $FST; then + set -- + FST=false + fi + + case $i in + --*=*) + ARG=${i%%=*} + VAL=${i##*=} + set -- "$@" "$ARG" "$VAL" + ;; + *) + set -- "$@" "$i" + ;; + esac +done + +ocaml setup.ml -configure "$@" +# OASIS_STOP diff --git a/examples/sexpr.ml b/examples/sexpr.ml new file mode 100644 index 00000000..615f468d --- /dev/null +++ b/examples/sexpr.ml @@ -0,0 +1,305 @@ +(* +Zipperposition: a functional superposition prover for prototyping +Copyright (C) 2012 Simon Cruanes + +This is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301 USA. +*) + +(* {1 Basic S-expressions, with printing and parsing} *) + +(** S-expression *) +type t = + | Atom of string (** An atom *) + | List of t list (** A list of S-expressions *) + +(** Token that compose a Sexpr once serialized *) +type token = [`Open | `Close | `Atom of string] + +(** {2 Traverse a sequence of tokens} *) + +(** Iterate on the S-expression, calling the callback with tokens *) +let rec iter f s = match s with + | Atom a -> f (`Atom a) + | List l -> f `Open; iter_list f l; f `Close +and iter_list f l = match l with + | [] -> () + | x::l' -> iter f x; iter_list f l' + +(** Traverse. This yields a sequence of tokens *) +let traverse s = Sequence.from_iter (fun k -> iter k s) + +(** Returns the same sequence of tokens, but during iteration, if + the structure of the Sexpr corresponding to the sequence + is wrong (bad parenthesing), Invalid_argument is raised + and iteration is stoped *) +let validate seq = + let depth = ref 0 in + Sequence.map + (fun tok -> match tok with + | `Open -> incr depth; tok + | `Close -> if !depth = 0 + then raise (Invalid_argument "wrong parenthesing") + else decr depth; tok + | _ -> tok) + seq + +(** {2 Text <-> tokens} *) + +(** Lex: create a sequence of tokens from the given in_channel. *) +let lex input = + let seq_fun k = + let in_word = ref false in + let buf = Buffer.create 128 in + (* loop. TODO handle escaping of (), and "" *) + let rec next c = + match c with + | '(' -> k `Open + | ')' -> flush_word(); k `Close + | ' ' | '\t' | '\n' -> flush_word () + | c -> in_word := true; Buffer.add_char buf c + (* finish the previous word token *) + and flush_word () = + if !in_word then begin + (* this whitespace follows a word *) + let word = Buffer.contents buf in + Buffer.clear buf; + in_word := false; + k (`Atom word) + end + in + Sequence.iter next input + in + Sequence.from_iter seq_fun + +(** Build a Sexpr from a sequence of tokens *) +let of_seq seq = + (* called on every token *) + let rec k stack token = match token with + | `Open -> `Open :: stack + | `Close -> collapse [] stack + | `Atom a -> (`Expr (Atom a)) :: stack + (* collapse last list into an `Expr *) + and collapse acc stack = match stack with + | `Open::stack' -> `Expr (List acc) :: stack' + | `Expr a::stack' -> collapse (a :: acc) stack' + | _ -> assert false + in + (* iterate on the sequence, given an empty initial stack *) + let stack = Sequence.fold k [] seq in + (* stack should contain exactly one expression *) + match stack with + | [`Expr expr] -> expr + | [] -> failwith "no Sexpr could be parsed" + | _ -> failwith "too many elements on the stack" + +(** {2 Printing} *) + +(** Print a token on the given formatter *) +let pp_token formatter token = match token with + | `Open -> Format.fprintf formatter "@[(" + | `Close -> Format.fprintf formatter ")@]" + | `Atom s -> Format.pp_print_string formatter s + +(** Print a sequence of Sexpr tokens on the given formatter *) +let pp_tokens formatter tokens = + let first = ref true in + let last = ref false in + Sequence.iter + (fun token -> + (match token with + | `Open -> (if not !first then Format.fprintf formatter " "); first := true + | `Close -> first := false; last := true + | _ -> if !first then first := false else Format.fprintf formatter " "); + pp_token formatter token; + if !last then last := false) + tokens + +(** Pretty-print the S-expr. If [indent] is true, the S-expression + is printed with indentation. *) +let pp_sexpr ?(indent=false) formatter s = + if indent + then Format.fprintf formatter "@[%a@]" pp_tokens (traverse s) + else pp_tokens formatter (traverse s) + +(** {2 Serializing} *) + +let output_seq name subexpr k = + k `Open; + k (`Atom name); + Sequence.iter k subexpr; + k `Close + +let output_str name str k = + k `Open; + k (`Atom name); + k (`Atom str); + k `Close + +(** {2 Parsing} *) + +(** Monadic combinators for parsing data from a sequence of tokens, + without converting to concrete S-expressions. + + The [one] parser can raise ParseFailure if it fails to parse + the atomic type. *) + +(** parser that returns a 'a *) +type 'a parser = + | Return : 'a -> 'a parser + | One : (token -> 'a) -> 'a parser + | Zero : (token -> 'a parser) -> 'a parser + (* | Maybe of (token -> 'a option) *) + | Bind : ('b parser * ('b -> 'a parser)) -> 'a parser + | Fail : string -> 'a parser + +exception ParseFailure of string + +let (>>=) p f = Bind (p, f) + +let (>>) p p' = p >>= fun _ -> p' + +let return x = Return x + +let fail reason = Fail reason + +let one f = One f + +let skip = One (fun _ -> ()) + +let lookahead f = Zero f + +let left = One (function | `Open -> () + | _ -> raise (ParseFailure "expected '('")) + +let right = One (function | `Close -> () + | _ -> raise (ParseFailure "expected ')'")) + +let pair f g = + f >>= fun x -> + g >>= fun y -> + return (x, y) + +let triple f g h = + f >>= fun x -> + g >>= fun y -> + h >>= fun z -> + return (x, y, z) + +(** [(name,p) ^|| p'] behaves as p if the next token is [`Atom name], and + like [p'] otherwise *) +let (^||) (name,p) p' = + lookahead + (fun token -> match token with + | `Atom s when s = name -> skip >> p () + | _ -> p') + +(** Maps the value returned by the parser *) +let map p f = p >>= fun x -> return (f x) + +let p_str = one + (function | `Atom s -> s | _ -> raise (ParseFailure "expected string")) + +let p_int = one + (function | `Atom s -> (try int_of_string s + with Failure _ -> raise (ParseFailure "expected int")) + | _ -> raise (ParseFailure "expected int")) + +let p_bool = one + (function | `Atom s -> (try bool_of_string s + with Failure _ -> raise (ParseFailure "expected bool")) + | _ -> raise (ParseFailure "expected bool")) + +let p_float = one + (function | `Atom s -> (try float_of_string s + with Failure _ -> raise (ParseFailure "expected float")) + | _ -> raise (ParseFailure "expected float")) + +let many p = + let rec elements token = + match token with + | `Close -> return [] + | _ -> + p >>= fun x -> + lookahead elements >>= fun l -> + return (x :: l) + in + left >> lookahead elements >>= fun l -> right >> return l + +let many1 p = + p >>= fun x -> + many p >>= fun l -> + return (x::l) + +(** parsing state that returns a 'a *) +type 'a state = + | Bottom : 'a state + | Push : ('b parser * ('b -> 'a state)) -> 'a state + +(** Actually parse the sequence of tokens, with a callback to be called + on every parsed value. The callback decides whether to push another + state or whether to continue. *) +let parse_k p tokens k = + let rec state = Push(p, fun x -> match k x with `Stop -> Bottom | `Continue -> state) in + (* Token handler. It also takes the current parser. *) + let rec one_step state token = + match reduce state with + | Bottom -> (* should not happen, unless there are too many tokens *) + raise (ParseFailure "unexpected ')'") + | Push (Return _, cont) -> + assert false (* should be reduced *) + | Push (Zero f, cont) -> + let p' = f token in + let state' = Push (p', cont) in + one_step state' token (* do not consume token *) + | Push (One f, cont) -> + let x = f token in + let state' = cont x in + reduce state' (* consume token *) + (* | Maybe f, _ -> let x = f token in (Obj.magic cont) x *) + | Push (Bind (p', cont'), cont) -> + let cont'' x = + let p'' = cont' x in + Push (p'', cont) + in + let state' = Push (p', cont'') in + one_step state' token (* do not consume token *) + | Push (Fail reason, _) -> raise (ParseFailure reason) + (* Reduce parser state *) + and reduce state = match state with + | Push (Return x, cont) -> + let state' = cont x in + reduce state' + | _ -> state + in + (* iterate on the tokens *) + ignore (Sequence.fold one_step state tokens) + +(** Parse one value *) +let parse p tokens = + let res = ref None in + parse_k p tokens (fun x -> res := Some x; `Stop); + (* return result *) + match !res with + | None -> raise (ParseFailure "incomplete input") + | Some x -> x + +(** Parse a sequence of values *) +let parse_seq p tokens = + let seq_fun k = + parse_k p tokens (fun x -> k x; `Continue) + in + Sequence.from_iter seq_fun + diff --git a/examples/sexpr.mli b/examples/sexpr.mli new file mode 100644 index 00000000..6a8a53c0 --- /dev/null +++ b/examples/sexpr.mli @@ -0,0 +1,132 @@ +(* +Zipperposition: a functional superposition prover for prototyping +Copyright (C) 2012 Simon Cruanes + +This is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301 USA. +*) + +(* {1 Basic S-expressions, with printing and parsing} *) + +type t = + | Atom of string (** An atom *) + | List of t list (** A list of S-expressions *) + (** S-expression *) + +type token = [`Open | `Close | `Atom of string] + (** Token that compose a Sexpr once serialized *) + +(** {2 Traverse a sequence of tokens} *) + +val iter : (token -> unit) -> t -> unit + (** Iterate on the S-expression, calling the callback with tokens *) + +val traverse : t -> token Sequence.t + (** Traverse. This yields a sequence of tokens *) + +val validate : token Sequence.t -> token Sequence.t + (** Returns the same sequence of tokens, but during iteration, if + the structure of the Sexpr corresponding to the sequence + is wrong (bad parenthesing), Invalid_argument is raised + and iteration is stoped *) + +(** {2 Text <-> tokens} *) + +val lex : char Sequence.t -> token Sequence.t + (** Lex: create a sequence of tokens from the given sequence of chars. *) + +val of_seq : token Sequence.t -> t + (** Build a Sexpr from a sequence of tokens, or raise Failure *) + +(** {2 Printing} *) + +val pp_token : Format.formatter -> token -> unit + (** Print a token on the given formatter *) + +val pp_tokens : Format.formatter -> token Sequence.t -> unit + (** Print a sequence of Sexpr tokens on the given formatter *) + +val pp_sexpr : ?indent:bool -> Format.formatter -> t -> unit + (** Pretty-print the S-expr. If [indent] is true, the S-expression + is printed with indentation. *) + +(** {2 Serializing} *) + +val output_seq : string -> token Sequence.t -> (token -> unit) -> unit + (** print a pair "(name @,sequence)" *) + +val output_str : string -> string -> (token -> unit) -> unit + (** print a pair "(name str)" *) + +(** {2 Parsing} *) + +(** Monadic combinators for parsing data from a sequence of tokens, + without converting to concrete S-expressions. *) + +type 'a parser + +exception ParseFailure of string + +val (>>=) : 'a parser -> ('a -> 'b parser) -> 'b parser + (** Monadic bind: computes a parser from the result of + the first parser *) + +val (>>) : 'a parser -> 'b parser -> 'b parser + (** Like (>>=), but ignores the result of the first parser *) + +val return : 'a -> 'a parser + (** Parser that consumes no input and return the given value *) + +val fail : string -> 'a parser + (** Fails parsing with the given message *) + +val one : (token -> 'a) -> 'a parser + (** consumes one token with the function *) + +val skip : unit parser + (** Skip the token *) + +val lookahead : (token -> 'a parser) -> 'a parser + (** choose parser given current token *) + +val left : unit parser + (** Parses a `Open *) + +val right : unit parser + (** Parses a `Close *) + +val pair : 'a parser -> 'b parser -> ('a * 'b) parser +val triple : 'a parser -> 'b parser -> 'c parser -> ('a * 'b * 'c) parser + +val (^||) : (string * (unit -> 'a parser)) -> 'a parser -> 'a parser + (** [(name,p) ^|| p'] behaves as [p ()] if the next token is [`Atom name], and + like [p'] otherwise *) + +val map : 'a parser -> ('a -> 'b) -> 'b parser + (** Maps the value returned by the parser *) + +val p_str : string parser +val p_int : int parser +val p_bool : bool parser + +val many : 'a parser -> 'a list parser +val many1 : 'a parser -> 'a list parser + +val parse : 'a parser -> token Sequence.t -> 'a + (** Parses exactly one value from the sequence of tokens. Raises + ParseFailure if anything goes wrong. *) + +val parse_seq : 'a parser -> token Sequence.t -> 'a Sequence.t + (** Parses a sequence of values *) diff --git a/examples/test_sexpr.ml b/examples/test_sexpr.ml new file mode 100644 index 00000000..75de0685 --- /dev/null +++ b/examples/test_sexpr.ml @@ -0,0 +1,131 @@ + +(** {2 Test sequences} *) + +(** print a list of items using the printing function *) +let pp_list ?(sep=", ") pp_item formatter l = + Sequence.pp_seq ~sep pp_item formatter (Sequence.of_list l) + +(** Set of integers *) +module ISet = Set.Make(struct type t = int let compare = compare end) +let iset = (module ISet : Set.S with type elt = int and type t = ISet.t) + +module OrderedString = struct type t = string let compare = compare end +module SMap = Sequence.Map.Make(OrderedString) + +let my_map = SMap.of_seq (Sequence.of_list ["1", 1; "2", 2; "3", 3; "answer", 42]) + +let sexpr = "(foo bar (bazz quux hello 42) world (zoo foo bar (1 2 (3 4))))" + +type term = | Lambda of term | Const of string | Var of int | Apply of term * term + +let random_term () = + let max = 10 + and num = ref 0 in + let rec build depth = + if depth > 4 || !num > max then Const (random_const ()) else + match Random.int 6 with + | 0 -> if depth > 0 then Var (Random.int depth) else Const (random_const ()) + | 1 -> incr num; Lambda (build (depth+1)) + | 2 -> Const (random_const ()) + | _ -> incr num; Apply ((build depth), (build depth)) + and random_const () = [|"a"; "b"; "c"; "f"; "g"; "h"|].(Random.int 6) + in build 0 + +let rec sexpr_of_term t = + let f t k = match t with + | Var i -> Sexpr.output_str "var" (string_of_int i) k + | Lambda t' -> Sexpr.output_seq "lambda" (sexpr_of_term t') k + | Apply (t1, t2) -> Sexpr.output_seq "apply" (Sequence.append (sexpr_of_term t1) (sexpr_of_term t2)) k + | Const s -> Sexpr.output_str "const" s k + in Sequence.from_iter (f t) + +let term_parser = + let open Sexpr in + let rec p_term () = + left >> + (("lambda", p_lambda) ^|| ("var", p_var) ^|| ("const", p_const) ^|| + ("apply", p_apply) ^|| fail "bad term") >>= fun x -> + right >> return x + and p_apply () = + p_term () >>= fun x -> + p_term () >>= fun y -> + return (Apply (x,y)) + and p_var () = p_int >>= fun i -> return (Var i) + and p_const () = p_str >>= fun s -> return (Const s) + and p_lambda () = p_term () >>= fun t -> return (Lambda t) + in p_term () + +let term_of_sexp seq = Sexpr.parse term_parser seq + +let test_term () = + let t = random_term () in + Format.printf "@[random term: %a@]@." Sexpr.pp_tokens (sexpr_of_term t); + let tokens = sexpr_of_term t in + let t' = term_of_sexp tokens in + Format.printf "@[parsed: %a@]@." Sexpr.pp_tokens (sexpr_of_term t'); + () + +let _ = + (* lists *) + let l = [0;1;2;3;4;5;6] in + let l' = Sequence.to_list + (Sequence.filter (fun x -> x mod 2 = 0) (Sequence.of_list l)) in + let l'' = Sequence.to_list + (Sequence.take 3 (Sequence.drop 1 (Sequence.of_list l))) in + let h = Hashtbl.create 3 in + for i = 0 to 5 do + Hashtbl.add h i (i*i); + done; + let l2 = Sequence.to_list + (Sequence.map (fun (x, y) -> (string_of_int x) ^ " -> " ^ (string_of_int y)) + (Sequence.of_hashtbl h)) + in + let l3 = Sequence.to_list (Sequence.rev (Sequence.int_range ~start:0 ~stop:42)) in + let set = List.fold_left (fun set x -> ISet.add x set) ISet.empty [4;3;100;42] in + let l4 = Sequence.to_list (Sequence.of_set iset set) in + Format.printf "l=@[[%a]@]@." (pp_list Format.pp_print_int) l; + Format.printf "l'=@[[%a]@]@." (pp_list Format.pp_print_int) l'; + Format.printf "l''=@[[%a]@]@." (pp_list Format.pp_print_int) l''; + Format.printf "l2=@[[%a]@]@." (pp_list Format.pp_print_string) l2; + Format.printf "l3=@[[%a]@]@." (pp_list Format.pp_print_int) l3; + Format.printf "s={@[%a@]}@." (Sequence.pp_seq Format.pp_print_int) (Sequence.of_set iset set); + Format.printf "l4=@[[%a]@]@." (pp_list Format.pp_print_int) l4; + Format.printf "l3[:5]+l4=@[[%a]@]@." (Sequence.pp_seq Format.pp_print_int) + (Sequence.of_array + (Sequence.to_array (Sequence.append + (Sequence.take 5 (Sequence.of_list l3)) (Sequence.of_list l4)))); + (* sequence, persistent, etc *) + let seq = Sequence.int_range ~start:0 ~stop:100000 in + let seq' = Sequence.persistent seq in + let stream = Sequence.to_stream seq' in + Format.printf "test length [0..100000]: persistent1 %d, stream %d, persistent2 %d" + (Sequence.length seq') (Sequence.length (Sequence.of_stream stream)) (Sequence.length seq'); + (* maps *) + Format.printf "@[map: %a@]@." + (Sequence.pp_seq (fun formatter (k,v) -> Format.fprintf formatter "\"%s\" -> %d" k v)) + (SMap.to_seq my_map); + let module MyMapSeq = Sequence.Map.Adapt(Map.Make(OrderedString)) in + let my_map' = MyMapSeq.of_seq (Sequence.of_list ["1", 1; "2", 2; "3", 3; "answer", 42]) in + Format.printf "@[map: %a@]@." + (Sequence.pp_seq (fun formatter (k,v) -> Format.fprintf formatter "\"%s\" -> %d" k v)) + (MyMapSeq.to_seq my_map'); + (* sum *) + let n = 1000000 in + let sum = Sequence.fold (+) 0 (Sequence.take n (Sequence.repeat 1)) in + Format.printf "%dx1 = %d@." n sum; + assert (n=sum); + (* sexpr *) + let s = Sexpr.of_seq (Sexpr.lex (Sequence.of_str sexpr)) in + let s = Sexpr.of_seq (Sequence.map + (function | `Atom s -> `Atom (String.capitalize s) | tok -> tok) + (Sexpr.traverse s)) + in + Format.printf "@[transform @[%s@] into @[%a@]@]@." sexpr (Sexpr.pp_sexpr ~indent:false) s; + Format.printf "@[ cycle:%a@]@." Sexpr.pp_tokens + (Sequence.concat (Sequence.take 10 (Sequence.repeat (Sexpr.traverse s)))); + (* sexpr parsing/printing *) + for i = 0 to 20 do + Format.printf "%d-th term test@." i; + test_term (); + done; + () diff --git a/invert/.merlin b/invert/.merlin new file mode 100644 index 00000000..3b9a31d9 --- /dev/null +++ b/invert/.merlin @@ -0,0 +1,2 @@ +REC +PKG delimcc diff --git a/invert/invert.mldylib b/invert/invert.mldylib new file mode 100644 index 00000000..b031b43d --- /dev/null +++ b/invert/invert.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: d74492d261fcc87665b60e0331c04236) +SequenceInvert +# OASIS_STOP diff --git a/invert/invert.mllib b/invert/invert.mllib new file mode 100644 index 00000000..b031b43d --- /dev/null +++ b/invert/invert.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: d74492d261fcc87665b60e0331c04236) +SequenceInvert +# OASIS_STOP diff --git a/invert/sequenceInvert.ml b/invert/sequenceInvert.ml new file mode 100644 index 00000000..46efc693 --- /dev/null +++ b/invert/sequenceInvert.ml @@ -0,0 +1,62 @@ +(* +Copyright (c) 2014, Simon Cruanes +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. Redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Interface to Delimcc (Invert control flow)} *) + +type 'a gen = unit -> 'a option + +type 'a res = + | Start + | Yield of 'a + | Stop + +let _ret_none () = None +let _ret_unit () = () + +let to_gen seq = + let p = Delimcc.new_prompt () in + let _next = ref None in + ignore (Delimcc.push_prompt p + (fun () -> + Delimcc.take_subcont p (fun c () -> _next := Some c; Start); + seq + (fun x -> + Delimcc.take_subcont p (fun c () -> _next := Some c; Yield x) + ); + _next := None; + Stop + )); + (* call next subcont *) + let rec next () = + match !_next with + | None -> None + | Some f -> + begin match Delimcc.push_delim_subcont f _ret_unit with + | Start -> next () + | Yield x -> Some x + | Stop -> None + end + in + next diff --git a/invert/sequenceInvert.mli b/invert/sequenceInvert.mli new file mode 100644 index 00000000..bd3c8433 --- /dev/null +++ b/invert/sequenceInvert.mli @@ -0,0 +1,32 @@ +(* +Copyright (c) 2014, Simon Cruanes +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. Redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Interface to Delimcc (Invert control flow)} *) + +type 'a gen = unit -> 'a option + +val to_gen : 'a Sequence.t -> 'a gen +(** Use delimited continuations to iterate on the sequence step by step. + Relatively costly but still useful *) diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 00000000..0d9d2514 --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,610 @@ +(* OASIS_START *) +(* DO NOT EDIT (digest: c4bb6d2ca42efb069d5612eb2bbcf244) *) +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 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_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + 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 + + +# 132 "myocamlbuild.ml" +module BaseEnvLight = struct +(* # 22 "src/base/BaseEnvLight.ml" *) + + + module MapString = Map.Make(String) + + + type t = string MapString.t + + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 237 "myocamlbuild.ml" +module MyOCamlbuildFindlib = struct +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) + + + (** OCamlbuild extension, copied from + * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild + * by N. Pouillard and others + * + * Updated on 2009/02/28 + * + * Modified by Sylvain Le Gall + *) + open Ocamlbuild_plugin + + + (* these functions are not really officially exported *) + let run_and_read = + Ocamlbuild_pack.My_unix.run_and_read + + + let blank_sep_strings = + Ocamlbuild_pack.Lexers.blank_sep_strings + + + let exec_from_conf exec = + let exec = + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in + try + BaseEnvLight.var_get exec env + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" exec; + exec + in + let fix_win32 str = + if Sys.os_type = "Win32" then begin + let buff = Buffer.create (String.length str) in + (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. + *) + String.iter + (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) + str; + Buffer.contents buff + end else begin + str + end + in + fix_win32 exec + + let split s ch = + let buf = Buffer.create 13 in + let x = ref [] in + let flush () = + x := (Buffer.contents buf) :: !x; + Buffer.clear buf + in + String.iter + (fun c -> + if c = ch then + flush () + else + Buffer.add_char buf c) + s; + flush (); + List.rev !x + + + let split_nl s = split s '\n' + + + let before_space s = + try + String.before s (String.index s ' ') + with Not_found -> s + + (* ocamlfind command *) + let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] + + (* This lists all supported packages. *) + let find_packages () = + List.map before_space (split_nl & run_and_read "ocamlfind list") + + + (* Mock to list available syntaxes. *) + let find_syntaxes () = ["camlp4o"; "camlp4r"] + + + let well_known_syntax = [ + "camlp4.quotations.o"; + "camlp4.quotations.r"; + "camlp4.exceptiontracer"; + "camlp4.extend"; + "camlp4.foldgenerator"; + "camlp4.listcomprehension"; + "camlp4.locationstripper"; + "camlp4.macro"; + "camlp4.mapgenerator"; + "camlp4.metagenerator"; + "camlp4.profiler"; + "camlp4.tracer" + ] + + + let dispatch = + function + | After_options -> + (* By using Before_options one let command line options have an higher + * priority on the contrary using After_options will guarantee to have + * the higher priority override default commands by ocamlfind ones *) + Options.ocamlc := ocamlfind & A"ocamlc"; + Options.ocamlopt := ocamlfind & A"ocamlopt"; + Options.ocamldep := ocamlfind & A"ocamldep"; + Options.ocamldoc := ocamlfind & A"ocamldoc"; + Options.ocamlmktop := ocamlfind & A"ocamlmktop"; + Options.ocamlmklib := ocamlfind & A"ocamlmklib" + + | After_rules -> + + (* When one link an OCaml library/binary/package, one should use + * -linkpkg *) + flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + let base_args = [A"-package"; A pkg] in + (* TODO: consider how to really choose camlp4o or camlp4r. *) + let syn_args = [A"-syntax"; A "camlp4o"] in + let args = + (* Heuristic to identify syntax extensions: whether they end in + ".syntax"; some might not. + *) + if Filename.check_suffix pkg "syntax" || + List.mem pkg well_known_syntax then + syn_args @ base_args + else + base_args + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + end + (find_packages ()); + + (* Like -package but for extensions syntax. Morover -syntax is useless + * when linking. *) + List.iter begin fun syntax -> + flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & + S[A"-syntax"; A syntax]; + end (find_syntaxes ()); + + (* The default "thread" tag is not compatible with ocamlfind. + * Indeed, the default rules add the "threads.cma" or "threads.cmxa" + * options when using this tag. When using the "-linkpkg" option with + * ocamlfind, this module will then be added twice on the command line. + * + * To solve this, one approach is to add the "-thread" option when using + * the "threads" package using the previous plugin. + *) + flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); + + | _ -> + () +end + +module MyOCamlbuildBase = struct +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + + (** Base functions for writing myocamlbuild.ml + @author Sylvain Le Gall + *) + + + + + + open Ocamlbuild_plugin + module OC = Ocamlbuild_pack.Ocaml_compiler + + + type dir = string + type file = string + type name = string + type tag = string + + +(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + + type t = + { + lib_ocaml: (name * dir list * string list) list; + lib_c: (name * dir * file list) list; + flags: (tag list * (spec OASISExpr.choices)) list; + (* Replace the 'dir: include' from _tags by a precise interdepends in + * directory. + *) + includes: (dir * dir list) list; + } + + + let env_filename = + Pathname.basename + BaseEnvLight.default_filename + + + let dispatch_combine lst = + fun e -> + List.iter + (fun dispatch -> dispatch e) + lst + + + let tag_libstubs nm = + "use_lib"^nm^"_stubs" + + + let nm_libstubs nm = + nm^"_stubs" + + + let dispatch t e = + let env = + BaseEnvLight.load + ~filename:env_filename + ~allow_empty:true + () + in + match e with + | Before_options -> + let no_trailing_dot s = + if String.length s >= 1 && s.[0] = '.' then + String.sub s 1 ((String.length s) - 1) + else + s + in + List.iter + (fun (opt, var) -> + try + opt := no_trailing_dot (BaseEnvLight.var_get var env) + with Not_found -> + Printf.eprintf "W: Cannot get variable %s\n" var) + [ + Options.ext_obj, "ext_obj"; + Options.ext_lib, "ext_lib"; + Options.ext_dll, "ext_dll"; + ] + + | After_rules -> + (* Declare OCaml libraries *) + List.iter + (function + | nm, [], intf_modules -> + ocaml_lib nm; + let cmis = + List.map (fun m -> (String.uncapitalize m) ^ ".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis + | nm, dir :: tl, intf_modules -> + ocaml_lib ~dir:dir (dir^"/"^nm); + List.iter + (fun dir -> + List.iter + (fun str -> + flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) + ["compile"; "infer_interface"; "doc"]) + tl; + let cmis = + List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] + cmis) + t.lib_ocaml; + + (* Declare directories dependencies, replace "include" in _tags. *) + List.iter + (fun (dir, include_dirs) -> + Pathname.define_context dir include_dirs) + t.includes; + + (* Declare C libraries *) + List.iter + (fun (lib, dir, headers) -> + (* Handle C part of library *) + flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; + A("-l"^(nm_libstubs lib))]); + + flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] + (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); + + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); + + (* When ocaml link something that use the C library, then one + need that file to be up to date. + *) + dep ["link"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + dep ["compile"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + (* TODO: be more specific about what depends on headers *) + (* Depends on .h files *) + dep ["compile"; "c"] + headers; + + (* Setup search path for lib *) + flag ["link"; "ocaml"; "use_"^lib] + (S[A"-I"; P(dir)]); + ) + t.lib_c; + + (* Add flags *) + List.iter + (fun (tags, cond_specs) -> + let spec = BaseEnvLight.var_choose cond_specs env in + let rec eval_specs = + function + | S lst -> S (List.map eval_specs lst) + | A str -> A (BaseEnvLight.var_expand str env) + | spec -> spec + in + flag tags & (eval_specs spec)) + t.flags + | _ -> + () + + + let dispatch_default t = + dispatch_combine + [ + dispatch t; + MyOCamlbuildFindlib.dispatch; + ] + + +end + + +# 594 "myocamlbuild.ml" +open Ocamlbuild_plugin;; +let package_default = + { + MyOCamlbuildBase.lib_ocaml = + [("sequence", [], []); ("invert", ["invert"], [])]; + lib_c = []; + flags = []; + includes = [] + } + ;; + +let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; + +# 609 "myocamlbuild.ml" +(* OASIS_STOP *) +Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/sequence.ml b/sequence.ml new file mode 100644 index 00000000..9e5fb844 --- /dev/null +++ b/sequence.ml @@ -0,0 +1,771 @@ +(* +Copyright (c) 2013, Simon Cruanes +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. Redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Transient iterators, that abstract on a finite sequence of elements.} *) + +(** Sequence abstract iterator type *) +type 'a t = ('a -> unit) -> unit + +type 'a sequence = 'a t + +type (+'a, +'b) t2 = ('a -> 'b -> unit) -> unit + (** Sequence of pairs of values of type ['a] and ['b]. *) + +(** Build a sequence from a iter function *) +let from_iter f = f + +let rec from_fun f k = match f () with + | None -> () + | Some x -> k x; from_fun f k + +let empty k = () + +let singleton x k = k x +let return x k = k x +let pure f k = k f + +let doubleton x y k = k x; k y + +let cons x l k = k x; l k +let snoc l x k = l k; k x + +let repeat x k = while true do k x done + +let rec iterate f x k = + k x; + iterate f (f x) k + +let rec forever f k = + k (f ()); + forever f k + +let cycle s k = while true do s k; done + +let iter f seq = seq f + +let iteri f seq = + let r = ref 0 in + seq + (fun x -> + f !r x; + incr r) + +let fold f init seq = + let r = ref init in + seq (fun elt -> r := f !r elt); + !r + +let foldi f init seq = + let i = ref 0 in + let r = ref init in + seq + (fun elt -> + r := f !r !i elt; + incr i); + !r + +let map f seq k = seq (fun x -> k (f x)) + +let mapi f seq k = + let i = ref 0 in + seq (fun x -> k (f !i x); incr i) + +let filter p seq k = seq (fun x -> if p x then k x) + +let append s1 s2 k = s1 k; s2 k + +let concat s k = s (fun s' -> s' k) + +let flatten s = concat s + +let flatMap f seq k = seq (fun x -> f x k) + +let flat_map = flatMap + +let fmap f seq k = + seq (fun x -> match f x with + | None -> () + | Some y -> k y + ) + +let filter_map = fmap + +let intersperse elem seq k = + let first = ref true in + seq (fun x -> (if !first then first := false else k elem); k x) + +(** Mutable unrolled list to serve as intermediate storage *) +module MList = struct + type 'a node = + | Nil + | Cons of 'a array * int ref * 'a node ref + + (* build and call callback on every element *) + let of_seq_with seq k = + let start = ref Nil in + let chunk_size = ref 8 in + (* fill the list. prev: tail-reference from previous node *) + let prev, cur = ref start, ref Nil in + seq + (fun x -> + k x; (* callback *) + match !cur with + | Nil -> + let n = !chunk_size in + if n < 4096 then chunk_size := 2 * !chunk_size; + cur := Cons (Array.make n x, ref 1, ref Nil) + | Cons (a,n,next) -> + assert (!n < Array.length a); + a.(!n) <- x; + incr n; + if !n = Array.length a then begin + !prev := !cur; + prev := next; + cur := Nil + end + ); + !prev := !cur; + !start + + let of_seq seq = + of_seq_with seq (fun _ -> ()) + + let is_empty = function + | Nil -> true + | Cons _ -> false + + let rec iter f l = match l with + | Nil -> () + | Cons (a, n, tl) -> + for i=0 to !n - 1 do f a.(i) done; + iter f !tl + + let iteri f l = + let rec iteri i f l = match l with + | Nil -> () + | Cons (a, n, tl) -> + for j=0 to !n - 1 do f (i+j) a.(j) done; + iteri (i+ !n) f !tl + in iteri 0 f l + + let rec iter_rev f l = match l with + | Nil -> () + | Cons (a, n, tl) -> + iter_rev f !tl; + for i = !n-1 downto 0 do f a.(i) done + + let length l = + let rec len acc l = match l with + | Nil -> acc + | Cons (_, n, tl) -> len (acc+ !n) !tl + in len 0 l + + (** Get element by index *) + let rec get l i = match l with + | Nil -> raise (Invalid_argument "MList.get") + | Cons (a, n, _) when i < !n -> a.(i) + | Cons (_, n, tl) -> get !tl (i- !n) + + let to_seq l k = iter k l + + let _to_next arg l = + let cur = ref l in + let i = ref 0 in (* offset in cons *) + let rec get_next _ = match !cur with + | Nil -> None + | Cons (_, n, tl) when !i = !n -> + cur := !tl; + i := 0; + get_next arg + | Cons (a, n, _) -> + let x = a.(!i) in + incr i; + Some x + in get_next + + let to_gen l = _to_next () l + + let to_stream l = + Stream.from (_to_next 42 l) (* 42=magic cookiiiiiie *) + + let to_klist l = + let rec make (l,i) () = match l with + | Nil -> `Nil + | Cons (_, n, tl) when i = !n -> make (!tl,0) () + | Cons (a, n, _) -> `Cons (a.(i), make (l,i+1)) + in make (l,0) +end + +let persistent seq = + let l = MList.of_seq seq in + MList.to_seq l + +type 'a lazy_state = + | LazySuspend + | LazyCached of 'a t + +let persistent_lazy (seq:'a t) = + let r = ref LazySuspend in + fun k -> + match !r with + | LazyCached seq' -> seq' k + | LazySuspend -> + (* here if this traversal is interruted, no caching occurs *) + let seq' = MList.of_seq_with seq k in + r := LazyCached (MList.to_seq seq') + +let sort ?(cmp=Pervasives.compare) seq = + (* use an intermediate list, then sort the list *) + let l = fold (fun l x -> x::l) [] seq in + let l = List.fast_sort cmp l in + fun k -> List.iter k l + +let group ?(eq=fun x y -> x = y) seq k = + let cur = ref [] in + seq (fun x -> + match !cur with + | [] -> cur := [x] + | (y::_) as l when eq x y -> + cur := x::l (* [x] belongs to the group *) + | (_::_) as l -> + k l; (* yield group, and start another one *) + cur := [x]); + (* last list *) + if !cur <> [] then k !cur + +let uniq ?(eq=fun x y -> x = y) seq k = + let has_prev = ref false + and prev = ref (Obj.magic 0) in (* avoid option type, costly *) + seq (fun x -> + if !has_prev && eq !prev x + then () (* duplicate *) + else begin + has_prev := true; + prev := x; + k x + end) + +let sort_uniq (type elt) ?(cmp=Pervasives.compare) seq = + let module S = Set.Make(struct + type t = elt + let compare = cmp + end) in + let set = fold (fun acc x -> S.add x acc) S.empty seq in + fun k -> S.iter k set + +let product outer inner k = + outer (fun x -> + inner (fun y -> k (x,y)) + ) + +let product2 outer inner k = + outer (fun x -> + inner (fun y -> k x y) + ) + +let join ~join_row s1 s2 k = + s1 (fun a -> + s2 (fun b -> + match join_row a b with + | None -> () + | Some c -> k c + ) + ) (* yield the combination of [a] and [b] *) + +let rec unfoldr f b k = match f b with + | None -> () + | Some (x, b') -> + k x; + unfoldr f b' k + +let scan f acc seq k = + k acc; + let acc = ref acc in + seq (fun elt -> let acc' = f !acc elt in k acc'; acc := acc') + +let max ?(lt=fun x y -> x < y) seq = + let ret = ref None in + seq (fun x -> match !ret with + | None -> ret := Some x + | Some y -> if lt y x then ret := Some x); + !ret + +let min ?(lt=fun x y -> x < y) seq = + let ret = ref None in + seq (fun x -> match !ret with + | None -> ret := Some x + | Some y -> if lt x y then ret := Some x); + !ret + +exception ExitSequence + +let head seq = + let r = ref None in + try + seq (fun x -> r := Some x; raise ExitSequence); None + with ExitSequence -> !r + +let head_exn seq = + match head seq with + | None -> invalid_arg "Sequence.head_exn" + | Some x -> x + +let take n seq k = + let count = ref 0 in + try + seq (fun x -> + incr count; + k x; + if !count = n then raise ExitSequence + ) + with ExitSequence -> () + +let take_while p seq k = + try + seq (fun x -> if p x then k x else raise ExitSequence) + with ExitSequence -> () + +let drop n seq k = + let count = ref 0 in + seq (fun x -> if !count >= n then k x else incr count) + +let drop_while p seq k = + let drop = ref true in + seq (fun x -> + if !drop + then if p x then () else (drop := false; k x) + else k x) + +let rev seq = + let l = MList.of_seq seq in + fun k -> MList.iter_rev k l + +let for_all p seq = + try + seq (fun x -> if not (p x) then raise ExitSequence); + true + with ExitSequence -> false + +(** Exists there some element satisfying the predicate? *) +let exists p seq = + try + seq (fun x -> if p x then raise ExitSequence); + false + with ExitSequence -> true + +let mem ?(eq=(=)) x seq = exists (eq x) seq + +let find f seq = + let r = ref None in + begin try + seq (fun x -> match f x with + | None -> () + | Some _ as res -> r := res + ); + with ExitSequence -> () + end; + !r + +let length seq = + let r = ref 0 in + seq (fun _ -> incr r); + !r + +let is_empty seq = + try seq (fun _ -> raise ExitSequence); true + with ExitSequence -> false + +(** {2 Transform a sequence} *) + +let empty2 k = () + +let is_empty2 seq2 = + try ignore (seq2 (fun _ _ -> raise ExitSequence)); true + with ExitSequence -> false + +let length2 seq2 = + let r = ref 0 in + seq2 (fun _ _ -> incr r); + !r + +let zip seq2 k = seq2 (fun x y -> k (x,y)) + +let unzip seq k = seq (fun (x,y) -> k x y) + +let zip_i seq k = + let r = ref 0 in + seq (fun x -> let n = !r in incr r; k n x) + +let fold2 f acc seq2 = + let acc = ref acc in + seq2 (fun x y -> acc := f !acc x y); + !acc + +let iter2 f seq2 = seq2 f + +let map2 f seq2 k = seq2 (fun x y -> k (f x y)) + +let map2_2 f g seq2 k = + seq2 (fun x y -> k (f x y) (g x y)) + +(** {2 Basic data structures converters} *) + +let to_list seq = List.rev (fold (fun y x -> x::y) [] seq) + +let to_rev_list seq = fold (fun y x -> x :: y) [] seq + +let to_opt = head + +let of_opt o k = match o with + | None -> () + | Some x -> k x + +let of_list l k = List.iter k l + +let to_array seq = + let l = MList.of_seq seq in + let n = MList.length l in + if n = 0 + then [||] + else begin + let a = Array.make n (MList.get l 0) in + MList.iteri (fun i x -> a.(i) <- x) l; + a + end + +let of_array a k = + for i = 0 to Array.length a - 1 do + k (Array.unsafe_get a i) + done + +let of_array_i a k = + for i = 0 to Array.length a - 1 do + k (i, Array.unsafe_get a i) + done + +let of_array2 a k = + for i = 0 to Array.length a - 1 do + k i (Array.unsafe_get a i) + done + +let array_slice a i j k = + assert (i >= 0 && j < Array.length a); + for idx = i to j do + k a.(idx); (* iterate on sub-array *) + done + +let of_stream s k = Stream.iter k s + +let to_stream seq = + let l = MList.of_seq seq in + MList.to_stream l + +let to_stack s seq = iter (fun x -> Stack.push x s) seq + +let of_stack s k = Stack.iter k s + +let to_queue q seq = seq (fun x -> Queue.push x q) + +let of_queue q k = Queue.iter k q + +let hashtbl_add h seq = + seq (fun (k,v) -> Hashtbl.add h k v) + +let hashtbl_replace h seq = + seq (fun (k,v) -> Hashtbl.replace h k v) + +let to_hashtbl seq = + let h = Hashtbl.create 3 in + hashtbl_replace h seq; + h + +let to_hashtbl2 seq2 = + let h = Hashtbl.create 3 in + seq2 (fun k v -> Hashtbl.replace h k v); + h + +let of_hashtbl h k = Hashtbl.iter (fun a b -> k (a, b)) h + +let of_hashtbl2 h k = Hashtbl.iter k h + +let hashtbl_keys h k = Hashtbl.iter (fun a b -> k a) h + +let hashtbl_values h k = Hashtbl.iter (fun a b -> k b) h + +let of_str s k = String.iter k s + +let to_str seq = + let b = Buffer.create 64 in + iter (fun c -> Buffer.add_char b c) seq; + Buffer.contents b + +let concat_str seq = + let b = Buffer.create 64 in + iter (Buffer.add_string b) seq; + Buffer.contents b + +exception OneShotSequence + +let of_in_channel ic = + let first = ref true in + fun k -> + if not !first + then raise OneShotSequence + else ( + first := false; + try + while true do + let c = input_char ic in k c + done + with End_of_file -> () + ) + +let to_buffer seq buf = + seq (fun c -> Buffer.add_char buf c) + +(** Iterator on integers in [start...stop] by steps 1 *) +let int_range ~start ~stop k = + for i = start to stop do k i done + +let int_range_dec ~start ~stop k = + for i = start downto stop do k i done + +let of_set (type s) (type v) m set = + let module S = (val m : Set.S with type t = s and type elt = v) in + fun k -> S.iter k set + +let to_set (type s) (type v) m seq = + let module S = (val m : Set.S with type t = s and type elt = v) in + fold + (fun set x -> S.add x set) + S.empty seq + +type 'a gen = unit -> 'a option +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] + +let of_gen g = + (* consume the generator to build a MList *) + let rec iter1 k = match g () with + | None -> () + | Some x -> k x; iter1 k + in + let l = MList.of_seq iter1 in + MList.to_seq l + +let to_gen seq = + let l = MList.of_seq seq in + MList.to_gen l + +let rec of_klist l k = match l() with + | `Nil -> () + | `Cons (x,tl) -> k x; of_klist tl k + +let to_klist seq = + let l = MList.of_seq seq in + MList.to_klist l + +(** {2 Functorial conversions between sets and sequences} *) + +module Set = struct + module type S = sig + include Set.S + val of_seq : elt sequence -> t + val to_seq : t -> elt sequence + val to_list : t -> elt list + val of_list : elt list -> t + end + + (** Create an enriched Set module from the given one *) + module Adapt(X : Set.S) = struct + let to_seq set k = X.iter k set + + let of_seq seq = fold (fun set x -> X.add x set) X.empty seq + + let of_list l = of_seq (of_list l) + + let to_list set = to_list (to_seq set) + + include X + end + + (** Functor to build an extended Set module from an ordered type *) + module Make(X : Set.OrderedType) = struct + module MySet = Set.Make(X) + include Adapt(MySet) + end +end + +(** {2 Conversion between maps and sequences.} *) + +module Map = struct + module type S = sig + include Map.S + val to_seq : 'a t -> (key * 'a) sequence + val of_seq : (key * 'a) sequence -> 'a t + val keys : 'a t -> key sequence + val values : 'a t -> 'a sequence + val to_list : 'a t -> (key * 'a) list + val of_list : (key * 'a) list -> 'a t + end + + (** Adapt a pre-existing Map module to make it sequence-aware *) + module Adapt(M : Map.S) = struct + let to_seq m = from_iter (fun k -> M.iter (fun x y -> k (x,y)) m) + + let of_seq seq = fold (fun m (k,v) -> M.add k v m) M.empty seq + + let keys m = from_iter (fun k -> M.iter (fun x _ -> k x) m) + + let values m = from_iter (fun k -> M.iter (fun _ y -> k y) m) + + let of_list l = of_seq (of_list l) + + let to_list x = to_list (to_seq x) + + include M + end + + (** Create an enriched Map module, with sequence-aware functions *) + module Make(V : Map.OrderedType) : S with type key = V.t = struct + module M = Map.Make(V) + include Adapt(M) + end +end + +(** {2 Infinite sequences of random values} *) + +let random_int bound = forever (fun () -> Random.int bound) + +let random_bool = forever Random.bool + +let random_float bound = forever (fun () -> Random.float bound) + +let random_array a k = + assert (Array.length a > 0); + while true do + let i = Random.int (Array.length a) in + k a.(i); + done + +let random_list l = random_array (Array.of_list l) + +(** {2 Infix functions} *) + +module Infix = struct + let (--) i j = int_range ~start:i ~stop:j + + let (--^) i j = int_range_dec ~start:i ~stop:j + + let (>>=) x f = flat_map f x + + let (>|=) x f = map f x + + let (<*>) funs args k = + funs (fun f -> args (fun x -> k (f x))) + + let (<+>) = append +end + +include Infix + +(** {2 Pretty printing of sequences} *) + +(** Pretty print a sequence of ['a], using the given pretty printer + to print each elements. An optional separator string can be provided. *) +let pp_seq ?(sep=", ") pp_elt formatter seq = + let first = ref true in + seq + (fun x -> + (if !first then first := false + else begin + Format.pp_print_string formatter sep; + Format.pp_print_cut formatter (); + end); + pp_elt formatter x) + +let pp_buf ?(sep=", ") pp_elt buf seq = + let first = ref true in + seq + (fun x -> + if !first then first := false else Buffer.add_string buf sep; + pp_elt buf x) + +let to_string ?sep pp_elt seq = + let buf = Buffer.create 25 in + pp_buf ?sep (fun buf x -> Buffer.add_string buf (pp_elt x)) buf seq; + Buffer.contents buf + +(** {2 Basic IO} *) + +module IO = struct + let lines_of ?(mode=0o644) ?(flags=[Open_rdonly]) filename = + fun k -> + let ic = open_in_gen flags mode filename in + try + while true do + let line = input_line ic in + k line + done + with + | End_of_file -> close_in ic + | e -> close_in_noerr ic; raise e + + let chunks_of ?(mode=0o644) ?(flags=[]) ?(size=1024) filename = + fun k -> + let ic = open_in_gen flags mode filename in + try + let buf = String.create size in + let n = ref 0 in + let stop = ref false in + while not !stop do + n := 0; + (* try to read [size] chars. If [input] returns [0] it means + the end of file, so we stop, but first we yield the current chunk *) + while !n < size && not !stop do + let n' = input ic buf !n (size - !n) in + if n' = 0 then stop := true else n := !n + n'; + done; + if !n > 0 + then k (String.sub buf 0 !n) + done; + close_in ic + with e -> + close_in_noerr ic; + raise e + + let write_to ?(mode=0o644) ?(flags=[Open_creat;Open_wronly]) filename seq = + let oc = open_out_gen flags mode filename in + try + seq (fun s -> output oc s 0 (String.length s)); + close_out oc + with e -> + close_out oc; + raise e + + let write_lines ?mode ?flags filename seq = + write_to ?mode ?flags filename (snoc (intersperse "\n" seq) "\n") +end + + diff --git a/sequence.mldylib b/sequence.mldylib new file mode 100644 index 00000000..2f635d2a --- /dev/null +++ b/sequence.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5) +Sequence +# OASIS_STOP diff --git a/sequence.mli b/sequence.mli new file mode 100644 index 00000000..04a63102 --- /dev/null +++ b/sequence.mli @@ -0,0 +1,587 @@ +(* +copyright (c) 2013, simon cruanes +all rights reserved. + +redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Simple and Efficient Iterators} *) + +(** The iterators are designed to allow easy transfer (mappings) between data + structures, without defining [n^2] conversions between the [n] types. The + implementation relies on the assumption that a sequence can be iterated + on as many times as needed; this choice allows for high performance + of many combinators. However, for transient iterators, the {!persistent} + function is provided, storing elements of a transient iterator + in memory; the iterator can then be used several times (See further). + + Note that some combinators also return sequences (e.g. {!group}). The + transformation is computed on the fly every time one iterates over + the resulting sequence. If a transformation performs heavy computation, + {!persistent} can also be used as intermediate storage. + + Most functions are {b lazy}, i.e. they do not actually use their arguments + until their result is iterated on. For instance, if one calls {!map} + on a sequence, one gets a new sequence, but nothing else happens until + this new sequence is used (by folding or iterating on it). + + If a sequence is built from an iteration function that is {b repeatable} + (i.e. calling it several times always iterates on the same set of + elements, for instance List.iter or Map.iter), then + the resulting {!t} object is also repeatable. For {b one-time iter functions} + such as iteration on a file descriptor or a {!Stream}, + the {!persistent} function can be used to iterate and store elements in + a memory structure; the result is a sequence that iterates on the elements + of this memory structure, cheaply and repeatably. *) + +type +'a t = ('a -> unit) -> unit + (** A sequence of values of type ['a]. If you give it a function ['a -> unit] + it will be applied to every element of the sequence successively. *) + +type +'a sequence = 'a t + +type (+'a, +'b) t2 = ('a -> 'b -> unit) -> unit + (** Sequence of pairs of values of type ['a] and ['b]. *) + +(** {2 Build a sequence} *) + +val from_iter : (('a -> unit) -> unit) -> 'a t + (** Build a sequence from a iter function *) + +val from_fun : (unit -> 'a option) -> 'a t + (** Call the function repeatedly until it returns None. This + sequence is transient, use {!persistent} if needed! *) + +val empty : 'a t + (** Empty sequence. It contains no element. *) + +val singleton : 'a -> 'a t + (** Singleton sequence, with exactly one element. *) + +val doubleton : 'a -> 'a -> 'a t + (** Sequence with exactly two elements *) + +val cons : 'a -> 'a t -> 'a t + (** [cons x l] yields [x], then yields from [l]. + Same as [append (singleton x) l] *) + +val snoc : 'a t -> 'a -> 'a t + (** Same as {!cons} but yields the element after iterating on [l] *) + +val return : 'a -> 'a t + (** Synonym to {!singleton} *) + +val pure : 'a -> 'a t + (** Synonym to {!singleton} *) + +val repeat : 'a -> 'a t + (** Infinite sequence of the same element. You may want to look + at {!take} and the likes if you iterate on it. *) + +val iterate : ('a -> 'a) -> 'a -> 'a t + (** [iterate f x] is the infinite sequence [x, f(x), f(f(x)), ...] *) + +val forever : (unit -> 'b) -> 'b t + (** Sequence that calls the given function to produce elements. + The sequence may be transient (depending on the function), and definitely + is infinite. You may want to use {!take} and {!persistent}. *) + +val cycle : 'a t -> 'a t + (** Cycle forever through the given sequence. Assume the given sequence can + be traversed any amount of times (not transient). This yields an + infinite sequence, you should use something like {!take} not to loop + forever. *) + +(** {2 Consume a sequence} *) + +val iter : ('a -> unit) -> 'a t -> unit + (** Consume the sequence, passing all its arguments to the function. + Basically [iter f seq] is just [seq f]. *) + +val iteri : (int -> 'a -> unit) -> 'a t -> unit + (** Iterate on elements and their index in the sequence *) + +val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b + (** Fold over elements of the sequence, consuming it *) + +val foldi : ('b -> int -> 'a -> 'b) -> 'b -> 'a t -> 'b + (** Fold over elements of the sequence and their index, consuming it *) + +val map : ('a -> 'b) -> 'a t -> 'b t + (** Map objects of the sequence into other elements, lazily *) + +val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t + (** Map objects, along with their index in the sequence *) + +val for_all : ('a -> bool) -> 'a t -> bool + (** Do all elements satisfy the predicate? *) + +val exists : ('a -> bool) -> 'a t -> bool + (** Exists there some element satisfying the predicate? *) + +val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool + (** Is the value a member of the sequence? + @param eq the equality predicate to use (default [(=)]) + @since 0.5 *) + +val find : ('a -> 'b option) -> 'a t -> 'b option + (** Find the first element on which the function doesn't return [None] + @since 0.5 *) + +val length : 'a t -> int + (** How long is the sequence? Forces the sequence. *) + +val is_empty : 'a t -> bool + (** Is the sequence empty? Forces the sequence. *) + +(** {2 Transform a sequence} *) + +val filter : ('a -> bool) -> 'a t -> 'a t + (** Filter on elements of the sequence *) + +val append : 'a t -> 'a t -> 'a t + (** Append two sequences. Iterating on the result is like iterating + on the first, then on the second. *) + +val concat : 'a t t -> 'a t + (** Concatenate a sequence of sequences into one sequence. *) + +val flatten : 'a t t -> 'a t + (** Alias for {!concat} *) + +val flatMap : ('a -> 'b t) -> 'a t -> 'b t + (** Monadic bind. Intuitively, it applies the function to every element of the + initial sequence, and calls {!concat}. *) + +val flat_map : ('a -> 'b t) -> 'a t -> 'b t + (** Alias to {!flatMap} with a more explicit name + @since 0.5 *) + +val fmap : ('a -> 'b option) -> 'a t -> 'b t + (** Specialized version of {!flatMap} for options. *) + +val filter_map : ('a -> 'b option) -> 'a t -> 'b t + (** Alias to {!fmap} with a more explicit name + @since 0.5 *) + +val intersperse : 'a -> 'a t -> 'a t + (** Insert the single element between every element of the sequence *) + +(** {2 Caching} *) + +val persistent : 'a t -> 'a t + (** Iterate on the sequence, storing elements in an efficient internal structure.. + The resulting sequence can be iterated on as many times as needed. + {b Note}: calling persistent on an already persistent sequence + will still make a new copy of the sequence! *) + +val persistent_lazy : 'a t -> 'a t + (** Lazy version of {!persistent}. When calling [persistent_lazy s], + a new sequence [s'] is immediately returned (without actually consuming + [s]) in constant time; the first time [s'] is iterated on, + it also consumes [s] and caches its content into a inner data + structure that will back [s'] for future iterations. + + {b warning}: on the first traversal of [s'], if the traversal + is interrupted prematurely ({!take}, etc.) then [s'] will not be + memorized, and the next call to [s'] will traverse [s] again. *) + +(** {2 Misc} *) + +val sort : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t + (** Sort the sequence. Eager, O(n) ram and O(n ln(n)) time. + It iterates on elements of the argument sequence immediately, + before it sorts them. *) + +val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t + (** Sort the sequence and remove duplicates. Eager, same as [sort] *) + +val group : ?eq:('a -> 'a -> bool) -> 'a t -> 'a list t + (** Group equal consecutive elements. *) + +val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t + (** Remove consecutive duplicate elements. Basically this is + like [fun seq -> map List.hd (group seq)]. *) + +val product : 'a t -> 'b t -> ('a * 'b) t + (** Cartesian product of the sequences. When calling [product a b], + the caller {b MUST} ensure that [b] can be traversed as many times + as required (several times), possibly by calling {!persistent} on it + beforehand. *) + +val product2 : 'a t -> 'b t -> ('a, 'b) t2 + (** Binary version of {!product}. Same requirements. + @since 0.5 *) + +val join : join_row:('a -> 'b -> 'c option) -> 'a t -> 'b t -> 'c t + (** [join ~join_row a b] combines every element of [a] with every + element of [b] using [join_row]. If [join_row] returns None, then + the two elements do not combine. Assume that [b] allows for multiple + iterations. *) + +val unfoldr : ('b -> ('a * 'b) option) -> 'b -> 'a t + (** [unfoldr f b] will apply [f] to [b]. If it + yields [Some (x,b')] then [x] is returned + and unfoldr recurses with [b']. *) + +val scan : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t + (** Sequence of intermediate results *) + +val max : ?lt:('a -> 'a -> bool) -> 'a t -> 'a option + (** Max element of the sequence, using the given comparison function. + @return None if the sequence is empty, Some [m] where [m] is the maximal + element otherwise *) + +val min : ?lt:('a -> 'a -> bool) -> 'a t -> 'a option + (** Min element of the sequence, using the given comparison function. + see {!max} for more details. *) + +val head : 'a t -> 'a option + (** First element, if any, otherwise [None] + @since 0.5.1 *) + +val head_exn : 'a t -> 'a + (** First element, if any, fails + @raise Invalid_argument if the sequence is empty + @since 0.5.1 *) + +val take : int -> 'a t -> 'a t + (** Take at most [n] elements from the sequence. Works on infinite + sequences. *) + +val take_while : ('a -> bool) -> 'a t -> 'a t + (** Take elements while they satisfy the predicate, then stops iterating. + Will work on an infinite sequence [s] if the predicate is false for at + least one element of [s]. *) + +val drop : int -> 'a t -> 'a t + (** Drop the [n] first elements of the sequence. Lazy. *) + +val drop_while : ('a -> bool) -> 'a t -> 'a t + (** Predicate version of {!drop} *) + +val rev : 'a t -> 'a t + (** Reverse the sequence. O(n) memory and time, needs the + sequence to be finite. The result is persistent and does + not depend on the input being repeatable. *) + +(** {2 Binary sequences} *) + +val empty2 : ('a, 'b) t2 + +val is_empty2 : (_, _) t2 -> bool + +val length2 : (_, _) t2 -> int + +val zip : ('a, 'b) t2 -> ('a * 'b) t + +val unzip : ('a * 'b) t -> ('a, 'b) t2 + +val zip_i : 'a t -> (int, 'a) t2 + (** Zip elements of the sequence with their index in the sequence *) + +val fold2 : ('c -> 'a -> 'b -> 'c) -> 'c -> ('a, 'b) t2 -> 'c + +val iter2 : ('a -> 'b -> unit) -> ('a, 'b) t2 -> unit + +val map2 : ('a -> 'b -> 'c) -> ('a, 'b) t2 -> 'c t + +val map2_2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'd) -> ('a, 'b) t2 -> ('c, 'd) t2 + (** [map2_2 f g seq2] maps each [x, y] of seq2 into [f x y, g x y] *) + +(** {2 Basic data structures converters} *) + +val to_list : 'a t -> 'a list + (** Convert the sequence into a list. Preserves order of elements. + This function is tail-recursive, but consumes 2*n memory. + If order doesn't matter to you, consider {!to_rev_list}. *) + +val to_rev_list : 'a t -> 'a list + (** Get the list of the reversed sequence (more efficient than {!to_list}) *) + +val of_list : 'a list -> 'a t + +val to_opt : 'a t -> 'a option + (** Alias to {!head} + @since 0.5.1 *) + +val to_array : 'a t -> 'a array + (** Convert to an array. Currently not very efficient because + an intermediate list is used. *) + +val of_array : 'a array -> 'a t + +val of_array_i : 'a array -> (int * 'a) t + (** Elements of the array, with their index *) + +val of_array2 : 'a array -> (int, 'a) t2 + +val array_slice : 'a array -> int -> int -> 'a t + (** [array_slice a i j] Sequence of elements whose indexes range + from [i] to [j] *) + +val of_opt : 'a option -> 'a t + (** Iterate on 0 or 1 values. + @since 0.5.1 *) + +val of_stream : 'a Stream.t -> 'a t + (** Sequence of elements of a stream (usable only once) *) + +val to_stream : 'a t -> 'a Stream.t + (** Convert to a stream. linear in memory and time (a copy is made in memory) *) + +val to_stack : 'a Stack.t -> 'a t -> unit + (** Push elements of the sequence on the stack *) + +val of_stack : 'a Stack.t -> 'a t + (** Sequence of elements of the stack (same order as [Stack.iter]) *) + +val to_queue : 'a Queue.t -> 'a t -> unit + (** Push elements of the sequence into the queue *) + +val of_queue : 'a Queue.t -> 'a t + (** Sequence of elements contained in the queue, FIFO order *) + +val hashtbl_add : ('a, 'b) Hashtbl.t -> ('a * 'b) t -> unit + (** Add elements of the sequence to the hashtable, with + Hashtbl.add *) + +val hashtbl_replace : ('a, 'b) Hashtbl.t -> ('a * 'b) t -> unit + (** Add elements of the sequence to the hashtable, with + Hashtbl.replace (erases conflicting bindings) *) + +val to_hashtbl : ('a * 'b) t -> ('a, 'b) Hashtbl.t + (** Build a hashtable from a sequence of key/value pairs *) + +val to_hashtbl2 : ('a, 'b) t2 -> ('a, 'b) Hashtbl.t + (** Build a hashtable from a sequence of key/value pairs *) + +val of_hashtbl : ('a, 'b) Hashtbl.t -> ('a * 'b) t + (** Sequence of key/value pairs from the hashtable *) + +val of_hashtbl2 : ('a, 'b) Hashtbl.t -> ('a, 'b) t2 + (** Sequence of key/value pairs from the hashtable *) + +val hashtbl_keys : ('a, 'b) Hashtbl.t -> 'a t +val hashtbl_values : ('a, 'b) Hashtbl.t -> 'b t + +val of_str : string -> char t +val to_str : char t -> string + +val concat_str : string t -> string + (** Concatenate strings together, eagerly. + Also see {!intersperse} to add a separator. + @since 0.5 *) + +exception OneShotSequence + (** Raised when the user tries to iterate several times on + a transient iterator *) + +val of_in_channel : in_channel -> char t + (** Iterates on characters of the input (can block when one + iterates over the sequence). If you need to iterate + several times on this sequence, use {!persistent}. + @raise OneShotSequence when used more than once. *) + +val to_buffer : char t -> Buffer.t -> unit + (** Copy content of the sequence into the buffer *) + +val int_range : start:int -> stop:int -> int t + (** Iterator on integers in [start...stop] by steps 1. Also see + {!(--)} for an infix version. *) + +val int_range_dec : start:int -> stop:int -> int t + (** Iterator on decreasing integers in [stop...start] by steps -1. + See {!(--^)} for an infix version *) + +val of_set : (module Set.S with type elt = 'a and type t = 'b) -> 'b -> 'a t + (** Convert the given set to a sequence. The set module must be provided. *) + +val to_set : (module Set.S with type elt = 'a and type t = 'b) -> 'a t -> 'b + (** Convert the sequence to a set, given the proper set module *) + +type 'a gen = unit -> 'a option +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] + +val of_gen : 'a gen -> 'a t + (** Traverse eagerly the generator and build a sequence from it *) + +val to_gen : 'a t -> 'a gen + (** Make the sequence persistent (O(n)) and then iterate on it. Eager. *) + +val of_klist : 'a klist -> 'a t + (** Iterate on the lazy list *) + +val to_klist : 'a t -> 'a klist + (** Make the sequence persistent and then iterate on it. Eager. *) + +(** {2 Functorial conversions between sets and sequences} *) + +module Set : sig + module type S = sig + include Set.S + val of_seq : elt sequence -> t + val to_seq : t -> elt sequence + val to_list : t -> elt list + val of_list : elt list -> t + end + + (** Create an enriched Set module from the given one *) + module Adapt(X : Set.S) : S with type elt = X.elt and type t = X.t + + (** Functor to build an extended Set module from an ordered type *) + module Make(X : Set.OrderedType) : S with type elt = X.t +end + +(** {2 Conversion between maps and sequences.} *) + +module Map : sig + module type S = sig + include Map.S + val to_seq : 'a t -> (key * 'a) sequence + val of_seq : (key * 'a) sequence -> 'a t + val keys : 'a t -> key sequence + val values : 'a t -> 'a sequence + val to_list : 'a t -> (key * 'a) list + val of_list : (key * 'a) list -> 'a t + end + + (** Adapt a pre-existing Map module to make it sequence-aware *) + module Adapt(M : Map.S) : S with type key = M.key and type 'a t = 'a M.t + + (** Create an enriched Map module, with sequence-aware functions *) + module Make(V : Map.OrderedType) : S with type key = V.t +end + +(** {2 Infinite sequences of random values} *) + +val random_int : int -> int t + (** Infinite sequence of random integers between 0 and + the given higher bound (see Random.int) *) + +val random_bool : bool t + (** Infinite sequence of random bool values *) + +val random_float : float -> float t + +val random_array : 'a array -> 'a t + (** Sequence of choices of an element in the array *) + +val random_list : 'a list -> 'a t + (** Infinite sequence of random elements of the list. Basically the + same as {!random_array}. *) + +(** {2 Infix functions} *) + +module Infix : sig + val (--) : int -> int -> int t + (** [a -- b] is the range of integers from [a] to [b], both included, + in increasing order. It will therefore be empty if [a > b]. *) + + val (--^) : int -> int -> int t + (** [a --^ b] is the range of integers from [b] to [a], both included, + in decreasing order (starts from [a]). + It will therefore be empty if [a < b]. *) + + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + (** Monadic bind (infix version of {!flat_map} + @since 0.5 *) + + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + (** Infix version of {!map} + @since 0.5 *) + + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + (** Applicative operator (product+application) + @since 0.5 *) + + val (<+>) : 'a t -> 'a t -> 'a t + (** Concatenation of sequences + @since 0.5 *) +end + +include module type of Infix + + +(** {2 Pretty printing of sequences} *) + +val pp_seq : ?sep:string -> (Format.formatter -> 'a -> unit) -> + Format.formatter -> 'a t -> unit + (** Pretty print a sequence of ['a], using the given pretty printer + to print each elements. An optional separator string can be provided. *) + +val pp_buf : ?sep:string -> (Buffer.t -> 'a -> unit) -> + Buffer.t -> 'a t -> unit + (** Print into a buffer *) + +val to_string : ?sep:string -> ('a -> string) -> 'a t -> string + (** Print into a string *) + +(** {2 Basic IO} + +Very basic interface to manipulate files as sequence of chunks/lines. The +sequences take care of opening and closing files properly; every time +one iterates over a sequence, the file is opened/closed again. + +Example: copy a file ["a"] into file ["b"], removing blank lines: + +{[ + Sequence.(IO.lines_of "a" |> filter (fun l-> l<> "") |> IO.write_lines "b");; +]} + +By chunks of [4096] bytes: + +{[ + Sequence.IO.(chunks_of ~size:4096 "a" |> write_to "b");; +]} + +@since 0.5.1 *) + +module IO : sig + val lines_of : ?mode:int -> ?flags:open_flag list -> + string -> string t + (** [lines_of filename] reads all lines of the given file. It raises the + same exception as would opening the file and read from it, except + from [End_of_file] (which is caught). The file is {b always} properly + closed. + Every time the sequence is iterated on, the file is opened again, so + different iterations might return different results + @param mode default [0o644] + @param flags default: [[Open_rdonly]] *) + + val chunks_of : ?mode:int -> ?flags:open_flag list -> ?size:int -> + string -> string t + (** Read chunks of the given [size] from the file. The last chunk might be + smaller. Behaves like {!lines_of} regarding errors and options. + Every time the sequence is iterated on, the file is opened again, so + different iterations might return different results *) + + val write_to : ?mode:int -> ?flags:open_flag list -> + string -> string t -> unit + (** [write_to filename seq] writes all strings from [seq] into the given + file. It takes care of opening and closing the file. + @param mode default [0o644] + @param flags used by [open_out_gen]. Default: [[Open_creat;Open_wronly]]. *) + + val write_lines : ?mode:int -> ?flags:open_flag list -> + string -> string t -> unit + (** Same as {!write_to}, but intercales ['\n'] between each string *) +end diff --git a/sequence.mllib b/sequence.mllib new file mode 100644 index 00000000..2f635d2a --- /dev/null +++ b/sequence.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5) +Sequence +# OASIS_STOP diff --git a/sequence.odocl b/sequence.odocl new file mode 100644 index 00000000..2f635d2a --- /dev/null +++ b/sequence.odocl @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5) +Sequence +# OASIS_STOP diff --git a/setup.ml b/setup.ml new file mode 100644 index 00000000..e293257d --- /dev/null +++ b/setup.ml @@ -0,0 +1,7205 @@ +(* setup.ml generated for the first time by OASIS v0.4.4 *) + +(* OASIS_START *) +(* DO NOT EDIT (digest: d7a207daf3186cce7792651a50aaba59) *) +(* + 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_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + 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" + (OASISVersion.string_of_version t.oasis_version) + (String.concat ", " t.alpha_features) + (String.concat ", " t.beta_features) + (String.concat ", " + (MapPlugin.fold + (fun (_, plg) ver_opt acc -> + (plg^ + (match ver_opt with + | Some v -> + " "^(OASISVersion.string_of_version v) + | None -> "")) + :: acc) + t.plugin_versions [])) + end + + type origin = + | Field of string * string + | Section of string + | NoOrigin + + type stage = Alpha | Beta + + + let string_of_stage = + function + | Alpha -> "alpha" + | Beta -> "beta" + + + let field_of_stage = + function + | Alpha -> "AlphaFeatures" + | Beta -> "BetaFeatures" + + type publication = InDev of stage | SinceVersion of OASISVersion.t + + type t = + { + name: string; + plugin: all_plugin option; + publication: publication; + description: unit -> string; + } + + (* TODO: mutex protect this. *) + let all_features = Hashtbl.create 13 + + + let since_version ver_str = SinceVersion (version_of_string ver_str) + let alpha = InDev Alpha + let beta = InDev Beta + + + let to_string t = + Printf.sprintf + "feature: %s; plugin: %s; publication: %s" + t.name + (match t.plugin with + | None -> "" + | Some (_, nm, _) -> nm) + (match t.publication with + | InDev stage -> string_of_stage stage + | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) + + let data_check t data origin = + let no_message = "no message" in + + let check_feature features stage = + let has_feature = List.mem t.name features in + if not has_feature then + match origin with + | Field (fld, where) -> + Some + (Printf.sprintf + (f_ "Field %s in %s is only available when feature %s \ + is in field %s.") + fld where t.name (field_of_stage stage)) + | Section sct -> + Some + (Printf.sprintf + (f_ "Section %s is only available when features %s \ + is in field %s.") + sct t.name (field_of_stage stage)) + | NoOrigin -> + Some no_message + else + None + in + + let version_is_good ~min_version version fmt = + let version_is_good = + OASISVersion.comparator_apply + version (OASISVersion.VGreaterEqual min_version) + in + Printf.ksprintf + (fun str -> + if version_is_good then + None + else + Some str) + fmt + in + + match origin, t.plugin, t.publication with + | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha + | _, _, InDev Beta -> check_feature data.Data.beta_features Beta + | Field(fld, where), None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Field %s in %s is only valid since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking \ + OASIS changelog.") + fld where (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Field(fld, where), Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Field %s in %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + fld where plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Field %s in %s is only valid when the OASIS plugin %s \ + is defined.") + fld where plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Field %s in %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + fld where plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | Section sct, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Section %s is only valid for since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking OASIS \ + changelog.") + sct (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Section sct, Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Section %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + sct plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Section %s is only valid when the OASIS plugin %s \ + is defined.") + sct plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Section %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + sct plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | NoOrigin, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version "%s" no_message + + | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> + begin + try + let plugin_version_current = + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> raise Not_found + in + version_is_good ~min_version plugin_version_current + "%s" no_message + with Not_found -> + Some no_message + end + + + let data_assert t data origin = + match data_check t data origin with + | None -> () + | Some str -> failwith str + + + let data_test t data = + match data_check t data NoOrigin with + | None -> true + | Some str -> false + + + let package_test t pkg = + data_test t (Data.of_package pkg) + + + let create ?plugin name publication description = + let () = + if Hashtbl.mem all_features name then + failwithf "Feature '%s' is already declared." name + in + let t = + { + name = name; + plugin = plugin; + publication = publication; + description = description; + } + in + Hashtbl.add all_features name t; + t + + + let get_stage name = + try + (Hashtbl.find all_features name).publication + with Not_found -> + failwithf (f_ "Feature %s doesn't exist.") name + + + let list () = + Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] + + (* + * Real flags. + *) + + + let features = + create "features_fields" + (since_version "0.4") + (fun () -> + s_ "Enable to experiment not yet official features.") + + + let flag_docs = + create "flag_docs" + (since_version "0.3") + (fun () -> + s_ "Building docs require '-docs' flag at configure.") + + + let flag_tests = + create "flag_tests" + (since_version "0.3") + (fun () -> + s_ "Running tests require '-tests' flag at configure.") + + + let pack = + create "pack" + (since_version "0.3") + (fun () -> + s_ "Allow to create packed library.") + + + let section_object = + create "section_object" beta + (fun () -> + s_ "Implement an object section.") + + + let dynrun_for_release = + create "dynrun_for_release" alpha + (fun () -> + s_ "Make '-setup-update dynamic' suitable for releasing project.") + + + let compiled_setup_ml = + create "compiled_setup_ml" alpha + (fun () -> + s_ "It compiles the setup.ml and speed-up actions done with it.") + + let disable_oasis_section = + create "disable_oasis_section" alpha + (fun () -> + s_ "Allows the OASIS section comments and digest to be omitted in \ + generated files.") +end + +module OASISUnixPath = struct +(* # 22 "src/oasis/OASISUnixPath.ml" *) + + + type unix_filename = string + type unix_dirname = string + + + type host_filename = string + type host_dirname = string + + + let current_dir_name = "." + + + let parent_dir_name = ".." + + + let is_current_dir fn = + fn = current_dir_name || fn = "" + + + let concat f1 f2 = + if is_current_dir f1 then + f2 + else + let f1' = + try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 + in + f1'^"/"^f2 + + + let make = + function + | hd :: tl -> + List.fold_left + (fun f p -> concat f p) + hd + tl + | [] -> + invalid_arg "OASISUnixPath.make" + + + let dirname f = + try + String.sub f 0 (String.rindex f '/') + with Not_found -> + current_dir_name + + + let basename f = + try + let pos_start = + (String.rindex f '/') + 1 + in + String.sub f pos_start ((String.length f) - pos_start) + with Not_found -> + f + + + let chop_extension f = + try + let last_dot = + String.rindex f '.' + in + let sub = + String.sub f 0 last_dot + in + try + let last_slash = + String.rindex f '/' + in + if last_slash < last_dot then + sub + else + f + with Not_found -> + sub + + with Not_found -> + f + + + let capitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.capitalize base) + + + let uncapitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.uncapitalize base) + + +end + +module OASISHostPath = struct +(* # 22 "src/oasis/OASISHostPath.ml" *) + + + open Filename + + + module Unix = OASISUnixPath + + + let make = + function + | [] -> + invalid_arg "OASISHostPath.make" + | hd :: tl -> + List.fold_left Filename.concat hd tl + + + let of_unix ufn = + if Sys.os_type = "Unix" then + ufn + else + make + (List.map + (fun p -> + if p = Unix.current_dir_name then + current_dir_name + else if p = Unix.parent_dir_name then + parent_dir_name + else + p) + (OASISString.nsplit ufn '/')) + + +end + +module OASISSection = struct +(* # 22 "src/oasis/OASISSection.ml" *) + + + open OASISTypes + + + let section_kind_common = + function + | Library (cs, _, _) -> + `Library, cs + | Object (cs, _, _) -> + `Object, cs + | Executable (cs, _, _) -> + `Executable, cs + | Flag (cs, _) -> + `Flag, cs + | SrcRepo (cs, _) -> + `SrcRepo, cs + | Test (cs, _) -> + `Test, cs + | Doc (cs, _) -> + `Doc, cs + + + let section_common sct = + snd (section_kind_common sct) + + + let section_common_set cs = + function + | Library (_, bs, lib) -> Library (cs, bs, lib) + | Object (_, bs, obj) -> Object (cs, bs, obj) + | Executable (_, bs, exec) -> Executable (cs, bs, exec) + | Flag (_, flg) -> Flag (cs, flg) + | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) + | Test (_, tst) -> Test (cs, tst) + | Doc (_, doc) -> Doc (cs, doc) + + + (** Key used to identify section + *) + let section_id sct = + let k, cs = + section_kind_common sct + in + k, cs.cs_name + + + let string_of_section sct = + let k, nm = + section_id sct + in + (match k with + | `Library -> "library" + | `Object -> "object" + | `Executable -> "executable" + | `Flag -> "flag" + | `SrcRepo -> "src repository" + | `Test -> "test" + | `Doc -> "doc") + ^" "^nm + + + let section_find id scts = + List.find + (fun sct -> id = section_id sct) + scts + + + module CSection = + struct + type t = section + + let id = section_id + + let compare t1 t2 = + compare (id t1) (id t2) + + let equal t1 t2 = + (id t1) = (id t2) + + let hash t = + Hashtbl.hash (id t) + end + + + module MapSection = Map.Make(CSection) + module SetSection = Set.Make(CSection) + + +end + +module OASISBuildSection = struct +(* # 22 "src/oasis/OASISBuildSection.ml" *) + + +end + +module OASISExecutable = struct +(* # 22 "src/oasis/OASISExecutable.ml" *) + + + open OASISTypes + + + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = + OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.dirname exec.exec_main_is) + in + let is_native_exec = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native () + | Byte -> false + in + + OASISUnixPath.concat + dir + (cs.cs_name^(suffix_program ())), + + if not is_native_exec && + not exec.exec_custom && + bs.bs_c_sources <> [] then + Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) + else + None + + +end + +module OASISLibrary = struct +(* # 22 "src/oasis/OASISLibrary.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + + (* Look for a module file, considering capitalization or not. *) + let find_module source_file_exists bs modul = + let possible_base_fn = + List.map + (OASISUnixPath.concat bs.bs_path) + [modul; + OASISUnixPath.uncapitalize_file modul; + OASISUnixPath.capitalize_file modul] + in + (* TODO: we should be able to be able to determine the source for every + * files. Hence we should introduce a Module(source: fn) for the fields + * Modules and InternalModules + *) + List.fold_left + (fun acc base_fn -> + match acc with + | `No_sources _ -> + begin + let file_found = + List.fold_left + (fun acc ext -> + if source_file_exists (base_fn^ext) then + (base_fn^ext) :: acc + else + acc) + [] + [".ml"; ".mli"; ".mll"; ".mly"] + in + match file_found with + | [] -> + acc + | lst -> + `Sources (base_fn, lst) + end + | `Sources _ -> + acc) + (`No_sources possible_base_fn) + possible_base_fn + + + let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = + List.fold_left + (fun acc modul -> + match find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + acc) + [] + (lib.lib_modules @ lib.lib_internal_modules) + + + let generated_unix_files + ~ctxt + ~is_native + ~has_native_dynlink + ~ext_lib + ~ext_dll + ~source_file_exists + (cs, bs, lib) = + + let find_modules lst ext = + let find_module modul = + match find_module source_file_exists bs modul with + | `Sources (base_fn, [fn]) when ext <> "cmi" + && Filename.check_suffix fn ".mli" -> + None (* No implementation files for pure interface. *) + | `Sources (base_fn, _) -> + Some [base_fn] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + Some lst + in + List.fold_left + (fun acc nm -> + match find_module nm with + | None -> acc + | Some base_fns -> + List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) + [] + lst + in + + (* The headers that should be compiled along *) + let headers = + if lib.lib_pack then + [] + else + find_modules + lib.lib_modules + "cmi" + in + + (* The .cmx that be compiled along *) + let cmxs = + let should_be_built = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native + | Byte -> false + in + if should_be_built then + if lib.lib_pack then + find_modules + [cs.cs_name] + "cmx" + else + find_modules + (lib.lib_modules @ lib.lib_internal_modules) + "cmx" + else + [] + in + + let acc_nopath = + [] + in + + (* Compute what libraries should be built *) + let acc_nopath = + (* Add the packed header file if required *) + let add_pack_header acc = + if lib.lib_pack then + [cs.cs_name^".cmi"] :: acc + else + acc + in + let byte acc = + add_pack_header ([cs.cs_name^".cma"] :: acc) + in + let native acc = + let acc = + add_pack_header + (if has_native_dynlink then + [cs.cs_name^".cmxs"] :: acc + else acc) + in + [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc + in + match bs.bs_compiled_object with + | Native -> + byte (native acc_nopath) + | Best when is_native -> + byte (native acc_nopath) + | Byte | Best -> + byte acc_nopath + in + + (* Add C library to be built *) + let acc_nopath = + if bs.bs_c_sources <> [] then + begin + ["lib"^cs.cs_name^"_stubs"^ext_lib] + :: + ["dll"^cs.cs_name^"_stubs"^ext_dll] + :: + acc_nopath + end + else + acc_nopath + in + + (* All the files generated *) + List.rev_append + (List.rev_map + (List.rev_map + (OASISUnixPath.concat bs.bs_path)) + acc_nopath) + (headers @ cmxs) + + +end + +module OASISObject = struct +(* # 22 "src/oasis/OASISObject.ml" *) + + + open OASISTypes + open OASISGettext + + + let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = + List.fold_left + (fun acc modul -> + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name; + acc) + [] + obj.obj_modules + + + let generated_unix_files + ~ctxt + ~is_native + ~source_file_exists + (cs, bs, obj) = + + let find_module ext modul = + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, _) -> [base_fn ^ ext] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name ; + lst + in + + let header, byte, native, c_object, f = + match obj.obj_modules with + | [ m ] -> (find_module ".cmi" m, + find_module ".cmo" m, + find_module ".cmx" m, + find_module ".o" m, + fun x -> x) + | _ -> ([cs.cs_name ^ ".cmi"], + [cs.cs_name ^ ".cmo"], + [cs.cs_name ^ ".cmx"], + [cs.cs_name ^ ".o"], + OASISUnixPath.concat bs.bs_path) + in + List.map (List.map f) ( + match bs.bs_compiled_object with + | Native -> + native :: c_object :: byte :: header :: [] + | Best when is_native -> + native :: c_object :: byte :: header :: [] + | Byte | Best -> + byte :: header :: []) + + +end + +module OASISFindlib = struct +(* # 22 "src/oasis/OASISFindlib.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + [`Library of library | `Object of object_] * + group_t list) + + + type data = common_section * + build_section * + [`Library of library | `Object of object_] + type tree = + | Node of (data option) * (tree MapString.t) + | Leaf of data + + + let findlib_mapping pkg = + (* Map from library name to either full findlib name or parts + parent. *) + let fndlb_parts_of_lib_name = + let fndlb_parts cs lib = + let name = + match lib.lib_findlib_name with + | Some nm -> nm + | None -> cs.cs_name + in + let name = + String.concat "." (lib.lib_findlib_containers @ [name]) + in + name + in + List.fold_left + (fun mp -> + function + | Library (cs, _, lib) -> + begin + let lib_name = cs.cs_name in + let fndlb_parts = fndlb_parts cs lib in + if MapString.mem lib_name mp then + failwithf + (f_ "The library name '%s' is used more than once.") + lib_name; + match lib.lib_findlib_parent with + | Some lib_name_parent -> + MapString.add + lib_name + (`Unsolved (lib_name_parent, fndlb_parts)) + mp + | None -> + MapString.add + lib_name + (`Solved fndlb_parts) + mp + end + + | Object (cs, _, obj) -> + begin + let obj_name = cs.cs_name in + if MapString.mem obj_name mp then + failwithf + (f_ "The object name '%s' is used more than once.") + obj_name; + let findlib_full_name = match obj.obj_findlib_fullname with + | Some ns -> String.concat "." ns + | None -> obj_name + in + MapString.add + obj_name + (`Solved findlib_full_name) + mp + end + + | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> + mp) + MapString.empty + pkg.sections + in + + (* Solve the above graph to be only library name to full findlib name. *) + let fndlb_name_of_lib_name = + let rec solve visited mp lib_name lib_name_child = + if SetString.mem lib_name visited then + failwithf + (f_ "Library '%s' is involved in a cycle \ + with regard to findlib naming.") + lib_name; + let visited = SetString.add lib_name visited in + try + match MapString.find lib_name mp with + | `Solved fndlb_nm -> + fndlb_nm, mp + | `Unsolved (lib_nm_parent, post_fndlb_nm) -> + let pre_fndlb_nm, mp = + solve visited mp lib_nm_parent lib_name + in + let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in + fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp + with Not_found -> + failwithf + (f_ "Library '%s', which is defined as the findlib parent of \ + library '%s', doesn't exist.") + lib_name lib_name_child + in + let mp = + MapString.fold + (fun lib_name status mp -> + match status with + | `Solved _ -> + (* Solved initialy, no need to go further *) + mp + | `Unsolved _ -> + let _, mp = solve SetString.empty mp lib_name "" in + mp) + fndlb_parts_of_lib_name + fndlb_parts_of_lib_name + in + MapString.map + (function + | `Solved fndlb_nm -> fndlb_nm + | `Unsolved _ -> assert false) + mp + in + + (* Convert an internal library name to a findlib name. *) + let findlib_name_of_library_name lib_nm = + try + MapString.find lib_nm fndlb_name_of_lib_name + with Not_found -> + raise (InternalLibraryNotFound lib_nm) + in + + (* Add a library to the tree. + *) + let add sct mp = + let fndlb_fullname = + let cs, _, _ = sct in + let lib_name = cs.cs_name in + findlib_name_of_library_name lib_name + in + let rec add_children nm_lst (children: tree MapString.t) = + match nm_lst with + | (hd :: tl) -> + begin + let node = + try + add_node tl (MapString.find hd children) + with Not_found -> + (* New node *) + new_node tl + in + MapString.add hd node children + end + | [] -> + (* Should not have a nameless library. *) + assert false + and add_node tl node = + if tl = [] then + begin + match node with + | Node (None, children) -> + Node (Some sct, children) + | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> + (* TODO: allow to merge Package, i.e. + * archive(byte) = "foo.cma foo_init.cmo" + *) + let cs, _, _ = sct in + failwithf + (f_ "Library '%s' and '%s' have the same findlib name '%s'") + cs.cs_name cs'.cs_name fndlb_fullname + end + else + begin + match node with + | Leaf data -> + Node (Some data, add_children tl MapString.empty) + | Node (data_opt, children) -> + Node (data_opt, add_children tl children) + end + and new_node = + function + | [] -> + Leaf sct + | hd :: tl -> + Node (None, MapString.add hd (new_node tl) MapString.empty) + in + add_children (OASISString.nsplit fndlb_fullname '.') mp + in + + let rec group_of_tree mp = + MapString.fold + (fun nm node acc -> + let cur = + match node with + | Node (Some (cs, bs, lib), children) -> + Package (nm, cs, bs, lib, group_of_tree children) + | Node (None, children) -> + Container (nm, group_of_tree children) + | Leaf (cs, bs, lib) -> + Package (nm, cs, bs, lib, []) + in + cur :: acc) + mp [] + in + + let group_mp = + List.fold_left + (fun mp -> + function + | Library (cs, bs, lib) -> + add (cs, bs, `Library lib) mp + | Object (cs, bs, obj) -> + add (cs, bs, `Object obj) mp + | _ -> + mp) + MapString.empty + pkg.sections + in + + let groups = + group_of_tree group_mp + in + + let library_name_of_findlib_name = + Lazy.lazy_from_fun + (fun () -> + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty) + in + let library_name_of_findlib_name fndlb_nm = + try + MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) + with Not_found -> + raise (FindlibPackageNotFound fndlb_nm) + in + + groups, + findlib_name_of_library_name, + library_name_of_findlib_name + + + let findlib_of_group = + function + | Container (fndlb_nm, _) + | Package (fndlb_nm, _, _, _, _) -> fndlb_nm + + + let root_of_group grp = + let rec root_lib_aux = + (* We do a DFS in the group. *) + function + | Container (_, children) -> + List.fold_left + (fun res grp -> + if res = None then + root_lib_aux grp + else + res) + None + children + | Package (_, cs, bs, lib, _) -> + Some (cs, bs, lib) + in + match root_lib_aux grp with + | Some res -> + res + | None -> + failwithf + (f_ "Unable to determine root library of findlib library '%s'") + (findlib_of_group grp) + + +end + +module OASISFlag = struct +(* # 22 "src/oasis/OASISFlag.ml" *) + + +end + +module OASISPackage = struct +(* # 22 "src/oasis/OASISPackage.ml" *) + + +end + +module OASISSourceRepository = struct +(* # 22 "src/oasis/OASISSourceRepository.ml" *) + + +end + +module OASISTest = struct +(* # 22 "src/oasis/OASISTest.ml" *) + + +end + +module OASISDocument = struct +(* # 22 "src/oasis/OASISDocument.ml" *) + + +end + +module OASISExec = struct +(* # 22 "src/oasis/OASISExec.ml" *) + + + open OASISGettext + open OASISUtils + open OASISMessage + + + (* TODO: I don't like this quote, it is there because $(rm) foo expands to + * 'rm -f' foo... + *) + let run ~ctxt ?f_exit_code ?(quote=true) cmd args = + let cmd = + if quote then + if Sys.os_type = "Win32" then + if String.contains cmd ' ' then + (* Double the 1st double quote... win32... sigh *) + "\""^(Filename.quote cmd) + else + cmd + else + Filename.quote cmd + else + cmd + in + let cmdline = + String.concat " " (cmd :: args) + in + info ~ctxt (f_ "Running command '%s'") cmdline; + match f_exit_code, Sys.command cmdline with + | None, 0 -> () + | None, i -> + failwithf + (f_ "Command '%s' terminated with error code %d") + cmdline i + | Some f, i -> + f i + + + let run_read_output ~ctxt ?f_exit_code cmd args = + let fn = + Filename.temp_file "oasis-" ".txt" + in + try + begin + let () = + run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) + in + let chn = + open_in fn + in + let routput = + ref [] + in + begin + try + while true do + routput := (input_line chn) :: !routput + done + with End_of_file -> + () + end; + close_in chn; + Sys.remove fn; + List.rev !routput + end + with e -> + (try Sys.remove fn with _ -> ()); + raise e + + + let run_read_one_line ~ctxt ?f_exit_code cmd args = + match run_read_output ~ctxt ?f_exit_code cmd args with + | [fst] -> + fst + | lst -> + failwithf + (f_ "Command return unexpected output %S") + (String.concat "\n" lst) +end + +module OASISFileUtil = struct +(* # 22 "src/oasis/OASISFileUtil.ml" *) + + + open OASISGettext + + + let file_exists_case fn = + let dirname = Filename.dirname fn in + let basename = Filename.basename fn in + if Sys.file_exists dirname then + if basename = Filename.current_dir_name then + true + else + List.mem + basename + (Array.to_list (Sys.readdir dirname)) + else + false + + + let find_file ?(case_sensitive=true) paths exts = + + (* Cardinal product of two list *) + let ( * ) lst1 lst2 = + List.flatten + (List.map + (fun a -> + List.map + (fun b -> a, b) + lst2) + lst1) + in + + let rec combined_paths lst = + match lst with + | p1 :: p2 :: tl -> + let acc = + (List.map + (fun (a, b) -> Filename.concat a b) + (p1 * p2)) + in + combined_paths (acc :: tl) + | [e] -> + e + | [] -> + [] + in + + let alternatives = + List.map + (fun (p, e) -> + if String.length e > 0 && e.[0] <> '.' then + p ^ "." ^ e + else + p ^ e) + ((combined_paths paths) * exts) + in + List.find (fun file -> + (if case_sensitive then + file_exists_case file + else + Sys.file_exists file) + && not (Sys.is_directory file) + ) alternatives + + + let which ~ctxt prg = + let path_sep = + match Sys.os_type with + | "Win32" -> + ';' + | _ -> + ':' + in + let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in + let exec_ext = + match Sys.os_type with + | "Win32" -> + "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) + | _ -> + [""] + in + find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + + + (**/**) + let rec fix_dir dn = + (* Windows hack because Sys.file_exists "src\\" = false when + * Sys.file_exists "src" = true + *) + let ln = + String.length dn + in + if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then + fix_dir (String.sub dn 0 (ln - 1)) + else + dn + + + let q = Filename.quote + (**/**) + + + let cp ~ctxt ?(recurse=false) src tgt = + if recurse then + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt + "xcopy" [q src; q tgt; "/E"] + | _ -> + OASISExec.run ~ctxt + "cp" ["-r"; q src; q tgt] + else + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "copy" + | _ -> "cp") + [q src; q tgt] + + + let mkdir ~ctxt tgt = + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "md" + | _ -> "mkdir") + [q tgt] + + + let rec mkdir_parent ~ctxt f tgt = + let tgt = + fix_dir tgt + in + if Sys.file_exists tgt then + begin + if not (Sys.is_directory tgt) then + OASISUtils.failwithf + (f_ "Cannot create directory '%s', a file of the same name already \ + exists") + tgt + end + else + begin + mkdir_parent ~ctxt f (Filename.dirname tgt); + if not (Sys.file_exists tgt) then + begin + f tgt; + mkdir ~ctxt tgt + end + end + + + let rmdir ~ctxt tgt = + if Sys.readdir tgt = [||] then begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end else begin + OASISMessage.error ~ctxt + (f_ "Cannot remove directory '%s': not empty.") + tgt + end + + + let glob ~ctxt fn = + let basename = + Filename.basename fn + in + if String.length basename >= 2 && + basename.[0] = '*' && + basename.[1] = '.' then + begin + let ext_len = + (String.length basename) - 2 + in + let ext = + String.sub basename 2 ext_len + in + let dirname = + Filename.dirname fn + in + Array.fold_left + (fun acc fn -> + try + let fn_ext = + String.sub + fn + ((String.length fn) - ext_len) + ext_len + in + if fn_ext = ext then + (Filename.concat dirname fn) :: acc + else + acc + with Invalid_argument _ -> + acc) + [] + (Sys.readdir dirname) + end + else + begin + if file_exists_case fn then + [fn] + else + [] + end +end + + +# 2878 "setup.ml" +module BaseEnvLight = struct +(* # 22 "src/base/BaseEnvLight.ml" *) + + + module MapString = Map.Make(String) + + + type t = string MapString.t + + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 2983 "setup.ml" +module BaseContext = struct +(* # 22 "src/base/BaseContext.ml" *) + + (* TODO: get rid of this module. *) + open OASISContext + + + let args () = fst (fspecs ()) + + + let default = default + +end + +module BaseMessage = struct +(* # 22 "src/base/BaseMessage.ml" *) + + + (** Message to user, overrid for Base + @author Sylvain Le Gall + *) + open OASISMessage + open BaseContext + + + let debug fmt = debug ~ctxt:!default fmt + + + let info fmt = info ~ctxt:!default fmt + + + let warning fmt = warning ~ctxt:!default fmt + + + let error fmt = error ~ctxt:!default fmt + +end + +module BaseEnv = struct +(* # 22 "src/base/BaseEnv.ml" *) + + open OASISGettext + open OASISUtils + open PropList + + + module MapString = BaseEnvLight.MapString + + + type origin_t = + | ODefault + | OGetEnv + | OFileLoad + | OCommandLine + + + type cli_handle_t = + | CLINone + | CLIAuto + | CLIWith + | CLIEnable + | CLIUser of (Arg.key * Arg.spec * Arg.doc) list + + + type definition_t = + { + hide: bool; + dump: bool; + cli: cli_handle_t; + arg_help: string option; + group: string option; + } + + + let schema = + Schema.create "environment" + + + (* Environment data *) + let env = + Data.create () + + + (* Environment data from file *) + let env_from_file = + ref MapString.empty + + + (* Lexer for var *) + let var_lxr = + Genlex.make_lexer [] + + + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + (* TODO: this is a quick hack to allow calling Test.Command + * without defining executable name really. I.e. if there is + * an exec Executable toto, then $(toto) should be replace + * by its real name. It is however useful to have this function + * for other variable that depend on the host and should be + * written better than that. + *) + let st = + var_lxr (Stream.of_string var) + in + match Stream.npeek 3 st with + | [Genlex.Ident "utoh"; Genlex.Ident nm] -> + OASISHostPath.of_unix (var_get nm) + | [Genlex.Ident "utoh"; Genlex.String s] -> + OASISHostPath.of_unix s + | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> + String.escaped (var_get nm) + | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> + String.escaped s + | [Genlex.Ident nm] -> + var_get nm + | _ -> + failwithf + (f_ "Unknown expression '%s' in variable expansion of %s.") + var + str + with + | Unknown_field (_, _) -> + failwithf + (f_ "No variable %s defined when trying to expand %S.") + var + str + | Stream.Error e -> + failwithf + (f_ "Syntax error when parsing '%s' when trying to \ + expand %S: %s") + var + str + e) + str; + Buffer.contents buff + + + and var_get name = + let vl = + try + Schema.get schema env name + with Unknown_field _ as e -> + begin + try + MapString.find name !env_from_file + with Not_found -> + raise e + end + in + var_expand vl + + + let var_choose ?printer ?name lst = + OASISExpr.choose + ?printer + ?name + var_get + lst + + + let var_protect vl = + let buff = + Buffer.create (String.length vl) + in + String.iter + (function + | '$' -> Buffer.add_string buff "\\$" + | c -> Buffer.add_char buff c) + vl; + Buffer.contents buff + + + let var_define + ?(hide=false) + ?(dump=true) + ?short_desc + ?(cli=CLINone) + ?arg_help + ?group + name (* TODO: type constraint on the fact that name must be a valid OCaml + id *) + dflt = + + let default = + [ + OFileLoad, (fun () -> MapString.find name !env_from_file); + ODefault, dflt; + OGetEnv, (fun () -> Sys.getenv name); + ] + in + + let extra = + { + hide = hide; + dump = dump; + cli = cli; + arg_help = arg_help; + group = group; + } + in + + (* Try to find a value that can be defined + *) + let var_get_low lst = + let errors, res = + List.fold_left + (fun (errors, res) (o, v) -> + if res = None then + begin + try + errors, Some (v ()) + with + | Not_found -> + errors, res + | Failure rsn -> + (rsn :: errors), res + | e -> + (Printexc.to_string e) :: errors, res + end + else + errors, res) + ([], None) + (List.sort + (fun (o1, _) (o2, _) -> + Pervasives.compare o2 o1) + lst) + in + match res, errors with + | Some v, _ -> + v + | None, [] -> + raise (Not_set (name, None)) + | None, lst -> + raise (Not_set (name, Some (String.concat (s_ ", ") lst))) + in + + let help = + match short_desc with + | Some fs -> Some fs + | None -> None + in + + let var_get_lst = + FieldRO.create + ~schema + ~name + ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) + ~print:var_get_low + ~default + ~update:(fun ?context x old_x -> x @ old_x) + ?help + extra + in + + fun () -> + var_expand (var_get_low (var_get_lst env)) + + + let var_redefine + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt = + if Schema.mem schema name then + begin + (* TODO: look suspsicious, we want to memorize dflt not dflt () *) + Schema.set schema env ~context:ODefault name (dflt ()); + fun () -> var_get name + end + else + begin + var_define + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt + end + + + let var_ignore (e: unit -> string) = () + + + let print_hidden = + var_define + ~hide:true + ~dump:false + ~cli:CLIAuto + ~arg_help:"Print even non-printable variable. (debug)" + "print_hidden" + (fun () -> "false") + + + let var_all () = + List.rev + (Schema.fold + (fun acc nm def _ -> + if not def.hide || bool_of_string (print_hidden ()) then + nm :: acc + else + acc) + [] + schema) + + + let default_filename = + BaseEnvLight.default_filename + + + let load ?allow_empty ?filename () = + env_from_file := BaseEnvLight.load ?allow_empty ?filename () + + + let unload () = + env_from_file := MapString.empty; + Data.clear env + + + let dump ?(filename=default_filename) () = + let chn = + open_out_bin filename + in + let output nm value = + Printf.fprintf chn "%s=%S\n" nm value + in + let mp_todo = + (* Dump data from schema *) + Schema.fold + (fun mp_todo nm def _ -> + if def.dump then + begin + try + let value = + Schema.get + schema + env + nm + in + output nm value + with Not_set _ -> + () + end; + MapString.remove nm mp_todo) + !env_from_file + schema + in + (* Dump data defined outside of schema *) + MapString.iter output mp_todo; + + (* End of the dump *) + close_out chn + + + let print () = + let printable_vars = + Schema.fold + (fun acc nm def short_descr_opt -> + if not def.hide || bool_of_string (print_hidden ()) then + begin + try + let value = + Schema.get + schema + env + nm + in + let txt = + match short_descr_opt with + | Some s -> s () + | None -> nm + in + (txt, value) :: acc + with Not_set _ -> + acc + end + else + acc) + [] + schema + in + let max_length = + List.fold_left max 0 + (List.rev_map String.length + (List.rev_map fst printable_vars)) + in + let dot_pad str = + String.make ((max_length - (String.length str)) + 3) '.' + in + + Printf.printf "\nConfiguration: \n"; + List.iter + (fun (name, value) -> + Printf.printf "%s: %s %s\n" name (dot_pad name) value) + (List.rev printable_vars); + Printf.printf "\n%!" + + + let args () = + let arg_concat = + OASISUtils.varname_concat ~hyphen:'-' + in + [ + "--override", + Arg.Tuple + ( + let rvr = ref "" + in + let rvl = ref "" + in + [ + Arg.Set_string rvr; + Arg.Set_string rvl; + Arg.Unit + (fun () -> + Schema.set + schema + env + ~context:OCommandLine + !rvr + !rvl) + ] + ), + "var+val Override any configuration variable."; + + ] + @ + List.flatten + (Schema.fold + (fun acc name def short_descr_opt -> + let var_set s = + Schema.set + schema + env + ~context:OCommandLine + name + s + in + + let arg_name = + OASISUtils.varname_of_string ~hyphen:'-' name + in + + let hlp = + match short_descr_opt with + | Some txt -> txt () + | None -> "" + in + + let arg_hlp = + match def.arg_help with + | Some s -> s + | None -> "str" + in + + let default_value = + try + Printf.sprintf + (f_ " [%s]") + (Schema.get + schema + env + name) + with Not_set _ -> + "" + in + + let args = + match def.cli with + | CLINone -> + [] + | CLIAuto -> + [ + arg_concat "--" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIWith -> + [ + arg_concat "--with-" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIEnable -> + let dflt = + if default_value = " [true]" then + s_ " [default: enabled]" + else + s_ " [default: disabled]" + in + [ + arg_concat "--enable-" arg_name, + Arg.Unit (fun () -> var_set "true"), + Printf.sprintf (f_ " %s%s") hlp dflt; + + arg_concat "--disable-" arg_name, + Arg.Unit (fun () -> var_set "false"), + Printf.sprintf (f_ " %s%s") hlp dflt + ] + | CLIUser lst -> + lst + in + args :: acc) + [] + schema) +end + +module BaseArgExt = struct +(* # 22 "src/base/BaseArgExt.ml" *) + + + open OASISUtils + open OASISGettext + + + let parse argv args = + (* Simulate command line for Arg *) + let current = + ref 0 + in + + try + Arg.parse_argv + ~current:current + (Array.concat [[|"none"|]; argv]) + (Arg.align args) + (failwithf (f_ "Don't know what to do with arguments: '%s'")) + (s_ "configure options:") + with + | Arg.Help txt -> + print_endline txt; + exit 0 + | Arg.Bad txt -> + prerr_endline txt; + exit 1 +end + +module BaseCheck = struct +(* # 22 "src/base/BaseCheck.ml" *) + + + open BaseEnv + open BaseMessage + open OASISUtils + open OASISGettext + + + let prog_best prg prg_lst = + var_redefine + prg + (fun () -> + let alternate = + List.fold_left + (fun res e -> + match res with + | Some _ -> + res + | None -> + try + Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) + with Not_found -> + None) + None + prg_lst + in + match alternate with + | Some prg -> prg + | None -> raise Not_found) + + + let prog prg = + prog_best prg [prg] + + + let prog_opt prg = + prog_best prg [prg^".opt"; prg] + + + let ocamlfind = + prog "ocamlfind" + + + let version + var_prefix + cmp + fversion + () = + (* Really compare version provided *) + let var = + var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) + in + var_redefine + ~hide:true + var + (fun () -> + let version_str = + match fversion () with + | "[Distributed with OCaml]" -> + begin + try + (var_get "ocaml_version") + with Not_found -> + warning + (f_ "Variable ocaml_version not defined, fallback \ + to default"); + Sys.ocaml_version + end + | res -> + res + in + let version = + OASISVersion.version_of_string version_str + in + if OASISVersion.comparator_apply version cmp then + version_str + else + failwithf + (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") + var_prefix + (OASISVersion.string_of_comparator cmp) + version_str) + () + + + let package_version pkg = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%v"; pkg] + + + let package ?version_comparator pkg () = + let var = + OASISUtils.varname_concat + "pkg_" + (OASISUtils.varname_of_string pkg) + in + let findlib_dir pkg = + let dir = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%d"; pkg] + in + if Sys.file_exists dir && Sys.is_directory dir then + dir + else + failwithf + (f_ "When looking for findlib package %s, \ + directory %s return doesn't exist") + pkg dir + in + let vl = + var_redefine + var + (fun () -> findlib_dir pkg) + () + in + ( + match version_comparator with + | Some ver_cmp -> + ignore + (version + var + ver_cmp + (fun _ -> package_version pkg) + ()) + | None -> + () + ); + vl +end + +module BaseOCamlcConfig = struct +(* # 22 "src/base/BaseOCamlcConfig.ml" *) + + + open BaseEnv + open OASISUtils + open OASISGettext + + + module SMap = Map.Make(String) + + + let ocamlc = + BaseCheck.prog_opt "ocamlc" + + + let ocamlc_config_map = + (* Map name to value for ocamlc -config output + (name ^": "^value) + *) + let rec split_field mp lst = + match lst with + | line :: tl -> + let mp = + try + let pos_semicolon = + String.index line ':' + in + if pos_semicolon > 1 then + ( + let name = + String.sub line 0 pos_semicolon + in + let linelen = + String.length line + in + let value = + if linelen > pos_semicolon + 2 then + String.sub + line + (pos_semicolon + 2) + (linelen - pos_semicolon - 2) + else + "" + in + SMap.add name value mp + ) + else + ( + mp + ) + with Not_found -> + ( + mp + ) + in + split_field mp tl + | [] -> + mp + in + + let cache = + lazy + (var_protect + (Marshal.to_string + (split_field + SMap.empty + (OASISExec.run_read_output + ~ctxt:!BaseContext.default + (ocamlc ()) ["-config"])) + [])) + in + var_redefine + "ocamlc_config_map" + ~hide:true + ~dump:false + (fun () -> + (* TODO: update if ocamlc change !!! *) + Lazy.force cache) + + + let var_define nm = + (* Extract data from ocamlc -config *) + let avlbl_config_get () = + Marshal.from_string + (ocamlc_config_map ()) + 0 + in + let chop_version_suffix s = + try + String.sub s 0 (String.index s '+') + with _ -> + s + in + + let nm_config, value_config = + match nm with + | "ocaml_version" -> + "version", chop_version_suffix + | _ -> nm, (fun x -> x) + in + var_redefine + nm + (fun () -> + try + let map = + avlbl_config_get () + in + let value = + SMap.find nm_config map + in + value_config value + with Not_found -> + failwithf + (f_ "Cannot find field '%s' in '%s -config' output") + nm + (ocamlc ())) + +end + +module BaseStandardVar = struct +(* # 22 "src/base/BaseStandardVar.ml" *) + + + open OASISGettext + open OASISTypes + open OASISExpr + open BaseCheck + open BaseEnv + + + let ocamlfind = BaseCheck.ocamlfind + let ocamlc = BaseOCamlcConfig.ocamlc + let ocamlopt = prog_opt "ocamlopt" + let ocamlbuild = prog "ocamlbuild" + + + (**/**) + let rpkg = + ref None + + + let pkg_get () = + match !rpkg with + | Some pkg -> pkg + | None -> failwith (s_ "OASIS Package is not set") + + + let var_cond = ref [] + + + let var_define_cond ~since_version f dflt = + let holder = ref (fun () -> dflt) in + let since_version = + OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) + in + var_cond := + (fun ver -> + if OASISVersion.comparator_apply ver since_version then + holder := f ()) :: !var_cond; + fun () -> !holder () + + + (**/**) + + + let pkg_name = + var_define + ~short_desc:(fun () -> s_ "Package name") + "pkg_name" + (fun () -> (pkg_get ()).name) + + + let pkg_version = + var_define + ~short_desc:(fun () -> s_ "Package version") + "pkg_version" + (fun () -> + (OASISVersion.string_of_version (pkg_get ()).version)) + + + let c = BaseOCamlcConfig.var_define + + + let os_type = c "os_type" + let system = c "system" + let architecture = c "architecture" + let ccomp_type = c "ccomp_type" + let ocaml_version = c "ocaml_version" + + + (* TODO: Check standard variable presence at runtime *) + + + let standard_library_default = c "standard_library_default" + let standard_library = c "standard_library" + let standard_runtime = c "standard_runtime" + let bytecomp_c_compiler = c "bytecomp_c_compiler" + let native_c_compiler = c "native_c_compiler" + let model = c "model" + let ext_obj = c "ext_obj" + let ext_asm = c "ext_asm" + let ext_lib = c "ext_lib" + let ext_dll = c "ext_dll" + let default_executable_name = c "default_executable_name" + let systhread_supported = c "systhread_supported" + + + let flexlink = + BaseCheck.prog "flexlink" + + + let flexdll_version = + var_define + ~short_desc:(fun () -> "FlexDLL version (Win32)") + "flexdll_version" + (fun () -> + let lst = + OASISExec.run_read_output ~ctxt:!BaseContext.default + (flexlink ()) ["-help"] + in + match lst with + | line :: _ -> + Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) + | [] -> + raise Not_found) + + + (**/**) + let p name hlp dflt = + var_define + ~short_desc:hlp + ~cli:CLIAuto + ~arg_help:"dir" + name + dflt + + + let (/) a b = + if os_type () = Sys.os_type then + Filename.concat a b + else if os_type () = "Unix" then + OASISUnixPath.concat a b + else + OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") + (os_type ()) + (**/**) + + + let prefix = + p "prefix" + (fun () -> s_ "Install architecture-independent files dir") + (fun () -> + match os_type () with + | "Win32" -> + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) + | _ -> + "/usr/local") + + + let exec_prefix = + p "exec_prefix" + (fun () -> s_ "Install architecture-dependent files in dir") + (fun () -> "$prefix") + + + let bindir = + p "bindir" + (fun () -> s_ "User executables") + (fun () -> "$exec_prefix"/"bin") + + + let sbindir = + p "sbindir" + (fun () -> s_ "System admin executables") + (fun () -> "$exec_prefix"/"sbin") + + + let libexecdir = + p "libexecdir" + (fun () -> s_ "Program executables") + (fun () -> "$exec_prefix"/"libexec") + + + let sysconfdir = + p "sysconfdir" + (fun () -> s_ "Read-only single-machine data") + (fun () -> "$prefix"/"etc") + + + let sharedstatedir = + p "sharedstatedir" + (fun () -> s_ "Modifiable architecture-independent data") + (fun () -> "$prefix"/"com") + + + let localstatedir = + p "localstatedir" + (fun () -> s_ "Modifiable single-machine data") + (fun () -> "$prefix"/"var") + + + let libdir = + p "libdir" + (fun () -> s_ "Object code libraries") + (fun () -> "$exec_prefix"/"lib") + + + let datarootdir = + p "datarootdir" + (fun () -> s_ "Read-only arch-independent data root") + (fun () -> "$prefix"/"share") + + + let datadir = + p "datadir" + (fun () -> s_ "Read-only architecture-independent data") + (fun () -> "$datarootdir") + + + let infodir = + p "infodir" + (fun () -> s_ "Info documentation") + (fun () -> "$datarootdir"/"info") + + + let localedir = + p "localedir" + (fun () -> s_ "Locale-dependent data") + (fun () -> "$datarootdir"/"locale") + + + let mandir = + p "mandir" + (fun () -> s_ "Man documentation") + (fun () -> "$datarootdir"/"man") + + + let docdir = + p "docdir" + (fun () -> s_ "Documentation root") + (fun () -> "$datarootdir"/"doc"/"$pkg_name") + + + let htmldir = + p "htmldir" + (fun () -> s_ "HTML documentation") + (fun () -> "$docdir") + + + let dvidir = + p "dvidir" + (fun () -> s_ "DVI documentation") + (fun () -> "$docdir") + + + let pdfdir = + p "pdfdir" + (fun () -> s_ "PDF documentation") + (fun () -> "$docdir") + + + let psdir = + p "psdir" + (fun () -> s_ "PS documentation") + (fun () -> "$docdir") + + + let destdir = + p "destdir" + (fun () -> s_ "Prepend a path when installing package") + (fun () -> + raise + (PropList.Not_set + ("destdir", + Some (s_ "undefined by construct")))) + + + let findlib_version = + var_define + "findlib_version" + (fun () -> + BaseCheck.package_version "findlib") + + + let is_native = + var_define + "is_native" + (fun () -> + try + let _s: string = + ocamlopt () + in + "true" + with PropList.Not_set _ -> + let _s: string = + ocamlc () + in + "false") + + + let ext_program = + var_define + "suffix_program" + (fun () -> + match os_type () with + | "Win32" | "Cygwin" -> ".exe" + | _ -> "") + + + let rm = + var_define + ~short_desc:(fun () -> s_ "Remove a file.") + "rm" + (fun () -> + match os_type () with + | "Win32" -> "del" + | _ -> "rm -f") + + + let rmdir = + var_define + ~short_desc:(fun () -> s_ "Remove a directory.") + "rmdir" + (fun () -> + match os_type () with + | "Win32" -> "rd" + | _ -> "rm -rf") + + + let debug = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") + ~cli:CLIEnable + "debug" + (fun () -> "true") + + + let profile = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") + ~cli:CLIEnable + "profile" + (fun () -> "false") + + + let tests = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> + s_ "Compile tests executable and library and run them") + ~cli:CLIEnable + "tests" + (fun () -> "false")) + "true" + + + let docs = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> s_ "Create documentations") + ~cli:CLIEnable + "docs" + (fun () -> "true")) + "true" + + + let native_dynlink = + var_define + ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") + ~cli:CLINone + "native_dynlink" + (fun () -> + let res = + let ocaml_lt_312 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (ocaml_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "3.12.0")) + in + let flexdll_lt_030 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (flexdll_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "0.30")) + in + let has_native_dynlink = + let ocamlfind = ocamlfind () in + try + let fn = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ocamlfind + ["query"; "-predicates"; "native"; "dynlink"; + "-format"; "%d/%a"] + in + Sys.file_exists fn + with _ -> + false + in + if not has_native_dynlink then + false + else if ocaml_lt_312 () then + false + else if (os_type () = "Win32" || os_type () = "Cygwin") + && flexdll_lt_030 () then + begin + BaseMessage.warning + (f_ ".cmxs generation disabled because FlexDLL needs to be \ + at least 0.30. Please upgrade FlexDLL from %s to 0.30.") + (flexdll_version ()); + false + end + else + true + in + string_of_bool res) + + + let init pkg = + rpkg := Some pkg; + List.iter (fun f -> f pkg.oasis_version) !var_cond + +end + +module BaseFileAB = struct +(* # 22 "src/base/BaseFileAB.ml" *) + + + open BaseEnv + open OASISGettext + open BaseMessage + + + let to_filename fn = + let fn = + OASISHostPath.of_unix fn + in + if not (Filename.check_suffix fn ".ab") then + warning + (f_ "File '%s' doesn't have '.ab' extension") + fn; + Filename.chop_extension fn + + + let replace fn_lst = + let buff = + Buffer.create 13 + in + List.iter + (fun fn -> + let fn = + OASISHostPath.of_unix fn + in + let chn_in = + open_in fn + in + let chn_out = + open_out (to_filename fn) + in + ( + try + while true do + Buffer.add_string buff (var_expand (input_line chn_in)); + Buffer.add_char buff '\n' + done + with End_of_file -> + () + ); + Buffer.output_buffer chn_out buff; + Buffer.clear buff; + close_in chn_in; + close_out chn_out) + fn_lst +end + +module BaseLog = struct +(* # 22 "src/base/BaseLog.ml" *) + + + open OASISUtils + + + let default_filename = + Filename.concat + (Filename.dirname BaseEnv.default_filename) + "setup.log" + + + module SetTupleString = + Set.Make + (struct + type t = string * string + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with + | 0 -> String.compare s12 s22 + | n -> n + end) + + + let load () = + if Sys.file_exists default_filename then + begin + let chn = + open_in default_filename + in + let scbuf = + Scanf.Scanning.from_file default_filename + in + let rec read_aux (st, lst) = + if not (Scanf.Scanning.end_of_input scbuf) then + begin + let acc = + try + Scanf.bscanf scbuf "%S %S\n" + (fun e d -> + let t = + e, d + in + if SetTupleString.mem t st then + st, lst + else + SetTupleString.add t st, + t :: lst) + with Scanf.Scan_failure _ -> + failwith + (Scanf.bscanf scbuf + "%l" + (fun line -> + Printf.sprintf + "Malformed log file '%s' at line %d" + default_filename + line)) + in + read_aux acc + end + else + begin + close_in chn; + List.rev lst + end + in + read_aux (SetTupleString.empty, []) + end + else + begin + [] + end + + + let register event data = + let chn_out = + open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename + in + Printf.fprintf chn_out "%S %S\n" event data; + close_out chn_out + + + let unregister event data = + if Sys.file_exists default_filename then + begin + let lst = + load () + in + let chn_out = + open_out default_filename + in + let write_something = + ref false + in + List.iter + (fun (e, d) -> + if e <> event || d <> data then + begin + write_something := true; + Printf.fprintf chn_out "%S %S\n" e d + end) + lst; + close_out chn_out; + if not !write_something then + Sys.remove default_filename + end + + + let filter events = + let st_events = + List.fold_left + (fun st e -> + SetString.add e st) + SetString.empty + events + in + List.filter + (fun (e, _) -> SetString.mem e st_events) + (load ()) + + + let exists event data = + List.exists + (fun v -> (event, data) = v) + (load ()) +end + +module BaseBuilt = struct +(* # 22 "src/base/BaseBuilt.ml" *) + + + open OASISTypes + open OASISGettext + open BaseStandardVar + open BaseMessage + + + type t = + | BExec (* Executable *) + | BExecLib (* Library coming with executable *) + | BLib (* Library *) + | BObj (* Library *) + | BDoc (* Document *) + + + let to_log_event_file t nm = + "built_"^ + (match t with + | BExec -> "exec" + | BExecLib -> "exec_lib" + | BLib -> "lib" + | BObj -> "obj" + | BDoc -> "doc")^ + "_"^nm + + + let to_log_event_done t nm = + "is_"^(to_log_event_file t nm) + + + let register t nm lst = + BaseLog.register + (to_log_event_done t nm) + "true"; + List.iter + (fun alt -> + let registered = + List.fold_left + (fun registered fn -> + if OASISFileUtil.file_exists_case fn then + begin + BaseLog.register + (to_log_event_file t nm) + (if Filename.is_relative fn then + Filename.concat (Sys.getcwd ()) fn + else + fn); + true + end + else + registered) + false + alt + in + if not registered then + warning + (f_ "Cannot find an existing alternative files among: %s") + (String.concat (s_ ", ") alt)) + lst + + + let unregister t nm = + List.iter + (fun (e, d) -> + BaseLog.unregister e d) + (BaseLog.filter + [to_log_event_file t nm; + to_log_event_done t nm]) + + + let fold t nm f acc = + List.fold_left + (fun acc (_, fn) -> + if OASISFileUtil.file_exists_case fn then + begin + f acc fn + end + else + begin + warning + (f_ "File '%s' has been marked as built \ + for %s but doesn't exist") + fn + (Printf.sprintf + (match t with + | BExec | BExecLib -> + (f_ "executable %s") + | BLib -> + (f_ "library %s") + | BObj -> + (f_ "object %s") + | BDoc -> + (f_ "documentation %s")) + nm); + acc + end) + acc + (BaseLog.filter + [to_log_event_file t nm]) + + + let is_built t nm = + List.fold_left + (fun is_built (_, d) -> + (try + bool_of_string d + with _ -> + false)) + false + (BaseLog.filter + [to_log_event_done t nm]) + + + let of_executable ffn (cs, bs, exec) = + let unix_exec_is, unix_dll_opt = + OASISExecutable.unix_exec_is + (cs, bs, exec) + (fun () -> + bool_of_string + (is_native ())) + ext_dll + ext_program + in + let evs = + (BExec, cs.cs_name, [[ffn unix_exec_is]]) + :: + (match unix_dll_opt with + | Some fn -> + [BExecLib, cs.cs_name, [[ffn fn]]] + | None -> + []) + in + evs, + unix_exec_is, + unix_dll_opt + + + let of_library ffn (cs, bs, lib) = + let unix_lst = + OASISLibrary.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + ~has_native_dynlink:(bool_of_string (native_dynlink ())) + ~ext_lib:(ext_lib ()) + ~ext_dll:(ext_dll ()) + (cs, bs, lib) + in + let evs = + [BLib, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + + + let of_object ffn (cs, bs, obj) = + let unix_lst = + OASISObject.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + (cs, bs, obj) + in + let evs = + [BObj, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + +end + +module BaseCustom = struct +(* # 22 "src/base/BaseCustom.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + + let run cmd args extra_args = + OASISExec.run ~ctxt:!BaseContext.default ~quote:false + (var_expand cmd) + (List.map + var_expand + (args @ (Array.to_list extra_args))) + + + let hook ?(failsafe=false) cstm f e = + let optional_command lst = + let printer = + function + | Some (cmd, args) -> String.concat " " (cmd :: args) + | None -> s_ "No command" + in + match + var_choose + ~name:(s_ "Pre/Post Command") + ~printer + lst with + | Some (cmd, args) -> + begin + try + run cmd args [||] + with e when failsafe -> + warning + (f_ "Command '%s' fail with error: %s") + (String.concat " " (cmd :: args)) + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + end + | None -> + () + in + let res = + optional_command cstm.pre_command; + f e + in + optional_command cstm.post_command; + res +end + +module BaseDynVar = struct +(* # 22 "src/base/BaseDynVar.ml" *) + + + open OASISTypes + open OASISGettext + open BaseEnv + open BaseBuilt + + + let init pkg = + (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) + (* TODO: provide compile option for library libary_byte_args_VARNAME... *) + List.iter + (function + | Executable (cs, bs, exec) -> + if var_choose bs.bs_build then + var_ignore + (var_redefine + (* We don't save this variable *) + ~dump:false + ~short_desc:(fun () -> + Printf.sprintf + (f_ "Filename of executable '%s'") + cs.cs_name) + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + let fn_opt = + fold + BExec cs.cs_name + (fun _ fn -> Some fn) + None + in + match fn_opt with + | Some fn -> fn + | None -> + raise + (PropList.Not_set + (cs.cs_name, + Some (Printf.sprintf + (f_ "Executable '%s' not yet built.") + cs.cs_name))))) + + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + ()) + pkg.sections +end + +module BaseTest = struct +(* # 22 "src/base/BaseTest.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISExpr + open OASISGettext + + + let test lst pkg extra_args = + + let one_test (failure, n) (test_plugin, cs, test) = + if var_choose + ~name:(Printf.sprintf + (f_ "test %s run") + cs.cs_name) + ~printer:string_of_bool + test.test_run then + begin + let () = + info (f_ "Running test '%s'") cs.cs_name + in + let back_cwd = + match test.test_working_directory with + | Some dir -> + let cwd = + Sys.getcwd () + in + let chdir d = + info (f_ "Changing directory to '%s'") d; + Sys.chdir d + in + chdir dir; + fun () -> chdir cwd + + | None -> + fun () -> () + in + try + let failure_percent = + BaseCustom.hook + test.test_custom + (test_plugin pkg (cs, test)) + extra_args + in + back_cwd (); + (failure_percent +. failure, n + 1) + with e -> + begin + back_cwd (); + raise e + end + end + else + begin + info (f_ "Skipping test '%s'") cs.cs_name; + (failure, n) + end + in + let failed, n = + List.fold_left + one_test + (0.0, 0) + lst + in + let failure_percent = + if n = 0 then + 0.0 + else + failed /. (float_of_int n) + in + let msg = + Printf.sprintf + (f_ "Tests had a %.2f%% failure rate") + (100. *. failure_percent) + in + if failure_percent > 0.0 then + failwith msg + else + info "%s" msg; + + (* Possible explanation why the tests where not run. *) + if OASISFeatures.package_test OASISFeatures.flag_tests pkg && + not (bool_of_string (BaseStandardVar.tests ())) && + lst <> [] then + BaseMessage.warning + "Tests are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-tests'" +end + +module BaseDoc = struct +(* # 22 "src/base/BaseDoc.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + + let doc lst pkg extra_args = + + let one_doc (doc_plugin, cs, doc) = + if var_choose + ~name:(Printf.sprintf + (f_ "documentation %s build") + cs.cs_name) + ~printer:string_of_bool + doc.doc_build then + begin + info (f_ "Building documentation '%s'") cs.cs_name; + BaseCustom.hook + doc.doc_custom + (doc_plugin pkg (cs, doc)) + extra_args + end + in + List.iter one_doc lst; + + if OASISFeatures.package_test OASISFeatures.flag_docs pkg && + not (bool_of_string (BaseStandardVar.docs ())) && + lst <> [] then + BaseMessage.warning + "Docs are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-docs'" +end + +module BaseSetup = struct +(* # 22 "src/base/BaseSetup.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISSection + open OASISGettext + open OASISUtils + + + type std_args_fun = + package -> string array -> unit + + + type ('a, 'b) section_args_fun = + name * (package -> (common_section * 'a) -> string array -> 'b) + + + type t = + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + oasis_fn: string option; + oasis_version: string; + oasis_digest: Digest.t option; + oasis_exec: string option; + oasis_setup_args: string list; + setup_update: bool; + } + + + (* Associate a plugin function with data from package *) + let join_plugin_sections filter_map lst = + List.rev + (List.fold_left + (fun acc sct -> + match filter_map sct with + | Some e -> + e :: acc + | None -> + acc) + [] + lst) + + + (* Search for plugin data associated with a section name *) + let lookup_plugin_section plugin action nm lst = + try + List.assoc nm lst + with Not_found -> + failwithf + (f_ "Cannot find plugin %s matching section %s for %s action") + plugin + nm + action + + + let configure t args = + (* Run configure *) + BaseCustom.hook + t.package.conf_custom + (fun () -> + (* Reload if preconf has changed it *) + begin + try + unload (); + load (); + with _ -> + () + end; + + (* Run plugin's configure *) + t.configure t.package args; + + (* Dump to allow postconf to change it *) + dump ()) + (); + + (* Reload environment *) + unload (); + load (); + + (* Save environment *) + print (); + + (* Replace data in file *) + BaseFileAB.replace t.package.files_ab + + + let build t args = + BaseCustom.hook + t.package.build_custom + (t.build t.package) + args + + + let doc t args = + BaseDoc.doc + (join_plugin_sections + (function + | Doc (cs, e) -> + Some + (lookup_plugin_section + "documentation" + (s_ "build") + cs.cs_name + t.doc, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + + let test t args = + BaseTest.test + (join_plugin_sections + (function + | Test (cs, e) -> + Some + (lookup_plugin_section + "test" + (s_ "run") + cs.cs_name + t.test, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + + let all t args = + let rno_doc = + ref false + in + let rno_test = + ref false + in + let arg_rest = + ref [] + in + Arg.parse_argv + ~current:(ref 0) + (Array.of_list + ((Sys.executable_name^" all") :: + (Array.to_list args))) + [ + "-no-doc", + Arg.Set rno_doc, + s_ "Don't run doc target"; + + "-no-test", + Arg.Set rno_test, + s_ "Don't run test target"; + + "--", + Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), + s_ "All arguments for configure."; + ] + (failwithf (f_ "Don't know what to do with '%s'")) + ""; + + info "Running configure step"; + configure t (Array.of_list (List.rev !arg_rest)); + + info "Running build step"; + build t [||]; + + (* Load setup.log dynamic variables *) + BaseDynVar.init t.package; + + if not !rno_doc then + begin + info "Running doc step"; + doc t [||]; + end + else + begin + info "Skipping doc step" + end; + + if not !rno_test then + begin + info "Running test step"; + test t [||] + end + else + begin + info "Skipping test step" + end + + + let install t args = + BaseCustom.hook + t.package.install_custom + (t.install t.package) + args + + + let uninstall t args = + BaseCustom.hook + t.package.uninstall_custom + (t.uninstall t.package) + args + + + let reinstall t args = + uninstall t args; + install t args + + + let clean, distclean = + let failsafe f a = + try + f a + with e -> + warning + (f_ "Action fail with error: %s") + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + in + + let generic_clean t cstm mains docs tests args = + BaseCustom.hook + ~failsafe:true + cstm + (fun () -> + (* Clean section *) + List.iter + (function + | Test (cs, test) -> + let f = + try + List.assoc cs.cs_name tests + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, test)) + args + | Doc (cs, doc) -> + let f = + try + List.assoc cs.cs_name docs + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, doc)) + args + | Library _ + | Object _ + | Executable _ + | Flag _ + | SrcRepo _ -> + ()) + t.package.sections; + (* Clean whole package *) + List.iter + (fun f -> + failsafe + (f t.package) + args) + mains) + () + in + + let clean t args = + generic_clean + t + t.package.clean_custom + t.clean + t.clean_doc + t.clean_test + args + in + + let distclean t args = + (* Call clean *) + clean t args; + + (* Call distclean code *) + generic_clean + t + t.package.distclean_custom + t.distclean + t.distclean_doc + t.distclean_test + args; + + (* Remove generated file *) + List.iter + (fun fn -> + if Sys.file_exists fn then + begin + info (f_ "Remove '%s'") fn; + Sys.remove fn + end) + (BaseEnv.default_filename + :: + BaseLog.default_filename + :: + (List.rev_map BaseFileAB.to_filename t.package.files_ab)) + in + + clean, distclean + + + let version t _ = + print_endline t.oasis_version + + + let update_setup_ml, no_update_setup_ml_cli = + let b = ref true in + b, + ("-no-update-setup-ml", + Arg.Clear b, + s_ " Don't try to update setup.ml, even if _oasis has changed.") + + + let default_oasis_fn = "_oasis" + + + let update_setup_ml t = + let oasis_fn = + match t.oasis_fn with + | Some fn -> fn + | None -> default_oasis_fn + in + let oasis_exec = + match t.oasis_exec with + | Some fn -> fn + | None -> "oasis" + in + let ocaml = + Sys.executable_name + in + let setup_ml, args = + match Array.to_list Sys.argv with + | setup_ml :: args -> + setup_ml, args + | [] -> + failwith + (s_ "Expecting non-empty command line arguments.") + in + let ocaml, setup_ml = + if Sys.executable_name = Sys.argv.(0) then + (* We are not running in standard mode, probably the script + * is precompiled. + *) + "ocaml", "setup.ml" + else + ocaml, setup_ml + in + let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in + let do_update () = + let oasis_exec_version = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | 1 -> + failwithf + (f_ "Executable '%s' is probably an old version \ + of oasis (< 0.3.0), please update to version \ + v%s.") + oasis_exec t.oasis_version + | 127 -> + failwithf + (f_ "Cannot find executable '%s', please install \ + oasis v%s.") + oasis_exec t.oasis_version + | n -> + failwithf + (f_ "Command '%s version' exited with code %d.") + oasis_exec n) + oasis_exec ["version"] + in + if OASISVersion.comparator_apply + (OASISVersion.version_of_string oasis_exec_version) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string t.oasis_version)) then + begin + (* We have a version >= for the executable oasis, proceed with + * update. + *) + (* TODO: delegate this check to 'oasis setup'. *) + if Sys.os_type = "Win32" then + failwithf + (f_ "It is not possible to update the running script \ + setup.ml on Windows. Please update setup.ml by \ + running '%s'.") + (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) + else + begin + OASISExec.run + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | n -> + failwithf + (f_ "Unable to update setup.ml using '%s', \ + please fix the problem and retry.") + oasis_exec) + oasis_exec ("setup" :: t.oasis_setup_args); + OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) + end + end + else + failwithf + (f_ "The version of '%s' (v%s) doesn't match the version of \ + oasis used to generate the %s file. Please install at \ + least oasis v%s.") + oasis_exec oasis_exec_version setup_ml t.oasis_version + in + + if !update_setup_ml then + begin + try + match t.oasis_digest with + | Some dgst -> + if Sys.file_exists oasis_fn && + dgst <> Digest.file default_oasis_fn then + begin + do_update (); + true + end + else + false + | None -> + false + with e -> + error + (f_ "Error when updating setup.ml. If you want to avoid this error, \ + you can bypass the update of %s by running '%s %s %s %s'") + setup_ml ocaml setup_ml no_update_setup_ml_cli + (String.concat " " args); + raise e + end + else + false + + + let setup t = + let catch_exn = + ref true + in + try + let act_ref = + ref (fun _ -> + failwithf + (f_ "No action defined, run '%s %s -help'") + Sys.executable_name + Sys.argv.(0)) + + in + let extra_args_ref = + ref [] + in + let allow_empty_env_ref = + ref false + in + let arg_handle ?(allow_empty_env=false) act = + Arg.Tuple + [ + Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); + + Arg.Unit + (fun () -> + allow_empty_env_ref := allow_empty_env; + act_ref := act); + ] + in + + Arg.parse + (Arg.align + ([ + "-configure", + arg_handle ~allow_empty_env:true configure, + s_ "[options*] Configure the whole build process."; + + "-build", + arg_handle build, + s_ "[options*] Build executables and libraries."; + + "-doc", + arg_handle doc, + s_ "[options*] Build documents."; + + "-test", + arg_handle test, + s_ "[options*] Run tests."; + + "-all", + arg_handle ~allow_empty_env:true all, + s_ "[options*] Run configure, build, doc and test targets."; + + "-install", + arg_handle install, + s_ "[options*] Install libraries, data, executables \ + and documents."; + + "-uninstall", + arg_handle uninstall, + s_ "[options*] Uninstall libraries, data, executables \ + and documents."; + + "-reinstall", + arg_handle reinstall, + s_ "[options*] Uninstall and install libraries, data, \ + executables and documents."; + + "-clean", + arg_handle ~allow_empty_env:true clean, + s_ "[options*] Clean files generated by a build."; + + "-distclean", + arg_handle ~allow_empty_env:true distclean, + s_ "[options*] Clean files generated by a build and configure."; + + "-version", + arg_handle ~allow_empty_env:true version, + s_ " Display version of OASIS used to generate this setup.ml."; + + "-no-catch-exn", + Arg.Clear catch_exn, + s_ " Don't catch exception, useful for debugging."; + ] + @ + (if t.setup_update then + [no_update_setup_ml_cli] + else + []) + @ (BaseContext.args ()))) + (failwithf (f_ "Don't know what to do with '%s'")) + (s_ "Setup and run build process current package\n"); + + (* Build initial environment *) + load ~allow_empty:!allow_empty_env_ref (); + + (** Initialize flags *) + List.iter + (function + | Flag (cs, {flag_description = hlp; + flag_default = choices}) -> + begin + let apply ?short_desc () = + var_ignore + (var_define + ~cli:CLIEnable + ?short_desc + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + string_of_bool + (var_choose + ~name:(Printf.sprintf + (f_ "default value of flag %s") + cs.cs_name) + ~printer:string_of_bool + choices))) + in + match hlp with + | Some hlp -> + apply ~short_desc:(fun () -> hlp) () + | None -> + apply () + end + | _ -> + ()) + t.package.sections; + + BaseStandardVar.init t.package; + + BaseDynVar.init t.package; + + if t.setup_update && update_setup_ml t then + () + else + !act_ref t (Array.of_list (List.rev !extra_args_ref)) + + with e when !catch_exn -> + error "%s" (Printexc.to_string e); + exit 1 + + +end + + +# 5394 "setup.ml" +module InternalConfigurePlugin = struct +(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) + + + (** Configure using internal scheme + @author Sylvain Le Gall + *) + + + open BaseEnv + open OASISTypes + open OASISUtils + open OASISGettext + open BaseMessage + + + (** Configure build using provided series of check to be done + * and then output corresponding file. + *) + let configure pkg argv = + let var_ignore_eval var = let _s: string = var () in () in + let errors = ref SetString.empty in + let buff = Buffer.create 13 in + + let add_errors fmt = + Printf.kbprintf + (fun b -> + errors := SetString.add (Buffer.contents b) !errors; + Buffer.clear b) + buff + fmt + in + + let warn_exception e = + warning "%s" (Printexc.to_string e) + in + + (* Check tools *) + let check_tools lst = + List.iter + (function + | ExternalTool tool -> + begin + try + var_ignore_eval (BaseCheck.prog tool) + with e -> + warn_exception e; + add_errors (f_ "Cannot find external tool '%s'") tool + end + | InternalExecutable nm1 -> + (* Check that matching tool is built *) + List.iter + (function + | Executable ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal executable \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + lst + in + + let build_checks sct bs = + if var_choose bs.bs_build then + begin + if bs.bs_compiled_object = Native then + begin + try + var_ignore_eval BaseStandardVar.ocamlopt + with e -> + warn_exception e; + add_errors + (f_ "Section %s requires native compilation") + (OASISSection.string_of_section sct) + end; + + (* Check tools *) + check_tools bs.bs_build_tools; + + (* Check depends *) + List.iter + (function + | FindlibPackage (findlib_pkg, version_comparator) -> + begin + try + var_ignore_eval + (BaseCheck.package ?version_comparator findlib_pkg) + with e -> + warn_exception e; + match version_comparator with + | None -> + add_errors + (f_ "Cannot find findlib package %s") + findlib_pkg + | Some ver_cmp -> + add_errors + (f_ "Cannot find findlib package %s (%s)") + findlib_pkg + (OASISVersion.string_of_comparator ver_cmp) + end + | InternalLibrary nm1 -> + (* Check that matching library is built *) + List.iter + (function + | Library ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal library \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + bs.bs_build_depends + end + in + + (* Parse command line *) + BaseArgExt.parse argv (BaseEnv.args ()); + + (* OCaml version *) + begin + match pkg.ocaml_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "ocaml" + ver_cmp + BaseStandardVar.ocaml_version) + with e -> + warn_exception e; + add_errors + (f_ "OCaml version %s doesn't match version constraint %s") + (BaseStandardVar.ocaml_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* Findlib version *) + begin + match pkg.findlib_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "findlib" + ver_cmp + BaseStandardVar.findlib_version) + with e -> + warn_exception e; + add_errors + (f_ "Findlib version %s doesn't match version constraint %s") + (BaseStandardVar.findlib_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + (* Make sure the findlib version is fine for the OCaml compiler. *) + begin + let ocaml_ge4 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) + (OASISVersion.version_of_string "4.0.0") >= 0 in + if ocaml_ge4 then + let findlib_lt132 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) + (OASISVersion.version_of_string "1.3.2") < 0 in + if findlib_lt132 then + add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" + end; + + (* FlexDLL *) + if BaseStandardVar.os_type () = "Win32" || + BaseStandardVar.os_type () = "Cygwin" then + begin + try + var_ignore_eval BaseStandardVar.flexlink + with e -> + warn_exception e; + add_errors (f_ "Cannot find 'flexlink'") + end; + + (* Check build depends *) + List.iter + (function + | Executable (_, bs, _) + | Library (_, bs, _) as sct -> + build_checks sct bs + | Doc (_, doc) -> + if var_choose doc.doc_build then + check_tools doc.doc_build_tools + | Test (_, test) -> + if var_choose test.test_run then + check_tools test.test_tools + | _ -> + ()) + pkg.sections; + + (* Check if we need native dynlink (presence of libraries that compile to + * native) + *) + begin + let has_cmxa = + List.exists + (function + | Library (_, bs, _) -> + var_choose bs.bs_build && + (bs.bs_compiled_object = Native || + (bs.bs_compiled_object = Best && + bool_of_string (BaseStandardVar.is_native ()))) + | _ -> + false) + pkg.sections + in + if has_cmxa then + var_ignore_eval BaseStandardVar.native_dynlink + end; + + (* Check errors *) + if SetString.empty != !errors then + begin + List.iter + (fun e -> error "%s" e) + (SetString.elements !errors); + failwithf + (fn_ + "%d configuration error" + "%d configuration errors" + (SetString.cardinal !errors)) + (SetString.cardinal !errors) + end + + +end + +module InternalInstallPlugin = struct +(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) + + + (** Install using internal scheme + @author Sylvain Le Gall + *) + + + open BaseEnv + open BaseStandardVar + open BaseMessage + open OASISTypes + open OASISFindlib + open OASISGettext + open OASISUtils + + + let exec_hook = + ref (fun (cs, bs, exec) -> cs, bs, exec) + + + let lib_hook = + ref (fun (cs, bs, lib) -> cs, bs, lib, []) + + + let obj_hook = + ref (fun (cs, bs, obj) -> cs, bs, obj, []) + + + let doc_hook = + ref (fun (cs, doc) -> cs, doc) + + + let install_file_ev = + "install-file" + + + let install_dir_ev = + "install-dir" + + + let install_findlib_ev = + "install-findlib" + + + let win32_max_command_line_length = 8000 + + + let split_install_command ocamlfind findlib_name meta files = + if Sys.os_type = "Win32" then + (* Arguments for the first command: *) + let first_args = ["install"; findlib_name; meta] in + (* Arguments for remaining commands: *) + let other_args = ["install"; findlib_name; "-add"] in + (* Extract as much files as possible from [files], [len] is + the current command line length: *) + let rec get_files len acc files = + match files with + | [] -> + (List.rev acc, []) + | file :: rest -> + let len = len + 1 + String.length file in + if len > win32_max_command_line_length then + (List.rev acc, files) + else + get_files len (file :: acc) rest + in + (* Split the command into several commands. *) + let rec split args files = + match files with + | [] -> + [] + | _ -> + (* Length of "ocamlfind install [META|-add]" *) + let len = + List.fold_left + (fun len arg -> + len + 1 (* for the space *) + String.length arg) + (String.length ocamlfind) + args + in + match get_files len [] files with + | ([], _) -> + failwith (s_ "Command line too long.") + | (firsts, others) -> + let cmd = args @ firsts in + (* Use -add for remaining commands: *) + let () = + let findlib_ge_132 = + OASISVersion.comparator_apply + (OASISVersion.version_of_string + (BaseStandardVar.findlib_version ())) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string "1.3.2")) + in + if not findlib_ge_132 then + failwithf + (f_ "Installing the library %s require to use the \ + flag '-add' of ocamlfind because the command \ + line is too long. This flag is only available \ + for findlib 1.3.2. Please upgrade findlib from \ + %s to 1.3.2") + findlib_name (BaseStandardVar.findlib_version ()) + in + let cmds = split other_args others in + cmd :: cmds + in + (* The first command does not use -add: *) + split first_args files + else + ["install" :: findlib_name :: meta :: files] + + + let install pkg argv = + + let in_destdir = + try + let destdir = + destdir () + in + (* Practically speaking destdir is prepended + * at the beginning of the target filename + *) + fun fn -> destdir^fn + with PropList.Not_set _ -> + fun fn -> fn + in + + let install_file ?tgt_fn src_file envdir = + let tgt_dir = + in_destdir (envdir ()) + in + let tgt_file = + Filename.concat + tgt_dir + (match tgt_fn with + | Some fn -> + fn + | None -> + Filename.basename src_file) + in + (* Create target directory if needed *) + OASISFileUtil.mkdir_parent + ~ctxt:!BaseContext.default + (fun dn -> + info (f_ "Creating directory '%s'") dn; + BaseLog.register install_dir_ev dn) + tgt_dir; + + (* Really install files *) + info (f_ "Copying file '%s' to '%s'") src_file tgt_file; + OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; + BaseLog.register install_file_ev tgt_file + in + + (* Install data into defined directory *) + let install_data srcdir lst tgtdir = + let tgtdir = + OASISHostPath.of_unix (var_expand tgtdir) + in + List.iter + (fun (src, tgt_opt) -> + let real_srcs = + OASISFileUtil.glob + ~ctxt:!BaseContext.default + (Filename.concat srcdir src) + in + if real_srcs = [] then + failwithf + (f_ "Wildcard '%s' doesn't match any files") + src; + List.iter + (fun fn -> + install_file + fn + (fun () -> + match tgt_opt with + | Some s -> + OASISHostPath.of_unix (var_expand s) + | None -> + tgtdir)) + real_srcs) + lst + in + + (** Install all libraries *) + let install_libs pkg = + + let files_of_library (f_data, acc) data_lib = + let cs, bs, lib, lib_extra = + !lib_hook data_lib + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then + begin + let acc = + (* Start with acc + lib_extra *) + List.rev_append lib_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in library %s") + modul cs.cs_name; + acc + end) + acc + lib.lib_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BLib + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the library *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + and files_of_object (f_data, acc) data_obj = + let cs, bs, obj, obj_extra = + !obj_hook data_obj + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then + begin + let acc = + (* Start with acc + obj_extra *) + List.rev_append obj_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in object %s") + modul cs.cs_name; + acc + end) + acc + obj.obj_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BObj + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the object *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + + in + + (* Install one group of library *) + let install_group_lib grp = + (* Iterate through all group nodes *) + let rec install_group_lib_aux data_and_files grp = + let data_and_files, children = + match grp with + | Container (_, children) -> + data_and_files, children + | Package (_, cs, bs, `Library lib, children) -> + files_of_library data_and_files (cs, bs, lib), children + | Package (_, cs, bs, `Object obj, children) -> + files_of_object data_and_files (cs, bs, obj), children + in + List.fold_left + install_group_lib_aux + data_and_files + children + in + + (* Findlib name of the root library *) + let findlib_name = + findlib_of_group grp + in + + (* Determine root library *) + let root_lib = + root_of_group grp + in + + (* All files to install for this library *) + let f_data, files = + install_group_lib_aux (ignore, []) grp + in + + (* Really install, if there is something to install *) + if files = [] then + begin + warning + (f_ "Nothing to install for findlib library '%s'") + findlib_name + end + else + begin + let meta = + (* Search META file *) + let _, bs, _ = + root_lib + in + let res = + Filename.concat bs.bs_path "META" + in + if not (OASISFileUtil.file_exists_case res) then + failwithf + (f_ "Cannot find file '%s' for findlib library %s") + res + findlib_name; + res + in + let files = + (* Make filename shorter to avoid hitting command max line length + * too early, esp. on Windows. + *) + let remove_prefix p n = + let plen = String.length p in + let nlen = String.length n in + if plen <= nlen && String.sub n 0 plen = p then + begin + let fn_sep = + if Sys.os_type = "Win32" then + '\\' + else + '/' + in + let cutpoint = plen + + (if plen < nlen && n.[plen] = fn_sep then + 1 + else + 0) + in + String.sub n cutpoint (nlen - cutpoint) + end + else + n + in + List.map (remove_prefix (Sys.getcwd ())) files + in + info + (f_ "Installing findlib library '%s'") + findlib_name; + let ocamlfind = ocamlfind () in + let commands = + split_install_command + ocamlfind + findlib_name + meta + files + in + List.iter + (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) + commands; + BaseLog.register install_findlib_ev findlib_name + end; + + (* Install data files *) + f_data (); + + in + + let group_libs, _, _ = + findlib_mapping pkg + in + + (* We install libraries in groups *) + List.iter install_group_lib group_libs + in + + let install_execs pkg = + let install_exec data_exec = + let cs, bs, exec = + !exec_hook data_exec + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then + begin + let exec_libdir () = + Filename.concat + (libdir ()) + pkg.name + in + BaseBuilt.fold + BaseBuilt.BExec + cs.cs_name + (fun () fn -> + install_file + ~tgt_fn:(cs.cs_name ^ ext_program ()) + fn + bindir) + (); + BaseBuilt.fold + BaseBuilt.BExecLib + cs.cs_name + (fun () fn -> + install_file + fn + exec_libdir) + (); + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name) + end + in + List.iter + (function + | Executable (cs, bs, exec)-> + install_exec (cs, bs, exec) + | _ -> + ()) + pkg.sections + in + + let install_docs pkg = + let install_doc data = + let cs, doc = + !doc_hook data + in + if var_choose doc.doc_install && + BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then + begin + let tgt_dir = + OASISHostPath.of_unix (var_expand doc.doc_install_dir) + in + BaseBuilt.fold + BaseBuilt.BDoc + cs.cs_name + (fun () fn -> + install_file + fn + (fun () -> tgt_dir)) + (); + install_data + Filename.current_dir_name + doc.doc_data_files + doc.doc_install_dir + end + in + List.iter + (function + | Doc (cs, doc) -> + install_doc (cs, doc) + | _ -> + ()) + pkg.sections + in + + install_libs pkg; + install_execs pkg; + install_docs pkg + + + (* Uninstall already installed data *) + let uninstall _ argv = + List.iter + (fun (ev, data) -> + if ev = install_file_ev then + begin + if OASISFileUtil.file_exists_case data then + begin + info + (f_ "Removing file '%s'") + data; + Sys.remove data + end + else + begin + warning + (f_ "File '%s' doesn't exist anymore") + data + end + end + else if ev = install_dir_ev then + begin + if Sys.file_exists data && Sys.is_directory data then + begin + if Sys.readdir data = [||] then + begin + info + (f_ "Removing directory '%s'") + data; + OASISFileUtil.rmdir ~ctxt:!BaseContext.default data + end + else + begin + warning + (f_ "Directory '%s' is not empty (%s)") + data + (String.concat + ", " + (Array.to_list + (Sys.readdir data))) + end + end + else + begin + warning + (f_ "Directory '%s' doesn't exist anymore") + data + end + end + else if ev = install_findlib_ev then + begin + info (f_ "Removing findlib library '%s'") data; + OASISExec.run ~ctxt:!BaseContext.default + (ocamlfind ()) ["remove"; data] + end + else + failwithf (f_ "Unknown log event '%s'") ev; + BaseLog.unregister ev data) + (* We process event in reverse order *) + (List.rev + (BaseLog.filter + [install_file_ev; + install_dir_ev; + install_findlib_ev])) + + +end + + +# 6243 "setup.ml" +module OCamlbuildCommon = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) + + + (** Functions common to OCamlbuild build and doc plugin + *) + + + open OASISGettext + open BaseEnv + open BaseStandardVar + open OASISTypes + + + + + type extra_args = string list + + + let ocamlbuild_clean_ev = "ocamlbuild-clean" + + + let ocamlbuildflags = + var_define + ~short_desc:(fun () -> "OCamlbuild additional flags") + "ocamlbuildflags" + (fun () -> "") + + + (** Fix special arguments depending on environment *) + let fix_args args extra_argv = + List.flatten + [ + if (os_type ()) = "Win32" then + [ + "-classic-display"; + "-no-log"; + "-no-links"; + "-install-lib-dir"; + (Filename.concat (standard_library ()) "ocamlbuild") + ] + else + []; + + if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then + [ + "-byte-plugin" + ] + else + []; + args; + + if bool_of_string (debug ()) then + ["-tag"; "debug"] + else + []; + + if bool_of_string (profile ()) then + ["-tag"; "profile"] + else + []; + + OASISString.nsplit (ocamlbuildflags ()) ' '; + + Array.to_list extra_argv; + ] + + + (** Run 'ocamlbuild -clean' if not already done *) + let run_clean extra_argv = + let extra_cli = + String.concat " " (Array.to_list extra_argv) + in + (* Run if never called with these args *) + if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then + begin + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args ["-clean"] extra_argv); + BaseLog.register ocamlbuild_clean_ev extra_cli; + at_exit + (fun () -> + try + BaseLog.unregister ocamlbuild_clean_ev extra_cli + with _ -> + ()) + end + + + (** Run ocamlbuild, unregister all clean events *) + let run_ocamlbuild args extra_argv = + (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html + *) + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args args extra_argv); + (* Remove any clean event, we must run it again *) + List.iter + (fun (e, d) -> BaseLog.unregister e d) + (BaseLog.filter [ocamlbuild_clean_ev]) + + + (** Determine real build directory *) + let build_dir extra_argv = + let rec search_args dir = + function + | "-build-dir" :: dir :: tl -> + search_args dir tl + | _ :: tl -> + search_args dir tl + | [] -> + dir + in + search_args "_build" (fix_args [] extra_argv) + + +end + +module OCamlbuildPlugin = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) + + + (** Build using ocamlbuild + @author Sylvain Le Gall + *) + + + open OASISTypes + open OASISGettext + open OASISUtils + open OASISString + open BaseEnv + open OCamlbuildCommon + open BaseStandardVar + open BaseMessage + + + + + + let cond_targets_hook = + ref (fun lst -> lst) + + + let build extra_args pkg argv = + (* Return the filename in build directory *) + let in_build_dir fn = + Filename.concat + (build_dir argv) + fn + in + + (* Return the unix filename in host build directory *) + let in_build_dir_of_unix fn = + in_build_dir (OASISHostPath.of_unix fn) + in + + let cond_targets = + List.fold_left + (fun acc -> + function + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_library + in_build_dir_of_unix + (cs, bs, lib) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ~what:".cma" fn + || ends_with ~what:".cmxs" fn + || ends_with ~what:".cmxa" fn + || ends_with ~what:(ext_lib ()) fn + || ends_with ~what:(ext_dll ()) fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for library %s") + cs.cs_name + end + + | Object (cs, bs, obj) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_object + in_build_dir_of_unix + (cs, bs, obj) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ".cmo" fn + || ends_with ".cmx" fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for object %s") + cs.cs_name + end + + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, unix_exec_is, unix_dll_opt = + BaseBuilt.of_executable + in_build_dir_of_unix + (cs, bs, exec) + in + + let target ext = + let unix_tgt = + (OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.chop_extension + exec.exec_main_is))^ext + in + let evs = + (* Fix evs, we want to use the unix_tgt, without copying *) + List.map + (function + | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> + BaseBuilt.BExec, nm, + [[in_build_dir_of_unix unix_tgt]] + | ev -> + ev) + evs + in + evs, [unix_tgt] + in + + (* Add executable *) + let acc = + match bs.bs_compiled_object with + | Native -> + (target ".native") :: acc + | Best when bool_of_string (is_native ()) -> + (target ".native") :: acc + | Byte + | Best -> + (target ".byte") :: acc + in + acc + end + + | Library _ | Object _ | Executable _ | Test _ + | SrcRepo _ | Flag _ | Doc _ -> + acc) + [] + (* Keep the pkg.sections ordered *) + (List.rev pkg.sections); + in + + (* Check and register built files *) + let check_and_register (bt, bnm, lst) = + List.iter + (fun fns -> + if not (List.exists OASISFileUtil.file_exists_case fns) then + failwithf + (fn_ + "Expected built file %s doesn't exist." + "None of expected built files %s exists." + (List.length fns)) + (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) + lst; + (BaseBuilt.register bt bnm lst) + in + + (* Run the hook *) + let cond_targets = !cond_targets_hook cond_targets in + + (* Run a list of target... *) + run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; + (* ... and register events *) + List.iter check_and_register (List.flatten (List.map fst cond_targets)) + + + let clean pkg extra_args = + run_clean extra_args; + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + +end + +module OCamlbuildDocPlugin = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) + + + (* Create documentation using ocamlbuild .odocl files + @author Sylvain Le Gall + *) + + + open OASISTypes + open OASISGettext + open OASISMessage + open OCamlbuildCommon + open BaseStandardVar + + + + + type run_t = + { + extra_args: string list; + run_path: unix_filename; + } + + + let doc_build run pkg (cs, doc) argv = + let index_html = + OASISUnixPath.make + [ + run.run_path; + cs.cs_name^".docdir"; + "index.html"; + ] + in + let tgt_dir = + OASISHostPath.make + [ + build_dir argv; + OASISHostPath.of_unix run.run_path; + cs.cs_name^".docdir"; + ] + in + run_ocamlbuild (index_html :: run.extra_args) argv; + List.iter + (fun glb -> + BaseBuilt.register + BaseBuilt.BDoc + cs.cs_name + [OASISFileUtil.glob ~ctxt:!BaseContext.default + (Filename.concat tgt_dir glb)]) + ["*.html"; "*.css"] + + + let doc_clean run pkg (cs, doc) argv = + run_clean argv; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + + +end + + +# 6616 "setup.ml" +module CustomPlugin = struct +(* # 22 "src/plugins/custom/CustomPlugin.ml" *) + + + (** Generate custom configure/build/doc/test/install system + @author + *) + + + open BaseEnv + open OASISGettext + open OASISTypes + + + + + + type t = + { + cmd_main: command_line conditional; + cmd_clean: (command_line option) conditional; + cmd_distclean: (command_line option) conditional; + } + + + let run = BaseCustom.run + + + let main t _ extra_args = + let cmd, args = + var_choose + ~name:(s_ "main command") + t.cmd_main + in + run cmd args extra_args + + + let clean t pkg extra_args = + match var_choose t.cmd_clean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + + let distclean t pkg extra_args = + match var_choose t.cmd_distclean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + + module Build = + struct + let main t pkg extra_args = + main t pkg extra_args; + List.iter + (fun sct -> + let evs = + match sct with + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, _ = + BaseBuilt.of_library + OASISHostPath.of_unix + (cs, bs, lib) + in + evs + end + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, _, _ = + BaseBuilt.of_executable + OASISHostPath.of_unix + (cs, bs, exec) + in + evs + end + | _ -> + [] + in + List.iter + (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) + evs) + pkg.sections + + let clean t pkg extra_args = + clean t pkg extra_args; + (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild + * considering moving this to BaseSetup? + *) + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + let distclean t pkg extra_args = + distclean t pkg extra_args + end + + + module Test = + struct + let main t pkg (cs, test) extra_args = + try + main t pkg extra_args; + 0.0 + with Failure s -> + BaseMessage.warning + (f_ "Test '%s' fails: %s") + cs.cs_name + s; + 1.0 + + let clean t pkg (cs, test) extra_args = + clean t pkg extra_args + + let distclean t pkg (cs, test) extra_args = + distclean t pkg extra_args + end + + + module Doc = + struct + let main t pkg (cs, _) extra_args = + main t pkg extra_args; + BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] + + let clean t pkg (cs, _) extra_args = + clean t pkg extra_args; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + + let distclean t pkg (cs, _) extra_args = + distclean t pkg extra_args + end + + +end + + +# 6764 "setup.ml" +open OASISTypes;; + +let setup_t = + { + BaseSetup.configure = InternalConfigurePlugin.configure; + build = OCamlbuildPlugin.build []; + test = + [ + ("all", + CustomPlugin.Test.main + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("make", ["run-tests"]))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + doc = + [ + ("sequence", + OCamlbuildDocPlugin.doc_build + {OCamlbuildDocPlugin.extra_args = []; run_path = "."}) + ]; + install = InternalInstallPlugin.install; + uninstall = InternalInstallPlugin.uninstall; + clean = [OCamlbuildPlugin.clean]; + clean_test = + [ + ("all", + CustomPlugin.Test.clean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("make", ["run-tests"]))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + clean_doc = + [ + ("sequence", + OCamlbuildDocPlugin.doc_clean + {OCamlbuildDocPlugin.extra_args = []; run_path = "."}) + ]; + distclean = []; + distclean_test = + [ + ("all", + CustomPlugin.Test.distclean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("make", ["run-tests"]))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + distclean_doc = []; + package = + { + oasis_version = "0.4"; + ocaml_version = None; + findlib_version = None; + alpha_features = []; + beta_features = []; + name = "sequence"; + version = "0.5.1"; + license = + OASISLicense.DEP5License + (OASISLicense.DEP5Unit + { + OASISLicense.license = "BSD-2-clause"; + excption = None; + version = OASISLicense.NoVersion + }); + license_file = Some "LICENSE"; + copyrights = []; + maintainers = []; + authors = ["Simon Cruanes"]; + homepage = Some "https://github.com/c-cube/sequence"; + synopsis = "Simple sequence (iterator) datatype and combinators"; + description = + Some + [ + OASISText.Para + "Simple sequence datatype, intended to transfer a finite number of elements from one data structure to another. Some transformations on sequences, like `filter`, `map`, `take`, `drop` and `append` can be performed before the sequence is iterated/folded on." + ]; + categories = []; + conf_type = (`Configure, "internal", Some "0.4"); + conf_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + build_type = (`Build, "ocamlbuild", Some "0.4"); + build_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + install_type = (`Install, "internal", Some "0.4"); + install_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + uninstall_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + clean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + distclean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + files_ab = []; + sections = + [ + Flag + ({ + cs_name = "bench"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + flag_description = + Some "enable benchmarks (require library Benchmark)"; + flag_default = [(OASISExpr.EBool true, false)] + }); + Flag + ({ + cs_name = "invert"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + flag_description = + Some "build sequence.invert (requires Delimcc)"; + flag_default = [(OASISExpr.EBool true, false)] + }); + Library + ({ + cs_name = "sequence"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "."; + bs_compiled_object = Best; + bs_build_depends = []; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = ["Sequence"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = None; + lib_findlib_name = None; + lib_findlib_containers = [] + }); + Library + ({ + cs_name = "invert"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "invert", true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "invert", true) + ]; + bs_path = "invert"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "sequence"; + FindlibPackage ("delimcc", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = ["SequenceInvert"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "sequence"; + lib_findlib_name = Some "invert"; + lib_findlib_containers = [] + }); + Doc + ({ + cs_name = "sequence"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + doc_type = (`Doc, "ocamlbuild", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$docdir"; + doc_title = "Sequence docs"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = []; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] + }); + Executable + ({ + cs_name = "run_tests"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "tests", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests/"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "sequence"; + FindlibPackage ("oUnit", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "run_tests.ml"}); + Test + ({ + cs_name = "all"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + test_type = (`Test, "custom", None); + test_command = + [(OASISExpr.EBool true, ("make", ["run-tests"]))]; + test_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + test_working_directory = None; + test_run = + [ + (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); + (OASISExpr.EFlag "tests", false); + (OASISExpr.EAnd + (OASISExpr.EFlag "tests", + OASISExpr.EFlag "tests"), + true) + ]; + test_tools = + [ + ExternalTool "ocamlbuild"; + InternalExecutable "run_tests" + ] + }); + Executable + ({ + cs_name = "benchs"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "bench", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "bench"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "sequence"; + FindlibPackage ("benchmark", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "benchs.ml"}); + Executable + ({ + cs_name = "bench_persistent"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "bench", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "bench"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "sequence"; + FindlibPackage ("benchmark", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "bench_persistent.ml" + }); + Executable + ({ + cs_name = "bench_persistent_read"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "bench", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "bench"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "sequence"; + FindlibPackage ("benchmark", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + exec_custom = false; + exec_main_is = "bench_persistent_read.ml" + }); + SrcRepo + ({ + cs_name = "head"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + src_repo_type = Git; + src_repo_location = + "https://github.com/c-cube/sequence"; + src_repo_browser = + Some + "https://github.com/c-cube/sequence/tree/master/src"; + src_repo_module = None; + src_repo_branch = None; + src_repo_tag = None; + src_repo_subdir = None + }) + ]; + plugins = + [(`Extra, "META", Some "0.3"); (`Extra, "DevFiles", Some "0.3")]; + disable_oasis_section = []; + schema_data = PropList.Data.create (); + plugin_data = [] + }; + oasis_fn = Some "_oasis"; + oasis_version = "0.4.4"; + oasis_digest = Some "8\252\157\1340^<0\133GR\029nmc6"; + oasis_exec = None; + oasis_setup_args = []; + setup_update = false + };; + +let setup () = BaseSetup.setup setup_t;; + +# 7204 "setup.ml" +(* OASIS_STOP *) +let () = setup ();; diff --git a/tests/run_tests.ml b/tests/run_tests.ml new file mode 100644 index 00000000..0fa3d58c --- /dev/null +++ b/tests/run_tests.ml @@ -0,0 +1,9 @@ + +open OUnit + +let suite = + "run_tests" >::: + [ Test_sequence.suite; ] + +let _ = + OUnit.run_test_tt_main suite diff --git a/tests/test_sequence.ml b/tests/test_sequence.ml new file mode 100644 index 00000000..bfd7dac4 --- /dev/null +++ b/tests/test_sequence.ml @@ -0,0 +1,220 @@ + +open OUnit + +module S = Sequence +open Sequence.Infix + +let pp_ilist l = + let b = Buffer.create 15 in + Format.bprintf b "@[%a@]" (S.pp_seq Format.pp_print_int) (S.of_list l); + Buffer.contents b + +let test_empty () = + let seq = S.empty in + OUnit.assert_bool "empty" (S.is_empty seq); + OUnit.assert_bool "empty" + (try S.iter (fun _ -> raise Exit) seq; true with Exit -> false); + () + +let test_repeat () = + let seq = S.repeat "hello" in + OUnit.assert_equal ["hello"; "hello"; "hello"] + (seq |> S.take 3 |> S.to_list); + () + +let test_concat () = + let s1 = (1 -- 5) in + let s2 = (6 -- 10) in + let l = [1;2;3;4;5;6;7;8;9;10] in + OUnit.assert_equal l (S.to_list (S.append s1 s2)); + () + +let test_fold () = + let n = (1 -- 10) + |> S.fold (+) 0 in + OUnit.assert_equal 55 n; + () + +let test_foldi () = + let l = ["hello"; "world"] + |> S.of_list + |> S.foldi (fun acc i x -> (i,x) :: acc) [] in + OUnit.assert_equal [1, "world"; 0, "hello"] l; + () + +let test_exists () = + (1 -- 100) + |> S.exists (fun x -> x = 59) + |> OUnit.assert_bool "exists"; + (1 -- 100) + |> S.exists (fun x -> x < 0) + |> (fun x -> not x) + |> OUnit.assert_bool "not exists"; + () + +let test_length () = + (1 -- 1000) |> S.length |> OUnit.assert_equal 1000 + +let test_concat () = + 1 -- 1000 + |> S.map (fun i -> (i -- (i+1))) + |> S.concat + |> S.length + |> OUnit.assert_equal 2000 + +let test_flatMap () = + 1 -- 1000 + |> S.flatMap (fun i -> (i -- (i+1))) + |> S.length + |> OUnit.assert_equal 2000 + +let test_intersperse () = + 1 -- 100 + |> (fun seq -> S.intersperse 0 seq) + |> S.take 10 + |> S.to_list + |> OUnit.assert_equal [1;0;2;0;3;0;4;0;5;0] + +let test_not_persistent () = + let printer = pp_ilist in + let stream = Stream.from (fun i -> if i < 5 then Some i else None) in + let seq = S.of_stream stream in + OUnit.assert_equal ~printer [0;1;2;3;4] (seq |> S.to_list); + OUnit.assert_equal ~printer [] (seq |> S.to_list); + () + +let test_persistent () = + let printer = pp_ilist in + let stream = Stream.from (fun i -> if i < 5 then Some i else None) in + let seq = S.of_stream stream in + (* consume seq into a persistent version of itself *) + let seq' = S.persistent seq in + OUnit.assert_equal ~printer [] (seq |> S.to_list); + OUnit.assert_equal ~printer [0;1;2;3;4] (seq' |> S.to_list); + OUnit.assert_equal ~printer [0;1;2;3;4] (seq' |> S.to_list); + OUnit.assert_equal ~printer [0;1;2;3;4] (seq' |> S.to_stream |> S.of_stream |> S.to_list); + () + +let test_big_persistent () = + let printer = pp_ilist in + let seq = 0 -- 10_000 in + let seq' = S.persistent seq in + OUnit.assert_equal 10_001 (S.length seq'); + OUnit.assert_equal 10_001 (S.length seq'); + OUnit.assert_equal ~printer [0;1;2;3] (seq' |> S.take 4 |> S.to_list); + () + +let test_sort () = + 1 -- 100 + |> S.sort ~cmp:(fun i j -> j - i) + |> S.take 4 + |> S.to_list + |> OUnit.assert_equal [100;99;98;97] + +let test_sort_uniq () = + [42;1;2;3;4;5;4;3;2;1] + |> S.of_list + |> S.sort_uniq + |> S.to_list + |> OUnit.assert_equal [1;2;3;4;5;42] + +let test_group () = + [1;2;3;3;2;2;3;4] + |> S.of_list |> S.group |> S.to_list + |> OUnit.assert_equal [[1];[2];[3;3];[2;2];[3];[4]] + +let test_uniq () = + [1;2;2;3;4;4;4;3;3] + |> S.of_list |> S.uniq |> S.to_list + |> OUnit.assert_equal [1;2;3;4;3] + +let test_product () = + let stream = Stream.from (fun i -> if i < 3 then Some i else None) in + let a = S.of_stream stream in + let b = S.of_list ["a";"b";"c"] in + let s = S.product a b |> S.map (fun (x,y) -> y,x) + |> S.to_list |> List.sort compare in + OUnit.assert_equal ["a",0; "a", 1; "a", 2; + "b",0; "b", 1; "b", 2; + "c",0; "c", 1; "c", 2;] s + +let test_join () = + let s1 = (1 -- 3) in + let s2 = S.of_list ["1"; "2"] in + let join_row i j = + if string_of_int i = j then Some (string_of_int i ^ " = " ^ j) else None + in + let s = S.join ~join_row s1 s2 in + OUnit.assert_equal ["1 = 1"; "2 = 2"] (S.to_list s); + () + +let test_scan () = + 1 -- 5 + |> S.scan (+) 0 + |> S.to_list + |> OUnit.assert_equal ~printer:pp_ilist [0;1;3;6;10;15] + +let test_drop () = + 1 -- 5 |> S.drop 2 |> S.to_list |> OUnit.assert_equal [3;4;5] + +let test_rev () = + 1 -- 5 |> S.rev |> S.to_list |> OUnit.assert_equal [5;4;3;2;1] + +let test_unfoldr () = + let f x = if x < 5 then Some (string_of_int x,x+1) else None in + S.unfoldr f 0 + |> S.to_list + |> OUnit.assert_equal ["0"; "1"; "2"; "3"; "4"] + +let test_hashtbl () = + let h = 1 -- 5 + |> S.zip_i + |> S.to_hashtbl2 in + 0 -- 4 + |> S.iter (fun i -> OUnit.assert_equal (i+1) (Hashtbl.find h i)); + OUnit.assert_equal [0;1;2;3;4] (S.hashtbl_keys h |> S.sort |> S.to_list); + () + +let test_buff () = + let b = Buffer.create 4 in + "hello world" + |> S.of_str |> S.rev |> S.map Char.uppercase + |> (fun seq -> S.to_buffer seq b); + OUnit.assert_equal "DLROW OLLEH" (Buffer.contents b); + () + +let test_int_range () = + OUnit.assert_equal ~printer:pp_ilist [1;2;3;4] S.(to_list (1--4)); + OUnit.assert_equal ~printer:pp_ilist [10;9;8;7;6] S.(to_list (10 --^ 6)); + OUnit.assert_equal ~printer:pp_ilist [] S.(to_list (10--4)); + OUnit.assert_equal ~printer:pp_ilist [] S.(to_list (10 --^ 60)); + () + +let suite = + "test_sequence" >::: + [ "test_empty" >:: test_empty; + "test_repeat" >:: test_repeat; + "test_concat" >:: test_concat; + "test_fold" >:: test_fold; + "test_foldi" >:: test_foldi; + "test_exists" >:: test_exists; + "test_length" >:: test_length; + "test_concat" >:: test_concat; + "test_flatMap" >:: test_flatMap; + "test_intersperse" >:: test_intersperse; + "test_not_persistent" >:: test_not_persistent; + "test_persistent" >:: test_persistent; + "test_big_persistent" >:: test_big_persistent; + "test_sort" >:: test_sort; + "test_sort_uniq" >:: test_sort; + "test_group" >:: test_group; + "test_uniq" >:: test_uniq; + "test_product" >:: test_product; + "test_join" >:: test_join; + "test_scan" >:: test_scan; + "test_drop" >:: test_drop; + "test_rev" >:: test_rev; + "test_unfoldr" >:: test_unfoldr; + "test_hashtbl" >:: test_hashtbl; + "test_int_range" >:: test_int_range; + ] From d638038089a5d15c4c67846680ce2ba447acbd08 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 8 Aug 2014 20:26:04 +0200 Subject: [PATCH 15/16] CCSequence now shares code with the 'sequence' library; merged the .mli so it reflects versions properly --- core/CCSequence.ml | 692 +------------------------------------------- core/CCSequence.mli | 238 +++++++++++++-- 2 files changed, 215 insertions(+), 715 deletions(-) mode change 100644 => 120000 core/CCSequence.ml diff --git a/core/CCSequence.ml b/core/CCSequence.ml deleted file mode 100644 index b2e15ded..00000000 --- a/core/CCSequence.ml +++ /dev/null @@ -1,691 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Transient iterators, that abstract on a finite sequence of elements.} *) - -(** Sequence abstract iterator type *) -type 'a t = ('a -> unit) -> unit - -type 'a sequence = 'a t - -type (+'a, +'b) t2 = ('a -> 'b -> unit) -> unit - (** Sequence of pairs of values of type ['a] and ['b]. *) - -(** Build a sequence from a iter function *) -let from_iter f = f - -(** Call the function repeatedly until it returns None. This - sequence is transient, use {!persistent} if needed! *) -let from_fun f = - fun k -> - let rec next () = - match f () with - | None -> () - | Some x -> (k x; next ()) - in next () - -let empty = fun k -> () - -let singleton x = fun k -> k x - -(** Infinite sequence of the same element *) -let repeat x = fun k -> while true do k x done - -(** [iterate f x] is the infinite sequence (x, f(x), f(f(x)), ...) *) -let iterate f x = - let rec iterate k x = k x; iterate k (f x) in - from_iter (fun k -> iterate k x) - -(** Sequence that calls the given function to produce elements *) -let forever f = - let rec forever k = k (f ()); forever k in - from_iter forever - -(** Cycle forever through the given sequence. O(n). *) -let cycle s = fun k -> while true do s k; done - -(** Consume the sequence, passing all its arguments to the function *) -let iter f seq = seq f - -(** Iterate on elements and their index in the sequence *) -let iteri f seq = - let r = ref 0 in - let k x = - f !r x; - incr r - in seq k - -(** Fold over elements of the sequence, consuming it *) -let fold f init seq = - let r = ref init in - seq (fun elt -> r := f !r elt); - !r - -(** Fold over elements of the sequence and their index, consuming it *) -let foldi f init seq = - let i = ref 0 in - let r = ref init in - seq (fun elt -> - r := f !r !i elt; - incr i); - !r - -(** Map objects of the sequence into other elements, lazily *) -let map f seq = - let seq_fun' k = seq (fun x -> k (f x)) in - seq_fun' - -(** Map objects, along with their index in the sequence *) -let mapi f seq = - let seq_fun' k = - let i = ref 0 in - seq (fun x -> k (f !i x); incr i) in - seq_fun' - -(** Filter on elements of the sequence *) -let filter p seq = - let seq_fun' k = seq (fun x -> if p x then k x) in - seq_fun' - -(** Append two sequences *) -let append s1 s2 = - let seq_fun k = s1 k; s2 k in - seq_fun - -(** Concatenate a sequence of sequences into one sequence *) -let concat s = - from_iter (fun k -> - (* function that is called on every sub-sequence *) - let k_seq seq = iter k seq in - s k_seq) - -let flatten s = concat s - -(** Monadic bind. It applies the function to every element of the - initial sequence, and calls [concat]. *) -let flatMap f seq = - from_iter - (fun k -> seq (fun x -> (f x) k)) - -let fmap f seq = - from_iter - (fun k -> - seq (fun x -> match f x with - | None -> () - | Some y -> k y)) - -(** Insert the given element between every element of the sequence *) -let intersperse elem seq = - fun k -> - let first = ref true in - seq (fun x -> (if !first then first := false else k elem); k x) - -(** Mutable unrolled list to serve as intermediate storage *) -module MList = struct - type 'a node = - | Nil - | Cons of 'a array * int ref * 'a node ref - - let of_seq seq = - let start = ref Nil in - let chunk_size = ref 8 in - (* fill the list. prev: tail-reference from previous node *) - let prev, cur = ref start, ref Nil in - seq - (fun x -> match !cur with - | Nil -> - let n = !chunk_size in - if n < 4096 then chunk_size := 2 * !chunk_size; - cur := Cons (Array.make n x, ref 1, ref Nil) - | Cons (a,n,next) -> - assert (!n < Array.length a); - a.(!n) <- x; - incr n; - if !n = Array.length a then begin - !prev := !cur; - prev := next; - cur := Nil - end - ); - !prev := !cur; - !start - - let rec iter f l = match l with - | Nil -> () - | Cons (a, n, tl) -> - for i=0 to !n - 1 do f a.(i) done; - iter f !tl - - let iteri f l = - let rec iteri i f l = match l with - | Nil -> () - | Cons (a, n, tl) -> - for j=0 to !n - 1 do f (i+j) a.(j) done; - iteri (i+ !n) f !tl - in iteri 0 f l - - let rec iter_rev f l = match l with - | Nil -> () - | Cons (a, n, tl) -> - iter_rev f !tl; - for i = !n-1 downto 0 do f a.(i) done - - let length l = - let rec len acc l = match l with - | Nil -> acc - | Cons (_, n, tl) -> len (acc+ !n) !tl - in len 0 l - - (** Get element by index *) - let rec get l i = match l with - | Nil -> raise (Invalid_argument "MList.get") - | Cons (a, n, _) when i < !n -> a.(i) - | Cons (_, n, tl) -> get !tl (i- !n) - - let to_seq l k = iter k l - - let _to_next arg l = - let cur = ref l in - let i = ref 0 in (* offset in cons *) - let rec get_next _ = match !cur with - | Nil -> None - | Cons (_, n, tl) when !i = !n -> - cur := !tl; - i := 0; - get_next arg - | Cons (a, n, _) -> - let x = a.(!i) in - incr i; - Some x - in get_next - - let to_gen l = _to_next () l - - let to_stream l = - Stream.from (_to_next 42 l) (* 42=magic cookiiiiiie *) -end - -(** Iterate on the sequence, storing elements in a data structure. - The resulting sequence can be iterated on as many times as needed. *) -let persistent seq = - let l = MList.of_seq seq in - MList.to_seq l - -(** Sort the sequence. Eager, O(n) ram and O(n ln(n)) time. *) -let sort ?(cmp=Pervasives.compare) seq = - (* use an intermediate list, then sort the list *) - let l = fold (fun l x -> x::l) [] seq in - let l = List.fast_sort cmp l in - fun k -> List.iter k l - -(** Group equal consecutive elements. *) -let group ?(eq=fun x y -> x = y) seq = - fun k -> - let cur = ref [] in - seq (fun x -> - match !cur with - | [] -> cur := [x] - | (y::_) as l when eq x y -> - cur := x::l (* [x] belongs to the group *) - | (_::_) as l -> - k l; (* yield group, and start another one *) - cur := [x]); - (* last list *) - if !cur <> [] then k !cur - -(** Remove consecutive duplicate elements. Basically this is - like [fun seq -> map List.hd (group seq)]. *) -let uniq ?(eq=fun x y -> x = y) seq = - fun k -> - let has_prev = ref false - and prev = ref (Obj.magic 0) in (* avoid option type, costly *) - seq (fun x -> - if !has_prev && eq !prev x - then () (* duplicate *) - else begin - has_prev := true; - prev := x; - k x - end) - -(** Sort the sequence and remove duplicates. Eager, same as [sort] *) -let sort_uniq ?(cmp=Pervasives.compare) seq = - let seq' = sort ~cmp seq in - uniq ~eq:(fun x y -> cmp x y = 0) seq' - -(** Cartesian product of the sequences. *) -let product outer inner = - let inner = persistent inner in - from_iter - (fun k -> - outer (fun x -> - inner (fun y -> k (x,y)))) - -(** [join ~join_row a b] combines every element of [a] with every - element of [b] using [join_row]. If [join_row] returns None, then - the two elements do not combine. Assume that [b] allows for multiple - iterations. *) -let join ~join_row s1 s2 = - fun k -> - s1 (fun a -> - s2 (fun b -> - match join_row a b with - | None -> () - | Some c -> k c)) (* yield the combination of [a] and [b] *) - -(** [unfoldr f b] will apply [f] to [b]. If it - yields [Some (x,b')] then [x] is returned - and unfoldr recurses with [b']. *) -let unfoldr f b = - let rec unfold k b = match f b with - | None -> () - | Some (x, b') -> k x; unfold k b' - in - from_iter (fun k -> unfold k b) - -(** Sequence of intermediate results *) -let scan f acc seq = - from_iter - (fun k -> - k acc; - let acc = ref acc in - seq (fun elt -> let acc' = f !acc elt in k acc'; acc := acc')) - -let max ?(lt=fun x y -> x < y) seq = - let ret = ref None in - seq (fun x -> match !ret with - | None -> ret := Some x - | Some y -> if lt y x then ret := Some x); - !ret - -let min ?(lt=fun x y -> x < y) seq = - let ret = ref None in - seq (fun x -> match !ret with - | None -> ret := Some x - | Some y -> if lt x y then ret := Some x); - !ret - -exception ExitSequence - -(** Take at most [n] elements from the sequence *) -let take n seq = - let count = ref 0 in - if n = 0 then empty - else fun k -> - try - seq (fun x -> - incr count; - k x; - if !count = n then raise ExitSequence) - with ExitSequence -> () - -(** Drop the [n] first elements of the sequence *) -let drop n seq = - let count = ref 0 in - fun k -> seq - (fun x -> if !count >= n then k x else incr count) - -(** Reverse the sequence. O(n) memory. *) -let rev seq = - let l = MList.of_seq seq in - from_iter (fun k -> MList.iter_rev k l) - -(** Do all elements satisfy the predicate? *) -let for_all p seq = - try - seq (fun x -> if not (p x) then raise ExitSequence); - true - with ExitSequence -> false - -(** Exists there some element satisfying the predicate? *) -let exists p seq = - try - seq (fun x -> if p x then raise ExitSequence); - false - with ExitSequence -> true - -(** How long is the sequence? *) -let length seq = - let r = ref 0 in - seq (fun _ -> incr r); - !r - -(** Is the sequence empty? *) -let is_empty seq = - try seq (fun _ -> raise ExitSequence); true - with ExitSequence -> false - -(** {2 Transform a sequence} *) - -let empty2 = - fun k -> () - -let is_empty2 seq2 = - try ignore (seq2 (fun _ _ -> raise ExitSequence)); true - with ExitSequence -> false - -let length2 seq2 = - let r = ref 0 in - seq2 (fun _ _ -> incr r); - !r - -let zip seq2 = - fun k -> seq2 (fun x y -> k (x,y)) - -let unzip seq = - fun k -> seq (fun (x,y) -> k x y) - -(** Zip elements of the sequence with their index in the sequence *) -let zip_i seq = - fun k -> - let r = ref 0 in - seq (fun x -> let n = !r in incr r; k n x) - -let fold2 f acc seq2 = - let acc = ref acc in - seq2 (fun x y -> acc := f !acc x y); - !acc - -let iter2 f seq2 = - seq2 f - -let map2 f seq2 = - fun k -> seq2 (fun x y -> k (f x y)) - -(** [map2_2 f g seq2] maps each [x, y] of seq2 into [f x y, g x y] *) -let map2_2 f g seq2 = - fun k -> seq2 (fun x y -> k (f x y) (g x y)) - -(** {2 Basic data structures converters} *) - -let to_list seq = List.rev (fold (fun y x -> x::y) [] seq) - -let to_rev_list seq = fold (fun y x -> x :: y) [] seq - (** Get the list of the reversed sequence (more efficient) *) - -let of_list l = from_iter (fun k -> List.iter k l) - -let to_array seq = - let l = MList.of_seq seq in - let n = MList.length l in - if n = 0 - then [||] - else begin - let a = Array.make n (MList.get l 0) in - MList.iteri (fun i x -> a.(i) <- x) l; - a - end - -let of_array a = - fun k -> - for i = 0 to Array.length a - 1 do - k (Array.unsafe_get a i) - done - -let of_array_i a = - fun k -> - for i = 0 to Array.length a - 1 do - k (i, Array.unsafe_get a i) - done - -let of_array2 a = - fun k -> - for i = 0 to Array.length a - 1 do - k i (Array.unsafe_get a i) - done - -(** [array_slice a i j] Sequence of elements whose indexes range - from [i] to [j] *) -let array_slice a i j = - assert (i >= 0 && j < Array.length a); - fun k -> - for idx = i to j do - k a.(idx); (* iterate on sub-array *) - done - -(** Sequence of elements of a stream (usable only once) *) -let of_stream s = - let seq k = Stream.iter k s in - from_iter seq - -(** Convert to a stream. The sequence is made persistent. *) -let to_stream seq = - let l = MList.of_seq seq in - MList.to_stream l - -(** Push elements of the sequence on the stack *) -let to_stack s seq = iter (fun x -> Stack.push x s) seq - -(** Sequence of elements of the stack (same order as [Stack.iter]) *) -let of_stack s = from_iter (fun k -> Stack.iter k s) - -(** Push elements of the sequence into the queue *) -let to_queue q seq = iter (fun x -> Queue.push x q) seq - -(** Sequence of elements contained in the queue, FIFO order *) -let of_queue q = from_iter (fun k -> Queue.iter k q) - -let hashtbl_add h seq = - iter (fun (k,v) -> Hashtbl.add h k v) seq - -let hashtbl_replace h seq = - iter (fun (k,v) -> Hashtbl.replace h k v) seq - -let to_hashtbl seq = - let h = Hashtbl.create 3 in - hashtbl_replace h seq; - h - -let to_hashtbl2 seq2 = - let h = Hashtbl.create 3 in - seq2 (fun k v -> Hashtbl.replace h k v); - h - -let of_hashtbl h = - from_iter (fun k -> Hashtbl.iter (fun a b -> k (a, b)) h) - -let of_hashtbl2 h = - fun k -> Hashtbl.iter k h - -let hashtbl_keys h = - from_iter (fun k -> Hashtbl.iter (fun a b -> k a) h) - -let hashtbl_values h = - from_iter (fun k -> Hashtbl.iter (fun a b -> k b) h) - -let of_str s = from_iter (fun k -> String.iter k s) - -let to_str seq = - let b = Buffer.create 64 in - iter (fun c -> Buffer.add_char b c) seq; - Buffer.contents b - -let of_in_channel ic = - from_iter (fun k -> - try while true do - let c = input_char ic in k c - done with End_of_file -> ()) - -(** Copy content of the sequence into the buffer *) -let to_buffer seq buf = - iter (fun c -> Buffer.add_char buf c) seq - -(** Iterator on integers in [start...stop] by steps 1 *) -let int_range ~start ~stop = - fun k -> - for i = start to stop do k i done - -let int_range_dec ~start ~stop = - fun k -> - for i = start downto stop do k i done - -(** Convert the given set to a sequence. The set module must be provided. *) -let of_set (type s) (type v) m set = - let module S = (val m : Set.S with type t = s and type elt = v) in - from_iter - (fun k -> S.iter k set) - -(** Convert the sequence to a set, given the proper set module *) -let to_set (type s) (type v) m seq = - let module S = (val m : Set.S with type t = s and type elt = v) in - fold - (fun set x -> S.add x set) - S.empty seq - -type 'a gen = unit -> 'a option - -let of_gen g = - (* consume the generator to build a MList *) - let rec iter1 k = match g () with - | None -> () - | Some x -> k x; iter1 k - in - let l = MList.of_seq iter1 in - MList.to_seq l - -let to_gen seq = - let l = MList.of_seq seq in - MList.to_gen l - -(** {2 Functorial conversions between sets and sequences} *) - -module Set = struct - module type S = sig - include Set.S - val of_seq : elt sequence -> t - val to_seq : t -> elt sequence - end - - (** Create an enriched Set module from the given one *) - module Adapt(X : Set.S) = struct - let to_seq set = from_iter (fun k -> X.iter k set) - - let of_seq seq = fold (fun set x -> X.add x set) X.empty seq - - include X - end - - (** Functor to build an extended Set module from an ordered type *) - module Make(X : Set.OrderedType) = struct - module MySet = Set.Make(X) - include Adapt(MySet) - end -end - -(** {2 Conversion between maps and sequences.} *) - -module Map = struct - module type S = sig - include Map.S - val to_seq : 'a t -> (key * 'a) sequence - val of_seq : (key * 'a) sequence -> 'a t - val keys : 'a t -> key sequence - val values : 'a t -> 'a sequence - end - - (** Adapt a pre-existing Map module to make it sequence-aware *) - module Adapt(M : Map.S) = struct - let to_seq m = from_iter (fun k -> M.iter (fun x y -> k (x,y)) m) - - let of_seq seq = fold (fun m (k,v) -> M.add k v m) M.empty seq - - let keys m = from_iter (fun k -> M.iter (fun x _ -> k x) m) - - let values m = from_iter (fun k -> M.iter (fun _ y -> k y) m) - - include M - end - - (** Create an enriched Map module, with sequence-aware functions *) - module Make(V : Map.OrderedType) : S with type key = V.t = struct - module M = Map.Make(V) - include Adapt(M) - end -end - -(** {2 Infinite sequences of random values} *) - -let random_int bound = forever (fun () -> Random.int bound) - -let random_bool = forever Random.bool - -let random_float bound = forever (fun () -> Random.float bound) - -(** Sequence of choices of an element in the array *) -let random_array a = - assert (Array.length a > 0); - let seq k = - while true do - let i = Random.int (Array.length a) in - k a.(i); - done in - from_iter seq - -let random_list l = random_array (Array.of_list l) - -(** {2 Infix functions} *) - -module Infix = struct - let (--) i j = int_range ~start:i ~stop:j - - let (--^) i j = int_range_dec ~start:i ~stop:j -end - -include Infix - -(** {2 Pretty printing of sequences} *) - -(** Pretty print a sequence of ['a], using the given pretty printer - to print each elements. An optional separator string can be provided. *) -let print ?(start="") ?(stop="") ?(sep=", ") pp_elt formatter seq = - let first = ref true in - Format.pp_print_string formatter start; - iter - (fun x -> - (if !first then first := false - else begin - Format.pp_print_string formatter sep; - Format.pp_print_cut formatter (); - end); - pp_elt formatter x) - seq; - Format.pp_print_string formatter stop; - () - -let pp ?(start="") ?(stop="") ?(sep=", ") pp_elt buf seq = - let first = ref true in - Buffer.add_string buf start; - iter - (fun x -> - if !first then first := false else Buffer.add_string buf sep; - pp_elt buf x) - seq; - Buffer.add_string buf stop; - () - -let to_string ?start ?stop ?sep pp_elt seq = - let buf = Buffer.create 25 in - pp ?start ?stop ?sep pp_elt buf seq; - Buffer.contents buf diff --git a/core/CCSequence.ml b/core/CCSequence.ml new file mode 120000 index 00000000..397a44e3 --- /dev/null +++ b/core/CCSequence.ml @@ -0,0 +1 @@ +../sequence/sequence.ml \ No newline at end of file diff --git a/core/CCSequence.mli b/core/CCSequence.mli index b6e1a4a4..3b2056d3 100644 --- a/core/CCSequence.mli +++ b/core/CCSequence.mli @@ -23,16 +23,16 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(** {1 Transient iterators, that abstract on a finite sequence of elements.} *) +(** {1 Simple and Efficient Iterators} *) (** The iterators are designed to allow easy transfer (mappings) between data - structures, without defining n^2 conversions between the n types. The + structures, without defining [n^2] conversions between the [n] types. The implementation relies on the assumption that a sequence can be iterated on as many times as needed; this choice allows for high performance of many combinators. However, for transient iterators, the {!persistent} function is provided, storing elements of a transient iterator in memory; the iterator can then be used several times (See further). - + Note that some combinators also return sequences (e.g. {!group}). The transformation is computed on the fly every time one iterates over the resulting sequence. If a transformation performs heavy computation, @@ -42,7 +42,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. until their result is iterated on. For instance, if one calls {!map} on a sequence, one gets a new sequence, but nothing else happens until this new sequence is used (by folding or iterating on it). - + If a sequence is built from an iteration function that is {b repeatable} (i.e. calling it several times always iterates on the same set of elements, for instance List.iter or Map.iter), then @@ -53,8 +53,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. of this memory structure, cheaply and repeatably. *) type +'a t = ('a -> unit) -> unit - (** Sequence iterator type, representing a finite sequence of values - of type ['a] that one can iterate on. *) + (** A sequence of values of type ['a]. If you give it a function ['a -> unit] + it will be applied to every element of the sequence successively. *) type +'a sequence = 'a t @@ -76,12 +76,34 @@ val empty : 'a t val singleton : 'a -> 'a t (** Singleton sequence, with exactly one element. *) +val doubleton : 'a -> 'a -> 'a t + (** Sequence with exactly two elements + @since NEXT_RELEASE *) + +val cons : 'a -> 'a t -> 'a t + (** [cons x l] yields [x], then yields from [l]. + Same as [append (singleton x) l] + @since NEXT_RELEASE *) + + +val snoc : 'a t -> 'a -> 'a t + (** Same as {!cons} but yields the element after iterating on [l] + @since NEXT_RELEASE *) + +val return : 'a -> 'a t + (** Synonym to {!singleton} + @since NEXT_RELEASE *) + +val pure : 'a -> 'a t + (** Synonym to {!singleton} + @since NEXT_RELEASE *) + val repeat : 'a -> 'a t (** Infinite sequence of the same element. You may want to look - at {!take} if you iterate on it. *) + at {!take} and the likes if you iterate on it. *) val iterate : ('a -> 'a) -> 'a -> 'a t - (** [iterate f x] is the infinite sequence (x, f(x), f(f(x)), ...) *) + (** [iterate f x] is the infinite sequence [x, f(x), f(f(x)), ...] *) val forever : (unit -> 'b) -> 'b t (** Sequence that calls the given function to produce elements. @@ -97,7 +119,8 @@ val cycle : 'a t -> 'a t (** {2 Consume a sequence} *) val iter : ('a -> unit) -> 'a t -> unit - (** Consume the sequence, passing all its arguments to the function *) + (** Consume the sequence, passing all its arguments to the function. + Basically [iter f seq] is just [seq f]. *) val iteri : (int -> 'a -> unit) -> 'a t -> unit (** Iterate on elements and their index in the sequence *) @@ -120,6 +143,15 @@ val for_all : ('a -> bool) -> 'a t -> bool val exists : ('a -> bool) -> 'a t -> bool (** Exists there some element satisfying the predicate? *) +val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool + (** Is the value a member of the sequence? + @param eq the equality predicate to use (default [(=)]) + @since NEXT_RELEASE *) + +val find : ('a -> 'b option) -> 'a t -> 'b option + (** Find the first element on which the function doesn't return [None] + @since NEXT_RELEASE *) + val length : 'a t -> int (** How long is the sequence? Forces the sequence. *) @@ -145,18 +177,43 @@ val flatMap : ('a -> 'b t) -> 'a t -> 'b t (** Monadic bind. Intuitively, it applies the function to every element of the initial sequence, and calls {!concat}. *) +val flat_map : ('a -> 'b t) -> 'a t -> 'b t + (** Alias to {!flatMap} with a more explicit name + @since NEXT_RELEASE *) + val fmap : ('a -> 'b option) -> 'a t -> 'b t (** Specialized version of {!flatMap} for options. *) +val filter_map : ('a -> 'b option) -> 'a t -> 'b t + (** Alias to {!fmap} with a more explicit name + @since NEXT_RELEASE *) + val intersperse : 'a -> 'a t -> 'a t (** Insert the single element between every element of the sequence *) +(** {2 Caching} *) + val persistent : 'a t -> 'a t - (** Iterate on the sequence, storing elements in a data structure. + (** Iterate on the sequence, storing elements in an efficient internal structure.. The resulting sequence can be iterated on as many times as needed. {b Note}: calling persistent on an already persistent sequence will still make a new copy of the sequence! *) +val persistent_lazy : 'a t -> 'a t + (** Lazy version of {!persistent}. When calling [persistent_lazy s], + a new sequence [s'] is immediately returned (without actually consuming + [s]) in constant time; the first time [s'] is iterated on, + it also consumes [s] and caches its content into a inner data + structure that will back [s'] for future iterations. + + {b warning}: on the first traversal of [s'], if the traversal + is interrupted prematurely ({!take}, etc.) then [s'] will not be + memorized, and the next call to [s'] will traverse [s] again. + + @since NEXT_RELEASE *) + +(** {2 Misc} *) + val sort : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t (** Sort the sequence. Eager, O(n) ram and O(n ln(n)) time. It iterates on elements of the argument sequence immediately, @@ -173,9 +230,14 @@ val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t like [fun seq -> map List.hd (group seq)]. *) val product : 'a t -> 'b t -> ('a * 'b) t - (** Cartesian product of the sequences. The first one is transformed - by calling [persistent] on it, so that it can be traversed - several times (outer loop of the product) *) + (** Cartesian product of the sequences. When calling [product a b], + the caller {b MUST} ensure that [b] can be traversed as many times + as required (several times), possibly by calling {!persistent} on it + beforehand. *) + +val product2 : 'a t -> 'b t -> ('a, 'b) t2 + (** Binary version of {!product}. Same requirements. + @since NEXT_RELEASE *) val join : join_row:('a -> 'b -> 'c option) -> 'a t -> 'b t -> 'c t (** [join ~join_row a b] combines every element of [a] with every @@ -183,7 +245,7 @@ val join : join_row:('a -> 'b -> 'c option) -> 'a t -> 'b t -> 'c t the two elements do not combine. Assume that [b] allows for multiple iterations. *) -val unfoldr : ('b -> ('a * 'b) option) -> 'b -> 'a t +val unfoldr : ('b -> ('a * 'b) option) -> 'b -> 'a t (** [unfoldr f b] will apply [f] to [b]. If it yields [Some (x,b')] then [x] is returned and unfoldr recurses with [b']. *) @@ -200,13 +262,32 @@ val min : ?lt:('a -> 'a -> bool) -> 'a t -> 'a option (** Min element of the sequence, using the given comparison function. see {!max} for more details. *) +val head : 'a t -> 'a option + (** First element, if any, otherwise [None] + @since NEXT_RELEASE *) + +val head_exn : 'a t -> 'a + (** First element, if any, fails + @raise Invalid_argument if the sequence is empty + @since NEXT_RELEASE *) + val take : int -> 'a t -> 'a t (** Take at most [n] elements from the sequence. Works on infinite sequences. *) +val take_while : ('a -> bool) -> 'a t -> 'a t + (** Take elements while they satisfy the predicate, then stops iterating. + Will work on an infinite sequence [s] if the predicate is false for at + least one element of [s]. + @since NEXT_RELEASE *) + val drop : int -> 'a t -> 'a t (** Drop the [n] first elements of the sequence. Lazy. *) +val drop_while : ('a -> bool) -> 'a t -> 'a t + (** Predicate version of {!drop} + @since NEXT_RELEASE *) + val rev : 'a t -> 'a t (** Reverse the sequence. O(n) memory and time, needs the sequence to be finite. The result is persistent and does @@ -239,15 +320,22 @@ val map2_2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'd) -> ('a, 'b) t2 -> ('c, 'd) t2 (** {2 Basic data structures converters} *) val to_list : 'a t -> 'a list + (** Convert the sequence into a list. Preserves order of elements. + This function is tail-recursive, but consumes 2*n memory. + If order doesn't matter to you, consider {!to_rev_list}. *) val to_rev_list : 'a t -> 'a list (** Get the list of the reversed sequence (more efficient than {!to_list}) *) val of_list : 'a list -> 'a t +val to_opt : 'a t -> 'a option + (** Alias to {!head} + @since NEXT_RELEASE *) + val to_array : 'a t -> 'a array (** Convert to an array. Currently not very efficient because - and intermediate list is used. *) + an intermediate list is used. *) val of_array : 'a array -> 'a t @@ -260,6 +348,10 @@ val array_slice : 'a array -> int -> int -> 'a t (** [array_slice a i j] Sequence of elements whose indexes range from [i] to [j] *) +val of_opt : 'a option -> 'a t + (** Iterate on 0 or 1 values. + @since NEXT_RELEASE *) + val of_stream : 'a Stream.t -> 'a t (** Sequence of elements of a stream (usable only once) *) @@ -304,10 +396,20 @@ val hashtbl_values : ('a, 'b) Hashtbl.t -> 'b t val of_str : string -> char t val to_str : char t -> string +val concat_str : string t -> string + (** Concatenate strings together, eagerly. + Also see {!intersperse} to add a separator. + @since NEXT_RELEASE *) + +exception OneShotSequence + (** Raised when the user tries to iterate several times on + a transient iterator *) + val of_in_channel : in_channel -> char t (** Iterates on characters of the input (can block when one iterates over the sequence). If you need to iterate - several times on this sequence, use {!persistent}. *) + several times on this sequence, use {!persistent}. + @raise OneShotSequence when used more than once. *) val to_buffer : char t -> Buffer.t -> unit (** Copy content of the sequence into the buffer *) @@ -327,6 +429,7 @@ val to_set : (module Set.S with type elt = 'a and type t = 'b) -> 'a t -> 'b (** Convert the sequence to a set, given the proper set module *) type 'a gen = unit -> 'a option +type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] val of_gen : 'a gen -> 'a t (** Traverse eagerly the generator and build a sequence from it *) @@ -334,6 +437,12 @@ val of_gen : 'a gen -> 'a t val to_gen : 'a t -> 'a gen (** Make the sequence persistent (O(n)) and then iterate on it. Eager. *) +val of_klist : 'a klist -> 'a t + (** Iterate on the lazy list *) + +val to_klist : 'a t -> 'a klist + (** Make the sequence persistent and then iterate on it. Eager. *) + (** {2 Functorial conversions between sets and sequences} *) module Set : sig @@ -341,11 +450,17 @@ module Set : sig include Set.S val of_seq : elt sequence -> t val to_seq : t -> elt sequence + + val to_list : t -> elt list + (** @since NEXT_RELEASE *) + + val of_list : elt list -> t + (** @since NEXT_RELEASE *) end (** Create an enriched Set module from the given one *) module Adapt(X : Set.S) : S with type elt = X.elt and type t = X.t - + (** Functor to build an extended Set module from an ordered type *) module Make(X : Set.OrderedType) : S with type elt = X.t end @@ -359,6 +474,12 @@ module Map : sig val of_seq : (key * 'a) sequence -> 'a t val keys : 'a t -> key sequence val values : 'a t -> 'a sequence + + val to_list : 'a t -> (key * 'a) list + (** @since NEXT_RELEASE *) + + val of_list : (key * 'a) list -> 'a t + (** @since NEXT_RELEASE *) end (** Adapt a pre-existing Map module to make it sequence-aware *) @@ -390,26 +511,95 @@ val random_list : 'a list -> 'a t module Infix : sig val (--) : int -> int -> int t + (** [a -- b] is the range of integers from [a] to [b], both included, + in increasing order. It will therefore be empty if [a > b]. *) val (--^) : int -> int -> int t (** [a --^ b] is the range of integers from [b] to [a], both included, in decreasing order (starts from [a]). It will therefore be empty if [a < b]. *) + + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + (** Monadic bind (infix version of {!flat_map} + @since NEXT_RELEASE *) + + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + (** Infix version of {!map} + @since NEXT_RELEASE *) + + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + (** Applicative operator (product+application) + @since NEXT_RELEASE *) + + val (<+>) : 'a t -> 'a t -> 'a t + (** Concatenation of sequences + @since NEXT_RELEASE *) end include module type of Infix + (** {2 Pretty printing of sequences} *) -val print : ?start:string -> ?stop:string -> ?sep:string -> - (Format.formatter -> 'a -> unit) -> +val pp_seq : ?sep:string -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit (** Pretty print a sequence of ['a], using the given pretty printer to print each elements. An optional separator string can be provided. *) -val pp : ?start:string -> ?stop:string -> ?sep:string -> - (Buffer.t -> 'a -> unit) -> - Buffer.t -> 'a t -> unit +val pp_buf : ?sep:string -> (Buffer.t -> 'a -> unit) -> + Buffer.t -> 'a t -> unit + (** Print into a buffer *) -val to_string : ?start:string -> ?stop:string -> ?sep:string -> - (Buffer.t -> 'a -> unit) -> 'a t -> string +val to_string : ?sep:string -> ('a -> string) -> 'a t -> string + (** Print into a string *) + +(** {2 Basic IO} + +Very basic interface to manipulate files as sequence of chunks/lines. The +sequences take care of opening and closing files properly; every time +one iterates over a sequence, the file is opened/closed again. + +Example: copy a file ["a"] into file ["b"], removing blank lines: + +{[ + Sequence.(IO.lines_of "a" |> filter (fun l-> l<> "") |> IO.write_lines "b");; +]} + +By chunks of [4096] bytes: + +{[ + Sequence.IO.(chunks_of ~size:4096 "a" |> write_to "b");; +]} + +@since NEXT_RELEASE *) + +module IO : sig + val lines_of : ?mode:int -> ?flags:open_flag list -> + string -> string t + (** [lines_of filename] reads all lines of the given file. It raises the + same exception as would opening the file and read from it, except + from [End_of_file] (which is caught). The file is {b always} properly + closed. + Every time the sequence is iterated on, the file is opened again, so + different iterations might return different results + @param mode default [0o644] + @param flags default: [[Open_rdonly]] *) + + val chunks_of : ?mode:int -> ?flags:open_flag list -> ?size:int -> + string -> string t + (** Read chunks of the given [size] from the file. The last chunk might be + smaller. Behaves like {!lines_of} regarding errors and options. + Every time the sequence is iterated on, the file is opened again, so + different iterations might return different results *) + + val write_to : ?mode:int -> ?flags:open_flag list -> + string -> string t -> unit + (** [write_to filename seq] writes all strings from [seq] into the given + file. It takes care of opening and closing the file. + @param mode default [0o644] + @param flags used by [open_out_gen]. Default: [[Open_creat;Open_wronly]]. *) + + val write_lines : ?mode:int -> ?flags:open_flag list -> + string -> string t -> unit + (** Same as {!write_to}, but intercales ['\n'] between each string *) +end From 15665761b2d85469c1f0591cb976ba6956100cc5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 8 Aug 2014 23:54:39 +0200 Subject: [PATCH 16/16] Squashed 'sequence/' changes from e5625c6..0d721a6 0d721a6 release 0.5.2 a50f307 merge from master 81d7315 bugfix: take would fail on 0 4ae9e77 Merge pull request #5 from Drup/master ae390d3 Add on_list. git-subtree-dir: sequence git-subtree-split: 0d721a63515949fe564552c98895780d86fc2a98 --- CHANGELOG.md | 5 +++++ META | 6 +++--- _oasis | 2 +- sequence.ml | 11 ++++++----- sequence.mli | 5 +++++ setup.ml | 9 +++++---- tests/test_sequence.ml | 8 ++++++++ 7 files changed, 33 insertions(+), 13 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1e311bb9..09b514c1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog +## 0.5.2 + +- bugfix in `take` +- `on_list` for mapping lists through sequences + ## 0.5.1 - `Sequence.IO` module, a very very simple way to read/write files diff --git a/META b/META index 5fc1bff7..ffd12c91 100644 --- a/META +++ b/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 3b9ebef180f5e4bdb720d2103ba95667) -version = "0.5.1" +# DO NOT EDIT (digest: f4f3ee8dc8cda763af26a927b88956e6) +version = "0.5.2" description = "Simple sequence (iterator) datatype and combinators" archive(byte) = "sequence.cma" archive(byte, plugin) = "sequence.cma" @@ -8,7 +8,7 @@ archive(native) = "sequence.cmxa" archive(native, plugin) = "sequence.cmxs" exists_if = "sequence.cma" package "invert" ( - version = "0.5.1" + version = "0.5.2" description = "Simple sequence (iterator) datatype and combinators" requires = "sequence delimcc" archive(byte) = "invert.cma" diff --git a/_oasis b/_oasis index d1452f2e..7c5a8e43 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: sequence -Version: 0.5.1 +Version: 0.5.2 Homepage: https://github.com/c-cube/sequence Authors: Simon Cruanes License: BSD-2-clause diff --git a/sequence.ml b/sequence.ml index 9e5fb844..54ed7e85 100644 --- a/sequence.ml +++ b/sequence.ml @@ -336,9 +336,9 @@ let take n seq k = let count = ref 0 in try seq (fun x -> + if !count = n then raise ExitSequence; incr count; k x; - if !count = n then raise ExitSequence ) with ExitSequence -> () @@ -436,14 +436,17 @@ let to_list seq = List.rev (fold (fun y x -> x::y) [] seq) let to_rev_list seq = fold (fun y x -> x :: y) [] seq +let of_list l k = List.iter k l + +let on_list f l = + to_list (f (of_list l)) + let to_opt = head let of_opt o k = match o with | None -> () | Some x -> k x -let of_list l k = List.iter k l - let to_array seq = let l = MList.of_seq seq in let n = MList.length l in @@ -767,5 +770,3 @@ module IO = struct let write_lines ?mode ?flags filename seq = write_to ?mode ?flags filename (snoc (intersperse "\n" seq) "\n") end - - diff --git a/sequence.mli b/sequence.mli index 04a63102..449b3f77 100644 --- a/sequence.mli +++ b/sequence.mli @@ -319,6 +319,11 @@ val to_rev_list : 'a t -> 'a list val of_list : 'a list -> 'a t +val on_list : ('a t -> 'b t) -> 'a list -> 'b list +(** [on_list f l] is equivalent to [to_list @@ f @@ of_list l]. + @since 0.5.2 +*) + val to_opt : 'a t -> 'a option (** Alias to {!head} @since 0.5.1 *) diff --git a/setup.ml b/setup.ml index e293257d..72507e21 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: d7a207daf3186cce7792651a50aaba59) *) +(* DO NOT EDIT (digest: 3e1599f233d66e02cd17bbb3a1c71d9e) *) (* Regenerated by OASIS v0.4.4 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6826,7 +6826,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "sequence"; - version = "0.5.1"; + version = "0.5.2"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -7192,7 +7192,8 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.4"; - oasis_digest = Some "8\252\157\1340^<0\133GR\029nmc6"; + oasis_digest = + Some "\142\243\242-\024\139\245\030\1867\186\147D\175\251\192"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7200,6 +7201,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7204 "setup.ml" +# 7205 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/tests/test_sequence.ml b/tests/test_sequence.ml index bfd7dac4..1b6c8623 100644 --- a/tests/test_sequence.ml +++ b/tests/test_sequence.ml @@ -190,6 +190,13 @@ let test_int_range () = OUnit.assert_equal ~printer:pp_ilist [] S.(to_list (10 --^ 60)); () +let test_take () = + let l = S.(to_list (take 0 (of_list [1]))) in + OUnit.assert_equal ~printer:pp_ilist [] l; + let l = S.(to_list (take 5 (of_list [1;2;3;4;5;6;7;8;9;10]))) in + OUnit.assert_equal ~printer:pp_ilist [1;2;3;4;5] l; + () + let suite = "test_sequence" >::: [ "test_empty" >:: test_empty; @@ -217,4 +224,5 @@ let suite = "test_unfoldr" >:: test_unfoldr; "test_hashtbl" >:: test_hashtbl; "test_int_range" >:: test_int_range; + "test_take" >:: test_take; ]