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