From 6313fb26c13110f328efe8d064e8cb2b97fdaa2b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 13 Dec 2014 01:45:53 +0100 Subject: [PATCH] breaking: remove CCSequence and CCGen, since they have their own repositories --- _oasis | 5 +- core/CCGen.ml | 1 - core/CCGen.mli | 105 - core/CCSequence.ml | 1 - core/CCSequence.mli | 624 -- core/Gen_intf.ml | 1 - gen/.gitignore | 11 - gen/.merlin | 5 - gen/META | 11 - gen/Makefile | 59 - gen/README.md | 32 - gen/_oasis | 65 - gen/_tags | 43 - gen/bench/.merlin | 4 - gen/bench/bench_persistent.ml | 161 - gen/configure | 27 - gen/gen.ml | 1669 ------ gen/gen.mldylib | 5 - gen/gen.mli | 102 - gen/gen.mllib | 5 - gen/gen.odocl | 5 - gen/gen_intf.ml | 321 - gen/myocamlbuild.ml | 623 -- gen/setup.ml | 7150 ----------------------- gen/tests/run_tests.ml | 4 - gen/tests/test_gen.ml | 146 - sequence/.gitignore | 9 - sequence/.merlin | 9 - sequence/.ocamlinit | 9 - sequence/CHANGELOG.md | 65 - sequence/LICENSE | 22 - sequence/META | 11 - sequence/Makefile | 67 - sequence/README.md | 50 - sequence/_oasis | 102 - sequence/_tags | 31 - sequence/bench/bench_persistent.ml | 128 - sequence/bench/bench_persistent_read.ml | 139 - sequence/bench/benchs.ml | 34 - sequence/bench/simple_bench.ml | 11 - sequence/bigarray/sequenceBigarray.ml | 45 - sequence/bigarray/sequenceBigarray.mli | 34 - sequence/configure | 27 - sequence/examples/sexpr.ml | 305 - sequence/examples/sexpr.mli | 132 - sequence/examples/test_sexpr.ml | 131 - sequence/invert/.merlin | 2 - sequence/invert/sequenceInvert.ml | 62 - sequence/invert/sequenceInvert.mli | 32 - sequence/myocamlbuild.ml | 609 -- sequence/sequence.ml | 787 --- sequence/sequence.mldylib | 4 - sequence/sequence.mli | 606 -- sequence/sequence.mllib | 4 - sequence/sequence.odocl | 4 - sequence/setup.ml | 37 - sequence/tests/run_tests.ml | 9 - sequence/tests/test_sequence.ml | 235 - 58 files changed, 2 insertions(+), 14935 deletions(-) delete mode 120000 core/CCGen.ml delete mode 100644 core/CCGen.mli delete mode 120000 core/CCSequence.ml delete mode 100644 core/CCSequence.mli delete mode 120000 core/Gen_intf.ml delete mode 100644 gen/.gitignore delete mode 100644 gen/.merlin delete mode 100644 gen/META delete mode 100644 gen/Makefile delete mode 100644 gen/README.md delete mode 100644 gen/_oasis delete mode 100644 gen/_tags delete mode 100644 gen/bench/.merlin delete mode 100644 gen/bench/bench_persistent.ml delete mode 100755 gen/configure delete mode 100644 gen/gen.ml delete mode 100644 gen/gen.mldylib delete mode 100644 gen/gen.mli delete mode 100644 gen/gen.mllib delete mode 100644 gen/gen.odocl delete mode 100644 gen/gen_intf.ml delete mode 100644 gen/myocamlbuild.ml delete mode 100644 gen/setup.ml delete mode 100644 gen/tests/run_tests.ml delete mode 100644 gen/tests/test_gen.ml delete mode 100644 sequence/.gitignore delete mode 100644 sequence/.merlin delete mode 100644 sequence/.ocamlinit delete mode 100644 sequence/CHANGELOG.md delete mode 100644 sequence/LICENSE delete mode 100644 sequence/META delete mode 100644 sequence/Makefile delete mode 100644 sequence/README.md delete mode 100644 sequence/_oasis delete mode 100644 sequence/_tags delete mode 100644 sequence/bench/bench_persistent.ml delete mode 100644 sequence/bench/bench_persistent_read.ml delete mode 100644 sequence/bench/benchs.ml delete mode 100644 sequence/bench/simple_bench.ml delete mode 100644 sequence/bigarray/sequenceBigarray.ml delete mode 100644 sequence/bigarray/sequenceBigarray.mli delete mode 100755 sequence/configure delete mode 100644 sequence/examples/sexpr.ml delete mode 100644 sequence/examples/sexpr.mli delete mode 100644 sequence/examples/test_sexpr.ml delete mode 100644 sequence/invert/.merlin delete mode 100644 sequence/invert/sequenceInvert.ml delete mode 100644 sequence/invert/sequenceInvert.mli delete mode 100644 sequence/myocamlbuild.ml delete mode 100644 sequence/sequence.ml delete mode 100644 sequence/sequence.mldylib delete mode 100644 sequence/sequence.mli delete mode 100644 sequence/sequence.mllib delete mode 100644 sequence/sequence.odocl delete mode 100644 sequence/setup.ml delete mode 100644 sequence/tests/run_tests.ml delete mode 100644 sequence/tests/test_sequence.ml diff --git a/_oasis b/_oasis index 4230ce40..6386f2b3 100644 --- a/_oasis +++ b/_oasis @@ -69,8 +69,7 @@ Library "containers_data" Library "containers_iter" Path: core - Modules: CCKTree, CCGen, CCSequence, CCKList - InternalModules: Gen_intf + Modules: CCKTree, CCKList FindlibParent: containers FindlibName: iter @@ -92,7 +91,7 @@ Library "containers_advanced" Library "containers_pervasives" Path: pervasives Modules: CCPervasives - BuildDepends: containers + BuildDepends: containers, FindlibName: pervasives FindlibParent: containers diff --git a/core/CCGen.ml b/core/CCGen.ml deleted file mode 120000 index 8eb5e88d..00000000 --- a/core/CCGen.ml +++ /dev/null @@ -1 +0,0 @@ -../gen/gen.ml \ No newline at end of file diff --git a/core/CCGen.mli b/core/CCGen.mli deleted file mode 100644 index 0d284c22..00000000 --- a/core/CCGen.mli +++ /dev/null @@ -1,105 +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 Generators} - -Values of type ['a Gen.t] represent a possibly infinite sequence of values -of type 'a. One can only iterate once on the sequence, as it is consumed -by iteration/deconstruction/access. [None] is returned when the generator -is exhausted. Most functions consume elements. - -The submodule {!Restart} provides utilities to work with -{b restartable generators}, that is, functions [unit -> 'a Gen.t] that -allow to build as many generators from the same source as needed. -*) - -(** {2 Global type declarations} *) - -type 'a t = unit -> 'a option - (** A generator may be called several times, yielding the next value - each time. It returns [None] when no elements remain *) - -type 'a gen = 'a t - -(** {b NOTE}: version informations ("@since" annotations) in CCGen_intf - will not be reliable, for they will represent versions of Gen - rather than containers. *) -module type S = Gen_intf.S - -(** {2 Transient generators} *) - -val get : 'a t -> 'a option - (** Get the next value *) - -val next : 'a t -> 'a option - (** Synonym for {!get} *) - -val get_exn : 'a t -> 'a - (** Get the next value, or fails - @raise Invalid_argument if no element remains *) - -val junk : 'a t -> unit - (** Drop the next value, discarding it. *) - -val repeatedly : (unit -> 'a) -> 'a t - (** Call the same function an infinite number of times (useful for instance - if the function is a random generator). *) - -include S with type 'a t := 'a gen - (** Operations on {b transient} generators *) - -(** {2 Restartable generators} *) - -module Restart : sig - type 'a t = unit -> 'a gen - - type 'a restartable = 'a t - - include S with type 'a t := 'a restartable - - val cycle : 'a t -> 'a t - (** Cycle through the enum, endlessly. The enum must not be empty. *) - - val lift : ('a gen -> 'b) -> 'a t -> 'b - - val lift2 : ('a gen -> 'b gen -> 'c) -> 'a t -> 'b t -> 'c -end - -(** {2 Utils} *) - -val persistent : 'a t -> 'a Restart.t - (** Store content of the transient generator in memory, to be able to iterate - on it several times later. If possible, consider using combinators - from {!Restart} directly instead. *) - -val persistent_lazy : 'a t -> 'a Restart.t - (** Same as {!persistent}, but consumes the generator on demand (by chunks). - This allows to make a restartable generator out of an ephemeral one, - without paying a big cost upfront (nor even consuming it fully). - @since 0.6.1 *) - -val start : 'a Restart.t -> 'a t - (** Create a new transient generator. - [start gen] is the same as [gen ()] but is included for readability. *) diff --git a/core/CCSequence.ml b/core/CCSequence.ml deleted file mode 120000 index 397a44e3..00000000 --- a/core/CCSequence.ml +++ /dev/null @@ -1 +0,0 @@ -../sequence/sequence.ml \ No newline at end of file diff --git a/core/CCSequence.mli b/core/CCSequence.mli deleted file mode 100644 index 476af4db..00000000 --- a/core/CCSequence.mli +++ /dev/null @@ -1,624 +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 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 - @since 0.3.4 *) - -val cons : 'a -> 'a t -> 'a t - (** [cons x l] yields [x], then yields from [l]. - Same as [append (singleton x) l] - @since 0.3.4 *) - - -val snoc : 'a t -> 'a -> 'a t - (** Same as {!cons} but yields the element after iterating on [l] - @since 0.3.4 *) - -val return : 'a -> 'a t - (** Synonym to {!singleton} - @since 0.3.4 *) - -val pure : 'a -> 'a t - (** Synonym to {!singleton} - @since 0.3.4 *) - -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.3.4 *) - -val find : ('a -> 'b option) -> 'a t -> 'b option - (** Find the first element on which the function doesn't return [None] - @since 0.3.4 *) - -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.3.4 *) - -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.3.4 *) - -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. - - @since 0.3.4 *) - -(** {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.3.4 *) - -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.3.4 *) - -val head_exn : 'a t -> 'a - (** First element, if any, fails - @raise Invalid_argument if the sequence is empty - @since 0.3.4 *) - -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 0.3.4 *) - -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 0.3.4 *) - -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 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.3.4 -*) - -val to_opt : 'a t -> 'a option - (** Alias to {!head} - @since 0.3.4 *) - -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.3.4 *) - -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.3.4 *) - -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 - (** @since 0.3.4 *) - - val of_list : elt list -> t - (** @since 0.3.4 *) - 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 - (** @since 0.3.4 *) - - val of_list : (key * 'a) list -> 'a t - (** @since 0.3.4 *) - 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.3.4 *) - - val (>|=) : 'a t -> ('a -> 'b) -> 'b t - (** Infix version of {!map} - @since 0.3.4 *) - - val (<*>) : ('a -> 'b) t -> 'a t -> 'b t - (** Applicative operator (product+application) - @since 0.3.4 *) - - val (<+>) : 'a t -> 'a t -> 'a t - (** Concatenation of sequences - @since 0.3.4 *) -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");; -]} - -Read the lines of a file into a list: - -{[ - Sequence.IO.lines "a" |> Sequence.to_list -]} - -@since 0.3.4 *) - -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_bytes_to : ?mode:int -> ?flags:open_flag list -> - string -> Bytes.t t -> unit - (** @since 0.5 *) - - val write_lines : ?mode:int -> ?flags:open_flag list -> - string -> string t -> unit - (** Same as {!write_to}, but intercales ['\n'] between each string *) - - val write_bytes_lines : ?mode:int -> ?flags:open_flag list -> - string -> Bytes.t t -> unit - (** @since 0.5 *) -end diff --git a/core/Gen_intf.ml b/core/Gen_intf.ml deleted file mode 120000 index 32cbb5c8..00000000 --- a/core/Gen_intf.ml +++ /dev/null @@ -1 +0,0 @@ -../gen/gen_intf.ml \ No newline at end of file diff --git a/gen/.gitignore b/gen/.gitignore deleted file mode 100644 index 20f09d16..00000000 --- a/gen/.gitignore +++ /dev/null @@ -1,11 +0,0 @@ -.*.swp -.*.swo -_build -*.native -*.byte -.session -TAGS -*.docdir -setup.log -setup.data -qtest diff --git a/gen/.merlin b/gen/.merlin deleted file mode 100644 index 26649dfa..00000000 --- a/gen/.merlin +++ /dev/null @@ -1,5 +0,0 @@ -S . -B _build -S tests -B _build/tests -PKG oUnit diff --git a/gen/META b/gen/META deleted file mode 100644 index edcf3e82..00000000 --- a/gen/META +++ /dev/null @@ -1,11 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: c6b7b0973d898c3e8b7f565b701ee0d0) -version = "0.2.2" -description = "Simple, efficient iterators for OCaml" -archive(byte) = "gen.cma" -archive(byte, plugin) = "gen.cma" -archive(native) = "gen.cmxa" -archive(native, plugin) = "gen.cmxs" -exists_if = "gen.cma" -# OASIS_STOP - diff --git a/gen/Makefile b/gen/Makefile deleted file mode 100644 index 43e32bdf..00000000 --- a/gen/Makefile +++ /dev/null @@ -1,59 +0,0 @@ -# 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 - -push_doc: all doc - scp -r gen.docdir/* cedeela.fr:~/simon/root/software/gen/ - -qtest-gen: - mkdir -p qtest - qtest extract gen.ml > qtest/run_qtest.ml - -test-all: - ./run_tests.native - ./run_qtest.native - -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 diff --git a/gen/README.md b/gen/README.md deleted file mode 100644 index f8ff67c6..00000000 --- a/gen/README.md +++ /dev/null @@ -1,32 +0,0 @@ -Gen -=== - -Iterators for OCaml, both restartable and consumable. Performances should -be good, yet the code is simple and straightforward. - -The documentation can be found [here](http://cedeela.fr/~simon/software/gen) - -## Use - -You can either build and install the library (see `Build`), or just copy -files to your own project. The last solution has the benefits that you -don't have additional dependencies nor build complications (and it may enable -more inlining). I therefore recommand it for its simplicity. - -If you have comments, requests, or bugfixes, please share them! :-) - -## Build - -There are no dependencies. This should work with OCaml>=3.12. - - $ make - -To build and run tests (requires `oUnit`): - - $ opam install oUnit - $ make tests - $ ./tests.native - -## License - -This code is free, under the BSD license. diff --git a/gen/_oasis b/gen/_oasis deleted file mode 100644 index d13b7765..00000000 --- a/gen/_oasis +++ /dev/null @@ -1,65 +0,0 @@ -OASISFormat: 0.3 -Name: gen -Version: 0.2.2 -Homepage: https://github.com/c-cube/gen -Authors: Simon Cruanes -License: BSD3 -LicenseFile: LICENSE -Plugins: META (0.3), DevFiles (0.3) -BuildTools: ocamlbuild - -Synopsis: Simple, efficient iterators for OCaml - -Flag "bench" - Description: build benchmark - Default: false - -Library "gen" - Path: . - Pack: false - Modules: Gen, Gen_intf - -Document gen - Title: Containers docs - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Install: true - XOCamlbuildPath: . - XOCamlbuildLibraries: gen - -PreBuildCommand: make qtest-gen - -Executable run_tests - Path: tests/ - Install: false - CompiledObject: native - MainIs: run_tests.ml - Build$: flag(tests) - BuildDepends: gen,oUnit - -Executable run_qtest - Path: qtest/ - Install: false - CompiledObject: native - MainIs: run_qtest.ml - Build$: flag(tests) - BuildDepends: containers, containers.misc, containers.string, - oUnit, QTest2Lib - -Test all - Command: make test-all - TestTools: run_tests, run_qtest - Run$: flag(tests) - -Executable bench_persistent - Path: bench/ - Install: false - CompiledObject: native - MainIs: bench_persistent.ml - Build$: flag(bench) - BuildDepends: gen,benchmark - -SourceRepository head - Type: git - Location: https://github.com/c-cube/gen - Browser: https://github.com/c-cube/gen/tree/master/src diff --git a/gen/_tags b/gen/_tags deleted file mode 100644 index 8760f650..00000000 --- a/gen/_tags +++ /dev/null @@ -1,43 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: a9f4ed4316e4221c9e3cad121ae7a8a9) -# 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 -true: annot, bin_annot -<**/.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 gen -"gen.cmxs": use_gen -# Executable run_tests -"tests/run_tests.native": pkg_oUnit -"tests/run_tests.native": use_gen -: pkg_oUnit -: use_gen -# Executable run_qtest -"qtest/run_qtest.native": pkg_QTest2Lib -"qtest/run_qtest.native": pkg_containers -"qtest/run_qtest.native": pkg_containers.misc -"qtest/run_qtest.native": pkg_containers.string -"qtest/run_qtest.native": pkg_oUnit -: pkg_QTest2Lib -: pkg_containers -: pkg_containers.misc -: pkg_containers.string -: pkg_oUnit -# Executable bench_persistent -"bench/bench_persistent.native": pkg_benchmark -"bench/bench_persistent.native": use_gen -: pkg_benchmark -: use_gen -# OASIS_STOP -"qtest": include -<**/*.ml>: warn_A, warn(-4), warn(-44) - diff --git a/gen/bench/.merlin b/gen/bench/.merlin deleted file mode 100644 index ba79d719..00000000 --- a/gen/bench/.merlin +++ /dev/null @@ -1,4 +0,0 @@ -S . -B ../_build/bench/ -REC -PKG benchmark diff --git a/gen/bench/bench_persistent.ml b/gen/bench/bench_persistent.ml deleted file mode 100644 index d2a5551b..00000000 --- a/gen/bench/bench_persistent.ml +++ /dev/null @@ -1,161 +0,0 @@ - -let _sum g = - Gen.Restart.fold (+) 0 g - - -module MList = struct - type 'a t = 'a node option ref - and 'a node = { - content : 'a; - mutable prev : 'a node; - mutable next : 'a node; - } - - let create () = ref None - - let is_empty d = - match !d with - | None -> true - | Some _ -> false - - let push_back d x = - match !d with - | None -> - let rec elt = { - content = x; prev = elt; next = elt; } in - d := Some elt - | Some first -> - let elt = { content = x; next=first; prev=first.prev; } in - first.prev.next <- elt; - first.prev <- elt - - (* conversion to gen *) - let to_gen d = - fun () -> - match !d with - | None -> (fun () -> None) - | Some first -> - let cur = ref first in (* current element of the list *) - let stop = ref false in (* are we done yet? *) - fun () -> - if !stop then None - else begin - let x = (!cur).content in - cur := (!cur).next; - (if !cur == first then stop := true); (* EOG, we made a full cycle *) - Some x - end -end - -(** Store content of the generator in an enum *) -let persistent_mlist gen = - let l = MList.create () in - Gen.iter (MList.push_back l) gen; - MList.to_gen l - -let bench_mlist n = - for _i = 0 to 100 do - let g = persistent_mlist Gen.(1 -- n) in - ignore (_sum g) - done - -(** {6 Unrolled mutable list} *) -module UnrolledList = struct - type 'a node = - | Nil - | Partial of 'a array * int - | Cons of 'a array * 'a node ref - - let of_gen gen = - let start = ref Nil in - let chunk_size = ref 16 in - let rec fill prev cur = - match cur, gen() with - | Partial (a,n), None -> - prev := Cons (Array.sub a 0 n, ref Nil); () (* done *) - | _, None -> prev := cur; () (* done *) - | Nil, Some x -> - let n = !chunk_size in - if n < 4096 then chunk_size := 2 * !chunk_size; - fill prev (Partial (Array.make n x, 1)) - | Partial (a, n), Some x -> - assert (n < Array.length a); - a.(n) <- x; - if n+1 = Array.length a - then begin - let r = ref Nil in - prev := Cons(a, r); - fill r Nil - end else fill prev (Partial (a, n+1)) - | Cons _, _ -> assert false - in - fill start !start ; - !start - - let to_gen l () = - let cur = ref l in - let i = ref 0 in - let rec next() = match !cur with - | Nil -> None - | Cons (a,l') -> - if !i = Array.length a - then begin - cur := !l'; - i := 0; - next() - end else begin - let y = a.(!i) in - incr i; - Some y - end - | Partial _ -> assert false - in - next -end - -(** Store content of the generator in an enum *) -let persistent_unrolled gen = - let l = UnrolledList.of_gen gen in - UnrolledList.to_gen l - -let bench_unrolled n = - for _i = 0 to 100 do - let g = persistent_unrolled Gen.(1 -- n) in - ignore (_sum g) - done - -let bench_naive n = - for _i = 0 to 100 do - let l = Gen.to_rev_list Gen.(1 -- n) in - let g = Gen.Restart.of_list (List.rev l) in - ignore (_sum g) - done - -let bench_current n = - for _i = 0 to 100 do - let g = Gen.persistent Gen.(1 -- n) in - ignore (_sum g) - done - -let bench_current_lazy n = - for _i = 0 to 100 do - let g = Gen.persistent_lazy Gen.(1 -- n) in - ignore (_sum g) - 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 - ; "unrolled", bench_unrolled, n - ; "current", bench_current, n - ; "current_lazy", bench_current_lazy, n - ] - in Benchmark.tabulate res - in - bench_n 100; - bench_n 100_000; - () - diff --git a/gen/configure b/gen/configure deleted file mode 100755 index 6acfaeb9..00000000 --- a/gen/configure +++ /dev/null @@ -1,27 +0,0 @@ -#!/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/gen/gen.ml b/gen/gen.ml deleted file mode 100644 index 8aa35265..00000000 --- a/gen/gen.ml +++ /dev/null @@ -1,1669 +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 Restartable generators} *) - -(** {2 Global type declarations} *) - -type 'a t = unit -> 'a option - -type 'a gen = 'a t - -module type S = Gen_intf.S - -(** {2 Transient generators} *) - -let empty () = None - -(*$T empty - empty |> to_list = [] -*) - -let singleton x = - let first = ref true in - fun () -> - if !first then (first := false; Some x) else None - -(*T singleton - singleton 1 |> to_list = [1] - singleton "foo" |> to_list = ["foo"] -*) - -let repeat x () = Some x - -(*$T repeat - repeat 42 |> take 3 |> to_list = [42; 42; 42] -*) - -let repeatedly f () = Some (f ()) - -(*$T repeatedly - repeatedly (let r = ref 0 in fun () -> incr r; !r) \ - |> take 5 |> to_list = [1;2;3;4;5] -*) - -let iterate x f = - let cur = ref x in - fun () -> - let x = !cur in - cur := f !cur; - Some x - -(*$T iterate - iterate 0 ((+)1) |> take 5 |> to_list = [0;1;2;3;4] -*) - -let next gen = gen () - -let get gen = gen () - -let get_exn gen = - match gen () with - | Some x -> x - | None -> raise (Invalid_argument "Gen.get_exn") - -(*$R get_exn - let g = of_list [1;2;3] in - assert_equal 1 (get_exn g); - assert_equal 2 (get_exn g); - assert_equal 3 (get_exn g); - assert_raises (Invalid_argument "Gen.get_exn") (fun () -> get_exn g) -*) - -let junk gen = ignore (gen ()) - -let rec fold f acc gen = - match gen () with - | None -> acc - | Some x -> fold f (f acc x) gen - -(*$Q - (Q.list Q.small_int) (fun l -> \ - of_list l |> fold (fun l x->x::l) [] = List.rev l) -*) - -let reduce f g = - let acc = match g () with - | None -> raise (Invalid_argument "reduce") - | Some x -> x - in - fold f acc g - -(* Dual of {!fold}, with a deconstructing operation *) -let unfold f acc = - let acc = ref acc in - fun () -> - match f !acc with - | None -> None - | Some (x, acc') -> - acc := acc'; - Some x - -(*$T unfold - unfold (fun (prev,cur) -> Some (prev, (cur,prev+cur))) (0,1) \ - |> take 7 |> to_list = [0; 1; 1; 2; 3; 5; 8] -*) - -let init ?(limit=max_int) f = - let r = ref 0 in - fun () -> - if !r >= limit - then None - else - let x = f !r in - let _ = incr r in - Some x - -(*$T init - init ~limit:5 (fun i->i) |> to_list = [0;1;2;3;4] -*) - -let rec iter f gen = - match gen() with - | None -> () - | Some x -> f x; iter f gen - -let iteri f gen = - let rec iteri i = match gen() with - | None -> () - | Some x -> f i x; iteri (i+1) - in - iteri 0 - -let is_empty gen = match gen () with - | None -> true - | Some _ -> false - -(*$T - is_empty empty - not (is_empty (singleton 2)) -*) - -let length gen = - fold (fun acc _ -> acc + 1) 0 gen - -(*$Q - (Q.list Q.small_int) (fun l -> \ - of_list l |> length = List.length l) -*) - -(* useful state *) -module RunState = struct - type 'a t = - | Init - | Run of 'a - | Stop -end - -let scan f acc g = - let open RunState in - let state = ref Init in - fun () -> - match !state with - | Init -> - state := Run acc; - Some acc - | Stop -> None - | Run acc -> - match g() with - | None -> state := Stop; None - | Some x -> - let acc' = f acc x in - state := Run acc'; - Some acc' - -(*$T scan - scan (fun acc x -> x+1::acc) [] (1--5) |> to_list \ - = [[]; [2]; [3;2]; [4;3;2]; [5;4;3;2]; [6;5;4;3;2]] -*) - -let unfold_scan f acc g = - let open RunState in - let state = ref (Run acc) in - fun () -> - match !state with - | Init -> assert false - | Stop -> None - | Run acc -> - match g() with - | None -> state := Stop; None - | Some x -> - let acc', y = f acc x in - state := Run acc'; - Some y - -(*$T unfold_scan - unfold_scan (fun acc x -> x+acc,acc) 0 (1--5) |> to_list \ - = [0; 1; 3; 6; 10] -*) - -(** {3 Lazy} *) - -let map f gen = - let stop = ref false in - fun () -> - if !stop then None - else match gen() with - | None -> stop:= true; None - | Some x -> Some (f x) - -(*$Q map - (Q.list Q.small_int) (fun l -> \ - let f x = x*2 in \ - of_list l |> map f |> to_list = List.map f l) -*) - -let append gen1 gen2 = - let first = ref true in - let rec next() = - if !first - then match gen1() with - | (Some _) as x -> x - | None -> first:=false; next() - else gen2() - in next - -(*$Q - (Q.pair (Q.list Q.small_int)(Q.list Q.small_int)) (fun (l1,l2) -> \ - append (of_list l1) (of_list l2) |> to_list = l1 @ l2) -*) - -let flatten next_gen = - let open RunState in - let state = ref Init in - (* get next element *) - let rec next () = - match !state with - | Init -> get_next_gen() - | Run gen -> - begin match gen () with - | None -> get_next_gen () - | (Some _) as x -> x - end - | Stop -> None - and get_next_gen() = match next_gen() with - | None -> state := Stop; None - | Some gen -> state := Run gen; next() - in - next - -let flat_map f next_elem = - let open RunState in - let state = ref Init in - let rec next() = - match !state with - | Init -> get_next_gen() - | Run gen -> - begin match gen () with - | None -> get_next_gen () - | (Some _) as x -> x - end - | Stop -> None - and get_next_gen() = match next_elem() with - | None -> state:=Stop; None - | Some x -> - try state := Run (f x); next() - with e -> state := Stop; raise e - in - next - -(*$Q flat_map - (Q.list Q.small_int) (fun l -> \ - let f x = of_list [x;x*2] in \ - eq (map f (of_list l) |> flatten) (flat_map f (of_list l))) -*) - -let mem ?(eq=(=)) x gen = - let rec mem eq x gen = - match gen() with - | Some y -> eq x y || mem eq x gen - | None -> false - in mem eq x gen - -let take n gen = - assert (n >= 0); - let count = ref 0 in (* how many yielded elements *) - fun () -> - if !count = n || !count = ~-1 - then None - else match gen() with - | None -> count := ~-1; None (* indicate stop *) - | (Some _) as x -> incr count; x - -(*$Q - (Q.pair Q.small_int (Q.list Q.small_int)) (fun (n,l) -> \ - of_list l |> take n |> length = Pervasives.min n (List.length l)) -*) - -(* call [gen] at most [n] times, and stop *) -let rec __drop n gen = - if n = 0 then () - else match gen() with - | Some _ -> __drop (n-1) gen - | None -> () - -let drop n gen = - assert (n >= 0); - let dropped = ref false in - fun () -> - if !dropped - then gen() - else begin - (* drop [n] elements and yield the next element *) - dropped := true; - __drop n gen; - gen() - end - -(*$Q - (Q.pair Q.small_int (Q.list Q.small_int)) (fun (n,l) -> \ - let g1,g2 = take n (of_list l), drop n (of_list l) in \ - append g1 g2 |> to_list = l) -*) - -let nth n gen = - assert (n>=0); - __drop n gen; - match gen () with - | None -> raise Not_found - | Some x -> x - -(*$= nth & ~printer:string_of_int - 4 (nth 4 (0--10)) - 8 (nth 8 (0--10)) -*) - -(*$T - (try ignore (nth 11 (1--10)); false with Not_found -> true) -*) - -let take_nth n gen = - assert (n>=1); - let i = ref n in - let rec next() = - match gen() with - | None -> None - | (Some _) as res when !i = n -> i:=1; res - | Some _ -> incr i; next() - in next - -let filter p gen = - let rec next () = - (* wrap exception into option, for next to be tailrec *) - match gen() with - | None -> None - | (Some x) as res -> - if p x - then res (* yield element *) - else next () (* discard element *) - in next - -(*$T - filter (fun x ->x mod 2 = 0) (1--10) |> to_list = [2;4;6;8;10] -*) - -let take_while p gen = - let stop = ref false in - fun () -> - if !stop - then None - else match gen() with - | (Some x) as res -> - if p x then res else (stop := true; None) - | None -> stop:=true; None - -(*$T - take_while (fun x ->x<10) (1--1000) |> eq (1--9) -*) - -module DropWhileState = struct - type t = - | Stop - | Drop - | Yield -end - -let drop_while p gen = - let open DropWhileState in - let state = ref Drop in - let rec next () = - match !state with - | Stop -> None - | Drop -> - begin match gen () with - | None -> state := Stop; None - | (Some x) as res -> - if p x then next() else (state:=Yield; res) - end - | Yield -> - begin match gen () with - | None -> state := Stop; None - | Some _ as res -> res - end - in next - -(*$T - drop_while (fun x-> x<10) (1--20) |> eq (10--20) -*) - -let filter_map f gen = - (* tailrec *) - let rec next () = - match gen() with - | None -> None - | Some x -> - match f x with - | None -> next() - | (Some _) as res -> res - in next - -(*$T - filter_map (fun x-> if x mod 2 = 0 then Some (string_of_int x) else None) (1--10) \ - |> to_list = List.map string_of_int [2;4;6;8;10] -*) - -let zip_index gen = - let r = ref ~-1 in - fun () -> - match gen() with - | None -> None - | Some x -> - incr r; - Some (!r, x) - -(*$T - zip_index (1--5) |> to_list = [0,1; 1,2; 2,3; 3,4; 4,5] -*) - -let unzip gen = - let stop = ref false in - let q1 = Queue.create () in - let q2 = Queue.create () in - let next_left () = - if Queue.is_empty q1 - then if !stop then None - else match gen() with - | Some (x,y) -> - Queue.push y q2; - Some x - | None -> stop := true; None - else Some (Queue.pop q1) - in - let next_right () = - if Queue.is_empty q2 - then if !stop then None - else match gen() with - | Some (x,y) -> - Queue.push x q1; - Some y - | None -> stop := true; None - else Some (Queue.pop q2) - in - next_left, next_right - -(*$T - unzip (of_list [1,2;3,4]) |> (fun (x,y)-> to_list x, to_list y) \ - = ([1;3], [2;4]) -*) - -(*$Q - (Q.list (Q.pair Q.small_int Q.small_int)) (fun l -> \ - of_list l |> unzip |> (fun (x,y) -> to_list x,to_list y) = \ - List.split l) -*) - -(* [partition p l] returns the elements that satisfy [p], - and the elements that do not satisfy [p] *) -let partition p gen = - let qtrue = Queue.create () in - let qfalse = Queue.create () in - let stop = ref false in - let rec nexttrue () = - if Queue.is_empty qtrue - then if !stop then None - else match gen() with - | (Some x) as res -> - if p x then res else (Queue.push x qfalse; nexttrue()) - | None -> stop:=true; None - else Some (Queue.pop qtrue) - and nextfalse() = - if Queue.is_empty qfalse - then if !stop then None - else match gen() with - | (Some x) as res -> - if p x then (Queue.push x qtrue; nextfalse()) else res - | None -> stop:= true; None - else Some (Queue.pop qfalse) - in - nexttrue, nextfalse - -(*$T - partition (fun x -> x mod 2 = 0) (1--10) |> \ - (fun (x,y)->to_list x, to_list y) = ([2;4;6;8;10], [1;3;5;7;9]) -*) - -let rec for_all p gen = - match gen() with - | None -> true - | Some x -> p x && for_all p gen - -let rec exists p gen = - match gen() with - | None -> false - | Some x -> p x || exists p gen - -let min ?(lt=fun x y -> x < y) gen = - let first = match gen () with - | Some x -> x - | None -> raise (Invalid_argument "min") - in - fold (fun min x -> if lt x min then x else min) first gen - -(*$T - min (of_list [1;4;6;0;11; -2]) = ~-2 - (try ignore (min empty); false with Invalid_argument _ -> true) -*) - -let max ?(lt=fun x y -> x < y) gen = - let first = match gen () with - | Some x -> x - | None -> raise (Invalid_argument "max") - in - fold (fun max x -> if lt max x then x else max) first gen - -(*$T - max (of_list [1;4;6;0;11; -2]) = 11 - (try ignore (max empty); false with Invalid_argument _ -> true) -*) - -let eq ?(eq=(=)) gen1 gen2 = - let rec check () = - match gen1(), gen2() with - | None, None -> true - | Some x1, Some x2 when eq x1 x2 -> check () - | _ -> false - in - check () - -(*$Q - (Q.pair (Q.list Q.small_int)(Q.list Q.small_int)) (fun (l1,l2) -> \ - eq (of_list l1)(of_list l2) = (l1 = l2)) -*) - -let lexico ?(cmp=Pervasives.compare) gen1 gen2 = - let rec lexico () = - match gen1(), gen2() with - | None, None -> 0 - | Some x1, Some x2 -> - let c = cmp x1 x2 in - if c <> 0 then c else lexico () - | Some _, None -> 1 - | None, Some _ -> -1 - in lexico () - -let compare ?cmp gen1 gen2 = lexico ?cmp gen1 gen2 - -(*$Q - (Q.pair (Q.list Q.small_int)(Q.list Q.small_int)) (fun (l1,l2) -> \ - let sign x = if x < 0 then -1 else if x=0 then 0 else 1 in \ - sign (compare (of_list l1)(of_list l2)) = sign (Pervasives.compare l1 l2)) -*) - -let rec find p e = match e () with - | None -> None - | Some x when p x -> Some x - | Some _ -> find p e - -(*$T - find (fun x -> x>=5) (1--10) = Some 5 - find (fun x -> x>5) (1--4) = None -*) - -let sum e = - let rec sum acc = match e() with - | None -> acc - | Some x -> sum (x+acc) - in sum 0 - -(*$T - sum (1--10) = 55 -*) - -(** {2 Multiple Iterators} *) - -let map2 f e1 e2 = - fun () -> match e1(), e2() with - | Some x, Some y -> Some (f x y) - | _ -> None - -(*$T - map2 (+) (1--5) (1--4) |> eq (of_list [2;4;6;8]) - map2 (+) (1--5) (repeat 0) |> eq (1--5) -*) - -let rec iter2 f e1 e2 = - match e1(), e2() with - | Some x, Some y -> f x y; iter2 f e1 e2 - | _ -> () - -(*$T iter2 - let r = ref 0 in iter2 (fun _ _ -> incr r) (1--10) (4--6); !r = 3 -*) - -let rec fold2 f acc e1 e2 = - match e1(), e2() with - | Some x, Some y -> fold2 f (f acc x y) e1 e2 - | _ -> acc - -let rec for_all2 p e1 e2 = - match e1(), e2() with - | Some x, Some y -> p x y && for_all2 p e1 e2 - | _ -> true - -let rec exists2 p e1 e2 = - match e1(), e2() with - | Some x, Some y -> p x y || exists2 p e1 e2 - | _ -> false - -let zip_with f a b = - let stop = ref false in - fun () -> - if !stop then None - else match a(), b() with - | Some xa, Some xb -> Some (f xa xb) - | _ -> stop:=true; None - -let zip a b = zip_with (fun x y -> x,y) a b - -(*$Q - (Q.list Q.small_int) (fun l -> \ - zip_with (fun x y->x,y) (of_list l) (of_list l) \ - |> unzip |> fst |> to_list = l) -*) - -(** {3 Complex combinators} *) - -module MergeState = struct - type 'a t = { - gens : 'a gen Queue.t; - mutable state : my_state; - } - - and my_state = - | NewGen - | YieldAndNew - | Yield - | Stop -end - -(* state machine: - (NewGen -> YieldAndNew)* // then no more generators in next_gen, so - -> Yield* -> Stop *) -let merge next_gen = - let open MergeState in - let state = {gens = Queue.create(); state=NewGen;}in - (* recursive function to get next element *) - let rec next () = - match state.state with - | Stop -> None - | Yield -> (* only yield from generators in state.gens *) - if Queue.is_empty state.gens - then (state.state <- Stop; None) - else - let gen = Queue.pop state.gens in - begin match gen () with - | None -> next() - | (Some _) as res -> - Queue.push gen state.gens; (* put gen back in queue *) - res - end - | NewGen -> - begin match next_gen() with - | None -> - state.state <- Yield; (* exhausted *) - next() - | Some gen -> - Queue.push gen state.gens; - state.state <- YieldAndNew; - next() - end - | YieldAndNew -> (* yield element from queue, then get a new generator *) - if Queue.is_empty state.gens - then (state.state <- NewGen; next()) - else - let gen = Queue.pop state.gens in - begin match gen () with - | None -> state.state <- NewGen; next() - | (Some _) as res -> - Queue.push gen state.gens; - state.state <- NewGen; - res - end - in next - -(*$T - merge (of_list [of_list [1;3;5]; of_list [2;4;6]; of_list [7;8;9]]) \ - |> to_list |> List.sort Pervasives.compare = [1;2;3;4;5;6;7;8;9] -*) - -let intersection ?(cmp=Pervasives.compare) gen1 gen2 = - let x1 = ref (gen1 ()) in - let x2 = ref (gen2 ()) in - let rec next () = - match !x1, !x2 with - | Some y1, Some y2 -> - let c = cmp y1 y2 in - if c = 0 (* equal elements, yield! *) - then (x1 := gen1(); x2 := gen2(); Some y1) - else if c < 0 (* drop y1 *) - then (x1 := gen1 (); next ()) - else (* drop y2 *) - (x2 := gen2(); next ()) - | _ -> None - in next - -(*$T - intersection (of_list [1;1;2;3;4;8]) (of_list [1;2;4;5;6;7;8;9]) \ - |> to_list = [1;2;4;8] -*) - -let sorted_merge ?(cmp=Pervasives.compare) gen1 gen2 = - let x1 = ref (gen1 ()) in - let x2 = ref (gen2 ()) in - fun () -> - match !x1, !x2 with - | None, None -> None - | (Some y1)as r1, ((Some y2) as r2) -> - if cmp y1 y2 <= 0 - then (x1 := gen1 (); r1) - else (x2 := gen2 (); r2) - | (Some _)as r, None -> - x1 := gen1 (); - r - | None, ((Some _)as r) -> - x2 := gen2 (); - r - -(*$T - sorted_merge (of_list [1;2;2;3;5;10;100]) (of_list [2;4;5;6;11]) \ - |> to_list = [1;2;2;2;3;4;5;5;6;10;11;100] -*) - -(** {4 Mutable heap (taken from heap.ml to avoid dependencies)} *) -module Heap = struct - type 'a t = { - mutable tree : 'a tree; - cmp : 'a -> 'a -> int; - } (** A pairing tree heap with the given comparison function *) - and 'a tree = - | Empty - | Node of 'a * 'a tree * 'a tree - - let empty ~cmp = { - tree = Empty; - cmp; - } - - let is_empty h = - match h.tree with - | Empty -> true - | Node _ -> false - - let rec union ~cmp t1 t2 = match t1, t2 with - | Empty, _ -> t2 - | _, Empty -> t1 - | Node (x1, l1, r1), Node (x2, l2, r2) -> - if cmp x1 x2 <= 0 - then Node (x1, union ~cmp t2 r1, l1) - else Node (x2, union ~cmp t1 r2, l2) - - let insert h x = - h.tree <- union ~cmp:h.cmp (Node (x, Empty, Empty)) h.tree - - let pop h = match h.tree with - | Empty -> raise Not_found - | Node (x, l, r) -> - h.tree <- union ~cmp:h.cmp l r; - x -end - -let sorted_merge_n ?(cmp=Pervasives.compare) l = - (* make a heap of (value, generator) *) - let cmp (v1,_) (v2,_) = cmp v1 v2 in - let heap = Heap.empty ~cmp in - (* add initial values *) - List.iter - (fun gen' -> match gen'() with - | Some x -> Heap.insert heap (x, gen') - | None -> ()) - l; - fun () -> - if Heap.is_empty heap then None - else begin - let x, gen = Heap.pop heap in - match gen() with - | Some y -> - Heap.insert heap (y, gen); (* insert next value *) - Some x - | None -> Some x (* gen empty, drop it *) - end - -(*$T - sorted_merge_n [of_list [1;2;2;3;5;10;100]; of_list [2;4;5;6;11]; (6--10)] \ - |> to_list = [1;2;2;2;3;4;5;5;6;6;7;8;9;10;10;11;100] -*) - -let round_robin ?(n=2) gen = - (* array of queues, together with their index *) - let qs = Array.init n (fun _ -> Queue.create ()) in - let cur = ref 0 in - (* get next element for the i-th queue *) - let rec next i = - let q = qs.(i) in - if Queue.is_empty q - then update_to_i i (* consume generator *) - else Some(Queue.pop q) - (* consume [gen] until some element for [i]-th generator is - available. *) - and update_to_i i = - match gen() with - | None -> None - | Some x -> - let j = !cur in - cur := (j+1) mod n; (* move cursor to next generator *) - let q = qs.(j) in - if j = i - then begin - assert (Queue.is_empty q); - Some x (* return the element *) - end else begin - Queue.push x q; - update_to_i i (* continue consuming [gen] *) - end - in - (* generators *) - let l = Array.mapi (fun i _ -> (fun () -> next i)) qs in - Array.to_list l - -(*$T - round_robin ~n:3 (1--12) |> List.map to_list = \ - [[1;4;7;10]; [2;5;8;11]; [3;6;9;12]] -*) - -(* Duplicate the enum into [n] generators (default 2). The generators - share the same underlying instance of the enum, so the optimal case is - when they are consumed evenly *) -let tee ?(n=2) gen = - (* array of queues, together with their index *) - let qs = Array.init n (fun _ -> Queue.create ()) in - let finished = ref false in (* is [gen] exhausted? *) - (* get next element for the i-th queue *) - let rec next i = - if Queue.is_empty qs.(i) - then - if !finished then None - else get_next i (* consume generator *) - else Queue.pop qs.(i) - (* consume one more element *) - and get_next i = match gen() with - | Some _ as res -> - for j = 0 to n-1 do - if j <> i then Queue.push res qs.(j) - done; - res - | None -> finished := true; None - in - (* generators *) - let l = Array.mapi (fun i _ -> (fun () -> next i)) qs in - Array.to_list l - -(*$T - tee ~n:3 (1--12) |> List.map to_list = \ - [to_list (1--12); to_list (1--12); to_list (1--12)] -*) - - -module InterleaveState = struct - type 'a t = - | Only of 'a gen - | Both of 'a gen * 'a gen * bool ref - | Stop -end - -(* Yield elements from a and b alternatively *) -let interleave gen_a gen_b = - let open InterleaveState in - let state = ref (Both (gen_a, gen_b, ref true)) in - let rec next() = match !state with - | Stop -> None - | Only g -> - begin match g() with - | None -> state := Stop; None - | (Some _) as res -> res - end - | Both (g1, g2, r) -> - match (if !r then g1() else g2()) with - | None -> - state := if !r then Only g2 else Only g1; - next() - | (Some _) as res -> - r := not !r; (* swap *) - res - in next - -(*$T - interleave (repeat 0) (1--5) |> take 10 |> to_list = \ - [0;1;0;2;0;3;0;4;0;5] -*) - -module IntersperseState = struct - type 'a t = - | Start - | YieldElem of 'a option - | YieldSep of 'a option (* next val *) - | Stop -end - -(* Put [x] between elements of [enum] *) -let intersperse x gen = - let open IntersperseState in - let state = ref Start in - let rec next() = match !state with - | Stop -> None - | YieldElem res -> - begin match gen() with - | None -> state := Stop - | Some _ as res' -> state := YieldSep res' - end; - res - | YieldSep res -> - state := YieldElem res; - Some x - | Start -> - match gen() with - | None -> state := Stop; None - | Some _ as res -> state := YieldElem res; next() - in next - -(*$T - intersperse 0 (1--5) |> to_list = [1;0;2;0;3;0;4;0;5] -*) - -(* Cartesian product *) -let product gena genb = - let all_a = ref [] in - let all_b = ref [] in - (* cur: current state, i.e., what we have to do next. Can be stop, - getLeft/getRight (to obtain next element from first/second generator), - or prodLeft/prodRIght to compute the product of an element with a list - of already met elements *) - let cur = ref `GetLeft in - let rec next () = - match !cur with - | `Stop -> None - | `GetLeft -> - begin match gena() with - | None -> cur := `GetRightOrStop - | Some a -> all_a := a :: !all_a; cur := `ProdLeft (a, !all_b) - end; - next () - | `GetRight | `GetRightOrStop -> (* TODO: test *) - begin match genb() with - | None when !cur = `GetRightOrStop -> cur := `Stop - | None -> cur := `GetLeft - | Some b -> all_b := b::!all_b; cur := `ProdRight (b, !all_a) - end; - next () - | `ProdLeft (_, []) -> - cur := `GetRight; - next() - | `ProdLeft (x, y::l) -> - cur := `ProdLeft (x, l); - Some (x, y) - | `ProdRight (_, []) -> - cur := `GetLeft; - next() - | `ProdRight (y, x::l) -> - cur := `ProdRight (y, l); - Some (x, y) - in - next - -(*$T - product (1--3) (of_list ["a"; "b"]) |> to_list \ - |> List.sort Pervasives.compare = \ - [1, "a"; 1, "b"; 2, "a"; 2, "b"; 3, "a"; 3, "b"] -*) - -(* Group equal consecutive elements together. *) -let group ?(eq=(=)) gen = - match gen() with - | None -> fun () -> None - | Some x -> - let cur = ref [x] in - let rec next () = - (* try to get an element *) - let next_x = if !cur = [] then None else gen() in - match next_x, !cur with - | None, [] -> None - | None, l -> - cur := []; (* stop *) - Some l - | Some x, y::_ when eq x y -> - cur := x::!cur; - next () (* same group *) - | Some x, l -> - cur := [x]; - Some l - in next - -(*$T - group (of_list [0;0;0;1;0;2;2;3;4;5;5;5;5;10]) |> to_list = \ - [[0;0;0];[1];[0];[2;2];[3];[4];[5;5;5;5];[10]] -*) - -let uniq ?(eq=(=)) gen = - let open RunState in - let state = ref Init in - let rec next() = match !state with - | Stop -> None - | Init -> - begin match gen() with - | None -> state:= Stop; None - | (Some x) as res -> state := Run x; res - end - | Run x -> - begin match gen() with - | None -> state:= Stop; None - | (Some y) as res -> - if eq x y - then next() (* ignore duplicate *) - else (state := Run y; res) - end - in next - -(*$T - uniq (of_list [0;0;0;1;0;2;2;3;4;5;5;5;5;10]) |> to_list = \ - [0;1;0;2;3;4;5;10] -*) - -let sort ?(cmp=Pervasives.compare) gen = - (* build heap *) - let h = Heap.empty ~cmp in - iter (Heap.insert h) gen; - fun () -> - if Heap.is_empty h - then None - else Some (Heap.pop h) -(*$T - sort (of_list [0;0;0;1;0;2;2;3;4;5;5;5;-42;5;10]) |> to_list = \ - [-42;0;0;0;0;1;2;2;3;4;5;5;5;5;10] -*) - - -(* NOTE: using a set is not really possible, because once we have built the - set there is no simple way to iterate on it *) -let sort_uniq ?(cmp=Pervasives.compare) gen = - uniq ~eq:(fun x y -> cmp x y = 0) (sort ~cmp gen) - -(*$T - sort_uniq (of_list [0;0;0;1;0;2;2;3;4;5;42;5;5;42;5;10]) |> to_list = \ - [0;1;2;3;4;5;10;42] -*) - -let chunks n e = - let rec next () = - match e() with - | None -> None - | Some x -> - let a = Array.make n x in - fill a 1 - - and fill a i = - (* fill the array. [i]: current index to fill *) - if i = n - then Some a - else match e() with - | None -> Some (Array.sub a 0 i) (* last array is not full *) - | Some x -> - a.(i) <- x; - fill a (i+1) - in - next - -(*$T - chunks 25 (0--100) |> map Array.to_list |> to_list = \ - List.map to_list [(0--24); (25--49);(50--74);(75--99);(100--100)] -*) - -(* state of the permutation machine. One machine manages one element [x], - and depends on a deeper machine [g] that generates permutations of the - list minus this element (down to the empty list). - The machine can do two things: - - insert the element in the current list of [g], at any position - - obtain the next list of [g] -*) - -module PermState = struct - type 'a state = - | Done - | Base (* bottom machine, yield [] *) - | Insert of 'a insert_state - and 'a insert_state = { - x : 'a; - mutable l : 'a list; - mutable n : int; (* idx for insertion *) - len : int; (* len of [l] *) - sub : 'a t; - } - and 'a t = { - mutable st : 'a state; - } -end - -let permutations g = - let open PermState in - (* make a machine for n elements. Invariant: n=len(l) *) - let rec make_machine n l = match l with - | [] -> assert (n=0); {st=Base} - | x :: tail -> - let sub = make_machine (n-1) tail in - let st = match next sub () with - | None -> Done - | Some l -> Insert {x;n=0;l;len=n;sub} - in - {st;} - (* next element of the machine *) - and next m () = match m.st with - | Done -> None - | Base -> m.st <- Done; Some [] - | Insert ({x;len;n;l;sub} as state) -> - if n=len - then match next sub () with - | None -> m.st <- Done; None - | Some l -> - state.l <- l; - state.n <- 0; - next m () - else ( - state.n <- state.n + 1; - Some (insert x n l) - ) - and insert x n l = match n, l with - | 0, _ -> x::l - | _, [] -> assert false - | _, y::tail -> y :: insert x (n-1) tail - in - let l = fold (fun acc x->x::acc) [] g in - next (make_machine (List.length l) l) - -(*$T permutations - permutations (1--3) |> to_list |> List.sort Pervasives.compare = \ - [[1;2;3]; [1;3;2]; [2;1;3]; [2;3;1]; [3;1;2]; [3;2;1]] - permutations empty |> to_list = [[]] - permutations (singleton 1) |> to_list = [[1]] -*) - -module CombState = struct - type 'a state = - | Done - | Base - | Add of 'a * 'a t * 'a t (* add x at beginning of first; then switch to second *) - | Follow of 'a t (* just forward *) - and 'a t = { - mutable st : 'a state - } -end - -let combinations n g = - let open CombState in - assert (n >= 0); - let rec make_state n l = match n, l with - | 0, _ -> {st=Base} - | _, [] -> {st=Done} - | _, x::tail -> - let m1 = make_state (n-1) tail in - let m2 = make_state n tail in - {st=Add(x,m1,m2)} - and next m () = match m.st with - | Done -> None - | Base -> m.st <- Done; Some [] - | Follow m -> - begin match next m () with - | None -> m.st <- Done; None - | Some _ as res -> res - end - | Add (x, m1, m2) -> - match next m1 () with - | None -> - m.st <- Follow m2; - next m () - | Some l -> Some (x::l) - in - let l = fold (fun acc x->x::acc) [] g in - next (make_state n l) - -(*$T - combinations 2 (1--4) |> map (List.sort Pervasives.compare) \ - |> to_list |> List.sort Pervasives.compare = \ - [[1;2]; [1;3]; [1;4]; [2;3]; [2;4]; [3;4]] - combinations 0 (1--4) |> to_list = [[]] - combinations 1 (singleton 1) |> to_list = [[1]] -*) - -module PowerSetState = struct - type 'a state = - | Done - | Base - | Add of 'a * 'a t (* add x before any result of m *) - | AddTo of 'a list * 'a * 'a t (* yield x::list, then back to Add(x,m) *) - and 'a t = { - mutable st : 'a state - } -end - -let power_set g = - let open PowerSetState in - let rec make_state l = match l with - | [] -> {st=Base} - | x::tail -> - let m = make_state tail in - {st=Add(x,m)} - and next m () = match m.st with - | Done -> None - | Base -> m.st <- Done; Some [] - | Add (x,m') -> - begin match next m' () with - | None -> m.st <- Done; None - | Some l as res -> m.st <- AddTo(l,x,m'); res - end - | AddTo (l, x, m') -> - m.st <- Add (x,m'); - Some (x::l) - in - let l = fold (fun acc x->x::acc) [] g in - next (make_state l) - -(*$T - power_set (1--3) |> map (List.sort Pervasives.compare) \ - |> to_list |> List.sort Pervasives.compare = \ - [[]; [1]; [1;2]; [1;2;3]; [1;3]; [2]; [2;3]; [3]] - power_set empty |> to_list = [[]] - power_set (singleton 1) |> map (List.sort Pervasives.compare) \ - |> to_list |> List.sort Pervasives.compare = [[]; [1]] -*) - -(** {3 Conversion} *) - -let of_list l = - let l = ref l in - fun () -> - match !l with - | [] -> None - | x::l' -> l := l'; Some x - -let to_rev_list gen = - fold (fun acc x -> x :: acc) [] gen - -(*$Q - (Q.list Q.small_int) (fun l -> \ - to_rev_list (of_list l) = List.rev l) -*) - -let to_list gen = List.rev (to_rev_list gen) - -let to_array gen = - let l = to_rev_list gen in - match l with - | [] -> [| |] - | _ -> - let a = Array.of_list l in - let n = Array.length a in - (* reverse array *) - for i = 0 to (n-1) / 2 do - let tmp = a.(i) in - a.(i) <- a.(n-i-1); - a.(n-i-1) <- tmp - done; - a - -let of_array ?(start=0) ?len a = - let len = match len with - | None -> Array.length a - start - | Some n -> assert (n + start < Array.length a); n in - let i = ref start in - fun () -> - if !i >= start + len - then None - else (let x = a.(!i) in incr i; Some x) - -(*$Q - (Q.array Q.small_int) (fun a -> \ - of_array a |> to_array = a) -*) - -let rand_int i = - repeatedly (fun () -> Random.int i) - -let int_range i j = - let r = ref i in - fun () -> - let x = !r in - if x > j then None - else begin - incr r; - Some x - end - -let pp ?(start="") ?(stop="") ?(sep=",") ?(horizontal=false) pp_elem formatter gen = - (if horizontal - then Format.pp_open_hbox formatter () - else Format.pp_open_hvbox formatter 0); - Format.pp_print_string formatter start; - let rec next is_first = - match gen() with - | Some x -> - if not is_first - then begin - Format.pp_print_string formatter sep; - Format.pp_print_space formatter (); - pp_elem formatter x - end else pp_elem formatter x; - next false - | None -> () - in - next true; - Format.pp_print_string formatter stop; - Format.pp_close_box formatter () - -module Infix = struct - let (--) = int_range - - let (>>=) x f = flat_map f x -end - -include Infix - -module Restart = struct - type 'a t = unit -> 'a gen - - type 'a restartable = 'a t - - let lift f e = f (e ()) - let lift2 f e1 e2 = f (e1 ()) (e2 ()) - - let empty () = empty - - let singleton x () = singleton x - - let iterate x f () = iterate x f - - let repeat x () = repeat x - - let unfold f acc () = unfold f acc - - let init ?limit f () = init ?limit f - - let cycle enum = - assert (not (is_empty (enum ()))); - fun () -> - let gen = ref (enum ()) in (* start cycle *) - let rec next () = - match (!gen) () with - | (Some _) as res -> res - | None -> gen := enum(); next() - in next - - let is_empty e = is_empty (e ()) - - let fold f acc e = fold f acc (e ()) - - let reduce f e = reduce f (e ()) - - let scan f acc e () = scan f acc (e ()) - - let unfold_scan f acc e () = unfold_scan f acc (e()) - - let iter f e = iter f (e ()) - - let iteri f e = iteri f (e ()) - - let length e = length (e ()) - - let map f e () = map f (e ()) - - let append e1 e2 () = append (e1 ()) (e2 ()) - - let flatten e () = flatten (e ()) - - let flat_map f e () = flat_map f (e ()) - - let mem ?eq x e = mem ?eq x (e ()) - - let take n e () = take n (e ()) - - let drop n e () = drop n (e ()) - - let nth n e = nth n (e ()) - - let take_nth n e () = take_nth n (e ()) - - let filter p e () = filter p (e ()) - - let take_while p e () = take_while p (e ()) - - let drop_while p e () = drop_while p (e ()) - - let filter_map f e () = filter_map f (e ()) - - let zip_with f e1 e2 () = zip_with f (e1 ()) (e2 ()) - - let zip e1 e2 () = zip (e1 ()) (e2 ()) - - let zip_index e () = zip_index (e ()) - - let unzip e = map fst e, map snd e - - let partition p e = - filter p e, filter (fun x -> not (p x)) e - - let for_all p e = - for_all p (e ()) - - let exists p e = - exists p (e ()) - - let for_all2 p e1 e2 = - for_all2 p (e1 ()) (e2 ()) - - let exists2 p e1 e2 = - exists2 p (e1 ()) (e2 ()) - - let map2 f e1 e2 () = - map2 f (e1()) (e2()) - - let iter2 f e1 e2 = - iter2 f (e1()) (e2()) - - let fold2 f acc e1 e2 = - fold2 f acc (e1()) (e2()) - - let min ?lt e = min ?lt (e ()) - - let max ?lt e = max ?lt (e ()) - - let ___eq = eq - let eq ?eq e1 e2 = ___eq ?eq (e1 ()) (e2 ()) - - let lexico ?cmp e1 e2 = lexico ?cmp (e1 ()) (e2 ()) - - let compare ?cmp e1 e2 = compare ?cmp (e1 ()) (e2 ()) - - let sum e = sum (e()) - - let find f e = find f (e()) - - let merge e () = merge (e ()) - - let intersection ?cmp e1 e2 () = - intersection ?cmp (e1 ()) (e2 ()) - - let sorted_merge ?cmp e1 e2 () = - sorted_merge ?cmp (e1 ()) (e2 ()) - - let sorted_merge_n ?cmp l () = - sorted_merge_n ?cmp (List.map (fun g -> g()) l) - - let tee ?n e = tee ?n (e ()) - - let round_robin ?n e = round_robin ?n (e ()) - - let interleave e1 e2 () = interleave (e1 ()) (e2 ()) - - let intersperse x e () = intersperse x (e ()) - - let product e1 e2 () = product (e1 ()) (e2 ()) - - let group ?eq e () = group ?eq (e ()) - - let uniq ?eq e () = uniq ?eq (e ()) - - let sort ?(cmp=Pervasives.compare) enum = - fun () -> sort ~cmp (enum ()) - - let sort_uniq ?(cmp=Pervasives.compare) e = - let e' = sort ~cmp e in - uniq ~eq:(fun x y -> cmp x y = 0) e' - - let chunks n e () = chunks n (e()) - - let permutations g () = permutations (g ()) - - let combinations n g () = combinations n (g()) - - let power_set g () = power_set (g()) - - let of_list l () = of_list l - - let to_rev_list e = to_rev_list (e ()) - - let to_list e = to_list (e ()) - - let to_array e = to_array (e ()) - - let of_array ?start ?len a () = of_array ?start ?len a - - let rand_int i () = rand_int i - - let int_range i j () = int_range i j - - module Infix = struct - let (--) = int_range - - let (>>=) x f = flat_map f x - end - - include Infix - - let pp ?start ?stop ?sep ?horizontal pp_elem fmt e = - pp ?start ?stop ?sep ?horizontal pp_elem fmt (e ()) -end - -(** {2 Generator functions} *) - -let start g = g () - -(** {6 Unrolled mutable list} *) -module MList = struct - type 'a node = - | Nil - | Cons of 'a array * int ref * 'a node ref - | Suspend of 'a gen - - type 'a t = { - start : 'a node ref; (* first node. *) - mutable chunk_size : int; - max_chunk_size : int; - } - - let _make ~max_chunk_size gen = { - start = ref (Suspend gen); - chunk_size = 8; - max_chunk_size; - } - - (* increment the size of chunks *) - let _incr_chunk_size mlist = - if mlist.chunk_size < mlist.max_chunk_size - then mlist.chunk_size <- 2 * mlist.chunk_size - - (* read one chunk of input; return the corresponding node. - will potentially change [mlist.chunk_size]. *) - let _read_chunk mlist gen = - match gen() with - | None -> Nil (* done *) - | Some x -> - (* new list node *) - let r = ref 1 in - let a = Array.make mlist.chunk_size x in - let tail = ref (Suspend gen) in - let stop = ref false in - let node = Cons (a, r, tail) in - (* read the rest of the chunk *) - while not !stop && !r < mlist.chunk_size do - match gen() with - | None -> - tail := Nil; - stop := true - | Some x -> - a.(!r) <- x; - incr r; - done; - _incr_chunk_size mlist; - node - - (* eager construction *) - let of_gen gen = - let mlist = _make ~max_chunk_size:4096 gen in - let rec _fill prev = match _read_chunk mlist gen with - | Nil -> prev := Nil - | Suspend _ -> assert false - | Cons (_, _, prev') as node -> - prev := node; - _fill prev' - in - _fill mlist.start; - mlist - - (* lazy construction *) - let of_gen_lazy gen = - let mlist = _make ~max_chunk_size:32 gen in - mlist - - let to_gen l () = - let cur = ref l.start in - let i = ref 0 in - let rec next() = match ! !cur with - | Nil -> None - | Cons (a,n,l') -> - if !i = !n - then begin - cur := l'; - i := 0; - next() - end else begin - let y = a.(!i) in - incr i; - Some y - end - | Suspend gen -> - let node = _read_chunk l gen in - !cur := node; - next() - in - next -end - -(** Store content of the generator in an enum *) -let persistent gen = - let l = MList.of_gen gen in - MList.to_gen l - -(*$T - let g = 1--10 in let g' = persistent g in \ - Restart.to_list g' = Restart.to_list g' - let g = 1--10 in let g' = persistent g in \ - Restart.to_list g' = [1;2;3;4;5;6;7;8;9;10] -*) - -let persistent_lazy gen = - let l = MList.of_gen_lazy gen in - MList.to_gen l - -(*$T - let g = 1--1_000_000_000 in let g' = persistent_lazy g in \ - (g' () |> take 100 |> to_list = (1--100 |> to_list)) && \ - (g' () |> take 200 |> to_list = (1--200 |> to_list)) -*) diff --git a/gen/gen.mldylib b/gen/gen.mldylib deleted file mode 100644 index 79105f52..00000000 --- a/gen/gen.mldylib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: f69818d114f140be18d72c90abdc60e8) -Gen -Gen_intf -# OASIS_STOP diff --git a/gen/gen.mli b/gen/gen.mli deleted file mode 100644 index 104e19b7..00000000 --- a/gen/gen.mli +++ /dev/null @@ -1,102 +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 Generators} - -Values of type ['a Gen.t] represent a possibly infinite sequence of values -of type 'a. One can only iterate once on the sequence, as it is consumed -by iteration/deconstruction/access. [None] is returned when the generator -is exhausted. - -The submodule {!Restart} provides utilities to work with -{b restartable generators}, that is, functions [unit -> 'a Gen.t] that -allow to build as many generators from the same source as needed. -*) - -(** {2 Global type declarations} *) - -type 'a t = unit -> 'a option - (** A generator may be called several times, yielding the next value - each time. It returns [None] when no elements remain *) - -type 'a gen = 'a t - -module type S = Gen_intf.S - -(** {2 Transient generators} *) - -val get : 'a t -> 'a option - (** Get the next value *) - -val next : 'a t -> 'a option - (** Synonym for {!get} *) - -val get_exn : 'a t -> 'a - (** Get the next value, or fails - @raise Invalid_argument if no element remains *) - -val junk : 'a t -> unit - (** Drop the next value, discarding it. *) - -val repeatedly : (unit -> 'a) -> 'a t - (** Call the same function an infinite number of times (useful for instance - if the function is a random generator). *) - -include S with type 'a t := 'a gen - (** Operations on {b transient} generators *) - -(** {2 Restartable generators} *) - -module Restart : sig - type 'a t = unit -> 'a gen - - type 'a restartable = 'a t - - include S with type 'a t := 'a restartable - - val cycle : 'a t -> 'a t - (** Cycle through the enum, endlessly. The enum must not be empty. *) - - val lift : ('a gen -> 'b) -> 'a t -> 'b - - val lift2 : ('a gen -> 'b gen -> 'c) -> 'a t -> 'b t -> 'c -end - -(** {2 Utils} *) - -val persistent : 'a t -> 'a Restart.t - (** Store content of the transient generator in memory, to be able to iterate - on it several times later. If possible, consider using combinators - from {!Restart} directly instead. *) - -val persistent_lazy : 'a t -> 'a Restart.t - (** Same as {!persistent}, but consumes the generator on demand (by chunks). - This allows to make a restartable generator out of an ephemeral one, - without paying a big cost upfront (nor even consuming it fully). - @since 0.2.2 *) - -val start : 'a Restart.t -> 'a t - (** Create a new transient generator. - [start gen] is the same as [gen ()] but is included for readability. *) diff --git a/gen/gen.mllib b/gen/gen.mllib deleted file mode 100644 index 79105f52..00000000 --- a/gen/gen.mllib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: f69818d114f140be18d72c90abdc60e8) -Gen -Gen_intf -# OASIS_STOP diff --git a/gen/gen.odocl b/gen/gen.odocl deleted file mode 100644 index 79105f52..00000000 --- a/gen/gen.odocl +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: f69818d114f140be18d72c90abdc60e8) -Gen -Gen_intf -# OASIS_STOP diff --git a/gen/gen_intf.ml b/gen/gen_intf.ml deleted file mode 100644 index 87208338..00000000 --- a/gen/gen_intf.ml +++ /dev/null @@ -1,321 +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 Common signature for transient and restartable generators} - -The signature {!S} abstracts on a type ['a t], where the [t] can be -the type of transient or restartable generators. Some functions specify -explicitely that they use ['a gen] (transient generators). *) - -type 'a gen = unit -> 'a option - -module type S = sig - type 'a t - - val empty : 'a t - (** Empty generator, with no elements *) - - val singleton : 'a -> 'a t - (** One-element generator *) - - val repeat : 'a -> 'a t - (** Repeat same element endlessly *) - - val iterate : 'a -> ('a -> 'a) -> 'a t - (** [iterate x f] is [[x; f x; f (f x); f (f (f x)); ...]] *) - - val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t - (** Dual of {!fold}, with a deconstructing operation. It keeps on - unfolding the ['b] value into a new ['b], and a ['a] which is yielded, - until [None] is returned. *) - - val init : ?limit:int -> (int -> 'a) -> 'a t - (** Calls the function, starting from 0, on increasing indices. - If [limit] is provided and is a positive int, iteration will - stop at the limit (excluded). - For instance [init ~limit:4 id] will yield 0, 1, 2, and 3. *) - - (** {2 Basic combinators} *) - - val is_empty : _ t -> bool - (** Check whether the enum is empty. Pops an element, if any *) - - val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold on the generator, tail-recursively. Consumes the generator. *) - - val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a - (** Fold on non-empty sequences. Consumes the generator. - @raise Invalid_argument on an empty gen *) - - val scan : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t - (** Like {!fold}, but keeping successive values of the accumulator. - Consumes the generator. *) - - val unfold_scan : ('b -> 'a -> 'b * 'c) -> 'b -> 'a t -> 'c t - (** A mix of {!unfold} and {!scan}. The current state is combined with - the current element to produce a new state, and an output value - of type 'c. - @since 0.2.2 *) - - val iter : ('a -> unit) -> 'a t -> unit - (** Iterate on the enum, consumes it. *) - - val iteri : (int -> 'a -> unit) -> 'a t -> unit - (** Iterate on elements with their index in the enum, from 0, consuming it. *) - - val length : _ t -> int - (** Length of an enum (linear time), consuming it *) - - val map : ('a -> 'b) -> 'a t -> 'b t - (** Lazy map. No iteration is performed now, the function will be called - when the result is traversed. *) - - val append : 'a t -> 'a t -> 'a t - (** Append the two enums; the result contains the elements of the first, - then the elements of the second enum. *) - - val flatten : 'a gen t -> 'a t - (** Flatten the enumeration of generators *) - - val flat_map : ('a -> 'b gen) -> 'a t -> 'b t - (** Monadic bind; each element is transformed to a sub-enum - which is then iterated on, before the next element is processed, - and so on. *) - - val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool - (** Is the given element, member of the enum? *) - - val take : int -> 'a t -> 'a t - (** Take at most n elements *) - - val drop : int -> 'a t -> 'a t - (** Drop n elements *) - - val nth : int -> 'a t -> 'a - (** n-th element, or Not_found - @raise Not_found if the generator contains less than [n] arguments *) - - val take_nth : int -> 'a t -> 'a t - (** [take_nth n g] returns every element of [g] whose index - is a multiple of [n]. For instance [take_nth 2 (1--10) |> to_list] - will return [1;3;5;7;9] *) - - val filter : ('a -> bool) -> 'a t -> 'a t - (** Filter out elements that do not satisfy the predicate. *) - - val take_while : ('a -> bool) -> 'a t -> 'a t - (** Take elements while they satisfy the predicate *) - - val drop_while : ('a -> bool) -> 'a t -> 'a t - (** Drop elements while they satisfy the predicate *) - - val filter_map : ('a -> 'b option) -> 'a t -> 'b t - (** Maps some elements to 'b, drop the other ones *) - - val zip_index : 'a t -> (int * 'a) t - (** Zip elements with their index in the enum *) - - val unzip : ('a * 'b) t -> 'a t * 'b t - (** Unzip into two sequences, splitting each pair *) - - val partition : ('a -> bool) -> 'a t -> 'a t * 'a t - (** [partition p l] returns the elements that satisfy [p], - and the elements that do not satisfy [p] *) - - val for_all : ('a -> bool) -> 'a t -> bool - (** Is the predicate true for all elements? *) - - val exists : ('a -> bool) -> 'a t -> bool - (** Is the predicate true for at least one element? *) - - val min : ?lt:('a -> 'a -> bool) -> 'a t -> 'a - (** Minimum element, according to the given comparison function. - @raise Invalid_argument if the generator is empty *) - - val max : ?lt:('a -> 'a -> bool) -> 'a t -> 'a - (** Maximum element, see {!min} - @raise Invalid_argument if the generator is empty *) - - val eq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool - (** Equality of generators. *) - - val lexico : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int - (** Lexicographic comparison of generators. If a generator is a prefix - of the other one, it is considered smaller. *) - - val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int - (** Synonym for {! lexico} *) - - val find : ('a -> bool) -> 'a t -> 'a option - (** [find p e] returns the first element of [e] to satisfy [p], - or None. *) - - val sum : int t -> int - (** Sum of all elements *) - - (** {2 Multiple iterators} *) - - val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t - (** Map on the two sequences. Stops once one of them is exhausted.*) - - val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit - (** Iterate on the two sequences. Stops once one of them is exhausted.*) - - val fold2 : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> 'a t -> 'b t -> 'acc - (** Fold the common prefix of the two iterators *) - - val for_all2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool - (** Succeeds if all pairs of elements satisfy the predicate. - Ignores elements of an iterator if the other runs dry. *) - - val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool - (** Succeeds if some pair of elements satisfy the predicate. - Ignores elements of an iterator if the other runs dry. *) - - val zip_with : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t - (** Combine common part of the enums (stops when one is exhausted) *) - - val zip : 'a t -> 'b t -> ('a * 'b) t - (** Zip together the common part of the enums *) - - (** {2 Complex combinators} *) - - val merge : 'a gen t -> 'a t - (** Pick elements fairly in each sub-generator. The merge of enums - [e1, e2, ... ] picks elements in [e1], [e2], - in [e3], [e1], [e2] .... Once a generator is empty, it is skipped; - when they are all empty, and none remains in the input, - their merge is also empty. - For instance, [merge [1;3;5] [2;4;6]] will be, in disorder, [1;2;3;4;5;6]. *) - - val intersection : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t - (** Intersection of two sorted sequences. Only elements that occur in both - inputs appear in the output *) - - val sorted_merge : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t - (** Merge two sorted sequences into a sorted sequence *) - - val sorted_merge_n : ?cmp:('a -> 'a -> int) -> 'a t list -> 'a t - (** Sorted merge of multiple sorted sequences *) - - val tee : ?n:int -> 'a t -> 'a gen list - (** Duplicate the enum into [n] generators (default 2). The generators - share the same underlying instance of the enum, so the optimal case is - when they are consumed evenly *) - - val round_robin : ?n:int -> 'a t -> 'a gen list - (** Split the enum into [n] generators in a fair way. Elements with - [index = k mod n] with go to the k-th enum. [n] default value - is 2. *) - - val interleave : 'a t -> 'a t -> 'a t - (** [interleave a b] yields an element of [a], then an element of [b], - and so on. When a generator is exhausted, this behaves like the - other generator. *) - - val intersperse : 'a -> 'a t -> 'a t - (** Put the separator element between all elements of the given enum *) - - val product : 'a t -> 'b t -> ('a * 'b) t - (** Cartesian product, in no predictable order. Works even if some of the - arguments are infinite. *) - - val group : ?eq:('a -> 'a -> bool) -> 'a t -> 'a list t - (** Group equal consecutive elements together. *) - - val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t - (** Remove consecutive duplicate elements. Basically this is - like [fun e -> map List.hd (group e)]. *) - - val sort : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t - (** Sort according to the given comparison function. The enum must be finite. *) - - val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t - (** Sort and remove duplicates. The enum must be finite. *) - - val chunks : int -> 'a t -> 'a array t - (** [chunks n e] returns a generator of arrays of length [n], composed - of successive elements of [e]. The last array may be smaller - than [n] *) - - val permutations : 'a t -> 'a list t - (** Permutations of the enum. - @since 0.2.2 *) - - val combinations : int -> 'a t -> 'a list t - (** Combinations of given length. The ordering of the elements within - each combination is unspecified. - Example (ignoring ordering): - [combinations 2 (1--3) |> to_list = [[1;2]; [1;3]; [2;3]]] - @since 0.2.2 *) - - val power_set : 'a t -> 'a list t - (** All subsets of the enum (in no particular order). The ordering of - the elements within each subset is unspecified. - @since 0.2.2 *) - - (** {2 Basic conversion functions} *) - - val of_list : 'a list -> 'a t - (** Enumerate elements of the list *) - - val to_list : 'a t -> 'a list - (** non tail-call trasnformation to list, in the same order *) - - val to_rev_list : 'a t -> 'a list - (** Tail call conversion to list, in reverse order (more efficient) *) - - val to_array : 'a t -> 'a array - (** Convert the enum to an array (not very efficient) *) - - val of_array : ?start:int -> ?len:int -> 'a array -> 'a t - (** Iterate on (a slice of) the given array *) - - val rand_int : int -> int t - (** Random ints in the given range. *) - - val int_range : int -> int -> int t - (** [int_range a b] enumerates integers between [a] and [b], included. [a] - is assumed to be smaller than [b]. *) - - module Infix : sig - val (--) : int -> int -> int t - (** Synonym for {! int_range} *) - - val (>>=) : 'a t -> ('a -> 'b gen) -> 'b t - (** Monadic bind operator *) - end - - val (--) : int -> int -> int t - (** Synonym for {! int_range} *) - - val (>>=) : 'a t -> ('a -> 'b gen) -> 'b t - (** Monadic bind operator *) - - val pp : ?start:string -> ?stop:string -> ?sep:string -> ?horizontal:bool -> - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - (** Pretty print the content of the generator on a formatter. *) -end - diff --git a/gen/myocamlbuild.ml b/gen/myocamlbuild.ml deleted file mode 100644 index 57fcede3..00000000 --- a/gen/myocamlbuild.ml +++ /dev/null @@ -1,623 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: 8b03085ed54d5ff9a8cbd756150607bd) *) -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 - - type conf = - { no_automatic_syntax: bool; - } - - (* 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 (exec_from_conf "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 conf = - 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"; - - if not (conf.no_automatic_syntax) then begin - (* 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, pargs) = - (* 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, syn_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; - - (* TODO: Check if this is allowed for OCaml < 3.12.1 *) - flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; - end - (find_packages ()); - end; - - (* 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. - This holds both for programs and for libraries. - *) - dep ["link"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - dep ["compile"; "ocaml"; 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 conf t = - dispatch_combine - [ - dispatch t; - MyOCamlbuildFindlib.dispatch conf; - ] - - -end - - -# 606 "myocamlbuild.ml" -open Ocamlbuild_plugin;; -let package_default = - { - MyOCamlbuildBase.lib_ocaml = [("gen", [], [])]; - lib_c = []; - flags = []; - includes = [] - } - ;; - -let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} - -let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; - -# 622 "myocamlbuild.ml" -(* OASIS_STOP *) -Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/gen/setup.ml b/gen/setup.ml deleted file mode 100644 index fe876747..00000000 --- a/gen/setup.ml +++ /dev/null @@ -1,7150 +0,0 @@ -(* setup.ml generated for the first time by OASIS v0.4.0 *) - -(* OASIS_START *) -(* DO NOT EDIT (digest: 751af72d4e295f56a78e6ed6d61afa74) *) -(* - Regenerated by OASIS v0.4.5 - 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 = Buffer.create (String.length s) in - String.iter (fun c -> Buffer.add_char buf (f c)) s; - Buffer.contents 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.") - - let no_automatic_syntax = - create "no_automatic_syntax" alpha - (fun () -> - s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ - that matches the internal heuristic (if a dependency ends with \ - a .syntax or is a well known syntax).") -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 .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 - - (* The headers and annot/cmt files that should be compiled along *) - let headers = - let sufx = - if lib.lib_pack - then [".cmti"; ".cmt"; ".annot"] - else [".cmi"; ".cmti"; ".cmt"; ".annot"] - in - List.map - begin - List.fold_left - begin fun accu s -> - let dot = String.rindex s '.' in - let base = String.sub s 0 dot in - List.map ((^) base) sufx @ accu - end - [] - end - (find_modules lib.lib_modules "cmi") - 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"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: 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 begin - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty - end - 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 - - -# 2893 "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 - - -# 2998 "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 - - -# 5409 "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 - - let make_fnames modul sufx = - List.fold_right - begin fun sufx accu -> - (String.capitalize modul ^ sufx) :: - (String.uncapitalize modul ^ sufx) :: - accu - end - sufx - [] - 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 - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ 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 - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ 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 - - -# 6273 "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 (tests ()) then - ["-tag"; "tests"] - 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 - - -# 6651 "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 - - -# 6799 "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", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - doc = - [ - ("gen", - 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", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - clean_doc = - [ - ("gen", - OCamlbuildDocPlugin.doc_clean - {OCamlbuildDocPlugin.extra_args = []; run_path = "."}) - ]; - distclean = []; - distclean_test = - [ - ("all", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - distclean_doc = []; - package = - { - oasis_version = "0.3"; - ocaml_version = None; - findlib_version = None; - alpha_features = []; - beta_features = []; - name = "gen"; - version = "0.2.2"; - license = - OASISLicense.DEP5License - (OASISLicense.DEP5Unit - { - OASISLicense.license = "BSD-3-clause"; - excption = None; - version = OASISLicense.NoVersion - }); - license_file = Some "LICENSE"; - copyrights = []; - maintainers = []; - authors = ["Simon Cruanes"]; - homepage = Some "https://github.com/c-cube/gen"; - synopsis = "Simple, efficient iterators for OCaml"; - description = None; - 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, Some (("make", ["qtest-gen"])))]; - 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 "build benchmark"; - flag_default = [(OASISExpr.EBool true, false)] - }); - Library - ({ - cs_name = "gen"; - 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 = ["Gen"; "Gen_intf"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = None; - lib_findlib_containers = [] - }); - Doc - ({ - cs_name = "gen"; - 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 = "Containers 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 "gen"; - 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"}); - Executable - ({ - cs_name = "run_qtest"; - 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 = "qtest/"; - bs_compiled_object = Native; - bs_build_depends = - [ - FindlibPackage ("containers", None); - FindlibPackage ("containers.misc", None); - FindlibPackage ("containers.string", None); - FindlibPackage ("oUnit", None); - FindlibPackage ("QTest2Lib", 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_qtest.ml"}); - Test - ({ - cs_name = "all"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - test_type = (`Test, "custom", Some "0.4"); - test_command = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - 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"; - InternalExecutable "run_qtest" - ] - }); - 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 "gen"; - 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" - }); - SrcRepo - ({ - cs_name = "head"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - src_repo_type = Git; - src_repo_location = "https://github.com/c-cube/gen"; - src_repo_browser = - Some "https://github.com/c-cube/gen/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.5"; - oasis_digest = Some "&R\193\241\164\161\179\006\021\1643N\0163\245K"; - oasis_exec = None; - oasis_setup_args = []; - setup_update = false - };; - -let setup () = BaseSetup.setup setup_t;; - -# 7149 "setup.ml" -(* OASIS_STOP *) -let () = setup ();; diff --git a/gen/tests/run_tests.ml b/gen/tests/run_tests.ml deleted file mode 100644 index 19afd2ed..00000000 --- a/gen/tests/run_tests.ml +++ /dev/null @@ -1,4 +0,0 @@ - -let () = - let _ = OUnit.run_test_tt_main Test_gen.suite in - () diff --git a/gen/tests/test_gen.ml b/gen/tests/test_gen.ml deleted file mode 100644 index fc968ab1..00000000 --- a/gen/tests/test_gen.ml +++ /dev/null @@ -1,146 +0,0 @@ - -open OUnit -open Gen.Infix - -module GR = Gen.Restart - -let pint i = string_of_int i -let pilist l = - let b = Buffer.create 15 in - let fmt = Format.formatter_of_buffer b in - Format.fprintf fmt "%a@?" - (Gen.pp Format.pp_print_int) (Gen.of_list l); - Buffer.contents b -let pi2list l = - let b = Buffer.create 15 in - let fmt = Format.formatter_of_buffer b in - Format.fprintf fmt "%a@?" - (Gen.pp (fun fmt (a,b) -> Format.fprintf fmt "%d,%d" a b)) - (Gen.of_list l); - Buffer.contents b -let pstrlist l = - let b = Buffer.create 15 in - let fmt = Format.formatter_of_buffer b in - Format.fprintf fmt "%a@?" - (Gen.pp Format.pp_print_string) (Gen.of_list l); - Buffer.contents b - -let test_singleton () = - let gen = Gen.singleton 42 in - OUnit.assert_equal (Some 42) (Gen.get gen); - OUnit.assert_equal None (Gen.get gen); - let gen = Gen.singleton 42 in - OUnit.assert_equal 1 (Gen.length gen); - () - -let test_iter () = - let e = GR.(1 -- 10) in - OUnit.assert_equal ~printer:pint 10 (GR.length e); - OUnit.assert_equal [1;2] GR.(to_list (1 -- 2)); - OUnit.assert_equal [1;2;3;4;5] (GR.to_list (GR.take 5 e)); - () - -let test_map () = - let e = 1 -- 10 in - let e' = Gen.map string_of_int e in - OUnit.assert_equal ~printer:pstrlist ["9"; "10"] (Gen.to_list (Gen.drop 8 e')); - () - -let test_append () = - let e = Gen.append (1 -- 5) (6 -- 10) in - OUnit.assert_equal [10;9;8;7;6;5;4;3;2;1] (Gen.to_rev_list e); - () - -let test_flat_map () = - let e = 1 -- 3 in - let e' = e >>= (fun x -> x -- (x+1)) in - OUnit.assert_equal [1;2;2;3;3;4] (Gen.to_list e'); - () - -let test_zip () = - let e = Gen.zip_with (+) (Gen.repeat 1) (4--7) in - OUnit.assert_equal [5;6;7;8] (Gen.to_list e); - () - -let test_filter_map () = - let f x = if x mod 2 = 0 then Some (string_of_int x) else None in - let e = Gen.filter_map f (1 -- 10) in - OUnit.assert_equal ["2"; "4"; "6"; "8"; "10"] (Gen.to_list e); - () - -let test_merge () = - let e = Gen.of_list [1--3; 4--6; 7--9] in - let e' = Gen.merge e in - OUnit.assert_equal [1;2;3;4;5;6;7;8;9] (Gen.to_list e' |> List.sort compare); - () - -let test_persistent () = - let i = ref 0 in - let gen () = - let j = !i in - if j > 5 then None else (incr i; Some j) - in - let e = Gen.persistent gen in - OUnit.assert_equal [0;1;2;3;4;5] (GR.to_list e); - OUnit.assert_equal [0;1;2;3;4;5] (GR.to_list e); - OUnit.assert_equal [0;1;2;3;4;5] (GR.to_list e); - () - -let test_round_robin () = - let e = GR.round_robin ~n:2 GR.(1--10) in - match e with - | [a;b] -> - OUnit.assert_equal [1;3;5;7;9] (Gen.to_list a); - OUnit.assert_equal [2;4;6;8;10] (Gen.to_list b) - | _ -> OUnit.assert_failure "wrong list lenght" - -let test_big_rr () = - let e = GR.round_robin ~n:3 GR.(1 -- 999) in - let l = List.map Gen.length e in - OUnit.assert_equal [333;333;333] l; - () - -let test_merge_sorted () = - [Gen.of_list [1;3;5]; Gen.of_list [0;1;1;3;4;6;10]; Gen.of_list [2;2;11]] - |> Gen.sorted_merge_n ?cmp:None - |> Gen.to_list - |> OUnit.assert_equal ~printer:pilist [0;1;1;1;2;2;3;3;4;5;6;10;11] - -let test_interleave () = - let e1 = Gen.of_list [1;3;5;7;9] in - let e2 = Gen.of_list [2;4;6;8;10] in - let e = Gen.interleave e1 e2 in - OUnit.assert_equal [1;2;3;4;5;6;7;8;9;10] (Gen.to_list e); - () - -let test_intersperse () = - let e = 1 -- 5 in - let e' = Gen.intersperse 0 e in - OUnit.assert_equal [1;0;2;0;3;0;4;0;5] (Gen.to_list e'); - () - -let test_product () = - let printer = pi2list in - let e = Gen.product (1--3) (4--5) in - OUnit.assert_equal ~printer [1,4; 1,5; 2,4; 2,5; 3,4; 3,5] - (List.sort compare (Gen.to_list e)); - () - -let suite = - "test_gen" >::: - [ "test_singleton" >:: test_singleton; - "test_iter" >:: test_iter; - "test_map" >:: test_map; - "test_append" >:: test_append; - "test_flat_map" >:: test_flat_map; - "test_zip" >:: test_zip; - "test_filter_map" >:: test_filter_map; - "test_merge" >:: test_merge; - "test_persistent" >:: test_persistent; - "test_round_robin" >:: test_round_robin; - "test_big_rr" >:: test_big_rr; - "test_merge_sorted" >:: test_merge_sorted; - "test_interleave" >:: test_interleave; - "test_intersperse" >:: test_intersperse; - "test_product" >:: test_product; - ] diff --git a/sequence/.gitignore b/sequence/.gitignore deleted file mode 100644 index 96cadb3a..00000000 --- a/sequence/.gitignore +++ /dev/null @@ -1,9 +0,0 @@ -.*.swp -_build -*.native -*.docdir -*.html -man/ -sequence.install -setup.log -setup.data diff --git a/sequence/.merlin b/sequence/.merlin deleted file mode 100644 index d9043276..00000000 --- a/sequence/.merlin +++ /dev/null @@ -1,9 +0,0 @@ -S . -S bench/ -S tests/ -B _build -B _build/tests/ -B _build/bench/ -PKG oUnit -PKG benchmark -FLAG -safe-string diff --git a/sequence/.ocamlinit b/sequence/.ocamlinit deleted file mode 100644 index 7123b8dc..00000000 --- a/sequence/.ocamlinit +++ /dev/null @@ -1,9 +0,0 @@ -#directory "_build";; -#load "sequence.cma";; - -open Sequence.Infix;; - -#directory "_build/bigarray/";; -#load "bigarray.cma";; - -(* vim:syntax=ocaml *) diff --git a/sequence/CHANGELOG.md b/sequence/CHANGELOG.md deleted file mode 100644 index 08c0e5a1..00000000 --- a/sequence/CHANGELOG.md +++ /dev/null @@ -1,65 +0,0 @@ -# Changelog - -## 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/sequence/LICENSE b/sequence/LICENSE deleted file mode 100644 index 7e29992c..00000000 --- a/sequence/LICENSE +++ /dev/null @@ -1,22 +0,0 @@ -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/sequence/META b/sequence/META deleted file mode 100644 index e2f9a7da..00000000 --- a/sequence/META +++ /dev/null @@ -1,11 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 1e28d93f3671e8db9acf63b73cdbca82) -version = "0.4.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" -# OASIS_STOP - diff --git a/sequence/Makefile b/sequence/Makefile deleted file mode 100644 index db135eec..00000000 --- a/sequence/Makefile +++ /dev/null @@ -1,67 +0,0 @@ -# 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/sequence/README.md b/sequence/README.md deleted file mode 100644 index 0ca32192..00000000 --- a/sequence/README.md +++ /dev/null @@ -1,50 +0,0 @@ -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/sequence/_oasis b/sequence/_oasis deleted file mode 100644 index b84e7253..00000000 --- a/sequence/_oasis +++ /dev/null @@ -1,102 +0,0 @@ -OASISFormat: 0.4 -Name: sequence -Version: dev -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 - -Flag bigarray - Description: build sequence.bigarray (requires bigarray) - Default: true - -Library "sequence" - Path: . - Modules: Sequence - BuildDepends: bytes - -Library "invert" - Path: invert - Build$: flag(invert) - Install$: flag(invert) - Modules: SequenceInvert - FindlibName: invert - FindlibParent: sequence - BuildDepends: sequence,delimcc - -Library "bigarray" - Path: bigarray - Build$: flag(bigarray) - Install$: flag(bigarray) - Modules: SequenceBigarray - FindlibName: bigarray - FindlibParent: sequence - BuildDepends: sequence,bigarray - -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/sequence/_tags b/sequence/_tags deleted file mode 100644 index a9971c20..00000000 --- a/sequence/_tags +++ /dev/null @@ -1,31 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: ffd3fbaf00b431777fea1b8279203bf9) -# 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 -# 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 -<**/*.ml>: warn_A, warn(-4) diff --git a/sequence/bench/bench_persistent.ml b/sequence/bench/bench_persistent.ml deleted file mode 100644 index 022b6b37..00000000 --- a/sequence/bench/bench_persistent.ml +++ /dev/null @@ -1,128 +0,0 @@ -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/sequence/bench/bench_persistent_read.ml b/sequence/bench/bench_persistent_read.ml deleted file mode 100644 index 8e0dea66..00000000 --- a/sequence/bench/bench_persistent_read.ml +++ /dev/null @@ -1,139 +0,0 @@ -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/sequence/bench/benchs.ml b/sequence/bench/benchs.ml deleted file mode 100644 index af8b5db9..00000000 --- a/sequence/bench/benchs.ml +++ /dev/null @@ -1,34 +0,0 @@ - -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/sequence/bench/simple_bench.ml b/sequence/bench/simple_bench.ml deleted file mode 100644 index 96611d7b..00000000 --- a/sequence/bench/simple_bench.ml +++ /dev/null @@ -1,11 +0,0 @@ - -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/sequence/bigarray/sequenceBigarray.ml b/sequence/bigarray/sequenceBigarray.ml deleted file mode 100644 index fd61b86b..00000000 --- a/sequence/bigarray/sequenceBigarray.ml +++ /dev/null @@ -1,45 +0,0 @@ -(* -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 and Helpers for bigarrays} *) - -let of_bigarray b yield = - let len = Bigarray.Array1.dim b in - for i=0 to len-1 do - yield b.{i} - done - -let mmap filename = - fun yield -> - let fd = Unix.openfile filename [Unix.O_RDONLY] 0 in - let len = Unix.lseek fd 0 Unix.SEEK_END in - let _ = Unix.lseek fd 0 Unix.SEEK_SET in - let b = Bigarray.Array1.map_file fd Bigarray.Char Bigarray.C_layout false len in - try - of_bigarray b yield; - Unix.close fd - with e -> - Unix.close fd; - raise e diff --git a/sequence/bigarray/sequenceBigarray.mli b/sequence/bigarray/sequenceBigarray.mli deleted file mode 100644 index a9c78808..00000000 --- a/sequence/bigarray/sequenceBigarray.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* -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 and Helpers for bigarrays} - -@since 0.5.4 *) - -val of_bigarray : ('a, _, _) Bigarray.Array1.t -> 'a Sequence.t -(** Iterate on the elements of a 1-D array *) - -val mmap : string -> char Sequence.t -(** Map the file into memory, and read the characters. *) diff --git a/sequence/configure b/sequence/configure deleted file mode 100755 index 6acfaeb9..00000000 --- a/sequence/configure +++ /dev/null @@ -1,27 +0,0 @@ -#!/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/sequence/examples/sexpr.ml b/sequence/examples/sexpr.ml deleted file mode 100644 index 615f468d..00000000 --- a/sequence/examples/sexpr.ml +++ /dev/null @@ -1,305 +0,0 @@ -(* -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/sequence/examples/sexpr.mli b/sequence/examples/sexpr.mli deleted file mode 100644 index 6a8a53c0..00000000 --- a/sequence/examples/sexpr.mli +++ /dev/null @@ -1,132 +0,0 @@ -(* -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/sequence/examples/test_sexpr.ml b/sequence/examples/test_sexpr.ml deleted file mode 100644 index 75de0685..00000000 --- a/sequence/examples/test_sexpr.ml +++ /dev/null @@ -1,131 +0,0 @@ - -(** {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/sequence/invert/.merlin b/sequence/invert/.merlin deleted file mode 100644 index 3b9a31d9..00000000 --- a/sequence/invert/.merlin +++ /dev/null @@ -1,2 +0,0 @@ -REC -PKG delimcc diff --git a/sequence/invert/sequenceInvert.ml b/sequence/invert/sequenceInvert.ml deleted file mode 100644 index 46efc693..00000000 --- a/sequence/invert/sequenceInvert.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* -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/sequence/invert/sequenceInvert.mli b/sequence/invert/sequenceInvert.mli deleted file mode 100644 index bd3c8433..00000000 --- a/sequence/invert/sequenceInvert.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* -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/sequence/myocamlbuild.ml b/sequence/myocamlbuild.ml deleted file mode 100644 index 1f969666..00000000 --- a/sequence/myocamlbuild.ml +++ /dev/null @@ -1,609 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: 958ece46307b808952e439e1cc47a739) *) -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", [], [])]; - lib_c = []; - flags = []; - includes = [] - } - ;; - -let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; - -# 608 "myocamlbuild.ml" -(* OASIS_STOP *) -Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/sequence/sequence.ml b/sequence/sequence.ml deleted file mode 100644 index 6c6bd3b8..00000000 --- a/sequence/sequence.ml +++ /dev/null @@ -1,787 +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 - -let rec from_fun f k = match f () with - | None -> () - | Some x -> k x; from_fun f k - -let empty _ = () - -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 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, _, _) -> - 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, _, _) -> `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 ExitHead - -let head seq = - let r = ref None in - try - seq (fun x -> r := Some x; raise ExitHead); None - with ExitHead -> !r - -let head_exn seq = - match head seq with - | None -> invalid_arg "Sequence.head_exn" - | Some x -> x - -exception ExitTake - -let take n seq k = - let count = ref 0 in - try - seq (fun x -> - if !count = n then raise ExitTake; - incr count; - k x; - ) - with ExitTake -> () - -exception ExitTakeWhile - -let take_while p seq k = - try - seq (fun x -> if p x then k x else raise ExitTakeWhile) - with ExitTakeWhile -> () - -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 - -exception ExitForall - -let for_all p seq = - try - seq (fun x -> if not (p x) then raise ExitForall); - true - with ExitForall -> false - -exception ExitExists - -(** Exists there some element satisfying the predicate? *) -let exists p seq = - try - seq (fun x -> if p x then raise ExitExists); - false - with ExitExists -> true - -let mem ?(eq=(=)) x seq = exists (eq x) seq - -exception ExitFind - -let find f seq = - let r = ref None in - begin try - seq (fun x -> match f x with - | None -> () - | Some _ as res -> r := res; raise ExitFind - ); - with ExitFind -> () - end; - !r - -let length seq = - let r = ref 0 in - seq (fun _ -> incr r); - !r - -exception ExitIsEmpty - -let is_empty seq = - try seq (fun _ -> raise ExitIsEmpty); true - with ExitIsEmpty -> false - -(** {2 Transform a sequence} *) - -let empty2 _ = () - -let is_empty2 seq2 = - try ignore (seq2 (fun _ _ -> raise ExitIsEmpty)); true - with ExitIsEmpty -> 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 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 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 _ -> k a) h - -let hashtbl_values h k = Hashtbl.iter (fun _ 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) : S with type elt = X.elt and type t = X.t = 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 to_list set = to_list (to_seq set) - - include X - - let of_list l = List.fold_left (fun set x -> add x set) empty l - 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 = Bytes.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 (Bytes.sub_string buf 0 !n) - done; - close_in ic - with e -> - close_in_noerr ic; - raise e - - let write_bytes_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 (Bytes.length s)); - close_out oc - with e -> - close_out oc; - raise e - - let write_to ?mode ?flags filename seq = - write_bytes_to ?mode ?flags filename (map Bytes.unsafe_of_string seq) - - let write_bytes_lines ?mode ?flags filename seq = - let ret = Bytes.unsafe_of_string "\n" in - write_bytes_to ?mode ?flags filename (snoc (intersperse ret seq) ret) - - let write_lines ?mode ?flags filename seq = - write_bytes_lines ?mode ?flags filename (map Bytes.unsafe_of_string seq) -end diff --git a/sequence/sequence.mldylib b/sequence/sequence.mldylib deleted file mode 100644 index 2f635d2a..00000000 --- a/sequence/sequence.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5) -Sequence -# OASIS_STOP diff --git a/sequence/sequence.mli b/sequence/sequence.mli deleted file mode 100644 index 677f79ce..00000000 --- a/sequence/sequence.mli +++ /dev/null @@ -1,606 +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 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 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 *) - -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");; -]} - -Read the lines of a file into a list: - -{[ - Sequence.IO.lines "a" |> Sequence.to_list -]} - -@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_bytes_to : ?mode:int -> ?flags:open_flag list -> - string -> Bytes.t t -> unit - (** @since 0.5.4 *) - - val write_lines : ?mode:int -> ?flags:open_flag list -> - string -> string t -> unit - (** Same as {!write_to}, but intercales ['\n'] between each string *) - - val write_bytes_lines : ?mode:int -> ?flags:open_flag list -> - string -> Bytes.t t -> unit - (** @since 0.5.4 *) -end diff --git a/sequence/sequence.mllib b/sequence/sequence.mllib deleted file mode 100644 index 2f635d2a..00000000 --- a/sequence/sequence.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5) -Sequence -# OASIS_STOP diff --git a/sequence/sequence.odocl b/sequence/sequence.odocl deleted file mode 100644 index 2f635d2a..00000000 --- a/sequence/sequence.odocl +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5) -Sequence -# OASIS_STOP diff --git a/sequence/setup.ml b/sequence/setup.ml deleted file mode 100644 index fe8169fe..00000000 --- a/sequence/setup.ml +++ /dev/null @@ -1,37 +0,0 @@ -(* setup.ml generated for the first time by OASIS v0.4.4 *) - -(* OASIS_START *) -(* DO NOT EDIT (digest: 9852805d5c19ca1cb6abefde2dcea323) *) -(******************************************************************************) -(* OASIS: architecture for building OCaml libraries and applications *) -(* *) -(* Copyright (C) 2011-2013, Sylvain Le Gall *) -(* Copyright (C) 2008-2011, OCamlCore SARL *) -(* *) -(* This library is free software; you can redistribute it and/or modify it *) -(* under the terms of the GNU Lesser General Public License as published by *) -(* the Free Software Foundation; either version 2.1 of the License, or (at *) -(* your option) any later version, with the OCaml static compilation *) -(* exception. *) -(* *) -(* This library 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 file COPYING for more *) -(* details. *) -(* *) -(* You should have received a copy of the GNU Lesser General Public License *) -(* along with this library; if not, write to the Free Software Foundation, *) -(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) -(******************************************************************************) - -let () = - try - Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") - with Not_found -> () -;; -#use "topfind";; -#require "oasis.dynrun";; -open OASISDynRun;; - -(* OASIS_STOP *) -let () = setup ();; diff --git a/sequence/tests/run_tests.ml b/sequence/tests/run_tests.ml deleted file mode 100644 index 0fa3d58c..00000000 --- a/sequence/tests/run_tests.ml +++ /dev/null @@ -1,9 +0,0 @@ - -open OUnit - -let suite = - "run_tests" >::: - [ Test_sequence.suite; ] - -let _ = - OUnit.run_test_tt_main suite diff --git a/sequence/tests/test_sequence.ml b/sequence/tests/test_sequence.ml deleted file mode 100644 index 30f0f1c9..00000000 --- a/sequence/tests/test_sequence.ml +++ /dev/null @@ -1,235 +0,0 @@ - -open OUnit - -module S = Sequence - -let pp_ilist l = - let b = Buffer.create 15 in - let fmt = Format.formatter_of_buffer b in - Format.fprintf fmt "@[%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 = S.(1 -- 5) in - let s2 = S.(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 = S.(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 () = - S.(1 -- 100) - |> S.exists (fun x -> x = 59) - |> OUnit.assert_bool "exists"; - S.(1 -- 100) - |> S.exists (fun x -> x < 0) - |> (fun x -> not x) - |> OUnit.assert_bool "not exists"; - () - -let test_length () = - S.(1 -- 1000) |> S.length |> OUnit.assert_equal 1000 - -let test_concat2 () = - S.(1 -- 1000) - |> S.map (fun i -> S.(i -- (i+1))) - |> S.concat - |> S.length - |> OUnit.assert_equal 2000 - -let test_flatMap () = - S.(1 -- 1000) - |> S.flatMap (fun i -> S.(i -- (i+1))) - |> S.length - |> OUnit.assert_equal 2000 - -let test_intersperse () = - S.(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 = S.(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 () = - S.(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 ?cmp:None - |> 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 ?eq:None |> 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 ?eq:None |> 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 = S.(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 () = - S.(1 -- 5) - |> S.scan (+) 0 - |> S.to_list - |> OUnit.assert_equal ~printer:pp_ilist [0;1;3;6;10;15] - -let test_drop () = - S.(1 -- 5) |> S.drop 2 |> S.to_list |> OUnit.assert_equal [3;4;5] - -let test_rev () = - S.(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 = S.(1 -- 5) - |> S.zip_i - |> S.to_hashtbl2 in - S.(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 ?cmp:None |> 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 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 test_regression1 () = - let s = S.(take 10 (repeat 1)) in - OUnit.assert_bool "not empty" (not (S.is_empty s)); - () - -let suite = - "test_sequence" >::: - [ "test_empty" >:: test_empty; - "test_repeat" >:: test_repeat; - "test_concat" >:: test_concat; - "test_concat2" >:: test_concat2; - "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; - "test_take" >:: test_take; - "test_regression1" >:: test_regression1; - ]