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