diff --git a/.merlin b/.merlin index 33392d20..d5a2d81a 100644 --- a/.merlin +++ b/.merlin @@ -1,20 +1,37 @@ -S core -S misc -S string -S pervasives -S tests -S examples +S src/core +S src/data/ +S src/io +S src/iter/ +S src/advanced/ +S src/lwt/ +S src/sexp/ +S src/threads/ +S src/misc +S src/string +S src/bigarray +S src/pervasives S benchs -B _build/core -B _build/misc -B _build/string -B _build/pervasives -B _build/tests +S examples +S tests +B _build/src/core +B _build/src/data/ +B _build/src/io +B _build/src/iter/ +B _build/src/advanced/ +B _build/src/lwt/ +B _build/src/sexp/ +B _build/src/threads/ +B _build/src/misc +B _build/src/string +B _build/src/bigarray +B _build/src/pervasives +B _build/benchs B _build/examples -B _build/benchs/ +B _build/tests PKG oUnit PKG benchmark PKG threads PKG threads.posix PKG lwt +PKG bigarray FLG -w +a -w -4 -w -44 diff --git a/.ocamlinit b/.ocamlinit index 4bc62be7..2d7217dd 100644 --- a/.ocamlinit +++ b/.ocamlinit @@ -1,24 +1,29 @@ #use "topfind";; #thread -#directory "_build/core";; -#directory "_build/misc";; -#directory "_build/pervasives/";; -#directory "_build/string";; -#directory "_build/threads";; +#require "bigarray";; +#directory "_build/src/core";; +#directory "_build/src/misc";; +#directory "_build/src/pervasives/";; +#directory "_build/src/string";; +#directory "_build/src/io";; +#directory "_build/src/iter";; +#directory "_build/src/data";; +#directory "_build/src/sexp";; +#directory "_build/src/bigarray/";; +#directory "_build/src/threads";; #directory "_build/tests/";; #load "containers.cma";; +#load "containers_iter.cma";; +#load "containers_data.cma";; +#load "containers_io.cma";; +#load "containers_sexp.cma";; #load "containers_string.cma";; #load "containers_pervasives.cma";; +#load "containers_bigarray.cma";; #load "containers_misc.cma";; #thread;; #load "containers_thread.cma";; open Containers_misc;; -#install_printer Sexp.print;; -#install_printer Bencode.pretty;; -#install_printer HGraph.Default.fmt;; -#require "CamlGI";; -#load "containers_cgi.cma";; -let pp_html fmt h = Format.pp_print_string fmt (ToWeb.HTML.render h);; -#install_printer pp_html;; +#install_printer CCSexp.print;; (* vim:syntax=ocaml: *) diff --git a/AUTHORS.md b/AUTHORS.md index 3c8c8d77..39b3731c 100644 --- a/AUTHORS.md +++ b/AUTHORS.md @@ -7,3 +7,4 @@ - Whitequark (Peter Zotov) - hcarty (Hezekiah M. Carty) - struktured (Carmelo Piccione) +- Bernardo da Costa diff --git a/CHANGELOG.md b/CHANGELOG.md index f931d873..22355ab8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,35 @@ # Changelog +## 0.7 + +### breaking + +- remove `cgi`/ +- removed useless Lwt-related module +- remove `CCGen` and `CCsequence` (use the separate libraries) +- split the library into smaller pieces (with `containers.io`, `containers.iter`, + `containers.sexp`, `containers.data`) + +#### other changes + +- cleanup: move sub-libraries to their own subdir each; mv everything into `src/` +- `sexp`: + * `CCSexp` now splitted into `CCSexp` (manipulating expressions) and `CCSexpStream` + * add `CCSexpM` for a simpler, monadic parser of S-expressions (deprecating `CCSexpStream`) +- `core`: + * `CCString.fold` + * `CCstring.suffix` + * more efficient `CCString.init` + * fix errors in documentation of `CCString` (slightly over-reaching sed) + * add `CCFloat.{fsign, sign_exn}` (thanks @bernardofpc) +- new `containers.bigarray`, with `CCBigstring` +- `CCHashtbl.map_list` +- `io`: + * `CCIO.read_all` now with ?size parameter + * use `Bytes.extend` (praise modernity!) + * bugfix in `CCIO.read_all` and `CCIO.read_chunks` +- use `-no-alias-deps` + ## 0.6.1 - use subtree `gen/` for `CCGen` (symlink) rather than a copy. diff --git a/Makefile b/Makefile index 7f42347e..3796bae5 100644 --- a/Makefile +++ b/Makefile @@ -54,12 +54,24 @@ push_doc: doc scp -r containers_misc.docdir/* cedeela.fr:~/simon/root/software/containers/misc/ scp -r containers_lwt.docdir/* cedeela.fr:~/simon/root/software/containers/lwt/ -DONTTEST=myocamlbuild.ml setup.ml $(wildcard **/*.cppo*) +DONTTEST=myocamlbuild.ml setup.ml $(wildcard src/**/*.cppo.*) QTESTABLE=$(filter-out $(DONTTEST), \ - $(wildcard core/*.ml) $(wildcard core/*.mli) \ - $(wildcard core/*.cppo.ml) $(wildcard core/*.cppo.mli) \ - $(wildcard misc/*.ml) $(wildcard misc/*.mli) \ - $(wildcard string/*.ml) $(wildcard string/*.mli) \ + $(wildcard src/core/*.ml) \ + $(wildcard src/core/*.mli) \ + $(wildcard src/data/*.ml) \ + $(wildcard src/data/*.mli) \ + $(wildcard src/string/*.ml) \ + $(wildcard src/string/*.mli) \ + $(wildcard src/io/*.ml) \ + $(wildcard src/io/*.mli) \ + $(wildcard src/sexp/*.ml) \ + $(wildcard src/sexp/*.mli) \ + $(wildcard src/advanced/*.ml) \ + $(wildcard src/advanced/*.mli) \ + $(wildcard src/iter/*.ml) \ + $(wildcard src/iter/*.mli) \ + $(wildcard src/bigarray/*.ml) \ + $(wildcard src/bigarray/*.mli) \ ) qtest-clean: @@ -78,11 +90,11 @@ QTEST_PREAMBLE='open CCFun;; ' qtest-gen: qtest-clean @mkdir -p qtest - @if which qtest ; then \ + @if which qtest > /dev/null ; then \ qtest extract --preamble $(QTEST_PREAMBLE) \ - -o qtest/run_qtest.cppo.ml \ + -o qtest/run_qtest.ml \ $(QTESTABLE) 2> /dev/null ; \ - else touch qtest/run_qtest.cppo.ml ; \ + else touch qtest/run_qtest.ml ; \ fi push-stable: @@ -109,11 +121,10 @@ 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 + zsh -c 'sed -i "s/NEXT_VERSION/$(VERSION)/g" **/*.ml **/*.mli' + zsh -c 'sed -i "s/NEXT_RELEASE/$(VERSION)/g" **/*.ml **/*.mli' udpate_sequence: git subtree pull --prefix sequence sequence stable --squash .PHONY: examples push_doc tags qtest clean update_sequence update_next_tag push-stable clean-generated - diff --git a/README.md b/README.md index bdd26862..71e8ecde 100644 --- a/README.md +++ b/README.md @@ -1,28 +1,37 @@ ocaml-containers ================ -1. A usable, reasonably well-designed library that extends OCaml's standard - library (in `core/`, packaged under `containers` in ocamlfind. Modules - are totally independent and are prefixed with `CC` (for "containers-core" - or "companion-cube" because I'm megalomaniac). This part should be - usable and should work. For instance, `CCList` contains functions and - lists including safe versions of `map` and `append`. -2. A satellite library, `containers.string` (in directory `string`) with +![logo](media/logo.png) + +What is _containers_? + +- A usable, reasonably well-designed library that extends OCaml's standard + library (in `core/`, packaged under `containers` in ocamlfind. Modules + are totally independent and are prefixed with `CC` (for "containers-core" + or "companion-cube" because I'm megalomaniac). This part should be + usable and should work. For instance, `CCList` contains functions and + lists including safe versions of `map` and `append`. +- Several small additional libraries that complement it: + * `containers.data` with additional data structures that don't have an + equivalent in the standard library; + * `containers.io` with utils to handle files and I/O streams; + * `containers.iter` with list-like and tree-like iterators; + * `containers.string` (in directory `string`) with a few packed modules that deal with strings (Levenshtein distance, KMP search algorithm, and a few naive utils). Again, modules are independent and sometimes parametric on the string and char types (so they should be able to deal with your favorite unicode library). -3. A drop-in replacement to the standard library, `containers.pervasives`, - that defined a `CCPervasives` module intented to be opened to extend some - modules of the stdlib. -4. A sub-library with complicated abstractions, `containers.advanced` (with - a LINQ-like query module, batch operations using GADTs, and others) -5. A library using [Lwt](https://github.com/ocsigen/lwt/), `containers.lwt`. - Currently only contains experimental, unstable stuff. -6. Random stuff, with *NO* *GUARANTEE* of even being barely usable or tested, - in other dirs (mostly `misc` but also `lwt` and `threads`). It's where I - tend to write code when I want to test some idea, so half the modules (at - least) are unfinished or don't really work. +- A drop-in replacement to the standard library, `containers.pervasives`, + that defined a `CCPervasives` module intented to be opened to extend some + modules of the stdlib. +- A sub-library with complicated abstractions, `containers.advanced` (with + a LINQ-like query module, batch operations using GADTs, and others). +- A library using [Lwt](https://github.com/ocsigen/lwt/), `containers.lwt`. + Currently only contains experimental, unstable stuff. +- Random stuff, with *NO* *GUARANTEE* of even being barely usable or tested, + in other dirs (mostly `misc` but also `lwt` and `threads`). It's where I + tend to write code when I want to test some idea, so half the modules (at + least) are unfinished or don't really work. Some of the modules have been moved to their own repository (e.g. `sequence`, `gen`, `qcheck`) and are on opam for great fun and profit. @@ -52,12 +61,15 @@ If you have comments, requests, or bugfixes, please share them! :-) This code is free, under the BSD license. +The logo (`media/logo.png`) is +CC-SA3 [wikimedia](http://en.wikipedia.org/wiki/File:Hypercube.svg). + ## Contents The design is mostly centered around polymorphism rather than functors. Such structures comprise (some modules in `misc/`, some other in `core/`): -### Core Structures +### Core Modules (extension of the standard library) the core library, `containers`, now depends on [cppo](https://github.com/mjambon/cppo) and `base-bytes` (provided @@ -65,36 +77,50 @@ by ocamlfind). Documentation [here](http://cedeela.fr/~simon/software/containers). -- `CCHeap`, a purely functional heap structure. +- `CCHeap`, a purely functional heap structure +- `CCVector`, a growable array (pure OCaml, no C) with mutability annotations +- `CCList`, functions on lists, including tail-recursive implementations of `map` and `append` and many other things +- `CCArray`, utilities on arrays and slices +- `CCHashtbl`, `CCMap` extensions of the standard modules `Hashtbl` and `Map` +- `CCInt` +- `CCString` (basic string operations) +- `CCPair` (cartesian products) +- `CCOpt` (options, very useful) +- `CCFun` (function combinators) +- `CCBool` +- `CCFloat` +- `CCOrd` (combinators for total orderings) +- `CCRandom` (combinators for random generators) +- `CCPrint` (printing combinators) +- `CCHash` (hashing combinators) +- `CCError` (monadic error handling, very useful) + +### Containers.data + +- `CCCache`, memoization caches, LRU, etc. +- `CCFlatHashtbl`, a flat (open-addressing) hashtable functorial implementation +- `CCTrie`, a prefix tree +- `CCMultimap` and `CCMultiset`, functors defining persistent structures - `CCFQueue`, a purely functional double-ended queue structure - `CCBV`, mutable bitvectors - `CCPersistentHashtbl`, a semi-persistent hashtable (similar to [persistent arrays](https://www.lri.fr/~filliatr/ftp/ocaml/ds/parray.ml.html)) -- `CCVector`, a growable array (pure OCaml, no C) with mutability annotations -- `CCGen` and `CCSequence`, generic iterators structures (with structural types so they can be defined in several places). They are also available in their own repository and opam packages (`gen` and `sequence`). Note that the `@since` annotations may not be accurate because of the use of `git subtree`. -- `CCKList`, a persistent iterator structure (akin to a lazy list) -- `CCList`, functions on lists, including tail-recursive implementations of `map` and `append` and many other things -- `CCArray`, utilities on arrays and slices -- `CCMultimap` and `CCMultiset`, functors defining persistent structures -- `CCHashtbl`, `CCMap` extensions of the standard modules `Hashtbl` and `Map` -- `CCFlatHashtbl`, a flat (open-addressing) hashtable functorial implementation -- `CCKTree`, an abstract lazy tree structure (similar to what `CCKlist` is to lists) -- `CCTrie`, a prefix tree -- small modules (basic types, utilities): - - `CCInt` - - `CCString` (basic string operations) - - `CCPair` (cartesian products) - - `CCOpt` (options, very useful) - - `CCFun` (function combinators) - - `CCBool` - - `CCFloat` - - `CCOrd` (combinators for total orderings) - - `CCRandom` (combinators for random generators) - - `CCPrint` (printing combinators) - - `CCHash` (hashing combinators) - - `CCError` (monadic error handling, very useful) -- `CCSexp`, a small S-expression library + +### Containers.io + - `CCIO`, basic utilities for IO -- `CCCache`, memoization caches, LRU, etc. + +### Containers.sexp + +A small S-expression library. + +- `CCSexp`, a small S-expression library + +### Containers.iter + +Iterators: + +- `CCKList`, a persistent iterator structure (akin to a lazy list, without memoization) +- `CCKTree`, an abstract lazy tree structure ### String @@ -136,19 +162,14 @@ access to elements by their index. - `Univ`, a universal type encoding with affectation - `FlatHashtbl`, a (deprecated) open addressing hashtable with a functorial interface (replaced by PHashtbl) -- `UnionFind`, a functorial imperative Union-Find structure. +- `UnionFind`, a functorial imperative Union-Find structure ### Others - `Future`, a set of tools for preemptive threading, including a thread pool, monadic futures, and MVars (concurrent boxes) -Some serialisation formats are also implemented, with a streaming, non-blocking -interface that allows the user to feed the input in chunk by chunk (useful -in combination with Lwt/Async). Currently, the modules are: - -- `Bencode`, for the [B-encode format](http://en.wikipedia.org/wiki/Bencode), -- `Sexp`, for S-expressions. +- `containers.lwt` contains [Lwt](http://ocsigen.org/lwt/)-related modules (experimental) There is a QuickCheck-like library called `QCheck` (now in its own repo). @@ -175,3 +196,18 @@ To build the small benchmarking suite (requires `benchmark`): $ opam install benchmark $ make bench $ ./benchs.native + +## Contributing + +PRs on github are welcome (patches by email too, if you prefer so). + +A few guidelines: + +- no dependencies between basic modules (even just for signatures); +- add `@since` tags for new functions; +- add tests if possible (using `qtest`). + +Powered by +OASIS + diff --git a/_oasis b/_oasis index 267dc2e2..ab2a2d77 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: containers -Version: 0.6.1 +Version: 0.7 Homepage: https://github.com/c-cube/ocaml-containers Authors: Simon Cruanes License: BSD-2-clause @@ -8,6 +8,7 @@ LicenseFile: LICENSE Plugins: META (0.3), DevFiles (0.3) OCamlVersion: >= 4.00.1 BuildTools: ocamlbuild +AlphaFeatures: ocamlbuild_more_args Synopsis: A modular standard library focused on data structures. Description: @@ -24,10 +25,6 @@ Flag "misc" Description: Build the misc library, containing everything from the rotating kitchen sink to automatic banana distributors Default: false -Flag "cgi" - Description: Build modules related to FastCGI, depending on CamlGI - Default: false - Flag "lwt" Description: Build modules which depend on Lwt Default: false @@ -40,80 +37,105 @@ Flag "bench" Description: Build and run benchmarks Default: false +Flag "bigarray" + Description: Build modules that depend on bigarrays + Default: false + Library "containers" - Path: core - Modules: CCVector, CCDeque, CCGen, Gen_intf, CCSequence, CCFQueue, CCMultiMap, - CCMultiSet, CCBV, CCPrint, CCPersistentHashtbl, CCError, - CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, - CCKList, CCInt, CCBool, CCFloat, CCArray, CCOrd, CCIO, - CCRandom, CCKTree, CCTrie, CCString, CCHashtbl, - CCFlatHashtbl, CCSexp, CCMap, CCCache + Path: src/core + Modules: CCVector, CCPrint, CCError, CCHeap, CCList, CCOpt, CCPair, + CCFun, CCHash, CCInt, CCBool, CCFloat, CCArray, + CCOrd, CCRandom, CCString, CCHashtbl, CCMap BuildDepends: bytes +Library "containers_io" + Path: src/io + Modules: CCIO + BuildDepends: bytes + FindlibParent: containers + FindlibName: io + +Library "containers_sexp" + Path: src/sexp + Modules: CCSexp, CCSexpStream, CCSexpM + BuildDepends: bytes + FindlibParent: containers + FindlibName: sexp + +Library "containers_data" + Path: src/data + Modules: CCMultiMap, CCMultiSet, CCTrie, CCFlatHashtbl, CCCache, + CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl + FindlibParent: containers + FindlibName: data + +Library "containers_iter" + Path: src/iter + Modules: CCKTree, CCKList + FindlibParent: containers + FindlibName: iter + Library "containers_string" - Path: string + Path: src/string Pack: true Modules: KMP, Levenshtein FindlibName: string FindlibParent: containers Library "containers_advanced" - Path: advanced + Path: src/advanced Pack: true Modules: CCLinq, CCBatch, CCCat, CCMonadIO FindlibName: advanced FindlibParent: containers - BuildDepends: containers + BuildDepends: containers, sequence + +Library "containers_bigarray" + Path: src/bigarray + Modules: CCBigstring + FindlibName: bigarray + FindlibParent: containers + BuildDepends: containers, bigarray, bytes Library "containers_pervasives" - Path: pervasives + Path: src/pervasives Modules: CCPervasives BuildDepends: containers FindlibName: pervasives FindlibParent: containers Library "containers_misc" - Path: misc + Path: src/misc Pack: true Modules: FHashtbl, FlatHashtbl, Hashset, Heap, LazyGraph, PersistentGraph, PHashtbl, SkipList, SplayTree, SplayMap, Univ, Bij, PiCalculus, RAL, UnionFind, SmallSet, AbsSet, CSM, TTree, PrintBox, HGraph, Automaton, Conv, Bidir, Iteratee, - BTree, Ty, Cause, AVL, ParseReact, Mixtbl - BuildDepends: unix,containers + BTree, Ty, Cause, AVL, ParseReact + BuildDepends: containers, containers.data FindlibName: misc FindlibParent: containers Library "containers_thread" - Path: threads/ + Path: src/threads/ Modules: CCFuture FindlibName: thread FindlibParent: containers Build$: flag(thread) Install$: flag(thread) - BuildDepends: containers,threads - XMETARequires: containers,threads + BuildDepends: containers, threads + XMETARequires: containers, threads Library "containers_lwt" - Path: lwt - Modules: Behavior, Lwt_automaton, Lwt_actor + Path: src/lwt + Modules: Lwt_automaton, Lwt_actor Pack: true FindlibName: lwt FindlibParent: containers Build$: flag(lwt) && flag(misc) Install$: flag(lwt) && flag(misc) - BuildDepends: containers, lwt, lwt.unix, containers.misc - -Library "containers_cgi" - Path: cgi - Modules: ToWeb - FindlibName: cgi - FindlibParent: containers - Build$: flag(cgi) - Install$: flag(cgi) - BuildDepends: containers,CamlGI - XMETARequires: containers,CamlGI + BuildDepends: containers, lwt, containers.misc Document containers Title: Containers docs @@ -121,39 +143,13 @@ Document containers BuildTools+: ocamldoc Install: true XOCamlbuildPath: . - XOCamlbuildLibraries: containers,containers.string - -Document containers_misc - Title: Containers_misc docs - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Install: true - XOCamlbuildPath: . - XOCamlbuildLibraries: containers.misc - -Document containers_string - Title: Containers_string docs - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Install: true - XOCamlbuildPath: . - XOCamlbuildLibraries: containers.string - -Document containers_advanced - Title: Containers_advanced docs - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Install: true - XOCamlbuildPath: . - XOCamlbuildLibraries: containers.advanced - -Document containers_lwt - Title: Containers_lwt docs - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Install: true - XOCamlbuildPath: . - XOCamlbuildLibraries: containers.lwt + XOCamlbuildExtraArgs: + "-docflags '-colorize-code -short-functors -charset utf-8'" + XOCamlbuildLibraries: + containers, containers.misc, containers.iter, containers.data, + containers.string, containers.pervasives, containers.bigarray, + containers.advanced, containers.io, containers.sexp, + containers.lwt Executable run_benchs Path: benchs/ @@ -162,7 +158,8 @@ Executable run_benchs Build$: flag(bench) && flag(misc) MainIs: run_benchs.ml BuildDepends: containers, containers.misc, containers.advanced, - containers.string, benchmark + containers.data, containers.string, containers.iter, + sequence, gen, benchmark Executable bench_hash Path: benchs/ @@ -170,7 +167,7 @@ Executable bench_hash CompiledObject: native Build$: flag(bench) && flag(misc) MainIs: bench_hash.ml - BuildDepends: containers,containers.misc + BuildDepends: containers, containers.misc Executable bench_conv Path: benchs/ @@ -178,7 +175,7 @@ Executable bench_conv CompiledObject: native Build$: flag(bench) MainIs: bench_conv.ml - BuildDepends: containers,benchmark + BuildDepends: containers, benchmark, gen Executable test_levenshtein Path: tests/ @@ -186,15 +183,7 @@ Executable test_levenshtein CompiledObject: native Build$: flag(tests) MainIs: test_levenshtein.ml - BuildDepends: containers,qcheck,containers.string - -Executable test_lwt - Path: tests/lwt/ - Install: false - CompiledObject: best - Build$: flag(tests) && flag(lwt) - MainIs: test_Behavior.ml - BuildDepends: containers,lwt,lwt.unix,oUnit,containers.lwt + BuildDepends: containers, qcheck, containers.string Executable test_threads Path: tests/lwt/ @@ -202,7 +191,7 @@ Executable test_threads CompiledObject: best Build$: flag(tests) && flag(thread) MainIs: test_Future.ml - BuildDepends: containers,threads,oUnit,containers.lwt + BuildDepends: containers, threads, oUnit, containers.lwt PreBuildCommand: make qtest-gen @@ -212,8 +201,10 @@ Executable run_qtest CompiledObject: native MainIs: run_qtest.ml Build$: flag(tests) - BuildDepends: containers, containers.misc, containers.string, - oUnit, QTest2Lib + BuildDepends: containers, containers.misc, containers.string, containers.iter, + containers.io, containers.advanced, containers.sexp, + containers.bigarray, + sequence, gen, oUnit, QTest2Lib Executable run_tests Path: tests/ @@ -221,26 +212,20 @@ Executable run_tests CompiledObject: native MainIs: run_tests.ml Build$: flag(tests) && flag(misc) - BuildDepends: containers, oUnit, qcheck, containers.misc + BuildDepends: containers, containers.data, oUnit, sequence, gen, + qcheck, containers.misc Test all Command: make test-all TestTools: run_tests, run_qtest Run$: flag(tests) && flag(misc) -Executable web_pwd - Path: examples/cgi/ - Install: false - MainIs: web_pwd.ml - Build$: flag(cgi) - BuildDepends: containers, containers.cgi, threads, CamlGI - Executable lambda Path: examples/ Install: false MainIs: lambda.ml Build$: flag(misc) - BuildDepends: containers,containers.misc + BuildDepends: containers, containers.misc Executable id_sexp Path: examples/ @@ -248,7 +233,15 @@ Executable id_sexp CompiledObject: native MainIs: id_sexp.ml Build$: flag(misc) - BuildDepends: containers + BuildDepends: containers.sexp + +Executable id_sexp2 + Path: examples/ + Install: false + CompiledObject: native + MainIs: id_sexp2.ml + Build$: flag(misc) + BuildDepends: containers.sexp SourceRepository head Type: git diff --git a/_tags b/_tags index 62463c8e..0c6ac720 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 87b09f8c85905e63062b223fad9468e9) +# DO NOT EDIT (digest: 616ce46d4cb6f4ca580b6de54c9a1d70) # 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 @@ -15,104 +15,119 @@ true: annot, bin_annot "_darcs": -traverse "_darcs": not_hygienic # Library containers -"core/containers.cmxs": use_containers -: package(bytes) +"src/core/containers.cmxs": use_containers +: package(bytes) +# Library containers_io +"src/io/containers_io.cmxs": use_containers_io +: package(bytes) +# Library containers_sexp +"src/sexp/containers_sexp.cmxs": use_containers_sexp +: package(bytes) +# Library containers_data +"src/data/containers_data.cmxs": use_containers_data +# Library containers_iter +"src/iter/containers_iter.cmxs": use_containers_iter # Library containers_string -"string/containers_string.cmxs": use_containers_string -"string/KMP.cmx": for-pack(Containers_string) -"string/levenshtein.cmx": for-pack(Containers_string) +"src/string/containers_string.cmxs": use_containers_string +"src/string/KMP.cmx": for-pack(Containers_string) +"src/string/levenshtein.cmx": for-pack(Containers_string) # Library containers_advanced -"advanced/containers_advanced.cmxs": use_containers_advanced -"advanced/CCLinq.cmx": for-pack(Containers_advanced) -"advanced/CCBatch.cmx": for-pack(Containers_advanced) -"advanced/CCCat.cmx": for-pack(Containers_advanced) -"advanced/CCMonadIO.cmx": for-pack(Containers_advanced) -: package(bytes) -: use_containers +"src/advanced/containers_advanced.cmxs": use_containers_advanced +"src/advanced/CCLinq.cmx": for-pack(Containers_advanced) +"src/advanced/CCBatch.cmx": for-pack(Containers_advanced) +"src/advanced/CCCat.cmx": for-pack(Containers_advanced) +"src/advanced/CCMonadIO.cmx": for-pack(Containers_advanced) +: package(bytes) +: package(sequence) +: use_containers +# Library containers_bigarray +"src/bigarray/containers_bigarray.cmxs": use_containers_bigarray +: package(bigarray) +: package(bytes) +: use_containers # Library containers_pervasives -"pervasives/containers_pervasives.cmxs": use_containers_pervasives -: package(bytes) -: use_containers +"src/pervasives/containers_pervasives.cmxs": use_containers_pervasives +: package(bytes) +: use_containers # Library containers_misc -"misc/containers_misc.cmxs": use_containers_misc -"misc/fHashtbl.cmx": for-pack(Containers_misc) -"misc/flatHashtbl.cmx": for-pack(Containers_misc) -"misc/hashset.cmx": for-pack(Containers_misc) -"misc/heap.cmx": for-pack(Containers_misc) -"misc/lazyGraph.cmx": for-pack(Containers_misc) -"misc/persistentGraph.cmx": for-pack(Containers_misc) -"misc/pHashtbl.cmx": for-pack(Containers_misc) -"misc/skipList.cmx": for-pack(Containers_misc) -"misc/splayTree.cmx": for-pack(Containers_misc) -"misc/splayMap.cmx": for-pack(Containers_misc) -"misc/univ.cmx": for-pack(Containers_misc) -"misc/bij.cmx": for-pack(Containers_misc) -"misc/piCalculus.cmx": for-pack(Containers_misc) -"misc/RAL.cmx": for-pack(Containers_misc) -"misc/unionFind.cmx": for-pack(Containers_misc) -"misc/smallSet.cmx": for-pack(Containers_misc) -"misc/absSet.cmx": for-pack(Containers_misc) -"misc/CSM.cmx": for-pack(Containers_misc) -"misc/tTree.cmx": for-pack(Containers_misc) -"misc/printBox.cmx": for-pack(Containers_misc) -"misc/hGraph.cmx": for-pack(Containers_misc) -"misc/automaton.cmx": for-pack(Containers_misc) -"misc/conv.cmx": for-pack(Containers_misc) -"misc/bidir.cmx": for-pack(Containers_misc) -"misc/iteratee.cmx": for-pack(Containers_misc) -"misc/bTree.cmx": for-pack(Containers_misc) -"misc/ty.cmx": for-pack(Containers_misc) -"misc/cause.cmx": for-pack(Containers_misc) -"misc/AVL.cmx": for-pack(Containers_misc) -"misc/parseReact.cmx": for-pack(Containers_misc) -"misc/mixtbl.cmx": for-pack(Containers_misc) -: package(bytes) -: package(unix) -: use_containers +"src/misc/containers_misc.cmxs": use_containers_misc +"src/misc/fHashtbl.cmx": for-pack(Containers_misc) +"src/misc/flatHashtbl.cmx": for-pack(Containers_misc) +"src/misc/hashset.cmx": for-pack(Containers_misc) +"src/misc/heap.cmx": for-pack(Containers_misc) +"src/misc/lazyGraph.cmx": for-pack(Containers_misc) +"src/misc/persistentGraph.cmx": for-pack(Containers_misc) +"src/misc/pHashtbl.cmx": for-pack(Containers_misc) +"src/misc/skipList.cmx": for-pack(Containers_misc) +"src/misc/splayTree.cmx": for-pack(Containers_misc) +"src/misc/splayMap.cmx": for-pack(Containers_misc) +"src/misc/univ.cmx": for-pack(Containers_misc) +"src/misc/bij.cmx": for-pack(Containers_misc) +"src/misc/piCalculus.cmx": for-pack(Containers_misc) +"src/misc/RAL.cmx": for-pack(Containers_misc) +"src/misc/unionFind.cmx": for-pack(Containers_misc) +"src/misc/smallSet.cmx": for-pack(Containers_misc) +"src/misc/absSet.cmx": for-pack(Containers_misc) +"src/misc/CSM.cmx": for-pack(Containers_misc) +"src/misc/tTree.cmx": for-pack(Containers_misc) +"src/misc/printBox.cmx": for-pack(Containers_misc) +"src/misc/hGraph.cmx": for-pack(Containers_misc) +"src/misc/automaton.cmx": for-pack(Containers_misc) +"src/misc/conv.cmx": for-pack(Containers_misc) +"src/misc/bidir.cmx": for-pack(Containers_misc) +"src/misc/iteratee.cmx": for-pack(Containers_misc) +"src/misc/bTree.cmx": for-pack(Containers_misc) +"src/misc/ty.cmx": for-pack(Containers_misc) +"src/misc/cause.cmx": for-pack(Containers_misc) +"src/misc/AVL.cmx": for-pack(Containers_misc) +"src/misc/parseReact.cmx": for-pack(Containers_misc) +: package(bytes) +: use_containers +: use_containers_data # Library containers_thread -"threads/containers_thread.cmxs": use_containers_thread -: package(bytes) -: package(threads) -: use_containers +"src/threads/containers_thread.cmxs": use_containers_thread +: package(bytes) +: package(threads) +: use_containers # Library containers_lwt -"lwt/containers_lwt.cmxs": use_containers_lwt -"lwt/behavior.cmx": for-pack(Containers_lwt) -"lwt/lwt_automaton.cmx": for-pack(Containers_lwt) -"lwt/lwt_actor.cmx": for-pack(Containers_lwt) -: package(bytes) -: package(lwt) -: package(lwt.unix) -: package(unix) -: use_containers -: use_containers_misc -# Library containers_cgi -"cgi/containers_cgi.cmxs": use_containers_cgi -: package(CamlGI) -: package(bytes) -: use_containers +"src/lwt/containers_lwt.cmxs": use_containers_lwt +"src/lwt/lwt_automaton.cmx": for-pack(Containers_lwt) +"src/lwt/lwt_actor.cmx": for-pack(Containers_lwt) +: package(bytes) +: package(lwt) +: use_containers +: use_containers_data +: use_containers_misc # Executable run_benchs "benchs/run_benchs.native": package(benchmark) "benchs/run_benchs.native": package(bytes) -"benchs/run_benchs.native": package(unix) +"benchs/run_benchs.native": package(gen) +"benchs/run_benchs.native": package(sequence) "benchs/run_benchs.native": use_containers "benchs/run_benchs.native": use_containers_advanced +"benchs/run_benchs.native": use_containers_data +"benchs/run_benchs.native": use_containers_iter "benchs/run_benchs.native": use_containers_misc "benchs/run_benchs.native": use_containers_string +: package(sequence) : use_containers_advanced +: use_containers_iter : use_containers_string # Executable bench_hash "benchs/bench_hash.native": package(bytes) -"benchs/bench_hash.native": package(unix) "benchs/bench_hash.native": use_containers +"benchs/bench_hash.native": use_containers_data "benchs/bench_hash.native": use_containers_misc -: package(unix) +: use_containers_data : use_containers_misc # Executable bench_conv "benchs/bench_conv.native": package(benchmark) "benchs/bench_conv.native": package(bytes) +"benchs/bench_conv.native": package(gen) "benchs/bench_conv.native": use_containers : package(benchmark) : package(bytes) +: package(gen) : use_containers # Executable test_levenshtein "tests/test_levenshtein.native": package(bytes) @@ -120,89 +135,90 @@ true: annot, bin_annot "tests/test_levenshtein.native": use_containers "tests/test_levenshtein.native": use_containers_string : use_containers_string -# Executable test_lwt -: package(bytes) -: package(lwt) -: package(lwt.unix) -: package(oUnit) -: package(unix) -: use_containers -: use_containers_lwt -: use_containers_misc # Executable test_threads : package(bytes) : package(lwt) -: package(lwt.unix) : package(oUnit) : package(threads) -: package(unix) : use_containers +: use_containers_data : use_containers_lwt : use_containers_misc : package(bytes) : package(lwt) -: package(lwt.unix) : package(oUnit) : package(threads) -: package(unix) : use_containers +: use_containers_data : use_containers_lwt : use_containers_misc # Executable run_qtest "qtest/run_qtest.native": package(QTest2Lib) +"qtest/run_qtest.native": package(bigarray) "qtest/run_qtest.native": package(bytes) +"qtest/run_qtest.native": package(gen) "qtest/run_qtest.native": package(oUnit) -"qtest/run_qtest.native": package(unix) +"qtest/run_qtest.native": package(sequence) "qtest/run_qtest.native": use_containers +"qtest/run_qtest.native": use_containers_advanced +"qtest/run_qtest.native": use_containers_bigarray +"qtest/run_qtest.native": use_containers_data +"qtest/run_qtest.native": use_containers_io +"qtest/run_qtest.native": use_containers_iter "qtest/run_qtest.native": use_containers_misc +"qtest/run_qtest.native": use_containers_sexp "qtest/run_qtest.native": use_containers_string : package(QTest2Lib) +: package(bigarray) : package(bytes) +: package(gen) : package(oUnit) -: package(unix) +: package(sequence) : use_containers +: use_containers_advanced +: use_containers_bigarray +: use_containers_data +: use_containers_io +: use_containers_iter : use_containers_misc +: use_containers_sexp : use_containers_string # Executable run_tests "tests/run_tests.native": package(bytes) +"tests/run_tests.native": package(gen) "tests/run_tests.native": package(oUnit) "tests/run_tests.native": package(qcheck) -"tests/run_tests.native": package(unix) +"tests/run_tests.native": package(sequence) "tests/run_tests.native": use_containers +"tests/run_tests.native": use_containers_data "tests/run_tests.native": use_containers_misc : package(bytes) +: package(gen) : package(oUnit) : package(qcheck) -: package(unix) +: package(sequence) : use_containers +: use_containers_data : use_containers_misc -# Executable web_pwd -"examples/cgi/web_pwd.byte": package(CamlGI) -"examples/cgi/web_pwd.byte": package(bytes) -"examples/cgi/web_pwd.byte": package(threads) -"examples/cgi/web_pwd.byte": use_containers -"examples/cgi/web_pwd.byte": use_containers_cgi -: package(CamlGI) -: package(bytes) -: package(threads) -: use_containers -: use_containers_cgi # Executable lambda "examples/lambda.byte": package(bytes) -"examples/lambda.byte": package(unix) "examples/lambda.byte": use_containers +"examples/lambda.byte": use_containers_data "examples/lambda.byte": use_containers_misc -: package(unix) +: use_containers +: use_containers_data : use_containers_misc # Executable id_sexp "examples/id_sexp.native": package(bytes) -"examples/id_sexp.native": use_containers +"examples/id_sexp.native": use_containers_sexp +# Executable id_sexp2 +"examples/id_sexp2.native": package(bytes) +"examples/id_sexp2.native": use_containers_sexp : package(bytes) -: use_containers +: use_containers_sexp # OASIS_STOP : thread -: thread -: -traverse -: -traverse -: inline(25) -<{string,core}/**/*.ml>: warn_A, warn(-4), warn(-44) +: thread +: inline(25) + and not : warn_A, warn(-4), warn(-44) +true: no_alias_deps diff --git a/benchs/bench_conv.ml b/benchs/bench_conv.ml index c117fda8..7e958f36 100644 --- a/benchs/bench_conv.ml +++ b/benchs/bench_conv.ml @@ -79,11 +79,11 @@ let () = bench_list [1,2; 3,4; 5,6; 7,8; 9,10]; let open CCFun in - let l = CCGen.(1 -- 100 |> map (fun x->x,x) |> to_rev_list) in + let l = Gen.(1 -- 100 |> map (fun x->x,x) |> to_rev_list) in Printf.printf "list of %d elements...\n" (List.length l); bench_list l; - let l = CCGen.(repeat Point.p |> take 10 |> to_rev_list) in + let l = Gen.(repeat Point.p |> take 10 |> to_rev_list) in Printf.printf "list of %d points...\n" (List.length l); bench_point_list l; diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index ec53abbd..3bde113e 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -480,8 +480,8 @@ module Iter = struct (** {2 Sequence/Gen} *) let bench_fold n = - let seq () = CCSequence.fold (+) 0 CCSequence.(0 --n) in - let gen () = CCGen.fold (+) 0 CCGen.(0 -- n) in + let seq () = Sequence.fold (+) 0 Sequence.(0 --n) in + let gen () = Gen.fold (+) 0 Gen.(0 -- n) in let klist () = CCKList.fold (+) 0 CCKList.(0 -- n) in CCBench.throughputN 3 [ "sequence.fold", seq, (); @@ -490,10 +490,10 @@ module Iter = struct ] let bench_flat_map n = - let seq () = CCSequence.( + let seq () = Sequence.( 0 -- n |> flat_map (fun x -> x-- (x+10)) |> fold (+) 0 ) - and gen () = CCGen.( + and gen () = Gen.( 0 -- n |> flat_map (fun x -> x-- (x+10)) |> fold (+) 0 ) and klist () = CCKList.( @@ -509,12 +509,12 @@ module Iter = struct let bench_iter n = let seq () = let i = ref 2 in - CCSequence.( + Sequence.( 1 -- n |> iter (fun x -> i := !i * x) ) and gen () = let i = ref 2 in - CCGen.( + Gen.( 1 -- n |> iter (fun x -> i := !i * x) ) and klist () = diff --git a/cgi/toWeb.ml b/cgi/toWeb.ml deleted file mode 100644 index 1d2f2fc1..00000000 --- a/cgi/toWeb.ml +++ /dev/null @@ -1,358 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Expose the State of a Program to the Web} - - We export some values (and associated functions for converting them to - html, and update them) as a FastCGI interface. - - This module depends on CamlGI. -*) - -(** {2 Some combinators to build HTML documents} *) - -module HTML = struct - type t = - | Str of string (* content *) - | List of t list - | Url of url - | Img of image - | Concat of t list - | H of int * t - | Link of link - | Tag of string * t - | TagWith of string * (string * string) list * t - and url = { - url_alt : string option; - url_url : string; - url_descr : string; - } - and image = { - img_alt : string option; - img_url : string; - } - and link = { - link_rel : string; - link_url : string; - } - - let str s = Str s - - let bprintf format = - let buffer = Buffer.create 64 in - let r = ref (str "") in - Printf.kbprintf - (fun x -> r := str (Buffer.contents buffer)) - buffer - format; - !r - - let sprintf format = - let r = ref (str "") in - Printf.ksprintf - (fun s -> r := str s) - format; - !r - - let list l = List l - - let url ?alt ~url ~descr = Url { - url_alt = alt; - url_url = url; - url_descr = descr; - } - - let img ?alt url = Img { - img_alt = alt; - img_url = url; - } - - let append a b = Concat [a; b] - - let concat l = Concat l - - let h1 x = H (1, x) - - let h2 x = H (2, x) - - let h3 x = H (3, x) - - let h n x = H (n, x) - - let p x = Tag ("p", x) - - let div ?id ?class_ x = - match id, class_ with - | None, None -> Tag ("div", x) - | Some i, None -> TagWith ("div", ["id", i], x) - | None, Some c -> TagWith ("div", ["class", c], x) - | Some i, Some c -> TagWith ("div", ["id", i; "class", c], x) - - let span ?id ?class_ x = - match id, class_ with - | None, None -> Tag ("span", x) - | Some i, None -> TagWith ("span", ["id", i], x) - | None, Some c -> TagWith ("span", ["class", c], x) - | Some i, Some c -> TagWith ("span", ["id", i; "class", c], x) - - let link ~rel ~url = Link { - link_rel = rel; - link_url = url; - } - - let head x = Tag ("head", x) - - let body x = Tag ("body", x) - - let html x = Tag ("html", x) - - let _to_hex n = match n with - | _ when n >= 0 && n < 10 -> Char.chr (Char.code '0' + n) - | 10 -> 'A' - | 11 -> 'B' - | 12 -> 'C' - | 13 -> 'D' - | 14 -> 'E' - | 15 -> 'F' - | _ -> failwith "not an hexadecimal digit" - - let _encode_char buf c = - Buffer.add_string buf "&#x"; - let h, l = Char.code c / 16, Char.code c mod 16 in - Buffer.add_char buf (_to_hex h); - Buffer.add_char buf (_to_hex l) - - let encode str = - let b = Buffer.create (String.length str + 10) in - for i = 0 to String.length str - 1 do - match str.[i] with - | ';' | '/' | '?' | ':' | '@' | '&' | '=' | '+' | '$' | ',' | '<' - | '>' | '#' | '%' | '"' | '{' | '}' | '|' | '\\' | '^' | '[' | ']' - | '`' -> _encode_char b str.[i] - | c when Char.code c < 32 -> _encode_char b str.[i] - | c when Char.code c > 127 -> _encode_char b str.[i] - | _ -> Buffer.add_char b str.[i] - done; - Buffer.contents b - - (* real rendering is always into a buffer (for now) *) - let rec to_buf buf x = - match x with - | Str s -> Buffer.add_string buf (encode s) - | List l -> - Buffer.add_string buf "
    "; - List.iter - (fun y -> Printf.bprintf buf "
  • %a
    • " to_buf y) - l; - Buffer.add_string buf "
" - | Url url -> - begin match url.url_alt with - | None -> - Printf.bprintf buf "%s" url.url_url - (encode url.url_descr) - | Some alt -> - Printf.bprintf buf "%s" - url.url_url (encode alt) (encode url.url_descr) - end - | Img i -> failwith "img: not implemented" - | Concat l -> - List.iteri - (fun i y -> - if i > 0 then Buffer.add_char buf ' '; - to_buf buf y) - l - | H (n, y) -> - Printf.bprintf buf " %a " n to_buf y n - | Link _ -> failwith "link: not implemented" - | Tag (str, y) -> Printf.bprintf buf "<%s> %a " str to_buf y str - | TagWith (str, attrs, y) -> - Printf.bprintf buf "<%s " str; - List.iter (fun (name,attr) -> Printf.bprintf buf "%s=\"%s\"" name attr) attrs; - Printf.bprintf buf "> %a " to_buf y str - - let render x = - let buf = Buffer.create 256 in - to_buf buf x; - Buffer.contents buf - - let to_chan oc x = - let buf = Buffer.create 256 in - to_buf buf x; - Buffer.output_buffer oc buf -end - -(** {2 Stateful Object on the Web} *) - -module State = struct - type 'a t = { - mutable content : 'a; - mutable callbacks : ('a -> unit) list; - id : ('a -> string) option; - export : 'a -> HTML.t; - update : (string * string) list -> 'a -> 'a; - } (** A value that can be exposed to the Web. - The [export] function is used to print the current state of - the object into HTML (when requested). - The [update] optional function can be used to update - the value, given a query with parameters. *) - - type wrap = Wrap : 'a t -> wrap - (** Hides the type parameter in a GADT. *) - - let create ?(update=fun _ x -> x) ?id ~export content = { - content; - export; - id; - callbacks = []; - update; - } - - let on_change st f = - st.callbacks <- f :: st.callbacks - - let handle_request st req = - let cgi = new CamlGI.Cgi.cgi req in - (* update value? *) - try - let x = st.content in - let params = cgi#params in - (* update [x] using the parameters? *) - let y = st.update params x in - let changed = match st.id with - | None -> x != y - | Some id -> id x <> id y - in - (* notify callbacks that we have a new object *) - if changed then - List.iter (fun f -> f y) st.callbacks; - (* now print [y] *) - (* TODO: add a head, declaration, etc. *) - let html = st.export y in - let final_output = HTML.render html in - (* render output *) - let template = object - method output f = f final_output - end in - cgi#template template - with e -> - let msg = Printf.sprintf "error: %s" (Printexc.to_string e) in - cgi#log msg -end - -(** {2 Routing} *) - -module Router = struct - type t = { - mutable default : State.wrap; - log : out_channel option; - tbl : (string, State.wrap) Hashtbl.t; - } - - let __default = - State.Wrap (State.create ~export:HTML.str "") - - let _log router fmt = match router.log with - | None -> - Printf.ifprintf stdout fmt - | Some oc -> - Printf.kfprintf - (fun oc -> - output_char oc '\n'; - flush oc) - oc - fmt - - let create ?(default=__default) ?log () = - let router = { - default; - log; - tbl = Hashtbl.create 15; - } in - _log router "new router created"; - router - - let default router default = - router.default <- default - - let unregister router name = - Hashtbl.remove router.tbl name - - let register ?(weak=false) router name state = - if Hashtbl.mem router.tbl name - then failwith "Router: name already registered" - else begin - Hashtbl.add router.tbl name state; - if weak then match state with - | State.Wrap st -> - Gc.finalise (fun _ -> unregister router name) st.State.content - end - - let add_list router l = - List.iter - (fun (name, state) -> register router name state) - l - - let to_list router = - Hashtbl.fold - (fun name state acc -> (name,state) :: acc) - router.tbl [] - - let random_id () = - CamlGI.Cgi.random_sessionid () - - let handle_request router req = - let cgi = new CamlGI.Cgi.cgi req in - let url = cgi#url () in - let st = - try - let last_part_i = String.rindex url '/' in - let last_part = String.sub url (last_part_i+1) (String.length url -last_part_i-1) in - _log router "received request for url /%s" last_part; - Hashtbl.find router.tbl last_part - with Not_found -> - router.default - in - match st with - | State.Wrap st -> State.handle_request st req -end - -(** {2 Main Interface} *) - -let serve_state ?sockfile ?sockaddr st = - match sockfile with - | None -> - CamlGI.Cgi.register_script ?sockaddr (State.handle_request st) - | Some f -> - let sockaddr = Unix.ADDR_UNIX f in - CamlGI.Cgi.register_script ~sockaddr (State.handle_request st) - -let serve_router ?sockfile ?sockaddr router = - match sockfile with - | None -> - CamlGI.Cgi.register_script ?sockaddr (Router.handle_request router) - | Some f -> - let sockaddr = Unix.ADDR_UNIX f in - CamlGI.Cgi.register_script ~sockaddr (Router.handle_request router) diff --git a/cgi/toWeb.mli b/cgi/toWeb.mli deleted file mode 100644 index b6e3eb40..00000000 --- a/cgi/toWeb.mli +++ /dev/null @@ -1,208 +0,0 @@ - -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Expose the State of a Program to the Web} - - We export some values (and associated functions for converting them to - html, and update them) as a FastCGI interface. - - This module depends on CamlGI. -*) - -(** {2 Some combinators to build HTML documents} *) - -module HTML : sig - type t - (** A html document. Encoding is assumed to be UTF8 for now. *) - - val str : string -> t - (** Simple string *) - - val bprintf : ('a, Buffer.t, unit, unit) format4 -> t - (** Use a buffer printer to render a string. Shortcut for {!str} *) - - val sprintf : ('a, unit, string, unit) format4 -> t - (** Use a string printer to render into a string. Shortcut for {!str} *) - - val list : t list -> t - (** Build a list of items *) - - val url : ?alt:string -> url:string -> descr:string -> t - (** build an URL tag. *) - - val img : ?alt:string -> string -> t - (** Link to an image *) - - val append : t -> t -> t - (** Concatenation of two documents *) - - val concat : t list -> t - (** Concatenation of html documents *) - - val h1 : t -> t - - val h2 : t -> t - - val h3 : t -> t - - val h : int -> t -> t - (** Title of level parametrized by the integer *) - - val p : t -> t - (** Paragraph *) - - val div : ?id:string -> ?class_:string -> t -> t - (** Div tag, to specify a block *) - - val span : ?id:string -> ?class_:string -> t -> t - (** Non semantic tag, mostly useful for CSS *) - - val link : rel:string -> url:string -> t - (** Link (for head) *) - - val head : t -> t - (** Head part of a document *) - - val body : t -> t - (** Body part of a document *) - - val html : t -> t - (** The whole document *) - - val render : t -> string - (** Print into a string *) - - val to_buf : Buffer.t -> t -> unit - (** Print in the buffer *) - - val to_chan : out_channel -> t -> unit - (** Print on the channel *) -end - -(** {2 Stateful Object on the Web} *) - -(** This module defines how to bundle an OCaml value (possibly - stateful) with functions that export it to HTML, - and possibly update it from a CGI request. -*) - -module State : sig - type 'a t - (** A value that can be exposed to the web. *) - - type wrap = Wrap : 'a t -> wrap - (** Hides the type parameter in a GADT. Useful for {!Router}. *) - - val create : ?update:((string*string) list -> 'a -> 'a) -> - ?id:('a -> string) -> - export:('a -> HTML.t) -> - 'a -> - 'a t - (** Create a value that can be exposed to the Web. - @param export function used to print the current state of - the object into HTML (when requested). - @param update optional function that can be used to update - the value, given a query with parameters. - @param id optional function that maps a value to a (unique) - string. Can be used to obtain a unique URL for this value. *) - - val on_change : 'a t -> ('a -> unit) -> unit - (** Register a callback that will be called everytime the value - is updated. Physical equality is used to determine whether - the value changed if no [id] function was provided; - otherwise, [id] is used to check whether the old and the new - strings are equal. *) - - val handle_request : 'a t -> CamlGI.Cgi.Request.t -> unit - (** Handle the incoming request. It replies to the request by - possibly updating the local state, and - object. *) -end - - -(** {2 Routing} *) - -module Router : sig - type t - (** An URL router. It dispatches incoming requests to registered - {!State.t} values depending on the request's URL. *) - - val create : ?default:State.wrap -> ?log:out_channel -> unit -> t - (** New router. - @param log a channel on which to log events (incoming requests) - @param default a default object to expose, for incorrect routes - *) - - val default : t -> State.wrap -> unit - (** Set the default handler, for incorrect routes (for which no - object is registered) or for routing the root url *) - - val register : ?weak:bool -> t -> string -> State.wrap -> unit - (** Register a state object (see {!State}) under a given path. - Right now routing only dispatches at one level, there is no - tree-like structure, only a flat "directory" of objects. - - @param weak (default false) if true, the object will unregister itself - when it's garbage collected. Only works if the type of the wrapped - object is heap allocated. - - @raise Failure if the name is already taken - @raise Invalid_argument if [weak] is true and no finalizer can be - registered. *) - - val unregister : t -> string -> unit - (** Remove a stateful value *) - - val add_list : t -> (string * State.wrap) list -> unit - (** Register several handlers. - @raise Failure if it meets an already registered handler *) - - val to_list : t -> (string * State.wrap) list - (** Currently registered objects *) - - val random_id : unit -> string - (** Fresh, random ID that can be used for registering temporary objects *) - - val handle_request : t -> CamlGI.Cgi.Request.t -> unit - (** Handle the incoming request, by routing to an appropriate - object. *) -end - -(** {2 Main interface} *) - -(* TODO: interface with {! LazyGraph}. A (string, html.t, string) graph - maps naturally to URLs and simplifies routing. *) - -val serve_state : ?sockfile:string -> ?sockaddr:Unix.sockaddr -> - 'a State.t -> unit - (** Serve incoming requests using a single object. - @param sockfile the unix file to use as a socket *) - -val serve_router : ?sockfile:string -> ?sockaddr:Unix.sockaddr -> - Router.t -> unit - (** Shortcut. It calls {!CamlGI.Cgi.register_script} with a callback - that forwards requests to the given Router. - @param sockfile the unix file to use as a socket *) diff --git a/containers.odocl b/containers.odocl index 64a636bc..b9745656 100644 --- a/containers.odocl +++ b/containers.odocl @@ -1,39 +1,77 @@ # OASIS_START -# DO NOT EDIT (digest: ce652946b9e4e3d4bbad78e220466df8) -core/CCVector -core/CCDeque -core/CCGen -core/Gen_intf -core/CCSequence -core/CCFQueue -core/CCMultiMap -core/CCMultiSet -core/CCBV -core/CCPrint -core/CCPersistentHashtbl -core/CCError -core/CCHeap -core/CCList -core/CCOpt -core/CCPair -core/CCFun -core/CCHash -core/CCKList -core/CCInt -core/CCBool -core/CCFloat -core/CCArray -core/CCOrd -core/CCIO -core/CCRandom -core/CCKTree -core/CCTrie -core/CCString -core/CCHashtbl -core/CCFlatHashtbl -core/CCSexp -core/CCMap -core/CCCache -string/KMP -string/Levenshtein +# DO NOT EDIT (digest: ffa47e180123d84227a563bc0c3e8534) +src/core/CCVector +src/core/CCPrint +src/core/CCError +src/core/CCHeap +src/core/CCList +src/core/CCOpt +src/core/CCPair +src/core/CCFun +src/core/CCHash +src/core/CCInt +src/core/CCBool +src/core/CCFloat +src/core/CCArray +src/core/CCOrd +src/core/CCRandom +src/core/CCString +src/core/CCHashtbl +src/core/CCMap +src/misc/FHashtbl +src/misc/FlatHashtbl +src/misc/Hashset +src/misc/Heap +src/misc/LazyGraph +src/misc/PersistentGraph +src/misc/PHashtbl +src/misc/SkipList +src/misc/SplayTree +src/misc/SplayMap +src/misc/Univ +src/misc/Bij +src/misc/PiCalculus +src/misc/RAL +src/misc/UnionFind +src/misc/SmallSet +src/misc/AbsSet +src/misc/CSM +src/misc/TTree +src/misc/PrintBox +src/misc/HGraph +src/misc/Automaton +src/misc/Conv +src/misc/Bidir +src/misc/Iteratee +src/misc/BTree +src/misc/Ty +src/misc/Cause +src/misc/AVL +src/misc/ParseReact +src/iter/CCKTree +src/iter/CCKList +src/data/CCMultiMap +src/data/CCMultiSet +src/data/CCTrie +src/data/CCFlatHashtbl +src/data/CCCache +src/data/CCPersistentHashtbl +src/data/CCDeque +src/data/CCFQueue +src/data/CCBV +src/data/CCMixtbl +src/string/KMP +src/string/Levenshtein +src/pervasives/CCPervasives +src/bigarray/CCBigstring +src/advanced/CCLinq +src/advanced/CCBatch +src/advanced/CCCat +src/advanced/CCMonadIO +src/io/CCIO +src/sexp/CCSexp +src/sexp/CCSexpStream +src/sexp/CCSexpM +src/lwt/Lwt_automaton +src/lwt/Lwt_actor # OASIS_STOP diff --git a/core/CCGen.ml b/core/CCGen.ml deleted file mode 120000 index 8eb5e88d..00000000 --- a/core/CCGen.ml +++ /dev/null @@ -1 +0,0 @@ -../gen/gen.ml \ No newline at end of file diff --git a/core/CCGen.mli b/core/CCGen.mli deleted file mode 100644 index 0d284c22..00000000 --- a/core/CCGen.mli +++ /dev/null @@ -1,105 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Generators} - -Values of type ['a Gen.t] represent a possibly infinite sequence of values -of type 'a. One can only iterate once on the sequence, as it is consumed -by iteration/deconstruction/access. [None] is returned when the generator -is exhausted. Most functions consume elements. - -The submodule {!Restart} provides utilities to work with -{b restartable generators}, that is, functions [unit -> 'a Gen.t] that -allow to build as many generators from the same source as needed. -*) - -(** {2 Global type declarations} *) - -type 'a t = unit -> 'a option - (** A generator may be called several times, yielding the next value - each time. It returns [None] when no elements remain *) - -type 'a gen = 'a t - -(** {b NOTE}: version informations ("@since" annotations) in CCGen_intf - will not be reliable, for they will represent versions of Gen - rather than containers. *) -module type S = Gen_intf.S - -(** {2 Transient generators} *) - -val get : 'a t -> 'a option - (** Get the next value *) - -val next : 'a t -> 'a option - (** Synonym for {!get} *) - -val get_exn : 'a t -> 'a - (** Get the next value, or fails - @raise Invalid_argument if no element remains *) - -val junk : 'a t -> unit - (** Drop the next value, discarding it. *) - -val repeatedly : (unit -> 'a) -> 'a t - (** Call the same function an infinite number of times (useful for instance - if the function is a random generator). *) - -include S with type 'a t := 'a gen - (** Operations on {b transient} generators *) - -(** {2 Restartable generators} *) - -module Restart : sig - type 'a t = unit -> 'a gen - - type 'a restartable = 'a t - - include S with type 'a t := 'a restartable - - val cycle : 'a t -> 'a t - (** Cycle through the enum, endlessly. The enum must not be empty. *) - - val lift : ('a gen -> 'b) -> 'a t -> 'b - - val lift2 : ('a gen -> 'b gen -> 'c) -> 'a t -> 'b t -> 'c -end - -(** {2 Utils} *) - -val persistent : 'a t -> 'a Restart.t - (** Store content of the transient generator in memory, to be able to iterate - on it several times later. If possible, consider using combinators - from {!Restart} directly instead. *) - -val persistent_lazy : 'a t -> 'a Restart.t - (** Same as {!persistent}, but consumes the generator on demand (by chunks). - This allows to make a restartable generator out of an ephemeral one, - without paying a big cost upfront (nor even consuming it fully). - @since 0.6.1 *) - -val start : 'a Restart.t -> 'a t - (** Create a new transient generator. - [start gen] is the same as [gen ()] but is included for readability. *) diff --git a/core/CCSequence.ml b/core/CCSequence.ml deleted file mode 120000 index 397a44e3..00000000 --- a/core/CCSequence.ml +++ /dev/null @@ -1 +0,0 @@ -../sequence/sequence.ml \ No newline at end of file diff --git a/core/CCSequence.mli b/core/CCSequence.mli deleted file mode 100644 index 476af4db..00000000 --- a/core/CCSequence.mli +++ /dev/null @@ -1,624 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Simple and Efficient Iterators} *) - -(** The iterators are designed to allow easy transfer (mappings) between data - structures, without defining [n^2] conversions between the [n] types. The - implementation relies on the assumption that a sequence can be iterated - on as many times as needed; this choice allows for high performance - of many combinators. However, for transient iterators, the {!persistent} - function is provided, storing elements of a transient iterator - in memory; the iterator can then be used several times (See further). - - Note that some combinators also return sequences (e.g. {!group}). The - transformation is computed on the fly every time one iterates over - the resulting sequence. If a transformation performs heavy computation, - {!persistent} can also be used as intermediate storage. - - Most functions are {b lazy}, i.e. they do not actually use their arguments - until their result is iterated on. For instance, if one calls {!map} - on a sequence, one gets a new sequence, but nothing else happens until - this new sequence is used (by folding or iterating on it). - - If a sequence is built from an iteration function that is {b repeatable} - (i.e. calling it several times always iterates on the same set of - elements, for instance List.iter or Map.iter), then - the resulting {!t} object is also repeatable. For {b one-time iter functions} - such as iteration on a file descriptor or a {!Stream}, - the {!persistent} function can be used to iterate and store elements in - a memory structure; the result is a sequence that iterates on the elements - of this memory structure, cheaply and repeatably. *) - -type +'a t = ('a -> unit) -> unit - (** A sequence of values of type ['a]. If you give it a function ['a -> unit] - it will be applied to every element of the sequence successively. *) - -type +'a sequence = 'a t - -type (+'a, +'b) t2 = ('a -> 'b -> unit) -> unit - (** Sequence of pairs of values of type ['a] and ['b]. *) - -(** {2 Build a sequence} *) - -val from_iter : (('a -> unit) -> unit) -> 'a t - (** Build a sequence from a iter function *) - -val from_fun : (unit -> 'a option) -> 'a t - (** Call the function repeatedly until it returns None. This - sequence is transient, use {!persistent} if needed! *) - -val empty : 'a t - (** Empty sequence. It contains no element. *) - -val singleton : 'a -> 'a t - (** Singleton sequence, with exactly one element. *) - -val doubleton : 'a -> 'a -> 'a t - (** Sequence with exactly two elements - @since 0.3.4 *) - -val cons : 'a -> 'a t -> 'a t - (** [cons x l] yields [x], then yields from [l]. - Same as [append (singleton x) l] - @since 0.3.4 *) - - -val snoc : 'a t -> 'a -> 'a t - (** Same as {!cons} but yields the element after iterating on [l] - @since 0.3.4 *) - -val return : 'a -> 'a t - (** Synonym to {!singleton} - @since 0.3.4 *) - -val pure : 'a -> 'a t - (** Synonym to {!singleton} - @since 0.3.4 *) - -val repeat : 'a -> 'a t - (** Infinite sequence of the same element. You may want to look - at {!take} and the likes if you iterate on it. *) - -val iterate : ('a -> 'a) -> 'a -> 'a t - (** [iterate f x] is the infinite sequence [x, f(x), f(f(x)), ...] *) - -val forever : (unit -> 'b) -> 'b t - (** Sequence that calls the given function to produce elements. - The sequence may be transient (depending on the function), and definitely - is infinite. You may want to use {!take} and {!persistent}. *) - -val cycle : 'a t -> 'a t - (** Cycle forever through the given sequence. Assume the given sequence can - be traversed any amount of times (not transient). This yields an - infinite sequence, you should use something like {!take} not to loop - forever. *) - -(** {2 Consume a sequence} *) - -val iter : ('a -> unit) -> 'a t -> unit - (** Consume the sequence, passing all its arguments to the function. - Basically [iter f seq] is just [seq f]. *) - -val iteri : (int -> 'a -> unit) -> 'a t -> unit - (** Iterate on elements and their index in the sequence *) - -val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold over elements of the sequence, consuming it *) - -val foldi : ('b -> int -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold over elements of the sequence and their index, consuming it *) - -val map : ('a -> 'b) -> 'a t -> 'b t - (** Map objects of the sequence into other elements, lazily *) - -val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t - (** Map objects, along with their index in the sequence *) - -val for_all : ('a -> bool) -> 'a t -> bool - (** Do all elements satisfy the predicate? *) - -val exists : ('a -> bool) -> 'a t -> bool - (** Exists there some element satisfying the predicate? *) - -val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool - (** Is the value a member of the sequence? - @param eq the equality predicate to use (default [(=)]) - @since 0.3.4 *) - -val find : ('a -> 'b option) -> 'a t -> 'b option - (** Find the first element on which the function doesn't return [None] - @since 0.3.4 *) - -val length : 'a t -> int - (** How long is the sequence? Forces the sequence. *) - -val is_empty : 'a t -> bool - (** Is the sequence empty? Forces the sequence. *) - -(** {2 Transform a sequence} *) - -val filter : ('a -> bool) -> 'a t -> 'a t - (** Filter on elements of the sequence *) - -val append : 'a t -> 'a t -> 'a t - (** Append two sequences. Iterating on the result is like iterating - on the first, then on the second. *) - -val concat : 'a t t -> 'a t - (** Concatenate a sequence of sequences into one sequence. *) - -val flatten : 'a t t -> 'a t - (** Alias for {!concat} *) - -val flatMap : ('a -> 'b t) -> 'a t -> 'b t - (** Monadic bind. Intuitively, it applies the function to every element of the - initial sequence, and calls {!concat}. *) - -val flat_map : ('a -> 'b t) -> 'a t -> 'b t - (** Alias to {!flatMap} with a more explicit name - @since 0.3.4 *) - -val fmap : ('a -> 'b option) -> 'a t -> 'b t - (** Specialized version of {!flatMap} for options. *) - -val filter_map : ('a -> 'b option) -> 'a t -> 'b t - (** Alias to {!fmap} with a more explicit name - @since 0.3.4 *) - -val intersperse : 'a -> 'a t -> 'a t - (** Insert the single element between every element of the sequence *) - -(** {2 Caching} *) - -val persistent : 'a t -> 'a t - (** Iterate on the sequence, storing elements in an efficient internal structure.. - The resulting sequence can be iterated on as many times as needed. - {b Note}: calling persistent on an already persistent sequence - will still make a new copy of the sequence! *) - -val persistent_lazy : 'a t -> 'a t - (** Lazy version of {!persistent}. When calling [persistent_lazy s], - a new sequence [s'] is immediately returned (without actually consuming - [s]) in constant time; the first time [s'] is iterated on, - it also consumes [s] and caches its content into a inner data - structure that will back [s'] for future iterations. - - {b warning}: on the first traversal of [s'], if the traversal - is interrupted prematurely ({!take}, etc.) then [s'] will not be - memorized, and the next call to [s'] will traverse [s] again. - - @since 0.3.4 *) - -(** {2 Misc} *) - -val sort : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t - (** Sort the sequence. Eager, O(n) ram and O(n ln(n)) time. - It iterates on elements of the argument sequence immediately, - before it sorts them. *) - -val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t - (** Sort the sequence and remove duplicates. Eager, same as [sort] *) - -val group : ?eq:('a -> 'a -> bool) -> 'a t -> 'a list t - (** Group equal consecutive elements. *) - -val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t - (** Remove consecutive duplicate elements. Basically this is - like [fun seq -> map List.hd (group seq)]. *) - -val product : 'a t -> 'b t -> ('a * 'b) t - (** Cartesian product of the sequences. When calling [product a b], - the caller {b MUST} ensure that [b] can be traversed as many times - as required (several times), possibly by calling {!persistent} on it - beforehand. *) - -val product2 : 'a t -> 'b t -> ('a, 'b) t2 - (** Binary version of {!product}. Same requirements. - @since 0.3.4 *) - -val join : join_row:('a -> 'b -> 'c option) -> 'a t -> 'b t -> 'c t - (** [join ~join_row a b] combines every element of [a] with every - element of [b] using [join_row]. If [join_row] returns None, then - the two elements do not combine. Assume that [b] allows for multiple - iterations. *) - -val unfoldr : ('b -> ('a * 'b) option) -> 'b -> 'a t - (** [unfoldr f b] will apply [f] to [b]. If it - yields [Some (x,b')] then [x] is returned - and unfoldr recurses with [b']. *) - -val scan : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t - (** Sequence of intermediate results *) - -val max : ?lt:('a -> 'a -> bool) -> 'a t -> 'a option - (** Max element of the sequence, using the given comparison function. - @return None if the sequence is empty, Some [m] where [m] is the maximal - element otherwise *) - -val min : ?lt:('a -> 'a -> bool) -> 'a t -> 'a option - (** Min element of the sequence, using the given comparison function. - see {!max} for more details. *) - -val head : 'a t -> 'a option - (** First element, if any, otherwise [None] - @since 0.3.4 *) - -val head_exn : 'a t -> 'a - (** First element, if any, fails - @raise Invalid_argument if the sequence is empty - @since 0.3.4 *) - -val take : int -> 'a t -> 'a t - (** Take at most [n] elements from the sequence. Works on infinite - sequences. *) - -val take_while : ('a -> bool) -> 'a t -> 'a t - (** Take elements while they satisfy the predicate, then stops iterating. - Will work on an infinite sequence [s] if the predicate is false for at - least one element of [s]. - @since 0.3.4 *) - -val drop : int -> 'a t -> 'a t - (** Drop the [n] first elements of the sequence. Lazy. *) - -val drop_while : ('a -> bool) -> 'a t -> 'a t - (** Predicate version of {!drop} - @since 0.3.4 *) - -val rev : 'a t -> 'a t - (** Reverse the sequence. O(n) memory and time, needs the - sequence to be finite. The result is persistent and does - not depend on the input being repeatable. *) - -(** {2 Binary sequences} *) - -val empty2 : ('a, 'b) t2 - -val is_empty2 : (_, _) t2 -> bool - -val length2 : (_, _) t2 -> int - -val zip : ('a, 'b) t2 -> ('a * 'b) t - -val unzip : ('a * 'b) t -> ('a, 'b) t2 - -val zip_i : 'a t -> (int, 'a) t2 - (** Zip elements of the sequence with their index in the sequence *) - -val fold2 : ('c -> 'a -> 'b -> 'c) -> 'c -> ('a, 'b) t2 -> 'c - -val iter2 : ('a -> 'b -> unit) -> ('a, 'b) t2 -> unit - -val map2 : ('a -> 'b -> 'c) -> ('a, 'b) t2 -> 'c t - -val map2_2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'd) -> ('a, 'b) t2 -> ('c, 'd) t2 - (** [map2_2 f g seq2] maps each [x, y] of seq2 into [f x y, g x y] *) - -(** {2 Basic data structures converters} *) - -val to_list : 'a t -> 'a list - (** Convert the sequence into a list. Preserves order of elements. - This function is tail-recursive, but consumes 2*n memory. - If order doesn't matter to you, consider {!to_rev_list}. *) - -val to_rev_list : 'a t -> 'a list - (** Get the list of the reversed sequence (more efficient than {!to_list}) *) - -val of_list : 'a list -> 'a t - -val on_list : ('a t -> 'b t) -> 'a list -> 'b list -(** [on_list f l] is equivalent to [to_list @@ f @@ of_list l]. - @since 0.3.4 -*) - -val to_opt : 'a t -> 'a option - (** Alias to {!head} - @since 0.3.4 *) - -val to_array : 'a t -> 'a array - (** Convert to an array. Currently not very efficient because - an intermediate list is used. *) - -val of_array : 'a array -> 'a t - -val of_array_i : 'a array -> (int * 'a) t - (** Elements of the array, with their index *) - -val of_array2 : 'a array -> (int, 'a) t2 - -val array_slice : 'a array -> int -> int -> 'a t - (** [array_slice a i j] Sequence of elements whose indexes range - from [i] to [j] *) - -val of_opt : 'a option -> 'a t - (** Iterate on 0 or 1 values. - @since 0.3.4 *) - -val of_stream : 'a Stream.t -> 'a t - (** Sequence of elements of a stream (usable only once) *) - -val to_stream : 'a t -> 'a Stream.t - (** Convert to a stream. linear in memory and time (a copy is made in memory) *) - -val to_stack : 'a Stack.t -> 'a t -> unit - (** Push elements of the sequence on the stack *) - -val of_stack : 'a Stack.t -> 'a t - (** Sequence of elements of the stack (same order as [Stack.iter]) *) - -val to_queue : 'a Queue.t -> 'a t -> unit - (** Push elements of the sequence into the queue *) - -val of_queue : 'a Queue.t -> 'a t - (** Sequence of elements contained in the queue, FIFO order *) - -val hashtbl_add : ('a, 'b) Hashtbl.t -> ('a * 'b) t -> unit - (** Add elements of the sequence to the hashtable, with - Hashtbl.add *) - -val hashtbl_replace : ('a, 'b) Hashtbl.t -> ('a * 'b) t -> unit - (** Add elements of the sequence to the hashtable, with - Hashtbl.replace (erases conflicting bindings) *) - -val to_hashtbl : ('a * 'b) t -> ('a, 'b) Hashtbl.t - (** Build a hashtable from a sequence of key/value pairs *) - -val to_hashtbl2 : ('a, 'b) t2 -> ('a, 'b) Hashtbl.t - (** Build a hashtable from a sequence of key/value pairs *) - -val of_hashtbl : ('a, 'b) Hashtbl.t -> ('a * 'b) t - (** Sequence of key/value pairs from the hashtable *) - -val of_hashtbl2 : ('a, 'b) Hashtbl.t -> ('a, 'b) t2 - (** Sequence of key/value pairs from the hashtable *) - -val hashtbl_keys : ('a, 'b) Hashtbl.t -> 'a t -val hashtbl_values : ('a, 'b) Hashtbl.t -> 'b t - -val of_str : string -> char t -val to_str : char t -> string - -val concat_str : string t -> string - (** Concatenate strings together, eagerly. - Also see {!intersperse} to add a separator. - @since 0.3.4 *) - -exception OneShotSequence - (** Raised when the user tries to iterate several times on - a transient iterator *) - -val of_in_channel : in_channel -> char t - (** Iterates on characters of the input (can block when one - iterates over the sequence). If you need to iterate - several times on this sequence, use {!persistent}. - @raise OneShotSequence when used more than once. *) - -val to_buffer : char t -> Buffer.t -> unit - (** Copy content of the sequence into the buffer *) - -val int_range : start:int -> stop:int -> int t - (** Iterator on integers in [start...stop] by steps 1. Also see - {!(--)} for an infix version. *) - -val int_range_dec : start:int -> stop:int -> int t - (** Iterator on decreasing integers in [stop...start] by steps -1. - See {!(--^)} for an infix version *) - -val of_set : (module Set.S with type elt = 'a and type t = 'b) -> 'b -> 'a t - (** Convert the given set to a sequence. The set module must be provided. *) - -val to_set : (module Set.S with type elt = 'a and type t = 'b) -> 'a t -> 'b - (** Convert the sequence to a set, given the proper set module *) - -type 'a gen = unit -> 'a option -type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] - -val of_gen : 'a gen -> 'a t - (** Traverse eagerly the generator and build a sequence from it *) - -val to_gen : 'a t -> 'a gen - (** Make the sequence persistent (O(n)) and then iterate on it. Eager. *) - -val of_klist : 'a klist -> 'a t - (** Iterate on the lazy list *) - -val to_klist : 'a t -> 'a klist - (** Make the sequence persistent and then iterate on it. Eager. *) - -(** {2 Functorial conversions between sets and sequences} *) - -module Set : sig - module type S = sig - include Set.S - val of_seq : elt sequence -> t - val to_seq : t -> elt sequence - - val to_list : t -> elt list - (** @since 0.3.4 *) - - val of_list : elt list -> t - (** @since 0.3.4 *) - end - - (** Create an enriched Set module from the given one *) - module Adapt(X : Set.S) : S with type elt = X.elt and type t = X.t - - (** Functor to build an extended Set module from an ordered type *) - module Make(X : Set.OrderedType) : S with type elt = X.t -end - -(** {2 Conversion between maps and sequences.} *) - -module Map : sig - module type S = sig - include Map.S - val to_seq : 'a t -> (key * 'a) sequence - val of_seq : (key * 'a) sequence -> 'a t - val keys : 'a t -> key sequence - val values : 'a t -> 'a sequence - - val to_list : 'a t -> (key * 'a) list - (** @since 0.3.4 *) - - val of_list : (key * 'a) list -> 'a t - (** @since 0.3.4 *) - end - - (** Adapt a pre-existing Map module to make it sequence-aware *) - module Adapt(M : Map.S) : S with type key = M.key and type 'a t = 'a M.t - - (** Create an enriched Map module, with sequence-aware functions *) - module Make(V : Map.OrderedType) : S with type key = V.t -end - -(** {2 Infinite sequences of random values} *) - -val random_int : int -> int t - (** Infinite sequence of random integers between 0 and - the given higher bound (see Random.int) *) - -val random_bool : bool t - (** Infinite sequence of random bool values *) - -val random_float : float -> float t - -val random_array : 'a array -> 'a t - (** Sequence of choices of an element in the array *) - -val random_list : 'a list -> 'a t - (** Infinite sequence of random elements of the list. Basically the - same as {!random_array}. *) - -(** {2 Infix functions} *) - -module Infix : sig - val (--) : int -> int -> int t - (** [a -- b] is the range of integers from [a] to [b], both included, - in increasing order. It will therefore be empty if [a > b]. *) - - val (--^) : int -> int -> int t - (** [a --^ b] is the range of integers from [b] to [a], both included, - in decreasing order (starts from [a]). - It will therefore be empty if [a < b]. *) - - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - (** Monadic bind (infix version of {!flat_map} - @since 0.3.4 *) - - val (>|=) : 'a t -> ('a -> 'b) -> 'b t - (** Infix version of {!map} - @since 0.3.4 *) - - val (<*>) : ('a -> 'b) t -> 'a t -> 'b t - (** Applicative operator (product+application) - @since 0.3.4 *) - - val (<+>) : 'a t -> 'a t -> 'a t - (** Concatenation of sequences - @since 0.3.4 *) -end - -include module type of Infix - - -(** {2 Pretty printing of sequences} *) - -val pp_seq : ?sep:string -> (Format.formatter -> 'a -> unit) -> - Format.formatter -> 'a t -> unit - (** Pretty print a sequence of ['a], using the given pretty printer - to print each elements. An optional separator string can be provided. *) - -val pp_buf : ?sep:string -> (Buffer.t -> 'a -> unit) -> - Buffer.t -> 'a t -> unit - (** Print into a buffer *) - -val to_string : ?sep:string -> ('a -> string) -> 'a t -> string - (** Print into a string *) - -(** {2 Basic IO} - -Very basic interface to manipulate files as sequence of chunks/lines. The -sequences take care of opening and closing files properly; every time -one iterates over a sequence, the file is opened/closed again. - -Example: copy a file ["a"] into file ["b"], removing blank lines: - -{[ - Sequence.(IO.lines_of "a" |> filter (fun l-> l<> "") |> IO.write_lines "b");; -]} - -By chunks of [4096] bytes: - -{[ - Sequence.IO.(chunks_of ~size:4096 "a" |> write_to "b");; -]} - -Read the lines of a file into a list: - -{[ - Sequence.IO.lines "a" |> Sequence.to_list -]} - -@since 0.3.4 *) - -module IO : sig - val lines_of : ?mode:int -> ?flags:open_flag list -> - string -> string t - (** [lines_of filename] reads all lines of the given file. It raises the - same exception as would opening the file and read from it, except - from [End_of_file] (which is caught). The file is {b always} properly - closed. - Every time the sequence is iterated on, the file is opened again, so - different iterations might return different results - @param mode default [0o644] - @param flags default: [[Open_rdonly]] *) - - val chunks_of : ?mode:int -> ?flags:open_flag list -> ?size:int -> - string -> string t - (** Read chunks of the given [size] from the file. The last chunk might be - smaller. Behaves like {!lines_of} regarding errors and options. - Every time the sequence is iterated on, the file is opened again, so - different iterations might return different results *) - - val write_to : ?mode:int -> ?flags:open_flag list -> - string -> string t -> unit - (** [write_to filename seq] writes all strings from [seq] into the given - file. It takes care of opening and closing the file. - @param mode default [0o644] - @param flags used by [open_out_gen]. Default: [[Open_creat;Open_wronly]]. *) - - val write_bytes_to : ?mode:int -> ?flags:open_flag list -> - string -> Bytes.t t -> unit - (** @since 0.5 *) - - val write_lines : ?mode:int -> ?flags:open_flag list -> - string -> string t -> unit - (** Same as {!write_to}, but intercales ['\n'] between each string *) - - val write_bytes_lines : ?mode:int -> ?flags:open_flag list -> - string -> Bytes.t t -> unit - (** @since 0.5 *) -end diff --git a/core/Gen_intf.ml b/core/Gen_intf.ml deleted file mode 120000 index 32cbb5c8..00000000 --- a/core/Gen_intf.ml +++ /dev/null @@ -1 +0,0 @@ -../gen/gen_intf.ml \ No newline at end of file diff --git a/doc/build_deps.ml b/doc/build_deps.ml new file mode 100755 index 00000000..5386c641 --- /dev/null +++ b/doc/build_deps.ml @@ -0,0 +1,26 @@ +#!/usr/bin/env ocaml + +#use "topfind";; +#require "containers";; +#require "containers.io";; +#require "gen";; +#require "unix";; + +let odoc_files = + CCIO.File.walk "_build" + |> Gen.filter_map + (function + | `File, f when CCString.suffix ~suf:".odoc" f -> Some f + | _ -> None + ) + |> Gen.flat_map + (fun f -> Gen.of_list ["-load"; f]) + |> Gen.to_list +;; + +let cmd = + "ocamldoc -dot -o deps.dot " ^ String.concat " " odoc_files +;; + +print_endline ("run: " ^ cmd);; +Unix.system cmd;; diff --git a/doc/intro.txt b/doc/intro.txt new file mode 100644 index 00000000..afde017d --- /dev/null +++ b/doc/intro.txt @@ -0,0 +1,137 @@ +{1 Containers} + +{2 Change Log} + +See {{: https://github.com/c-cube/ocaml-containers/blob/master/CHANGELOG.md } this file} + +{2 License} + +This code is free, under the BSD license. + +The logo (media/logo.png) is +CC-SA3 {{:http://en.wikipedia.org/wiki/File:Hypercube.svg} wikimedia} + +{2 Contents} + +The design is mostly centered around polymorphism rather than functors. Such +structures comprise (some modules in misc/, some other in core/): + +the core library, containers, now depends on +{{:https://github.com/mjambon/cppo}cppo} and base-bytes (provided +by ocamlfind). + +{4 Core Modules (extension of the standard library)} + +{!modules: +CCArray +CCBool +CCError +CCFloat +CCFun +CCHash +CCHeap +CCInt +CCList +CCOpt +CCOrd +CCPair +CCPrint +CCRandom +CCString +CCVector +} + +{4 Pervasives (aliases to Core Modules)} + +Contains aliases to most modules from {i containers core}, and mixins +such as: + +{[ module List = struct + include List + include CCList + end +]} + +{!modules: CCPervasives} + +{4 Containers.data} + +Various data structures. + +{!modules: +CCBV +CCCache +CCFQueue +CCFlatHashtbl +CCMixtbl +CCMultiMap +CCMultiSet +CCPersistentHashtbl +CCTrie +} + +{4 Containers.io} + +Helpers to perform simple IO (mostly on files) and iterate on channels. + +{!modules: CCIO} + +{4 Containers.sexp} + +A small S-expression library. The interface is relatively unstable, but +the main type ([CCSexp.t]) isn't. + +{!modules: CCSexp CCSexpStream CCSexpM} + +{4 Containers.iter} + +Iterators: + +{!modules: CCKList CCKTree} + +{4 String} + +{!modules: Levenshtein KMP} + +{4 Bigarrays} + +Use bigarrays to hold large strings and map files directly into memory. + +{!modules: CCBigstring} + +{4 Advanced} + +This module is qualified with [Containers_advanced]. + +{!modules: CCLinq CCCat CCBatch} + +{4 Misc} + +This list is not necessarily up-to-date. + +{!modules: +AbsSet +Bij +FlatHashtbl +Hashset +Heap +Heap +LazyGraph +PHashtbl +PrintBox +RAL +SmallSet +SplayMap +SplayTree +UnionFind +Univ +} + +{4 Others} + +{!modules: CCFuture} + + +{2 Index} + +{!indexlist} diff --git a/examples/id_sexp.ml b/examples/id_sexp.ml index a5d73e9b..1adf3080 100644 --- a/examples/id_sexp.ml +++ b/examples/id_sexp.ml @@ -3,11 +3,11 @@ let () = if Array.length Sys.argv <> 2 then failwith "usage: id_sexp file"; let f = Sys.argv.(1) in - let s = CCSexp.L.of_file f in + let s = CCSexpStream.L.of_file f in match s with | `Ok l -> List.iter - (fun s -> Format.printf "@[%a@]@." CCSexp.print s) + (fun s -> Format.printf "@[%a@]@." CCSexpStream.print s) l | `Error msg -> Format.printf "error: %s@." msg diff --git a/examples/id_sexp2.ml b/examples/id_sexp2.ml new file mode 100644 index 00000000..90e63c27 --- /dev/null +++ b/examples/id_sexp2.ml @@ -0,0 +1,13 @@ + + +let () = + if Array.length Sys.argv <> 2 then failwith "usage: id_sexp file"; + let f = Sys.argv.(1) in + let s = CCSexpM.parse_file_list f in + match s with + | `Ok l -> + List.iter + (fun s -> Format.printf "@[%a@]@." CCSexpM.print s) + l + | `Error msg -> + Format.printf "error: %s@." msg diff --git a/examples/mem_size.ml b/examples/mem_size.ml index d424e9ed..4e69c083 100644 --- a/examples/mem_size.ml +++ b/examples/mem_size.ml @@ -1,7 +1,7 @@ (** Compute the memory footprint of a value (and its subvalues). Reference is http://rwmj.wordpress.com/2009/08/05/ocaml-internals-part-2-strings-and-other-types/ *) -module Sequence = CCSequence + (** A graph vertex is an Obj.t value *) let graph = diff --git a/gen/.gitignore b/gen/.gitignore deleted file mode 100644 index 20f09d16..00000000 --- a/gen/.gitignore +++ /dev/null @@ -1,11 +0,0 @@ -.*.swp -.*.swo -_build -*.native -*.byte -.session -TAGS -*.docdir -setup.log -setup.data -qtest diff --git a/gen/.merlin b/gen/.merlin deleted file mode 100644 index 26649dfa..00000000 --- a/gen/.merlin +++ /dev/null @@ -1,5 +0,0 @@ -S . -B _build -S tests -B _build/tests -PKG oUnit diff --git a/gen/META b/gen/META deleted file mode 100644 index edcf3e82..00000000 --- a/gen/META +++ /dev/null @@ -1,11 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: c6b7b0973d898c3e8b7f565b701ee0d0) -version = "0.2.2" -description = "Simple, efficient iterators for OCaml" -archive(byte) = "gen.cma" -archive(byte, plugin) = "gen.cma" -archive(native) = "gen.cmxa" -archive(native, plugin) = "gen.cmxs" -exists_if = "gen.cma" -# OASIS_STOP - diff --git a/gen/Makefile b/gen/Makefile deleted file mode 100644 index 43e32bdf..00000000 --- a/gen/Makefile +++ /dev/null @@ -1,59 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) - -SETUP = ocaml setup.ml - -build: setup.data - $(SETUP) -build $(BUILDFLAGS) - -doc: setup.data build - $(SETUP) -doc $(DOCFLAGS) - -test: setup.data build - $(SETUP) -test $(TESTFLAGS) - -all: - $(SETUP) -all $(ALLFLAGS) - -install: setup.data - $(SETUP) -install $(INSTALLFLAGS) - -uninstall: setup.data - $(SETUP) -uninstall $(UNINSTALLFLAGS) - -reinstall: setup.data - $(SETUP) -reinstall $(REINSTALLFLAGS) - -clean: - $(SETUP) -clean $(CLEANFLAGS) - -distclean: - $(SETUP) -distclean $(DISTCLEANFLAGS) - -setup.data: - $(SETUP) -configure $(CONFIGUREFLAGS) - -configure: - $(SETUP) -configure $(CONFIGUREFLAGS) - -.PHONY: build doc test all install uninstall reinstall clean distclean configure - -# OASIS_STOP - -push_doc: all doc - scp -r gen.docdir/* cedeela.fr:~/simon/root/software/gen/ - -qtest-gen: - mkdir -p qtest - qtest extract gen.ml > qtest/run_qtest.ml - -test-all: - ./run_tests.native - ./run_qtest.native - -VERSION=$(shell awk '/^Version:/ {print $$2}' _oasis) - -update_next_tag: - @echo "update version to $(VERSION)..." - sed -i "s/NEXT_VERSION/$(VERSION)/g" *.ml *.mli - sed -i "s/NEXT_RELEASE/$(VERSION)/g" *.ml *.mli diff --git a/gen/README.md b/gen/README.md deleted file mode 100644 index f8ff67c6..00000000 --- a/gen/README.md +++ /dev/null @@ -1,32 +0,0 @@ -Gen -=== - -Iterators for OCaml, both restartable and consumable. Performances should -be good, yet the code is simple and straightforward. - -The documentation can be found [here](http://cedeela.fr/~simon/software/gen) - -## Use - -You can either build and install the library (see `Build`), or just copy -files to your own project. The last solution has the benefits that you -don't have additional dependencies nor build complications (and it may enable -more inlining). I therefore recommand it for its simplicity. - -If you have comments, requests, or bugfixes, please share them! :-) - -## Build - -There are no dependencies. This should work with OCaml>=3.12. - - $ make - -To build and run tests (requires `oUnit`): - - $ opam install oUnit - $ make tests - $ ./tests.native - -## License - -This code is free, under the BSD license. diff --git a/gen/_oasis b/gen/_oasis deleted file mode 100644 index d13b7765..00000000 --- a/gen/_oasis +++ /dev/null @@ -1,65 +0,0 @@ -OASISFormat: 0.3 -Name: gen -Version: 0.2.2 -Homepage: https://github.com/c-cube/gen -Authors: Simon Cruanes -License: BSD3 -LicenseFile: LICENSE -Plugins: META (0.3), DevFiles (0.3) -BuildTools: ocamlbuild - -Synopsis: Simple, efficient iterators for OCaml - -Flag "bench" - Description: build benchmark - Default: false - -Library "gen" - Path: . - Pack: false - Modules: Gen, Gen_intf - -Document gen - Title: Containers docs - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Install: true - XOCamlbuildPath: . - XOCamlbuildLibraries: gen - -PreBuildCommand: make qtest-gen - -Executable run_tests - Path: tests/ - Install: false - CompiledObject: native - MainIs: run_tests.ml - Build$: flag(tests) - BuildDepends: gen,oUnit - -Executable run_qtest - Path: qtest/ - Install: false - CompiledObject: native - MainIs: run_qtest.ml - Build$: flag(tests) - BuildDepends: containers, containers.misc, containers.string, - oUnit, QTest2Lib - -Test all - Command: make test-all - TestTools: run_tests, run_qtest - Run$: flag(tests) - -Executable bench_persistent - Path: bench/ - Install: false - CompiledObject: native - MainIs: bench_persistent.ml - Build$: flag(bench) - BuildDepends: gen,benchmark - -SourceRepository head - Type: git - Location: https://github.com/c-cube/gen - Browser: https://github.com/c-cube/gen/tree/master/src diff --git a/gen/_tags b/gen/_tags deleted file mode 100644 index 8760f650..00000000 --- a/gen/_tags +++ /dev/null @@ -1,43 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: a9f4ed4316e4221c9e3cad121ae7a8a9) -# Ignore VCS directories, you can use the same kind of rule outside -# OASIS_START/STOP if you want to exclude directories that contains -# useless stuff for the build process -true: annot, bin_annot -<**/.svn>: -traverse -<**/.svn>: not_hygienic -".bzr": -traverse -".bzr": not_hygienic -".hg": -traverse -".hg": not_hygienic -".git": -traverse -".git": not_hygienic -"_darcs": -traverse -"_darcs": not_hygienic -# Library gen -"gen.cmxs": use_gen -# Executable run_tests -"tests/run_tests.native": pkg_oUnit -"tests/run_tests.native": use_gen -: pkg_oUnit -: use_gen -# Executable run_qtest -"qtest/run_qtest.native": pkg_QTest2Lib -"qtest/run_qtest.native": pkg_containers -"qtest/run_qtest.native": pkg_containers.misc -"qtest/run_qtest.native": pkg_containers.string -"qtest/run_qtest.native": pkg_oUnit -: pkg_QTest2Lib -: pkg_containers -: pkg_containers.misc -: pkg_containers.string -: pkg_oUnit -# Executable bench_persistent -"bench/bench_persistent.native": pkg_benchmark -"bench/bench_persistent.native": use_gen -: pkg_benchmark -: use_gen -# OASIS_STOP -"qtest": include -<**/*.ml>: warn_A, warn(-4), warn(-44) - diff --git a/gen/bench/.merlin b/gen/bench/.merlin deleted file mode 100644 index ba79d719..00000000 --- a/gen/bench/.merlin +++ /dev/null @@ -1,4 +0,0 @@ -S . -B ../_build/bench/ -REC -PKG benchmark diff --git a/gen/bench/bench_persistent.ml b/gen/bench/bench_persistent.ml deleted file mode 100644 index d2a5551b..00000000 --- a/gen/bench/bench_persistent.ml +++ /dev/null @@ -1,161 +0,0 @@ - -let _sum g = - Gen.Restart.fold (+) 0 g - - -module MList = struct - type 'a t = 'a node option ref - and 'a node = { - content : 'a; - mutable prev : 'a node; - mutable next : 'a node; - } - - let create () = ref None - - let is_empty d = - match !d with - | None -> true - | Some _ -> false - - let push_back d x = - match !d with - | None -> - let rec elt = { - content = x; prev = elt; next = elt; } in - d := Some elt - | Some first -> - let elt = { content = x; next=first; prev=first.prev; } in - first.prev.next <- elt; - first.prev <- elt - - (* conversion to gen *) - let to_gen d = - fun () -> - match !d with - | None -> (fun () -> None) - | Some first -> - let cur = ref first in (* current element of the list *) - let stop = ref false in (* are we done yet? *) - fun () -> - if !stop then None - else begin - let x = (!cur).content in - cur := (!cur).next; - (if !cur == first then stop := true); (* EOG, we made a full cycle *) - Some x - end -end - -(** Store content of the generator in an enum *) -let persistent_mlist gen = - let l = MList.create () in - Gen.iter (MList.push_back l) gen; - MList.to_gen l - -let bench_mlist n = - for _i = 0 to 100 do - let g = persistent_mlist Gen.(1 -- n) in - ignore (_sum g) - done - -(** {6 Unrolled mutable list} *) -module UnrolledList = struct - type 'a node = - | Nil - | Partial of 'a array * int - | Cons of 'a array * 'a node ref - - let of_gen gen = - let start = ref Nil in - let chunk_size = ref 16 in - let rec fill prev cur = - match cur, gen() with - | Partial (a,n), None -> - prev := Cons (Array.sub a 0 n, ref Nil); () (* done *) - | _, None -> prev := cur; () (* done *) - | Nil, Some x -> - let n = !chunk_size in - if n < 4096 then chunk_size := 2 * !chunk_size; - fill prev (Partial (Array.make n x, 1)) - | Partial (a, n), Some x -> - assert (n < Array.length a); - a.(n) <- x; - if n+1 = Array.length a - then begin - let r = ref Nil in - prev := Cons(a, r); - fill r Nil - end else fill prev (Partial (a, n+1)) - | Cons _, _ -> assert false - in - fill start !start ; - !start - - let to_gen l () = - let cur = ref l in - let i = ref 0 in - let rec next() = match !cur with - | Nil -> None - | Cons (a,l') -> - if !i = Array.length a - then begin - cur := !l'; - i := 0; - next() - end else begin - let y = a.(!i) in - incr i; - Some y - end - | Partial _ -> assert false - in - next -end - -(** Store content of the generator in an enum *) -let persistent_unrolled gen = - let l = UnrolledList.of_gen gen in - UnrolledList.to_gen l - -let bench_unrolled n = - for _i = 0 to 100 do - let g = persistent_unrolled Gen.(1 -- n) in - ignore (_sum g) - done - -let bench_naive n = - for _i = 0 to 100 do - let l = Gen.to_rev_list Gen.(1 -- n) in - let g = Gen.Restart.of_list (List.rev l) in - ignore (_sum g) - done - -let bench_current n = - for _i = 0 to 100 do - let g = Gen.persistent Gen.(1 -- n) in - ignore (_sum g) - done - -let bench_current_lazy n = - for _i = 0 to 100 do - let g = Gen.persistent_lazy Gen.(1 -- n) in - ignore (_sum g) - done - -let () = - let bench_n n = - Printf.printf "BENCH for %d\n" n; - let res = Benchmark.throughputN 5 - [ "mlist", bench_mlist, n - ; "naive", bench_naive, n - ; "unrolled", bench_unrolled, n - ; "current", bench_current, n - ; "current_lazy", bench_current_lazy, n - ] - in Benchmark.tabulate res - in - bench_n 100; - bench_n 100_000; - () - diff --git a/gen/configure b/gen/configure deleted file mode 100755 index 6acfaeb9..00000000 --- a/gen/configure +++ /dev/null @@ -1,27 +0,0 @@ -#!/bin/sh - -# OASIS_START -# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) -set -e - -FST=true -for i in "$@"; do - if $FST; then - set -- - FST=false - fi - - case $i in - --*=*) - ARG=${i%%=*} - VAL=${i##*=} - set -- "$@" "$ARG" "$VAL" - ;; - *) - set -- "$@" "$i" - ;; - esac -done - -ocaml setup.ml -configure "$@" -# OASIS_STOP diff --git a/gen/gen.ml b/gen/gen.ml deleted file mode 100644 index 8aa35265..00000000 --- a/gen/gen.ml +++ /dev/null @@ -1,1669 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Restartable generators} *) - -(** {2 Global type declarations} *) - -type 'a t = unit -> 'a option - -type 'a gen = 'a t - -module type S = Gen_intf.S - -(** {2 Transient generators} *) - -let empty () = None - -(*$T empty - empty |> to_list = [] -*) - -let singleton x = - let first = ref true in - fun () -> - if !first then (first := false; Some x) else None - -(*T singleton - singleton 1 |> to_list = [1] - singleton "foo" |> to_list = ["foo"] -*) - -let repeat x () = Some x - -(*$T repeat - repeat 42 |> take 3 |> to_list = [42; 42; 42] -*) - -let repeatedly f () = Some (f ()) - -(*$T repeatedly - repeatedly (let r = ref 0 in fun () -> incr r; !r) \ - |> take 5 |> to_list = [1;2;3;4;5] -*) - -let iterate x f = - let cur = ref x in - fun () -> - let x = !cur in - cur := f !cur; - Some x - -(*$T iterate - iterate 0 ((+)1) |> take 5 |> to_list = [0;1;2;3;4] -*) - -let next gen = gen () - -let get gen = gen () - -let get_exn gen = - match gen () with - | Some x -> x - | None -> raise (Invalid_argument "Gen.get_exn") - -(*$R get_exn - let g = of_list [1;2;3] in - assert_equal 1 (get_exn g); - assert_equal 2 (get_exn g); - assert_equal 3 (get_exn g); - assert_raises (Invalid_argument "Gen.get_exn") (fun () -> get_exn g) -*) - -let junk gen = ignore (gen ()) - -let rec fold f acc gen = - match gen () with - | None -> acc - | Some x -> fold f (f acc x) gen - -(*$Q - (Q.list Q.small_int) (fun l -> \ - of_list l |> fold (fun l x->x::l) [] = List.rev l) -*) - -let reduce f g = - let acc = match g () with - | None -> raise (Invalid_argument "reduce") - | Some x -> x - in - fold f acc g - -(* Dual of {!fold}, with a deconstructing operation *) -let unfold f acc = - let acc = ref acc in - fun () -> - match f !acc with - | None -> None - | Some (x, acc') -> - acc := acc'; - Some x - -(*$T unfold - unfold (fun (prev,cur) -> Some (prev, (cur,prev+cur))) (0,1) \ - |> take 7 |> to_list = [0; 1; 1; 2; 3; 5; 8] -*) - -let init ?(limit=max_int) f = - let r = ref 0 in - fun () -> - if !r >= limit - then None - else - let x = f !r in - let _ = incr r in - Some x - -(*$T init - init ~limit:5 (fun i->i) |> to_list = [0;1;2;3;4] -*) - -let rec iter f gen = - match gen() with - | None -> () - | Some x -> f x; iter f gen - -let iteri f gen = - let rec iteri i = match gen() with - | None -> () - | Some x -> f i x; iteri (i+1) - in - iteri 0 - -let is_empty gen = match gen () with - | None -> true - | Some _ -> false - -(*$T - is_empty empty - not (is_empty (singleton 2)) -*) - -let length gen = - fold (fun acc _ -> acc + 1) 0 gen - -(*$Q - (Q.list Q.small_int) (fun l -> \ - of_list l |> length = List.length l) -*) - -(* useful state *) -module RunState = struct - type 'a t = - | Init - | Run of 'a - | Stop -end - -let scan f acc g = - let open RunState in - let state = ref Init in - fun () -> - match !state with - | Init -> - state := Run acc; - Some acc - | Stop -> None - | Run acc -> - match g() with - | None -> state := Stop; None - | Some x -> - let acc' = f acc x in - state := Run acc'; - Some acc' - -(*$T scan - scan (fun acc x -> x+1::acc) [] (1--5) |> to_list \ - = [[]; [2]; [3;2]; [4;3;2]; [5;4;3;2]; [6;5;4;3;2]] -*) - -let unfold_scan f acc g = - let open RunState in - let state = ref (Run acc) in - fun () -> - match !state with - | Init -> assert false - | Stop -> None - | Run acc -> - match g() with - | None -> state := Stop; None - | Some x -> - let acc', y = f acc x in - state := Run acc'; - Some y - -(*$T unfold_scan - unfold_scan (fun acc x -> x+acc,acc) 0 (1--5) |> to_list \ - = [0; 1; 3; 6; 10] -*) - -(** {3 Lazy} *) - -let map f gen = - let stop = ref false in - fun () -> - if !stop then None - else match gen() with - | None -> stop:= true; None - | Some x -> Some (f x) - -(*$Q map - (Q.list Q.small_int) (fun l -> \ - let f x = x*2 in \ - of_list l |> map f |> to_list = List.map f l) -*) - -let append gen1 gen2 = - let first = ref true in - let rec next() = - if !first - then match gen1() with - | (Some _) as x -> x - | None -> first:=false; next() - else gen2() - in next - -(*$Q - (Q.pair (Q.list Q.small_int)(Q.list Q.small_int)) (fun (l1,l2) -> \ - append (of_list l1) (of_list l2) |> to_list = l1 @ l2) -*) - -let flatten next_gen = - let open RunState in - let state = ref Init in - (* get next element *) - let rec next () = - match !state with - | Init -> get_next_gen() - | Run gen -> - begin match gen () with - | None -> get_next_gen () - | (Some _) as x -> x - end - | Stop -> None - and get_next_gen() = match next_gen() with - | None -> state := Stop; None - | Some gen -> state := Run gen; next() - in - next - -let flat_map f next_elem = - let open RunState in - let state = ref Init in - let rec next() = - match !state with - | Init -> get_next_gen() - | Run gen -> - begin match gen () with - | None -> get_next_gen () - | (Some _) as x -> x - end - | Stop -> None - and get_next_gen() = match next_elem() with - | None -> state:=Stop; None - | Some x -> - try state := Run (f x); next() - with e -> state := Stop; raise e - in - next - -(*$Q flat_map - (Q.list Q.small_int) (fun l -> \ - let f x = of_list [x;x*2] in \ - eq (map f (of_list l) |> flatten) (flat_map f (of_list l))) -*) - -let mem ?(eq=(=)) x gen = - let rec mem eq x gen = - match gen() with - | Some y -> eq x y || mem eq x gen - | None -> false - in mem eq x gen - -let take n gen = - assert (n >= 0); - let count = ref 0 in (* how many yielded elements *) - fun () -> - if !count = n || !count = ~-1 - then None - else match gen() with - | None -> count := ~-1; None (* indicate stop *) - | (Some _) as x -> incr count; x - -(*$Q - (Q.pair Q.small_int (Q.list Q.small_int)) (fun (n,l) -> \ - of_list l |> take n |> length = Pervasives.min n (List.length l)) -*) - -(* call [gen] at most [n] times, and stop *) -let rec __drop n gen = - if n = 0 then () - else match gen() with - | Some _ -> __drop (n-1) gen - | None -> () - -let drop n gen = - assert (n >= 0); - let dropped = ref false in - fun () -> - if !dropped - then gen() - else begin - (* drop [n] elements and yield the next element *) - dropped := true; - __drop n gen; - gen() - end - -(*$Q - (Q.pair Q.small_int (Q.list Q.small_int)) (fun (n,l) -> \ - let g1,g2 = take n (of_list l), drop n (of_list l) in \ - append g1 g2 |> to_list = l) -*) - -let nth n gen = - assert (n>=0); - __drop n gen; - match gen () with - | None -> raise Not_found - | Some x -> x - -(*$= nth & ~printer:string_of_int - 4 (nth 4 (0--10)) - 8 (nth 8 (0--10)) -*) - -(*$T - (try ignore (nth 11 (1--10)); false with Not_found -> true) -*) - -let take_nth n gen = - assert (n>=1); - let i = ref n in - let rec next() = - match gen() with - | None -> None - | (Some _) as res when !i = n -> i:=1; res - | Some _ -> incr i; next() - in next - -let filter p gen = - let rec next () = - (* wrap exception into option, for next to be tailrec *) - match gen() with - | None -> None - | (Some x) as res -> - if p x - then res (* yield element *) - else next () (* discard element *) - in next - -(*$T - filter (fun x ->x mod 2 = 0) (1--10) |> to_list = [2;4;6;8;10] -*) - -let take_while p gen = - let stop = ref false in - fun () -> - if !stop - then None - else match gen() with - | (Some x) as res -> - if p x then res else (stop := true; None) - | None -> stop:=true; None - -(*$T - take_while (fun x ->x<10) (1--1000) |> eq (1--9) -*) - -module DropWhileState = struct - type t = - | Stop - | Drop - | Yield -end - -let drop_while p gen = - let open DropWhileState in - let state = ref Drop in - let rec next () = - match !state with - | Stop -> None - | Drop -> - begin match gen () with - | None -> state := Stop; None - | (Some x) as res -> - if p x then next() else (state:=Yield; res) - end - | Yield -> - begin match gen () with - | None -> state := Stop; None - | Some _ as res -> res - end - in next - -(*$T - drop_while (fun x-> x<10) (1--20) |> eq (10--20) -*) - -let filter_map f gen = - (* tailrec *) - let rec next () = - match gen() with - | None -> None - | Some x -> - match f x with - | None -> next() - | (Some _) as res -> res - in next - -(*$T - filter_map (fun x-> if x mod 2 = 0 then Some (string_of_int x) else None) (1--10) \ - |> to_list = List.map string_of_int [2;4;6;8;10] -*) - -let zip_index gen = - let r = ref ~-1 in - fun () -> - match gen() with - | None -> None - | Some x -> - incr r; - Some (!r, x) - -(*$T - zip_index (1--5) |> to_list = [0,1; 1,2; 2,3; 3,4; 4,5] -*) - -let unzip gen = - let stop = ref false in - let q1 = Queue.create () in - let q2 = Queue.create () in - let next_left () = - if Queue.is_empty q1 - then if !stop then None - else match gen() with - | Some (x,y) -> - Queue.push y q2; - Some x - | None -> stop := true; None - else Some (Queue.pop q1) - in - let next_right () = - if Queue.is_empty q2 - then if !stop then None - else match gen() with - | Some (x,y) -> - Queue.push x q1; - Some y - | None -> stop := true; None - else Some (Queue.pop q2) - in - next_left, next_right - -(*$T - unzip (of_list [1,2;3,4]) |> (fun (x,y)-> to_list x, to_list y) \ - = ([1;3], [2;4]) -*) - -(*$Q - (Q.list (Q.pair Q.small_int Q.small_int)) (fun l -> \ - of_list l |> unzip |> (fun (x,y) -> to_list x,to_list y) = \ - List.split l) -*) - -(* [partition p l] returns the elements that satisfy [p], - and the elements that do not satisfy [p] *) -let partition p gen = - let qtrue = Queue.create () in - let qfalse = Queue.create () in - let stop = ref false in - let rec nexttrue () = - if Queue.is_empty qtrue - then if !stop then None - else match gen() with - | (Some x) as res -> - if p x then res else (Queue.push x qfalse; nexttrue()) - | None -> stop:=true; None - else Some (Queue.pop qtrue) - and nextfalse() = - if Queue.is_empty qfalse - then if !stop then None - else match gen() with - | (Some x) as res -> - if p x then (Queue.push x qtrue; nextfalse()) else res - | None -> stop:= true; None - else Some (Queue.pop qfalse) - in - nexttrue, nextfalse - -(*$T - partition (fun x -> x mod 2 = 0) (1--10) |> \ - (fun (x,y)->to_list x, to_list y) = ([2;4;6;8;10], [1;3;5;7;9]) -*) - -let rec for_all p gen = - match gen() with - | None -> true - | Some x -> p x && for_all p gen - -let rec exists p gen = - match gen() with - | None -> false - | Some x -> p x || exists p gen - -let min ?(lt=fun x y -> x < y) gen = - let first = match gen () with - | Some x -> x - | None -> raise (Invalid_argument "min") - in - fold (fun min x -> if lt x min then x else min) first gen - -(*$T - min (of_list [1;4;6;0;11; -2]) = ~-2 - (try ignore (min empty); false with Invalid_argument _ -> true) -*) - -let max ?(lt=fun x y -> x < y) gen = - let first = match gen () with - | Some x -> x - | None -> raise (Invalid_argument "max") - in - fold (fun max x -> if lt max x then x else max) first gen - -(*$T - max (of_list [1;4;6;0;11; -2]) = 11 - (try ignore (max empty); false with Invalid_argument _ -> true) -*) - -let eq ?(eq=(=)) gen1 gen2 = - let rec check () = - match gen1(), gen2() with - | None, None -> true - | Some x1, Some x2 when eq x1 x2 -> check () - | _ -> false - in - check () - -(*$Q - (Q.pair (Q.list Q.small_int)(Q.list Q.small_int)) (fun (l1,l2) -> \ - eq (of_list l1)(of_list l2) = (l1 = l2)) -*) - -let lexico ?(cmp=Pervasives.compare) gen1 gen2 = - let rec lexico () = - match gen1(), gen2() with - | None, None -> 0 - | Some x1, Some x2 -> - let c = cmp x1 x2 in - if c <> 0 then c else lexico () - | Some _, None -> 1 - | None, Some _ -> -1 - in lexico () - -let compare ?cmp gen1 gen2 = lexico ?cmp gen1 gen2 - -(*$Q - (Q.pair (Q.list Q.small_int)(Q.list Q.small_int)) (fun (l1,l2) -> \ - let sign x = if x < 0 then -1 else if x=0 then 0 else 1 in \ - sign (compare (of_list l1)(of_list l2)) = sign (Pervasives.compare l1 l2)) -*) - -let rec find p e = match e () with - | None -> None - | Some x when p x -> Some x - | Some _ -> find p e - -(*$T - find (fun x -> x>=5) (1--10) = Some 5 - find (fun x -> x>5) (1--4) = None -*) - -let sum e = - let rec sum acc = match e() with - | None -> acc - | Some x -> sum (x+acc) - in sum 0 - -(*$T - sum (1--10) = 55 -*) - -(** {2 Multiple Iterators} *) - -let map2 f e1 e2 = - fun () -> match e1(), e2() with - | Some x, Some y -> Some (f x y) - | _ -> None - -(*$T - map2 (+) (1--5) (1--4) |> eq (of_list [2;4;6;8]) - map2 (+) (1--5) (repeat 0) |> eq (1--5) -*) - -let rec iter2 f e1 e2 = - match e1(), e2() with - | Some x, Some y -> f x y; iter2 f e1 e2 - | _ -> () - -(*$T iter2 - let r = ref 0 in iter2 (fun _ _ -> incr r) (1--10) (4--6); !r = 3 -*) - -let rec fold2 f acc e1 e2 = - match e1(), e2() with - | Some x, Some y -> fold2 f (f acc x y) e1 e2 - | _ -> acc - -let rec for_all2 p e1 e2 = - match e1(), e2() with - | Some x, Some y -> p x y && for_all2 p e1 e2 - | _ -> true - -let rec exists2 p e1 e2 = - match e1(), e2() with - | Some x, Some y -> p x y || exists2 p e1 e2 - | _ -> false - -let zip_with f a b = - let stop = ref false in - fun () -> - if !stop then None - else match a(), b() with - | Some xa, Some xb -> Some (f xa xb) - | _ -> stop:=true; None - -let zip a b = zip_with (fun x y -> x,y) a b - -(*$Q - (Q.list Q.small_int) (fun l -> \ - zip_with (fun x y->x,y) (of_list l) (of_list l) \ - |> unzip |> fst |> to_list = l) -*) - -(** {3 Complex combinators} *) - -module MergeState = struct - type 'a t = { - gens : 'a gen Queue.t; - mutable state : my_state; - } - - and my_state = - | NewGen - | YieldAndNew - | Yield - | Stop -end - -(* state machine: - (NewGen -> YieldAndNew)* // then no more generators in next_gen, so - -> Yield* -> Stop *) -let merge next_gen = - let open MergeState in - let state = {gens = Queue.create(); state=NewGen;}in - (* recursive function to get next element *) - let rec next () = - match state.state with - | Stop -> None - | Yield -> (* only yield from generators in state.gens *) - if Queue.is_empty state.gens - then (state.state <- Stop; None) - else - let gen = Queue.pop state.gens in - begin match gen () with - | None -> next() - | (Some _) as res -> - Queue.push gen state.gens; (* put gen back in queue *) - res - end - | NewGen -> - begin match next_gen() with - | None -> - state.state <- Yield; (* exhausted *) - next() - | Some gen -> - Queue.push gen state.gens; - state.state <- YieldAndNew; - next() - end - | YieldAndNew -> (* yield element from queue, then get a new generator *) - if Queue.is_empty state.gens - then (state.state <- NewGen; next()) - else - let gen = Queue.pop state.gens in - begin match gen () with - | None -> state.state <- NewGen; next() - | (Some _) as res -> - Queue.push gen state.gens; - state.state <- NewGen; - res - end - in next - -(*$T - merge (of_list [of_list [1;3;5]; of_list [2;4;6]; of_list [7;8;9]]) \ - |> to_list |> List.sort Pervasives.compare = [1;2;3;4;5;6;7;8;9] -*) - -let intersection ?(cmp=Pervasives.compare) gen1 gen2 = - let x1 = ref (gen1 ()) in - let x2 = ref (gen2 ()) in - let rec next () = - match !x1, !x2 with - | Some y1, Some y2 -> - let c = cmp y1 y2 in - if c = 0 (* equal elements, yield! *) - then (x1 := gen1(); x2 := gen2(); Some y1) - else if c < 0 (* drop y1 *) - then (x1 := gen1 (); next ()) - else (* drop y2 *) - (x2 := gen2(); next ()) - | _ -> None - in next - -(*$T - intersection (of_list [1;1;2;3;4;8]) (of_list [1;2;4;5;6;7;8;9]) \ - |> to_list = [1;2;4;8] -*) - -let sorted_merge ?(cmp=Pervasives.compare) gen1 gen2 = - let x1 = ref (gen1 ()) in - let x2 = ref (gen2 ()) in - fun () -> - match !x1, !x2 with - | None, None -> None - | (Some y1)as r1, ((Some y2) as r2) -> - if cmp y1 y2 <= 0 - then (x1 := gen1 (); r1) - else (x2 := gen2 (); r2) - | (Some _)as r, None -> - x1 := gen1 (); - r - | None, ((Some _)as r) -> - x2 := gen2 (); - r - -(*$T - sorted_merge (of_list [1;2;2;3;5;10;100]) (of_list [2;4;5;6;11]) \ - |> to_list = [1;2;2;2;3;4;5;5;6;10;11;100] -*) - -(** {4 Mutable heap (taken from heap.ml to avoid dependencies)} *) -module Heap = struct - type 'a t = { - mutable tree : 'a tree; - cmp : 'a -> 'a -> int; - } (** A pairing tree heap with the given comparison function *) - and 'a tree = - | Empty - | Node of 'a * 'a tree * 'a tree - - let empty ~cmp = { - tree = Empty; - cmp; - } - - let is_empty h = - match h.tree with - | Empty -> true - | Node _ -> false - - let rec union ~cmp t1 t2 = match t1, t2 with - | Empty, _ -> t2 - | _, Empty -> t1 - | Node (x1, l1, r1), Node (x2, l2, r2) -> - if cmp x1 x2 <= 0 - then Node (x1, union ~cmp t2 r1, l1) - else Node (x2, union ~cmp t1 r2, l2) - - let insert h x = - h.tree <- union ~cmp:h.cmp (Node (x, Empty, Empty)) h.tree - - let pop h = match h.tree with - | Empty -> raise Not_found - | Node (x, l, r) -> - h.tree <- union ~cmp:h.cmp l r; - x -end - -let sorted_merge_n ?(cmp=Pervasives.compare) l = - (* make a heap of (value, generator) *) - let cmp (v1,_) (v2,_) = cmp v1 v2 in - let heap = Heap.empty ~cmp in - (* add initial values *) - List.iter - (fun gen' -> match gen'() with - | Some x -> Heap.insert heap (x, gen') - | None -> ()) - l; - fun () -> - if Heap.is_empty heap then None - else begin - let x, gen = Heap.pop heap in - match gen() with - | Some y -> - Heap.insert heap (y, gen); (* insert next value *) - Some x - | None -> Some x (* gen empty, drop it *) - end - -(*$T - sorted_merge_n [of_list [1;2;2;3;5;10;100]; of_list [2;4;5;6;11]; (6--10)] \ - |> to_list = [1;2;2;2;3;4;5;5;6;6;7;8;9;10;10;11;100] -*) - -let round_robin ?(n=2) gen = - (* array of queues, together with their index *) - let qs = Array.init n (fun _ -> Queue.create ()) in - let cur = ref 0 in - (* get next element for the i-th queue *) - let rec next i = - let q = qs.(i) in - if Queue.is_empty q - then update_to_i i (* consume generator *) - else Some(Queue.pop q) - (* consume [gen] until some element for [i]-th generator is - available. *) - and update_to_i i = - match gen() with - | None -> None - | Some x -> - let j = !cur in - cur := (j+1) mod n; (* move cursor to next generator *) - let q = qs.(j) in - if j = i - then begin - assert (Queue.is_empty q); - Some x (* return the element *) - end else begin - Queue.push x q; - update_to_i i (* continue consuming [gen] *) - end - in - (* generators *) - let l = Array.mapi (fun i _ -> (fun () -> next i)) qs in - Array.to_list l - -(*$T - round_robin ~n:3 (1--12) |> List.map to_list = \ - [[1;4;7;10]; [2;5;8;11]; [3;6;9;12]] -*) - -(* Duplicate the enum into [n] generators (default 2). The generators - share the same underlying instance of the enum, so the optimal case is - when they are consumed evenly *) -let tee ?(n=2) gen = - (* array of queues, together with their index *) - let qs = Array.init n (fun _ -> Queue.create ()) in - let finished = ref false in (* is [gen] exhausted? *) - (* get next element for the i-th queue *) - let rec next i = - if Queue.is_empty qs.(i) - then - if !finished then None - else get_next i (* consume generator *) - else Queue.pop qs.(i) - (* consume one more element *) - and get_next i = match gen() with - | Some _ as res -> - for j = 0 to n-1 do - if j <> i then Queue.push res qs.(j) - done; - res - | None -> finished := true; None - in - (* generators *) - let l = Array.mapi (fun i _ -> (fun () -> next i)) qs in - Array.to_list l - -(*$T - tee ~n:3 (1--12) |> List.map to_list = \ - [to_list (1--12); to_list (1--12); to_list (1--12)] -*) - - -module InterleaveState = struct - type 'a t = - | Only of 'a gen - | Both of 'a gen * 'a gen * bool ref - | Stop -end - -(* Yield elements from a and b alternatively *) -let interleave gen_a gen_b = - let open InterleaveState in - let state = ref (Both (gen_a, gen_b, ref true)) in - let rec next() = match !state with - | Stop -> None - | Only g -> - begin match g() with - | None -> state := Stop; None - | (Some _) as res -> res - end - | Both (g1, g2, r) -> - match (if !r then g1() else g2()) with - | None -> - state := if !r then Only g2 else Only g1; - next() - | (Some _) as res -> - r := not !r; (* swap *) - res - in next - -(*$T - interleave (repeat 0) (1--5) |> take 10 |> to_list = \ - [0;1;0;2;0;3;0;4;0;5] -*) - -module IntersperseState = struct - type 'a t = - | Start - | YieldElem of 'a option - | YieldSep of 'a option (* next val *) - | Stop -end - -(* Put [x] between elements of [enum] *) -let intersperse x gen = - let open IntersperseState in - let state = ref Start in - let rec next() = match !state with - | Stop -> None - | YieldElem res -> - begin match gen() with - | None -> state := Stop - | Some _ as res' -> state := YieldSep res' - end; - res - | YieldSep res -> - state := YieldElem res; - Some x - | Start -> - match gen() with - | None -> state := Stop; None - | Some _ as res -> state := YieldElem res; next() - in next - -(*$T - intersperse 0 (1--5) |> to_list = [1;0;2;0;3;0;4;0;5] -*) - -(* Cartesian product *) -let product gena genb = - let all_a = ref [] in - let all_b = ref [] in - (* cur: current state, i.e., what we have to do next. Can be stop, - getLeft/getRight (to obtain next element from first/second generator), - or prodLeft/prodRIght to compute the product of an element with a list - of already met elements *) - let cur = ref `GetLeft in - let rec next () = - match !cur with - | `Stop -> None - | `GetLeft -> - begin match gena() with - | None -> cur := `GetRightOrStop - | Some a -> all_a := a :: !all_a; cur := `ProdLeft (a, !all_b) - end; - next () - | `GetRight | `GetRightOrStop -> (* TODO: test *) - begin match genb() with - | None when !cur = `GetRightOrStop -> cur := `Stop - | None -> cur := `GetLeft - | Some b -> all_b := b::!all_b; cur := `ProdRight (b, !all_a) - end; - next () - | `ProdLeft (_, []) -> - cur := `GetRight; - next() - | `ProdLeft (x, y::l) -> - cur := `ProdLeft (x, l); - Some (x, y) - | `ProdRight (_, []) -> - cur := `GetLeft; - next() - | `ProdRight (y, x::l) -> - cur := `ProdRight (y, l); - Some (x, y) - in - next - -(*$T - product (1--3) (of_list ["a"; "b"]) |> to_list \ - |> List.sort Pervasives.compare = \ - [1, "a"; 1, "b"; 2, "a"; 2, "b"; 3, "a"; 3, "b"] -*) - -(* Group equal consecutive elements together. *) -let group ?(eq=(=)) gen = - match gen() with - | None -> fun () -> None - | Some x -> - let cur = ref [x] in - let rec next () = - (* try to get an element *) - let next_x = if !cur = [] then None else gen() in - match next_x, !cur with - | None, [] -> None - | None, l -> - cur := []; (* stop *) - Some l - | Some x, y::_ when eq x y -> - cur := x::!cur; - next () (* same group *) - | Some x, l -> - cur := [x]; - Some l - in next - -(*$T - group (of_list [0;0;0;1;0;2;2;3;4;5;5;5;5;10]) |> to_list = \ - [[0;0;0];[1];[0];[2;2];[3];[4];[5;5;5;5];[10]] -*) - -let uniq ?(eq=(=)) gen = - let open RunState in - let state = ref Init in - let rec next() = match !state with - | Stop -> None - | Init -> - begin match gen() with - | None -> state:= Stop; None - | (Some x) as res -> state := Run x; res - end - | Run x -> - begin match gen() with - | None -> state:= Stop; None - | (Some y) as res -> - if eq x y - then next() (* ignore duplicate *) - else (state := Run y; res) - end - in next - -(*$T - uniq (of_list [0;0;0;1;0;2;2;3;4;5;5;5;5;10]) |> to_list = \ - [0;1;0;2;3;4;5;10] -*) - -let sort ?(cmp=Pervasives.compare) gen = - (* build heap *) - let h = Heap.empty ~cmp in - iter (Heap.insert h) gen; - fun () -> - if Heap.is_empty h - then None - else Some (Heap.pop h) -(*$T - sort (of_list [0;0;0;1;0;2;2;3;4;5;5;5;-42;5;10]) |> to_list = \ - [-42;0;0;0;0;1;2;2;3;4;5;5;5;5;10] -*) - - -(* NOTE: using a set is not really possible, because once we have built the - set there is no simple way to iterate on it *) -let sort_uniq ?(cmp=Pervasives.compare) gen = - uniq ~eq:(fun x y -> cmp x y = 0) (sort ~cmp gen) - -(*$T - sort_uniq (of_list [0;0;0;1;0;2;2;3;4;5;42;5;5;42;5;10]) |> to_list = \ - [0;1;2;3;4;5;10;42] -*) - -let chunks n e = - let rec next () = - match e() with - | None -> None - | Some x -> - let a = Array.make n x in - fill a 1 - - and fill a i = - (* fill the array. [i]: current index to fill *) - if i = n - then Some a - else match e() with - | None -> Some (Array.sub a 0 i) (* last array is not full *) - | Some x -> - a.(i) <- x; - fill a (i+1) - in - next - -(*$T - chunks 25 (0--100) |> map Array.to_list |> to_list = \ - List.map to_list [(0--24); (25--49);(50--74);(75--99);(100--100)] -*) - -(* state of the permutation machine. One machine manages one element [x], - and depends on a deeper machine [g] that generates permutations of the - list minus this element (down to the empty list). - The machine can do two things: - - insert the element in the current list of [g], at any position - - obtain the next list of [g] -*) - -module PermState = struct - type 'a state = - | Done - | Base (* bottom machine, yield [] *) - | Insert of 'a insert_state - and 'a insert_state = { - x : 'a; - mutable l : 'a list; - mutable n : int; (* idx for insertion *) - len : int; (* len of [l] *) - sub : 'a t; - } - and 'a t = { - mutable st : 'a state; - } -end - -let permutations g = - let open PermState in - (* make a machine for n elements. Invariant: n=len(l) *) - let rec make_machine n l = match l with - | [] -> assert (n=0); {st=Base} - | x :: tail -> - let sub = make_machine (n-1) tail in - let st = match next sub () with - | None -> Done - | Some l -> Insert {x;n=0;l;len=n;sub} - in - {st;} - (* next element of the machine *) - and next m () = match m.st with - | Done -> None - | Base -> m.st <- Done; Some [] - | Insert ({x;len;n;l;sub} as state) -> - if n=len - then match next sub () with - | None -> m.st <- Done; None - | Some l -> - state.l <- l; - state.n <- 0; - next m () - else ( - state.n <- state.n + 1; - Some (insert x n l) - ) - and insert x n l = match n, l with - | 0, _ -> x::l - | _, [] -> assert false - | _, y::tail -> y :: insert x (n-1) tail - in - let l = fold (fun acc x->x::acc) [] g in - next (make_machine (List.length l) l) - -(*$T permutations - permutations (1--3) |> to_list |> List.sort Pervasives.compare = \ - [[1;2;3]; [1;3;2]; [2;1;3]; [2;3;1]; [3;1;2]; [3;2;1]] - permutations empty |> to_list = [[]] - permutations (singleton 1) |> to_list = [[1]] -*) - -module CombState = struct - type 'a state = - | Done - | Base - | Add of 'a * 'a t * 'a t (* add x at beginning of first; then switch to second *) - | Follow of 'a t (* just forward *) - and 'a t = { - mutable st : 'a state - } -end - -let combinations n g = - let open CombState in - assert (n >= 0); - let rec make_state n l = match n, l with - | 0, _ -> {st=Base} - | _, [] -> {st=Done} - | _, x::tail -> - let m1 = make_state (n-1) tail in - let m2 = make_state n tail in - {st=Add(x,m1,m2)} - and next m () = match m.st with - | Done -> None - | Base -> m.st <- Done; Some [] - | Follow m -> - begin match next m () with - | None -> m.st <- Done; None - | Some _ as res -> res - end - | Add (x, m1, m2) -> - match next m1 () with - | None -> - m.st <- Follow m2; - next m () - | Some l -> Some (x::l) - in - let l = fold (fun acc x->x::acc) [] g in - next (make_state n l) - -(*$T - combinations 2 (1--4) |> map (List.sort Pervasives.compare) \ - |> to_list |> List.sort Pervasives.compare = \ - [[1;2]; [1;3]; [1;4]; [2;3]; [2;4]; [3;4]] - combinations 0 (1--4) |> to_list = [[]] - combinations 1 (singleton 1) |> to_list = [[1]] -*) - -module PowerSetState = struct - type 'a state = - | Done - | Base - | Add of 'a * 'a t (* add x before any result of m *) - | AddTo of 'a list * 'a * 'a t (* yield x::list, then back to Add(x,m) *) - and 'a t = { - mutable st : 'a state - } -end - -let power_set g = - let open PowerSetState in - let rec make_state l = match l with - | [] -> {st=Base} - | x::tail -> - let m = make_state tail in - {st=Add(x,m)} - and next m () = match m.st with - | Done -> None - | Base -> m.st <- Done; Some [] - | Add (x,m') -> - begin match next m' () with - | None -> m.st <- Done; None - | Some l as res -> m.st <- AddTo(l,x,m'); res - end - | AddTo (l, x, m') -> - m.st <- Add (x,m'); - Some (x::l) - in - let l = fold (fun acc x->x::acc) [] g in - next (make_state l) - -(*$T - power_set (1--3) |> map (List.sort Pervasives.compare) \ - |> to_list |> List.sort Pervasives.compare = \ - [[]; [1]; [1;2]; [1;2;3]; [1;3]; [2]; [2;3]; [3]] - power_set empty |> to_list = [[]] - power_set (singleton 1) |> map (List.sort Pervasives.compare) \ - |> to_list |> List.sort Pervasives.compare = [[]; [1]] -*) - -(** {3 Conversion} *) - -let of_list l = - let l = ref l in - fun () -> - match !l with - | [] -> None - | x::l' -> l := l'; Some x - -let to_rev_list gen = - fold (fun acc x -> x :: acc) [] gen - -(*$Q - (Q.list Q.small_int) (fun l -> \ - to_rev_list (of_list l) = List.rev l) -*) - -let to_list gen = List.rev (to_rev_list gen) - -let to_array gen = - let l = to_rev_list gen in - match l with - | [] -> [| |] - | _ -> - let a = Array.of_list l in - let n = Array.length a in - (* reverse array *) - for i = 0 to (n-1) / 2 do - let tmp = a.(i) in - a.(i) <- a.(n-i-1); - a.(n-i-1) <- tmp - done; - a - -let of_array ?(start=0) ?len a = - let len = match len with - | None -> Array.length a - start - | Some n -> assert (n + start < Array.length a); n in - let i = ref start in - fun () -> - if !i >= start + len - then None - else (let x = a.(!i) in incr i; Some x) - -(*$Q - (Q.array Q.small_int) (fun a -> \ - of_array a |> to_array = a) -*) - -let rand_int i = - repeatedly (fun () -> Random.int i) - -let int_range i j = - let r = ref i in - fun () -> - let x = !r in - if x > j then None - else begin - incr r; - Some x - end - -let pp ?(start="") ?(stop="") ?(sep=",") ?(horizontal=false) pp_elem formatter gen = - (if horizontal - then Format.pp_open_hbox formatter () - else Format.pp_open_hvbox formatter 0); - Format.pp_print_string formatter start; - let rec next is_first = - match gen() with - | Some x -> - if not is_first - then begin - Format.pp_print_string formatter sep; - Format.pp_print_space formatter (); - pp_elem formatter x - end else pp_elem formatter x; - next false - | None -> () - in - next true; - Format.pp_print_string formatter stop; - Format.pp_close_box formatter () - -module Infix = struct - let (--) = int_range - - let (>>=) x f = flat_map f x -end - -include Infix - -module Restart = struct - type 'a t = unit -> 'a gen - - type 'a restartable = 'a t - - let lift f e = f (e ()) - let lift2 f e1 e2 = f (e1 ()) (e2 ()) - - let empty () = empty - - let singleton x () = singleton x - - let iterate x f () = iterate x f - - let repeat x () = repeat x - - let unfold f acc () = unfold f acc - - let init ?limit f () = init ?limit f - - let cycle enum = - assert (not (is_empty (enum ()))); - fun () -> - let gen = ref (enum ()) in (* start cycle *) - let rec next () = - match (!gen) () with - | (Some _) as res -> res - | None -> gen := enum(); next() - in next - - let is_empty e = is_empty (e ()) - - let fold f acc e = fold f acc (e ()) - - let reduce f e = reduce f (e ()) - - let scan f acc e () = scan f acc (e ()) - - let unfold_scan f acc e () = unfold_scan f acc (e()) - - let iter f e = iter f (e ()) - - let iteri f e = iteri f (e ()) - - let length e = length (e ()) - - let map f e () = map f (e ()) - - let append e1 e2 () = append (e1 ()) (e2 ()) - - let flatten e () = flatten (e ()) - - let flat_map f e () = flat_map f (e ()) - - let mem ?eq x e = mem ?eq x (e ()) - - let take n e () = take n (e ()) - - let drop n e () = drop n (e ()) - - let nth n e = nth n (e ()) - - let take_nth n e () = take_nth n (e ()) - - let filter p e () = filter p (e ()) - - let take_while p e () = take_while p (e ()) - - let drop_while p e () = drop_while p (e ()) - - let filter_map f e () = filter_map f (e ()) - - let zip_with f e1 e2 () = zip_with f (e1 ()) (e2 ()) - - let zip e1 e2 () = zip (e1 ()) (e2 ()) - - let zip_index e () = zip_index (e ()) - - let unzip e = map fst e, map snd e - - let partition p e = - filter p e, filter (fun x -> not (p x)) e - - let for_all p e = - for_all p (e ()) - - let exists p e = - exists p (e ()) - - let for_all2 p e1 e2 = - for_all2 p (e1 ()) (e2 ()) - - let exists2 p e1 e2 = - exists2 p (e1 ()) (e2 ()) - - let map2 f e1 e2 () = - map2 f (e1()) (e2()) - - let iter2 f e1 e2 = - iter2 f (e1()) (e2()) - - let fold2 f acc e1 e2 = - fold2 f acc (e1()) (e2()) - - let min ?lt e = min ?lt (e ()) - - let max ?lt e = max ?lt (e ()) - - let ___eq = eq - let eq ?eq e1 e2 = ___eq ?eq (e1 ()) (e2 ()) - - let lexico ?cmp e1 e2 = lexico ?cmp (e1 ()) (e2 ()) - - let compare ?cmp e1 e2 = compare ?cmp (e1 ()) (e2 ()) - - let sum e = sum (e()) - - let find f e = find f (e()) - - let merge e () = merge (e ()) - - let intersection ?cmp e1 e2 () = - intersection ?cmp (e1 ()) (e2 ()) - - let sorted_merge ?cmp e1 e2 () = - sorted_merge ?cmp (e1 ()) (e2 ()) - - let sorted_merge_n ?cmp l () = - sorted_merge_n ?cmp (List.map (fun g -> g()) l) - - let tee ?n e = tee ?n (e ()) - - let round_robin ?n e = round_robin ?n (e ()) - - let interleave e1 e2 () = interleave (e1 ()) (e2 ()) - - let intersperse x e () = intersperse x (e ()) - - let product e1 e2 () = product (e1 ()) (e2 ()) - - let group ?eq e () = group ?eq (e ()) - - let uniq ?eq e () = uniq ?eq (e ()) - - let sort ?(cmp=Pervasives.compare) enum = - fun () -> sort ~cmp (enum ()) - - let sort_uniq ?(cmp=Pervasives.compare) e = - let e' = sort ~cmp e in - uniq ~eq:(fun x y -> cmp x y = 0) e' - - let chunks n e () = chunks n (e()) - - let permutations g () = permutations (g ()) - - let combinations n g () = combinations n (g()) - - let power_set g () = power_set (g()) - - let of_list l () = of_list l - - let to_rev_list e = to_rev_list (e ()) - - let to_list e = to_list (e ()) - - let to_array e = to_array (e ()) - - let of_array ?start ?len a () = of_array ?start ?len a - - let rand_int i () = rand_int i - - let int_range i j () = int_range i j - - module Infix = struct - let (--) = int_range - - let (>>=) x f = flat_map f x - end - - include Infix - - let pp ?start ?stop ?sep ?horizontal pp_elem fmt e = - pp ?start ?stop ?sep ?horizontal pp_elem fmt (e ()) -end - -(** {2 Generator functions} *) - -let start g = g () - -(** {6 Unrolled mutable list} *) -module MList = struct - type 'a node = - | Nil - | Cons of 'a array * int ref * 'a node ref - | Suspend of 'a gen - - type 'a t = { - start : 'a node ref; (* first node. *) - mutable chunk_size : int; - max_chunk_size : int; - } - - let _make ~max_chunk_size gen = { - start = ref (Suspend gen); - chunk_size = 8; - max_chunk_size; - } - - (* increment the size of chunks *) - let _incr_chunk_size mlist = - if mlist.chunk_size < mlist.max_chunk_size - then mlist.chunk_size <- 2 * mlist.chunk_size - - (* read one chunk of input; return the corresponding node. - will potentially change [mlist.chunk_size]. *) - let _read_chunk mlist gen = - match gen() with - | None -> Nil (* done *) - | Some x -> - (* new list node *) - let r = ref 1 in - let a = Array.make mlist.chunk_size x in - let tail = ref (Suspend gen) in - let stop = ref false in - let node = Cons (a, r, tail) in - (* read the rest of the chunk *) - while not !stop && !r < mlist.chunk_size do - match gen() with - | None -> - tail := Nil; - stop := true - | Some x -> - a.(!r) <- x; - incr r; - done; - _incr_chunk_size mlist; - node - - (* eager construction *) - let of_gen gen = - let mlist = _make ~max_chunk_size:4096 gen in - let rec _fill prev = match _read_chunk mlist gen with - | Nil -> prev := Nil - | Suspend _ -> assert false - | Cons (_, _, prev') as node -> - prev := node; - _fill prev' - in - _fill mlist.start; - mlist - - (* lazy construction *) - let of_gen_lazy gen = - let mlist = _make ~max_chunk_size:32 gen in - mlist - - let to_gen l () = - let cur = ref l.start in - let i = ref 0 in - let rec next() = match ! !cur with - | Nil -> None - | Cons (a,n,l') -> - if !i = !n - then begin - cur := l'; - i := 0; - next() - end else begin - let y = a.(!i) in - incr i; - Some y - end - | Suspend gen -> - let node = _read_chunk l gen in - !cur := node; - next() - in - next -end - -(** Store content of the generator in an enum *) -let persistent gen = - let l = MList.of_gen gen in - MList.to_gen l - -(*$T - let g = 1--10 in let g' = persistent g in \ - Restart.to_list g' = Restart.to_list g' - let g = 1--10 in let g' = persistent g in \ - Restart.to_list g' = [1;2;3;4;5;6;7;8;9;10] -*) - -let persistent_lazy gen = - let l = MList.of_gen_lazy gen in - MList.to_gen l - -(*$T - let g = 1--1_000_000_000 in let g' = persistent_lazy g in \ - (g' () |> take 100 |> to_list = (1--100 |> to_list)) && \ - (g' () |> take 200 |> to_list = (1--200 |> to_list)) -*) diff --git a/gen/gen.mldylib b/gen/gen.mldylib deleted file mode 100644 index 79105f52..00000000 --- a/gen/gen.mldylib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: f69818d114f140be18d72c90abdc60e8) -Gen -Gen_intf -# OASIS_STOP diff --git a/gen/gen.mli b/gen/gen.mli deleted file mode 100644 index 104e19b7..00000000 --- a/gen/gen.mli +++ /dev/null @@ -1,102 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Generators} - -Values of type ['a Gen.t] represent a possibly infinite sequence of values -of type 'a. One can only iterate once on the sequence, as it is consumed -by iteration/deconstruction/access. [None] is returned when the generator -is exhausted. - -The submodule {!Restart} provides utilities to work with -{b restartable generators}, that is, functions [unit -> 'a Gen.t] that -allow to build as many generators from the same source as needed. -*) - -(** {2 Global type declarations} *) - -type 'a t = unit -> 'a option - (** A generator may be called several times, yielding the next value - each time. It returns [None] when no elements remain *) - -type 'a gen = 'a t - -module type S = Gen_intf.S - -(** {2 Transient generators} *) - -val get : 'a t -> 'a option - (** Get the next value *) - -val next : 'a t -> 'a option - (** Synonym for {!get} *) - -val get_exn : 'a t -> 'a - (** Get the next value, or fails - @raise Invalid_argument if no element remains *) - -val junk : 'a t -> unit - (** Drop the next value, discarding it. *) - -val repeatedly : (unit -> 'a) -> 'a t - (** Call the same function an infinite number of times (useful for instance - if the function is a random generator). *) - -include S with type 'a t := 'a gen - (** Operations on {b transient} generators *) - -(** {2 Restartable generators} *) - -module Restart : sig - type 'a t = unit -> 'a gen - - type 'a restartable = 'a t - - include S with type 'a t := 'a restartable - - val cycle : 'a t -> 'a t - (** Cycle through the enum, endlessly. The enum must not be empty. *) - - val lift : ('a gen -> 'b) -> 'a t -> 'b - - val lift2 : ('a gen -> 'b gen -> 'c) -> 'a t -> 'b t -> 'c -end - -(** {2 Utils} *) - -val persistent : 'a t -> 'a Restart.t - (** Store content of the transient generator in memory, to be able to iterate - on it several times later. If possible, consider using combinators - from {!Restart} directly instead. *) - -val persistent_lazy : 'a t -> 'a Restart.t - (** Same as {!persistent}, but consumes the generator on demand (by chunks). - This allows to make a restartable generator out of an ephemeral one, - without paying a big cost upfront (nor even consuming it fully). - @since 0.2.2 *) - -val start : 'a Restart.t -> 'a t - (** Create a new transient generator. - [start gen] is the same as [gen ()] but is included for readability. *) diff --git a/gen/gen.mllib b/gen/gen.mllib deleted file mode 100644 index 79105f52..00000000 --- a/gen/gen.mllib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: f69818d114f140be18d72c90abdc60e8) -Gen -Gen_intf -# OASIS_STOP diff --git a/gen/gen.odocl b/gen/gen.odocl deleted file mode 100644 index 79105f52..00000000 --- a/gen/gen.odocl +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: f69818d114f140be18d72c90abdc60e8) -Gen -Gen_intf -# OASIS_STOP diff --git a/gen/gen_intf.ml b/gen/gen_intf.ml deleted file mode 100644 index 87208338..00000000 --- a/gen/gen_intf.ml +++ /dev/null @@ -1,321 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Common signature for transient and restartable generators} - -The signature {!S} abstracts on a type ['a t], where the [t] can be -the type of transient or restartable generators. Some functions specify -explicitely that they use ['a gen] (transient generators). *) - -type 'a gen = unit -> 'a option - -module type S = sig - type 'a t - - val empty : 'a t - (** Empty generator, with no elements *) - - val singleton : 'a -> 'a t - (** One-element generator *) - - val repeat : 'a -> 'a t - (** Repeat same element endlessly *) - - val iterate : 'a -> ('a -> 'a) -> 'a t - (** [iterate x f] is [[x; f x; f (f x); f (f (f x)); ...]] *) - - val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t - (** Dual of {!fold}, with a deconstructing operation. It keeps on - unfolding the ['b] value into a new ['b], and a ['a] which is yielded, - until [None] is returned. *) - - val init : ?limit:int -> (int -> 'a) -> 'a t - (** Calls the function, starting from 0, on increasing indices. - If [limit] is provided and is a positive int, iteration will - stop at the limit (excluded). - For instance [init ~limit:4 id] will yield 0, 1, 2, and 3. *) - - (** {2 Basic combinators} *) - - val is_empty : _ t -> bool - (** Check whether the enum is empty. Pops an element, if any *) - - val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold on the generator, tail-recursively. Consumes the generator. *) - - val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a - (** Fold on non-empty sequences. Consumes the generator. - @raise Invalid_argument on an empty gen *) - - val scan : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t - (** Like {!fold}, but keeping successive values of the accumulator. - Consumes the generator. *) - - val unfold_scan : ('b -> 'a -> 'b * 'c) -> 'b -> 'a t -> 'c t - (** A mix of {!unfold} and {!scan}. The current state is combined with - the current element to produce a new state, and an output value - of type 'c. - @since 0.2.2 *) - - val iter : ('a -> unit) -> 'a t -> unit - (** Iterate on the enum, consumes it. *) - - val iteri : (int -> 'a -> unit) -> 'a t -> unit - (** Iterate on elements with their index in the enum, from 0, consuming it. *) - - val length : _ t -> int - (** Length of an enum (linear time), consuming it *) - - val map : ('a -> 'b) -> 'a t -> 'b t - (** Lazy map. No iteration is performed now, the function will be called - when the result is traversed. *) - - val append : 'a t -> 'a t -> 'a t - (** Append the two enums; the result contains the elements of the first, - then the elements of the second enum. *) - - val flatten : 'a gen t -> 'a t - (** Flatten the enumeration of generators *) - - val flat_map : ('a -> 'b gen) -> 'a t -> 'b t - (** Monadic bind; each element is transformed to a sub-enum - which is then iterated on, before the next element is processed, - and so on. *) - - val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool - (** Is the given element, member of the enum? *) - - val take : int -> 'a t -> 'a t - (** Take at most n elements *) - - val drop : int -> 'a t -> 'a t - (** Drop n elements *) - - val nth : int -> 'a t -> 'a - (** n-th element, or Not_found - @raise Not_found if the generator contains less than [n] arguments *) - - val take_nth : int -> 'a t -> 'a t - (** [take_nth n g] returns every element of [g] whose index - is a multiple of [n]. For instance [take_nth 2 (1--10) |> to_list] - will return [1;3;5;7;9] *) - - val filter : ('a -> bool) -> 'a t -> 'a t - (** Filter out elements that do not satisfy the predicate. *) - - val take_while : ('a -> bool) -> 'a t -> 'a t - (** Take elements while they satisfy the predicate *) - - val drop_while : ('a -> bool) -> 'a t -> 'a t - (** Drop elements while they satisfy the predicate *) - - val filter_map : ('a -> 'b option) -> 'a t -> 'b t - (** Maps some elements to 'b, drop the other ones *) - - val zip_index : 'a t -> (int * 'a) t - (** Zip elements with their index in the enum *) - - val unzip : ('a * 'b) t -> 'a t * 'b t - (** Unzip into two sequences, splitting each pair *) - - val partition : ('a -> bool) -> 'a t -> 'a t * 'a t - (** [partition p l] returns the elements that satisfy [p], - and the elements that do not satisfy [p] *) - - val for_all : ('a -> bool) -> 'a t -> bool - (** Is the predicate true for all elements? *) - - val exists : ('a -> bool) -> 'a t -> bool - (** Is the predicate true for at least one element? *) - - val min : ?lt:('a -> 'a -> bool) -> 'a t -> 'a - (** Minimum element, according to the given comparison function. - @raise Invalid_argument if the generator is empty *) - - val max : ?lt:('a -> 'a -> bool) -> 'a t -> 'a - (** Maximum element, see {!min} - @raise Invalid_argument if the generator is empty *) - - val eq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool - (** Equality of generators. *) - - val lexico : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int - (** Lexicographic comparison of generators. If a generator is a prefix - of the other one, it is considered smaller. *) - - val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int - (** Synonym for {! lexico} *) - - val find : ('a -> bool) -> 'a t -> 'a option - (** [find p e] returns the first element of [e] to satisfy [p], - or None. *) - - val sum : int t -> int - (** Sum of all elements *) - - (** {2 Multiple iterators} *) - - val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t - (** Map on the two sequences. Stops once one of them is exhausted.*) - - val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit - (** Iterate on the two sequences. Stops once one of them is exhausted.*) - - val fold2 : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> 'a t -> 'b t -> 'acc - (** Fold the common prefix of the two iterators *) - - val for_all2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool - (** Succeeds if all pairs of elements satisfy the predicate. - Ignores elements of an iterator if the other runs dry. *) - - val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool - (** Succeeds if some pair of elements satisfy the predicate. - Ignores elements of an iterator if the other runs dry. *) - - val zip_with : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t - (** Combine common part of the enums (stops when one is exhausted) *) - - val zip : 'a t -> 'b t -> ('a * 'b) t - (** Zip together the common part of the enums *) - - (** {2 Complex combinators} *) - - val merge : 'a gen t -> 'a t - (** Pick elements fairly in each sub-generator. The merge of enums - [e1, e2, ... ] picks elements in [e1], [e2], - in [e3], [e1], [e2] .... Once a generator is empty, it is skipped; - when they are all empty, and none remains in the input, - their merge is also empty. - For instance, [merge [1;3;5] [2;4;6]] will be, in disorder, [1;2;3;4;5;6]. *) - - val intersection : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t - (** Intersection of two sorted sequences. Only elements that occur in both - inputs appear in the output *) - - val sorted_merge : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t - (** Merge two sorted sequences into a sorted sequence *) - - val sorted_merge_n : ?cmp:('a -> 'a -> int) -> 'a t list -> 'a t - (** Sorted merge of multiple sorted sequences *) - - val tee : ?n:int -> 'a t -> 'a gen list - (** Duplicate the enum into [n] generators (default 2). The generators - share the same underlying instance of the enum, so the optimal case is - when they are consumed evenly *) - - val round_robin : ?n:int -> 'a t -> 'a gen list - (** Split the enum into [n] generators in a fair way. Elements with - [index = k mod n] with go to the k-th enum. [n] default value - is 2. *) - - val interleave : 'a t -> 'a t -> 'a t - (** [interleave a b] yields an element of [a], then an element of [b], - and so on. When a generator is exhausted, this behaves like the - other generator. *) - - val intersperse : 'a -> 'a t -> 'a t - (** Put the separator element between all elements of the given enum *) - - val product : 'a t -> 'b t -> ('a * 'b) t - (** Cartesian product, in no predictable order. Works even if some of the - arguments are infinite. *) - - val group : ?eq:('a -> 'a -> bool) -> 'a t -> 'a list t - (** Group equal consecutive elements together. *) - - val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t - (** Remove consecutive duplicate elements. Basically this is - like [fun e -> map List.hd (group e)]. *) - - val sort : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t - (** Sort according to the given comparison function. The enum must be finite. *) - - val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t - (** Sort and remove duplicates. The enum must be finite. *) - - val chunks : int -> 'a t -> 'a array t - (** [chunks n e] returns a generator of arrays of length [n], composed - of successive elements of [e]. The last array may be smaller - than [n] *) - - val permutations : 'a t -> 'a list t - (** Permutations of the enum. - @since 0.2.2 *) - - val combinations : int -> 'a t -> 'a list t - (** Combinations of given length. The ordering of the elements within - each combination is unspecified. - Example (ignoring ordering): - [combinations 2 (1--3) |> to_list = [[1;2]; [1;3]; [2;3]]] - @since 0.2.2 *) - - val power_set : 'a t -> 'a list t - (** All subsets of the enum (in no particular order). The ordering of - the elements within each subset is unspecified. - @since 0.2.2 *) - - (** {2 Basic conversion functions} *) - - val of_list : 'a list -> 'a t - (** Enumerate elements of the list *) - - val to_list : 'a t -> 'a list - (** non tail-call trasnformation to list, in the same order *) - - val to_rev_list : 'a t -> 'a list - (** Tail call conversion to list, in reverse order (more efficient) *) - - val to_array : 'a t -> 'a array - (** Convert the enum to an array (not very efficient) *) - - val of_array : ?start:int -> ?len:int -> 'a array -> 'a t - (** Iterate on (a slice of) the given array *) - - val rand_int : int -> int t - (** Random ints in the given range. *) - - val int_range : int -> int -> int t - (** [int_range a b] enumerates integers between [a] and [b], included. [a] - is assumed to be smaller than [b]. *) - - module Infix : sig - val (--) : int -> int -> int t - (** Synonym for {! int_range} *) - - val (>>=) : 'a t -> ('a -> 'b gen) -> 'b t - (** Monadic bind operator *) - end - - val (--) : int -> int -> int t - (** Synonym for {! int_range} *) - - val (>>=) : 'a t -> ('a -> 'b gen) -> 'b t - (** Monadic bind operator *) - - val pp : ?start:string -> ?stop:string -> ?sep:string -> ?horizontal:bool -> - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - (** Pretty print the content of the generator on a formatter. *) -end - diff --git a/gen/myocamlbuild.ml b/gen/myocamlbuild.ml deleted file mode 100644 index 57fcede3..00000000 --- a/gen/myocamlbuild.ml +++ /dev/null @@ -1,623 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: 8b03085ed54d5ff9a8cbd756150607bd) *) -module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) - - - let ns_ str = - str - - - let s_ str = - str - - - let f_ (str: ('a, 'b, 'c, 'd) format4) = - str - - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - - let init = - [] - - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - - - - open OASISGettext - - - type test = string - - - type flag = string - - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - - type 'a choices = (t * 'a) list - - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - - -end - - -# 132 "myocamlbuild.ml" -module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - - - module MapString = Map.Make(String) - - - type t = string MapString.t - - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - - let rec var_expand str env = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = - var_expand (MapString.find name env) env - - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -# 237 "myocamlbuild.ml" -module MyOCamlbuildFindlib = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) - - - (** OCamlbuild extension, copied from - * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild - * by N. Pouillard and others - * - * Updated on 2009/02/28 - * - * Modified by Sylvain Le Gall - *) - open Ocamlbuild_plugin - - type conf = - { no_automatic_syntax: bool; - } - - (* these functions are not really officially exported *) - let run_and_read = - Ocamlbuild_pack.My_unix.run_and_read - - - let blank_sep_strings = - Ocamlbuild_pack.Lexers.blank_sep_strings - - - let exec_from_conf exec = - let exec = - let env_filename = Pathname.basename BaseEnvLight.default_filename in - let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in - try - BaseEnvLight.var_get exec env - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" exec; - exec - in - let fix_win32 str = - if Sys.os_type = "Win32" then begin - let buff = Buffer.create (String.length str) in - (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. - *) - String.iter - (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) - str; - Buffer.contents buff - end else begin - str - end - in - fix_win32 exec - - let split s ch = - let buf = Buffer.create 13 in - let x = ref [] in - let flush () = - x := (Buffer.contents buf) :: !x; - Buffer.clear buf - in - String.iter - (fun c -> - if c = ch then - flush () - else - Buffer.add_char buf c) - s; - flush (); - List.rev !x - - - let split_nl s = split s '\n' - - - let before_space s = - try - String.before s (String.index s ' ') - with Not_found -> s - - (* ocamlfind command *) - let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] - - (* This lists all supported packages. *) - let find_packages () = - List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) - - - (* Mock to list available syntaxes. *) - let find_syntaxes () = ["camlp4o"; "camlp4r"] - - - let well_known_syntax = [ - "camlp4.quotations.o"; - "camlp4.quotations.r"; - "camlp4.exceptiontracer"; - "camlp4.extend"; - "camlp4.foldgenerator"; - "camlp4.listcomprehension"; - "camlp4.locationstripper"; - "camlp4.macro"; - "camlp4.mapgenerator"; - "camlp4.metagenerator"; - "camlp4.profiler"; - "camlp4.tracer" - ] - - - let dispatch conf = - function - | After_options -> - (* By using Before_options one let command line options have an higher - * priority on the contrary using After_options will guarantee to have - * the higher priority override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop"; - Options.ocamlmklib := ocamlfind & A"ocamlmklib" - - | After_rules -> - - (* When one link an OCaml library/binary/package, one should use - * -linkpkg *) - flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - - if not (conf.no_automatic_syntax) then begin - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - let base_args = [A"-package"; A pkg] in - (* TODO: consider how to really choose camlp4o or camlp4r. *) - let syn_args = [A"-syntax"; A "camlp4o"] in - let (args, pargs) = - (* Heuristic to identify syntax extensions: whether they end in - ".syntax"; some might not. - *) - if Filename.check_suffix pkg "syntax" || - List.mem pkg well_known_syntax then - (syn_args @ base_args, syn_args) - else - (base_args, []) - in - flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; - flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; - - (* TODO: Check if this is allowed for OCaml < 3.12.1 *) - flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; - end - (find_packages ()); - end; - - (* Like -package but for extensions syntax. Morover -syntax is useless - * when linking. *) - List.iter begin fun syntax -> - flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & - S[A"-syntax"; A syntax]; - end (find_syntaxes ()); - - (* The default "thread" tag is not compatible with ocamlfind. - * Indeed, the default rules add the "threads.cma" or "threads.cmxa" - * options when using this tag. When using the "-linkpkg" option with - * ocamlfind, this module will then be added twice on the command line. - * - * To solve this, one approach is to add the "-thread" option when using - * the "threads" package using the previous plugin. - *) - flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); - - | _ -> - () -end - -module MyOCamlbuildBase = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - - (** Base functions for writing myocamlbuild.ml - @author Sylvain Le Gall - *) - - - - - - open Ocamlbuild_plugin - module OC = Ocamlbuild_pack.Ocaml_compiler - - - type dir = string - type file = string - type name = string - type tag = string - - -(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - - type t = - { - lib_ocaml: (name * dir list * string list) list; - lib_c: (name * dir * file list) list; - flags: (tag list * (spec OASISExpr.choices)) list; - (* Replace the 'dir: include' from _tags by a precise interdepends in - * directory. - *) - includes: (dir * dir list) list; - } - - - let env_filename = - Pathname.basename - BaseEnvLight.default_filename - - - let dispatch_combine lst = - fun e -> - List.iter - (fun dispatch -> dispatch e) - lst - - - let tag_libstubs nm = - "use_lib"^nm^"_stubs" - - - let nm_libstubs nm = - nm^"_stubs" - - - let dispatch t e = - let env = - BaseEnvLight.load - ~filename:env_filename - ~allow_empty:true - () - in - match e with - | Before_options -> - let no_trailing_dot s = - if String.length s >= 1 && s.[0] = '.' then - String.sub s 1 ((String.length s) - 1) - else - s - in - List.iter - (fun (opt, var) -> - try - opt := no_trailing_dot (BaseEnvLight.var_get var env) - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" var) - [ - Options.ext_obj, "ext_obj"; - Options.ext_lib, "ext_lib"; - Options.ext_dll, "ext_dll"; - ] - - | After_rules -> - (* Declare OCaml libraries *) - List.iter - (function - | nm, [], intf_modules -> - ocaml_lib nm; - let cmis = - List.map (fun m -> (String.uncapitalize m) ^ ".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis - | nm, dir :: tl, intf_modules -> - ocaml_lib ~dir:dir (dir^"/"^nm); - List.iter - (fun dir -> - List.iter - (fun str -> - flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) - ["compile"; "infer_interface"; "doc"]) - tl; - let cmis = - List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] - cmis) - t.lib_ocaml; - - (* Declare directories dependencies, replace "include" in _tags. *) - List.iter - (fun (dir, include_dirs) -> - Pathname.define_context dir include_dirs) - t.includes; - - (* Declare C libraries *) - List.iter - (fun (lib, dir, headers) -> - (* Handle C part of library *) - flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; - A("-l"^(nm_libstubs lib))]); - - flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] - (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - - flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); - - (* When ocaml link something that use the C library, then one - need that file to be up to date. - This holds both for programs and for libraries. - *) - dep ["link"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - dep ["compile"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - (* TODO: be more specific about what depends on headers *) - (* Depends on .h files *) - dep ["compile"; "c"] - headers; - - (* Setup search path for lib *) - flag ["link"; "ocaml"; "use_"^lib] - (S[A"-I"; P(dir)]); - ) - t.lib_c; - - (* Add flags *) - List.iter - (fun (tags, cond_specs) -> - let spec = BaseEnvLight.var_choose cond_specs env in - let rec eval_specs = - function - | S lst -> S (List.map eval_specs lst) - | A str -> A (BaseEnvLight.var_expand str env) - | spec -> spec - in - flag tags & (eval_specs spec)) - t.flags - | _ -> - () - - - let dispatch_default conf t = - dispatch_combine - [ - dispatch t; - MyOCamlbuildFindlib.dispatch conf; - ] - - -end - - -# 606 "myocamlbuild.ml" -open Ocamlbuild_plugin;; -let package_default = - { - MyOCamlbuildBase.lib_ocaml = [("gen", [], [])]; - lib_c = []; - flags = []; - includes = [] - } - ;; - -let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} - -let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; - -# 622 "myocamlbuild.ml" -(* OASIS_STOP *) -Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/gen/setup.ml b/gen/setup.ml deleted file mode 100644 index fe876747..00000000 --- a/gen/setup.ml +++ /dev/null @@ -1,7150 +0,0 @@ -(* setup.ml generated for the first time by OASIS v0.4.0 *) - -(* OASIS_START *) -(* DO NOT EDIT (digest: 751af72d4e295f56a78e6ed6d61afa74) *) -(* - Regenerated by OASIS v0.4.5 - Visit http://oasis.forge.ocamlcore.org for more information and - documentation about functions used in this file. -*) -module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) - - - let ns_ str = - str - - - let s_ str = - str - - - let f_ (str: ('a, 'b, 'c, 'd) format4) = - str - - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - - let init = - [] - - -end - -module OASISContext = struct -(* # 22 "src/oasis/OASISContext.ml" *) - - - open OASISGettext - - - type level = - [ `Debug - | `Info - | `Warning - | `Error] - - - type t = - { - (* TODO: replace this by a proplist. *) - quiet: bool; - info: bool; - debug: bool; - ignore_plugins: bool; - ignore_unknown_fields: bool; - printf: level -> string -> unit; - } - - - let printf lvl str = - let beg = - match lvl with - | `Error -> s_ "E: " - | `Warning -> s_ "W: " - | `Info -> s_ "I: " - | `Debug -> s_ "D: " - in - prerr_endline (beg^str) - - - let default = - ref - { - quiet = false; - info = false; - debug = false; - ignore_plugins = false; - ignore_unknown_fields = false; - printf = printf; - } - - - let quiet = - {!default with quiet = true} - - - let fspecs () = - (* TODO: don't act on default. *) - let ignore_plugins = ref false in - ["-quiet", - Arg.Unit (fun () -> default := {!default with quiet = true}), - s_ " Run quietly"; - - "-info", - Arg.Unit (fun () -> default := {!default with info = true}), - s_ " Display information message"; - - - "-debug", - Arg.Unit (fun () -> default := {!default with debug = true}), - s_ " Output debug message"; - - "-ignore-plugins", - Arg.Set ignore_plugins, - s_ " Ignore plugin's field."; - - "-C", - (* TODO: remove this chdir. *) - Arg.String (fun str -> Sys.chdir str), - s_ "dir Change directory before running."], - fun () -> {!default with ignore_plugins = !ignore_plugins} -end - -module OASISString = struct -(* # 22 "src/oasis/OASISString.ml" *) - - - (** Various string utilities. - - Mostly inspired by extlib and batteries ExtString and BatString libraries. - - @author Sylvain Le Gall - *) - - - let nsplitf str f = - if str = "" then - [] - else - let buf = Buffer.create 13 in - let lst = ref [] in - let push () = - lst := Buffer.contents buf :: !lst; - Buffer.clear buf - in - let str_len = String.length str in - for i = 0 to str_len - 1 do - if f str.[i] then - push () - else - Buffer.add_char buf str.[i] - done; - push (); - List.rev !lst - - - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the - separator. - *) - let nsplit str c = - nsplitf str ((=) c) - - - let find ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx - - - let sub_start str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str len (str_len - len) - - - let sub_end ?(offset=0) str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str 0 (str_len - len) - - - let starts_with ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - let ok = ref true in - while !ok && - !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - ok := false; - incr str_idx - done; - if !what_idx = String.length what then - true - else - false - - - let strip_starts_with ~what str = - if starts_with ~what str then - sub_start str (String.length what) - else - raise Not_found - - - let ends_with ~what ?(offset=0) str = - let what_idx = ref ((String.length what) - 1) in - let str_idx = ref ((String.length str) - 1) in - let ok = ref true in - while !ok && - offset <= !str_idx && - 0 <= !what_idx do - if str.[!str_idx] = what.[!what_idx] then - decr what_idx - else - ok := false; - decr str_idx - done; - if !what_idx = -1 then - true - else - false - - - let strip_ends_with ~what str = - if ends_with ~what str then - sub_end str (String.length what) - else - raise Not_found - - - let replace_chars f s = - let buf = Buffer.create (String.length s) in - String.iter (fun c -> Buffer.add_char buf (f c)) s; - Buffer.contents buf - - -end - -module OASISUtils = struct -(* # 22 "src/oasis/OASISUtils.ml" *) - - - open OASISGettext - - - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end - - - module MapString = MapExt.Make(String) - - - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list = elements - end - end - - - module SetString = SetExt.Make(String) - - - let compare_csl s1 s2 = - String.compare (String.lowercase s1) (String.lowercase s2) - - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - - let equal s1 s2 = - (String.lowercase s1) = (String.lowercase s2) - - let hash s = - Hashtbl.hash (String.lowercase s) - end) - - module SetStringCsl = - SetExt.Make - (struct - type t = string - let compare = compare_csl - end) - - - let varname_of_string ?(hyphen='_') s = - if String.length s = 0 then - begin - invalid_arg "varname_of_string" - end - else - begin - let buf = - OASISString.replace_chars - (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || - ('0' <= c && c <= '9') then - c - else - hyphen) - s; - in - let buf = - (* Start with a _ if digit *) - if '0' <= s.[0] && s.[0] <= '9' then - "_"^buf - else - buf - in - String.lowercase buf - end - - - let varname_concat ?(hyphen='_') p s = - let what = String.make 1 hyphen in - let p = - try - OASISString.strip_ends_with ~what p - with Not_found -> - p - in - let s = - try - OASISString.strip_starts_with ~what s - with Not_found -> - s - in - p^what^s - - - let is_varname str = - str = varname_of_string str - - - let failwithf fmt = Printf.ksprintf failwith fmt - - -end - -module PropList = struct -(* # 22 "src/oasis/PropList.ml" *) - - - open OASISGettext - - - type name = string - - - exception Not_set of name * string option - exception No_printer of name - exception Unknown_field of name * name - - - let () = - Printexc.register_printer - (function - | Not_set (nm, Some rsn) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) - | Not_set (nm, None) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set") nm) - | No_printer nm -> - Some - (Printf.sprintf (f_ "No default printer for value %s") nm) - | Unknown_field (nm, schm) -> - Some - (Printf.sprintf - (f_ "Field %s is not defined in schema %s") nm schm) - | _ -> - None) - - - module Data = - struct - type t = - (name, unit -> unit) Hashtbl.t - - let create () = - Hashtbl.create 13 - - let clear t = - Hashtbl.clear t - - -(* # 78 "src/oasis/PropList.ml" *) - end - - - module Schema = - struct - type ('ctxt, 'extra) value = - { - get: Data.t -> string; - set: Data.t -> ?context:'ctxt -> string -> unit; - help: (unit -> string) option; - extra: 'extra; - } - - type ('ctxt, 'extra) t = - { - name: name; - fields: (name, ('ctxt, 'extra) value) Hashtbl.t; - order: name Queue.t; - name_norm: string -> string; - } - - let create ?(case_insensitive=false) nm = - { - name = nm; - fields = Hashtbl.create 13; - order = Queue.create (); - name_norm = - (if case_insensitive then - String.lowercase - else - fun s -> s); - } - - let add t nm set get extra help = - let key = - t.name_norm nm - in - - if Hashtbl.mem t.fields key then - failwith - (Printf.sprintf - (f_ "Field '%s' is already defined in schema '%s'") - nm t.name); - Hashtbl.add - t.fields - key - { - set = set; - get = get; - help = help; - extra = extra; - }; - Queue.add nm t.order - - let mem t nm = - Hashtbl.mem t.fields nm - - let find t nm = - try - Hashtbl.find t.fields (t.name_norm nm) - with Not_found -> - raise (Unknown_field (nm, t.name)) - - let get t data nm = - (find t nm).get data - - let set t data nm ?context x = - (find t nm).set - data - ?context - x - - let fold f acc t = - Queue.fold - (fun acc k -> - let v = - find t k - in - f acc k v.extra v.help) - acc - t.order - - let iter f t = - fold - (fun () -> f) - () - t - - let name t = - t.name - end - - - module Field = - struct - type ('ctxt, 'value, 'extra) t = - { - set: Data.t -> ?context:'ctxt -> 'value -> unit; - get: Data.t -> 'value; - sets: Data.t -> ?context:'ctxt -> string -> unit; - gets: Data.t -> string; - help: (unit -> string) option; - extra: 'extra; - } - - let new_id = - let last_id = - ref 0 - in - fun () -> incr last_id; !last_id - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - (* Default value container *) - let v = - ref None - in - - (* If name is not given, create unique one *) - let nm = - match name with - | Some s -> s - | None -> Printf.sprintf "_anon_%d" (new_id ()) - in - - (* Last chance to get a value: the default *) - let default () = - match default with - | Some d -> d - | None -> raise (Not_set (nm, Some (s_ "no default value"))) - in - - (* Get data *) - let get data = - (* Get value *) - try - (Hashtbl.find data nm) (); - match !v with - | Some x -> x - | None -> default () - with Not_found -> - default () - in - - (* Set data *) - let set data ?context x = - let x = - match update with - | Some f -> - begin - try - f ?context (get data) x - with Not_set _ -> - x - end - | None -> - x - in - Hashtbl.replace - data - nm - (fun () -> v := Some x) - in - - (* Parse string value, if possible *) - let parse = - match parse with - | Some f -> - f - | None -> - fun ?context s -> - failwith - (Printf.sprintf - (f_ "Cannot parse field '%s' when setting value %S") - nm - s) - in - - (* Set data, from string *) - let sets data ?context s = - set ?context data (parse ?context s) - in - - (* Output value as string, if possible *) - let print = - match print with - | Some f -> - f - | None -> - fun _ -> raise (No_printer nm) - in - - (* Get data, as a string *) - let gets data = - print (get data) - in - - begin - match schema with - | Some t -> - Schema.add t nm sets gets extra help - | None -> - () - end; - - { - set = set; - get = get; - sets = sets; - gets = gets; - help = help; - extra = extra; - } - - let fset data t ?context x = - t.set data ?context x - - let fget data t = - t.get data - - let fsets data t ?context s = - t.sets data ?context s - - let fgets data t = - t.gets data - end - - - module FieldRO = - struct - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - let fld = - Field.create ?schema ?name ?parse ?print ?default ?update ?help extra - in - fun data -> Field.fget data fld - end -end - -module OASISMessage = struct -(* # 22 "src/oasis/OASISMessage.ml" *) - - - open OASISGettext - open OASISContext - - - let generic_message ~ctxt lvl fmt = - let cond = - if ctxt.quiet then - false - else - match lvl with - | `Debug -> ctxt.debug - | `Info -> ctxt.info - | _ -> true - in - Printf.ksprintf - (fun str -> - if cond then - begin - ctxt.printf lvl str - end) - fmt - - - let debug ~ctxt fmt = - generic_message ~ctxt `Debug fmt - - - let info ~ctxt fmt = - generic_message ~ctxt `Info fmt - - - let warning ~ctxt fmt = - generic_message ~ctxt `Warning fmt - - - let error ~ctxt fmt = - generic_message ~ctxt `Error fmt - -end - -module OASISVersion = struct -(* # 22 "src/oasis/OASISVersion.ml" *) - - - open OASISGettext - - - - - - type s = string - - - type t = string - - - type comparator = - | VGreater of t - | VGreaterEqual of t - | VEqual of t - | VLesser of t - | VLesserEqual of t - | VOr of comparator * comparator - | VAnd of comparator * comparator - - - - (* Range of allowed characters *) - let is_digit c = - '0' <= c && c <= '9' - - - let is_alpha c = - ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') - - - let is_special = - function - | '.' | '+' | '-' | '~' -> true - | _ -> false - - - let rec version_compare v1 v2 = - if v1 <> "" || v2 <> "" then - begin - (* Compare ascii string, using special meaning for version - * related char - *) - let val_ascii c = - if c = '~' then -1 - else if is_digit c then 0 - else if c = '\000' then 0 - else if is_alpha c then Char.code c - else (Char.code c) + 256 - in - - let len1 = String.length v1 in - let len2 = String.length v2 in - - let p = ref 0 in - - (** Compare ascii part *) - let compare_vascii () = - let cmp = ref 0 in - while !cmp = 0 && - !p < len1 && !p < len2 && - not (is_digit v1.[!p] && is_digit v2.[!p]) do - cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); - incr p - done; - if !cmp = 0 && !p < len1 && !p = len2 then - val_ascii v1.[!p] - else if !cmp = 0 && !p = len1 && !p < len2 then - - (val_ascii v2.[!p]) - else - !cmp - in - - (** Compare digit part *) - let compare_digit () = - let extract_int v p = - let start_p = !p in - while !p < String.length v && is_digit v.[!p] do - incr p - done; - let substr = - String.sub v !p ((String.length v) - !p) - in - let res = - match String.sub v start_p (!p - start_p) with - | "" -> 0 - | s -> int_of_string s - in - res, substr - in - let i1, tl1 = extract_int v1 (ref !p) in - let i2, tl2 = extract_int v2 (ref !p) in - i1 - i2, tl1, tl2 - in - - match compare_vascii () with - | 0 -> - begin - match compare_digit () with - | 0, tl1, tl2 -> - if tl1 <> "" && is_digit tl1.[0] then - 1 - else if tl2 <> "" && is_digit tl2.[0] then - -1 - else - version_compare tl1 tl2 - | n, _, _ -> - n - end - | n -> - n - end - else - begin - 0 - end - - - let version_of_string str = str - - - let string_of_version t = t - - - let version_compare_string s1 s2 = - version_compare (version_of_string s1) (version_of_string s2) - - - let chop t = - try - let pos = - String.rindex t '.' - in - String.sub t 0 pos - with Not_found -> - t - - - let rec comparator_apply v op = - match op with - | VGreater cv -> - (version_compare v cv) > 0 - | VGreaterEqual cv -> - (version_compare v cv) >= 0 - | VLesser cv -> - (version_compare v cv) < 0 - | VLesserEqual cv -> - (version_compare v cv) <= 0 - | VEqual cv -> - (version_compare v cv) = 0 - | VOr (op1, op2) -> - (comparator_apply v op1) || (comparator_apply v op2) - | VAnd (op1, op2) -> - (comparator_apply v op1) && (comparator_apply v op2) - - - let rec string_of_comparator = - function - | VGreater v -> "> "^(string_of_version v) - | VEqual v -> "= "^(string_of_version v) - | VLesser v -> "< "^(string_of_version v) - | VGreaterEqual v -> ">= "^(string_of_version v) - | VLesserEqual v -> "<= "^(string_of_version v) - | VOr (c1, c2) -> - (string_of_comparator c1)^" || "^(string_of_comparator c2) - | VAnd (c1, c2) -> - (string_of_comparator c1)^" && "^(string_of_comparator c2) - - - let rec varname_of_comparator = - let concat p v = - OASISUtils.varname_concat - p - (OASISUtils.varname_of_string - (string_of_version v)) - in - function - | VGreater v -> concat "gt" v - | VLesser v -> concat "lt" v - | VEqual v -> concat "eq" v - | VGreaterEqual v -> concat "ge" v - | VLesserEqual v -> concat "le" v - | VOr (c1, c2) -> - (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) - | VAnd (c1, c2) -> - (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - - - let rec comparator_ge v' = - let cmp v = version_compare v v' >= 0 in - function - | VEqual v - | VGreaterEqual v - | VGreater v -> cmp v - | VLesserEqual _ - | VLesser _ -> false - | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 - | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 - - -end - -module OASISLicense = struct -(* # 22 "src/oasis/OASISLicense.ml" *) - - - (** License for _oasis fields - @author Sylvain Le Gall - *) - - - - - - type license = string - - - type license_exception = string - - - type license_version = - | Version of OASISVersion.t - | VersionOrLater of OASISVersion.t - | NoVersion - - - - type license_dep_5_unit = - { - license: license; - excption: license_exception option; - version: license_version; - } - - - - type license_dep_5 = - | DEP5Unit of license_dep_5_unit - | DEP5Or of license_dep_5 list - | DEP5And of license_dep_5 list - - - type t = - | DEP5License of license_dep_5 - | OtherLicense of string (* URL *) - - - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - - - - open OASISGettext - - - type test = string - - - type flag = string - - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - - type 'a choices = (t * 'a) list - - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - - -end - -module OASISText = struct -(* # 22 "src/oasis/OASISText.ml" *) - - - - type elt = - | Para of string - | Verbatim of string - | BlankLine - - - type t = elt list - -end - -module OASISTypes = struct -(* # 22 "src/oasis/OASISTypes.ml" *) - - - - - - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) - - - type findlib_name = string - type findlib_full = string - - - type compiled_object = - | Byte - | Native - | Best - - - - type dependency = - | FindlibPackage of findlib_full * OASISVersion.comparator option - | InternalLibrary of name - - - - type tool = - | ExternalTool of name - | InternalExecutable of name - - - - type vcs = - | Darcs - | Git - | Svn - | Cvs - | Hg - | Bzr - | Arch - | Monotone - | OtherVCS of url - - - - type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install - | `Extra - ] - - - type plugin_data_purpose = - [ `Configure - | `Build - | `Install - | `Clean - | `Distclean - | `Install - | `Uninstall - | `Test - | `Doc - | `Extra - | `Other of string - ] - - - type 'a plugin = 'a * name * OASISVersion.t option - - - type all_plugin = plugin_kind plugin - - - type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list - - -(* # 115 "src/oasis/OASISTypes.ml" *) - - - type 'a conditional = 'a OASISExpr.choices - - - type custom = - { - pre_command: (command_line option) conditional; - post_command: (command_line option) conditional; - } - - - - type common_section = - { - cs_name: name; - cs_data: PropList.Data.t; - cs_plugin_data: plugin_data; - } - - - - type build_section = - { - bs_build: bool conditional; - bs_install: bool conditional; - bs_path: unix_dirname; - bs_compiled_object: compiled_object; - bs_build_depends: dependency list; - bs_build_tools: tool list; - bs_c_sources: unix_filename list; - bs_data_files: (unix_filename * unix_filename option) list; - bs_ccopt: args conditional; - bs_cclib: args conditional; - bs_dlllib: args conditional; - bs_dllpath: args conditional; - bs_byteopt: args conditional; - bs_nativeopt: args conditional; - } - - - - type library = - { - lib_modules: string list; - lib_pack: bool; - lib_internal_modules: string list; - lib_findlib_parent: findlib_name option; - lib_findlib_name: findlib_name option; - lib_findlib_containers: findlib_name list; - } - - - type object_ = - { - obj_modules: string list; - obj_findlib_fullname: findlib_name list option; - } - - - type executable = - { - exec_custom: bool; - exec_main_is: unix_filename; - } - - - type flag = - { - flag_description: string option; - flag_default: bool conditional; - } - - - type source_repository = - { - src_repo_type: vcs; - src_repo_location: url; - src_repo_browser: url option; - src_repo_module: string option; - src_repo_branch: string option; - src_repo_tag: string option; - src_repo_subdir: unix_filename option; - } - - - type test = - { - test_type: [`Test] plugin; - test_command: command_line conditional; - test_custom: custom; - test_working_directory: unix_filename option; - test_run: bool conditional; - test_tools: tool list; - } - - - type doc_format = - | HTML of unix_filename - | DocText - | PDF - | PostScript - | Info of unix_filename - | DVI - | OtherDoc - - - - type doc = - { - doc_type: [`Doc] plugin; - doc_custom: custom; - doc_build: bool conditional; - doc_install: bool conditional; - doc_install_dir: unix_filename; - doc_title: string; - doc_authors: string list; - doc_abstract: string option; - doc_format: doc_format; - doc_data_files: (unix_filename * unix_filename option) list; - doc_build_tools: tool list; - } - - - type section = - | Library of common_section * build_section * library - | Object of common_section * build_section * object_ - | Executable of common_section * build_section * executable - | Flag of common_section * flag - | SrcRepo of common_section * source_repository - | Test of common_section * test - | Doc of common_section * doc - - - - type section_kind = - [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] - - - type package = - { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: OASISText.t option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - disable_oasis_section: unix_filename list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } - - -end - -module OASISFeatures = struct -(* # 22 "src/oasis/OASISFeatures.ml" *) - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISVersion - - module MapPlugin = - Map.Make - (struct - type t = plugin_kind * name - let compare = Pervasives.compare - end) - - module Data = - struct - type t = - { - oasis_version: OASISVersion.t; - plugin_versions: OASISVersion.t option MapPlugin.t; - alpha_features: string list; - beta_features: string list; - } - - let create oasis_version alpha_features beta_features = - { - oasis_version = oasis_version; - plugin_versions = MapPlugin.empty; - alpha_features = alpha_features; - beta_features = beta_features - } - - let of_package pkg = - create - pkg.OASISTypes.oasis_version - pkg.OASISTypes.alpha_features - pkg.OASISTypes.beta_features - - let add_plugin (plugin_kind, plugin_name, plugin_version) t = - {t with - plugin_versions = MapPlugin.add - (plugin_kind, plugin_name) - plugin_version - t.plugin_versions} - - let plugin_version plugin_kind plugin_name t = - MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions - - let to_string t = - Printf.sprintf - "oasis_version: %s; alpha_features: %s; beta_features: %s; \ - plugins_version: %s" - (OASISVersion.string_of_version t.oasis_version) - (String.concat ", " t.alpha_features) - (String.concat ", " t.beta_features) - (String.concat ", " - (MapPlugin.fold - (fun (_, plg) ver_opt acc -> - (plg^ - (match ver_opt with - | Some v -> - " "^(OASISVersion.string_of_version v) - | None -> "")) - :: acc) - t.plugin_versions [])) - end - - type origin = - | Field of string * string - | Section of string - | NoOrigin - - type stage = Alpha | Beta - - - let string_of_stage = - function - | Alpha -> "alpha" - | Beta -> "beta" - - - let field_of_stage = - function - | Alpha -> "AlphaFeatures" - | Beta -> "BetaFeatures" - - type publication = InDev of stage | SinceVersion of OASISVersion.t - - type t = - { - name: string; - plugin: all_plugin option; - publication: publication; - description: unit -> string; - } - - (* TODO: mutex protect this. *) - let all_features = Hashtbl.create 13 - - - let since_version ver_str = SinceVersion (version_of_string ver_str) - let alpha = InDev Alpha - let beta = InDev Beta - - - let to_string t = - Printf.sprintf - "feature: %s; plugin: %s; publication: %s" - t.name - (match t.plugin with - | None -> "" - | Some (_, nm, _) -> nm) - (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) - - let data_check t data origin = - let no_message = "no message" in - - let check_feature features stage = - let has_feature = List.mem t.name features in - if not has_feature then - match origin with - | Field (fld, where) -> - Some - (Printf.sprintf - (f_ "Field %s in %s is only available when feature %s \ - is in field %s.") - fld where t.name (field_of_stage stage)) - | Section sct -> - Some - (Printf.sprintf - (f_ "Section %s is only available when features %s \ - is in field %s.") - sct t.name (field_of_stage stage)) - | NoOrigin -> - Some no_message - else - None - in - - let version_is_good ~min_version version fmt = - let version_is_good = - OASISVersion.comparator_apply - version (OASISVersion.VGreaterEqual min_version) - in - Printf.ksprintf - (fun str -> - if version_is_good then - None - else - Some str) - fmt - in - - match origin, t.plugin, t.publication with - | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha - | _, _, InDev Beta -> check_feature data.Data.beta_features Beta - | Field(fld, where), None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Field %s in %s is only valid since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking \ - OASIS changelog.") - fld where (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Field(fld, where), Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Field %s in %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - fld where plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Field %s in %s is only valid when the OASIS plugin %s \ - is defined.") - fld where plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Field %s in %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - fld where plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | Section sct, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Section %s is only valid for since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking OASIS \ - changelog.") - sct (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Section sct, Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Section %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - sct plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Section %s is only valid when the OASIS plugin %s \ - is defined.") - sct plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Section %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - sct plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | NoOrigin, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version "%s" no_message - - | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> - begin - try - let plugin_version_current = - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> raise Not_found - in - version_is_good ~min_version plugin_version_current - "%s" no_message - with Not_found -> - Some no_message - end - - - let data_assert t data origin = - match data_check t data origin with - | None -> () - | Some str -> failwith str - - - let data_test t data = - match data_check t data NoOrigin with - | None -> true - | Some str -> false - - - let package_test t pkg = - data_test t (Data.of_package pkg) - - - let create ?plugin name publication description = - let () = - if Hashtbl.mem all_features name then - failwithf "Feature '%s' is already declared." name - in - let t = - { - name = name; - plugin = plugin; - publication = publication; - description = description; - } - in - Hashtbl.add all_features name t; - t - - - let get_stage name = - try - (Hashtbl.find all_features name).publication - with Not_found -> - failwithf (f_ "Feature %s doesn't exist.") name - - - let list () = - Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] - - (* - * Real flags. - *) - - - let features = - create "features_fields" - (since_version "0.4") - (fun () -> - s_ "Enable to experiment not yet official features.") - - - let flag_docs = - create "flag_docs" - (since_version "0.3") - (fun () -> - s_ "Building docs require '-docs' flag at configure.") - - - let flag_tests = - create "flag_tests" - (since_version "0.3") - (fun () -> - s_ "Running tests require '-tests' flag at configure.") - - - let pack = - create "pack" - (since_version "0.3") - (fun () -> - s_ "Allow to create packed library.") - - - let section_object = - create "section_object" beta - (fun () -> - s_ "Implement an object section.") - - - let dynrun_for_release = - create "dynrun_for_release" alpha - (fun () -> - s_ "Make '-setup-update dynamic' suitable for releasing project.") - - - let compiled_setup_ml = - create "compiled_setup_ml" alpha - (fun () -> - s_ "It compiles the setup.ml and speed-up actions done with it.") - - let disable_oasis_section = - create "disable_oasis_section" alpha - (fun () -> - s_ "Allows the OASIS section comments and digest to be omitted in \ - generated files.") - - let no_automatic_syntax = - create "no_automatic_syntax" alpha - (fun () -> - s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ - that matches the internal heuristic (if a dependency ends with \ - a .syntax or is a well known syntax).") -end - -module OASISUnixPath = struct -(* # 22 "src/oasis/OASISUnixPath.ml" *) - - - type unix_filename = string - type unix_dirname = string - - - type host_filename = string - type host_dirname = string - - - let current_dir_name = "." - - - let parent_dir_name = ".." - - - let is_current_dir fn = - fn = current_dir_name || fn = "" - - - let concat f1 f2 = - if is_current_dir f1 then - f2 - else - let f1' = - try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 - in - f1'^"/"^f2 - - - let make = - function - | hd :: tl -> - List.fold_left - (fun f p -> concat f p) - hd - tl - | [] -> - invalid_arg "OASISUnixPath.make" - - - let dirname f = - try - String.sub f 0 (String.rindex f '/') - with Not_found -> - current_dir_name - - - let basename f = - try - let pos_start = - (String.rindex f '/') + 1 - in - String.sub f pos_start ((String.length f) - pos_start) - with Not_found -> - f - - - let chop_extension f = - try - let last_dot = - String.rindex f '.' - in - let sub = - String.sub f 0 last_dot - in - try - let last_slash = - String.rindex f '/' - in - if last_slash < last_dot then - sub - else - f - with Not_found -> - sub - - with Not_found -> - f - - - let capitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.capitalize base) - - - let uncapitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.uncapitalize base) - - -end - -module OASISHostPath = struct -(* # 22 "src/oasis/OASISHostPath.ml" *) - - - open Filename - - - module Unix = OASISUnixPath - - - let make = - function - | [] -> - invalid_arg "OASISHostPath.make" - | hd :: tl -> - List.fold_left Filename.concat hd tl - - - let of_unix ufn = - if Sys.os_type = "Unix" then - ufn - else - make - (List.map - (fun p -> - if p = Unix.current_dir_name then - current_dir_name - else if p = Unix.parent_dir_name then - parent_dir_name - else - p) - (OASISString.nsplit ufn '/')) - - -end - -module OASISSection = struct -(* # 22 "src/oasis/OASISSection.ml" *) - - - open OASISTypes - - - let section_kind_common = - function - | Library (cs, _, _) -> - `Library, cs - | Object (cs, _, _) -> - `Object, cs - | Executable (cs, _, _) -> - `Executable, cs - | Flag (cs, _) -> - `Flag, cs - | SrcRepo (cs, _) -> - `SrcRepo, cs - | Test (cs, _) -> - `Test, cs - | Doc (cs, _) -> - `Doc, cs - - - let section_common sct = - snd (section_kind_common sct) - - - let section_common_set cs = - function - | Library (_, bs, lib) -> Library (cs, bs, lib) - | Object (_, bs, obj) -> Object (cs, bs, obj) - | Executable (_, bs, exec) -> Executable (cs, bs, exec) - | Flag (_, flg) -> Flag (cs, flg) - | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) - | Test (_, tst) -> Test (cs, tst) - | Doc (_, doc) -> Doc (cs, doc) - - - (** Key used to identify section - *) - let section_id sct = - let k, cs = - section_kind_common sct - in - k, cs.cs_name - - - let string_of_section sct = - let k, nm = - section_id sct - in - (match k with - | `Library -> "library" - | `Object -> "object" - | `Executable -> "executable" - | `Flag -> "flag" - | `SrcRepo -> "src repository" - | `Test -> "test" - | `Doc -> "doc") - ^" "^nm - - - let section_find id scts = - List.find - (fun sct -> id = section_id sct) - scts - - - module CSection = - struct - type t = section - - let id = section_id - - let compare t1 t2 = - compare (id t1) (id t2) - - let equal t1 t2 = - (id t1) = (id t2) - - let hash t = - Hashtbl.hash (id t) - end - - - module MapSection = Map.Make(CSection) - module SetSection = Set.Make(CSection) - - -end - -module OASISBuildSection = struct -(* # 22 "src/oasis/OASISBuildSection.ml" *) - - -end - -module OASISExecutable = struct -(* # 22 "src/oasis/OASISExecutable.ml" *) - - - open OASISTypes - - - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = - OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.dirname exec.exec_main_is) - in - let is_native_exec = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native () - | Byte -> false - in - - OASISUnixPath.concat - dir - (cs.cs_name^(suffix_program ())), - - if not is_native_exec && - not exec.exec_custom && - bs.bs_c_sources <> [] then - Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) - else - None - - -end - -module OASISLibrary = struct -(* # 22 "src/oasis/OASISLibrary.ml" *) - - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISSection - - - (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists bs modul = - let possible_base_fn = - List.map - (OASISUnixPath.concat bs.bs_path) - [modul; - OASISUnixPath.uncapitalize_file modul; - OASISUnixPath.capitalize_file modul] - in - (* TODO: we should be able to be able to determine the source for every - * files. Hence we should introduce a Module(source: fn) for the fields - * Modules and InternalModules - *) - List.fold_left - (fun acc base_fn -> - match acc with - | `No_sources _ -> - begin - let file_found = - List.fold_left - (fun acc ext -> - if source_file_exists (base_fn^ext) then - (base_fn^ext) :: acc - else - acc) - [] - [".ml"; ".mli"; ".mll"; ".mly"] - in - match file_found with - | [] -> - acc - | lst -> - `Sources (base_fn, lst) - end - | `Sources _ -> - acc) - (`No_sources possible_base_fn) - possible_base_fn - - - let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = - List.fold_left - (fun acc modul -> - match find_module source_file_exists bs modul with - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - acc) - [] - (lib.lib_modules @ lib.lib_internal_modules) - - - let generated_unix_files - ~ctxt - ~is_native - ~has_native_dynlink - ~ext_lib - ~ext_dll - ~source_file_exists - (cs, bs, lib) = - - let find_modules lst ext = - let find_module modul = - match find_module source_file_exists bs modul with - | `Sources (base_fn, [fn]) when ext <> "cmi" - && Filename.check_suffix fn ".mli" -> - None (* No implementation files for pure interface. *) - | `Sources (base_fn, _) -> - Some [base_fn] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - Some lst - in - List.fold_left - (fun acc nm -> - match find_module nm with - | None -> acc - | Some base_fns -> - List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) - [] - lst - in - - (* The .cmx that be compiled along *) - let cmxs = - let should_be_built = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native - | Byte -> false - in - if should_be_built then - if lib.lib_pack then - find_modules - [cs.cs_name] - "cmx" - else - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" - else - [] - in - - let acc_nopath = - [] - in - - (* The headers and annot/cmt files that should be compiled along *) - let headers = - let sufx = - if lib.lib_pack - then [".cmti"; ".cmt"; ".annot"] - else [".cmi"; ".cmti"; ".cmt"; ".annot"] - in - List.map - begin - List.fold_left - begin fun accu s -> - let dot = String.rindex s '.' in - let base = String.sub s 0 dot in - List.map ((^) base) sufx @ accu - end - [] - end - (find_modules lib.lib_modules "cmi") - in - - (* Compute what libraries should be built *) - let acc_nopath = - (* Add the packed header file if required *) - let add_pack_header acc = - if lib.lib_pack then - [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc - else - acc - in - let byte acc = - add_pack_header ([cs.cs_name^".cma"] :: acc) - in - let native acc = - let acc = - add_pack_header - (if has_native_dynlink then - [cs.cs_name^".cmxs"] :: acc - else acc) - in - [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc - in - match bs.bs_compiled_object with - | Native -> - byte (native acc_nopath) - | Best when is_native -> - byte (native acc_nopath) - | Byte | Best -> - byte acc_nopath - in - - (* Add C library to be built *) - let acc_nopath = - if bs.bs_c_sources <> [] then - begin - ["lib"^cs.cs_name^"_stubs"^ext_lib] - :: - ["dll"^cs.cs_name^"_stubs"^ext_dll] - :: - acc_nopath - end - else - acc_nopath - in - - (* All the files generated *) - List.rev_append - (List.rev_map - (List.rev_map - (OASISUnixPath.concat bs.bs_path)) - acc_nopath) - (headers @ cmxs) - - -end - -module OASISObject = struct -(* # 22 "src/oasis/OASISObject.ml" *) - - - open OASISTypes - open OASISGettext - - - let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = - List.fold_left - (fun acc modul -> - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name; - acc) - [] - obj.obj_modules - - - let generated_unix_files - ~ctxt - ~is_native - ~source_file_exists - (cs, bs, obj) = - - let find_module ext modul = - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, _) -> [base_fn ^ ext] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name ; - lst - in - - let header, byte, native, c_object, f = - match obj.obj_modules with - | [ m ] -> (find_module ".cmi" m, - find_module ".cmo" m, - find_module ".cmx" m, - find_module ".o" m, - fun x -> x) - | _ -> ([cs.cs_name ^ ".cmi"], - [cs.cs_name ^ ".cmo"], - [cs.cs_name ^ ".cmx"], - [cs.cs_name ^ ".o"], - OASISUnixPath.concat bs.bs_path) - in - List.map (List.map f) ( - match bs.bs_compiled_object with - | Native -> - native :: c_object :: byte :: header :: [] - | Best when is_native -> - native :: c_object :: byte :: header :: [] - | Byte | Best -> - byte :: header :: []) - - -end - -module OASISFindlib = struct -(* # 22 "src/oasis/OASISFindlib.ml" *) - - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISSection - - - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - [`Library of library | `Object of object_] * - group_t list) - - - type data = common_section * - build_section * - [`Library of library | `Object of object_] - type tree = - | Node of (data option) * (tree MapString.t) - | Leaf of data - - - let findlib_mapping pkg = - (* Map from library name to either full findlib name or parts + parent. *) - let fndlb_parts_of_lib_name = - let fndlb_parts cs lib = - let name = - match lib.lib_findlib_name with - | Some nm -> nm - | None -> cs.cs_name - in - let name = - String.concat "." (lib.lib_findlib_containers @ [name]) - in - name - in - List.fold_left - (fun mp -> - function - | Library (cs, _, lib) -> - begin - let lib_name = cs.cs_name in - let fndlb_parts = fndlb_parts cs lib in - if MapString.mem lib_name mp then - failwithf - (f_ "The library name '%s' is used more than once.") - lib_name; - match lib.lib_findlib_parent with - | Some lib_name_parent -> - MapString.add - lib_name - (`Unsolved (lib_name_parent, fndlb_parts)) - mp - | None -> - MapString.add - lib_name - (`Solved fndlb_parts) - mp - end - - | Object (cs, _, obj) -> - begin - let obj_name = cs.cs_name in - if MapString.mem obj_name mp then - failwithf - (f_ "The object name '%s' is used more than once.") - obj_name; - let findlib_full_name = match obj.obj_findlib_fullname with - | Some ns -> String.concat "." ns - | None -> obj_name - in - MapString.add - obj_name - (`Solved findlib_full_name) - mp - end - - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> - mp) - MapString.empty - pkg.sections - in - - (* Solve the above graph to be only library name to full findlib name. *) - let fndlb_name_of_lib_name = - let rec solve visited mp lib_name lib_name_child = - if SetString.mem lib_name visited then - failwithf - (f_ "Library '%s' is involved in a cycle \ - with regard to findlib naming.") - lib_name; - let visited = SetString.add lib_name visited in - try - match MapString.find lib_name mp with - | `Solved fndlb_nm -> - fndlb_nm, mp - | `Unsolved (lib_nm_parent, post_fndlb_nm) -> - let pre_fndlb_nm, mp = - solve visited mp lib_nm_parent lib_name - in - let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in - fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp - with Not_found -> - failwithf - (f_ "Library '%s', which is defined as the findlib parent of \ - library '%s', doesn't exist.") - lib_name lib_name_child - in - let mp = - MapString.fold - (fun lib_name status mp -> - match status with - | `Solved _ -> - (* Solved initialy, no need to go further *) - mp - | `Unsolved _ -> - let _, mp = solve SetString.empty mp lib_name "" in - mp) - fndlb_parts_of_lib_name - fndlb_parts_of_lib_name - in - MapString.map - (function - | `Solved fndlb_nm -> fndlb_nm - | `Unsolved _ -> assert false) - mp - in - - (* Convert an internal library name to a findlib name. *) - let findlib_name_of_library_name lib_nm = - try - MapString.find lib_nm fndlb_name_of_lib_name - with Not_found -> - raise (InternalLibraryNotFound lib_nm) - in - - (* Add a library to the tree. - *) - let add sct mp = - let fndlb_fullname = - let cs, _, _ = sct in - let lib_name = cs.cs_name in - findlib_name_of_library_name lib_name - in - let rec add_children nm_lst (children: tree MapString.t) = - match nm_lst with - | (hd :: tl) -> - begin - let node = - try - add_node tl (MapString.find hd children) - with Not_found -> - (* New node *) - new_node tl - in - MapString.add hd node children - end - | [] -> - (* Should not have a nameless library. *) - assert false - and add_node tl node = - if tl = [] then - begin - match node with - | Node (None, children) -> - Node (Some sct, children) - | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> - (* TODO: allow to merge Package, i.e. - * archive(byte) = "foo.cma foo_init.cmo" - *) - let cs, _, _ = sct in - failwithf - (f_ "Library '%s' and '%s' have the same findlib name '%s'") - cs.cs_name cs'.cs_name fndlb_fullname - end - else - begin - match node with - | Leaf data -> - Node (Some data, add_children tl MapString.empty) - | Node (data_opt, children) -> - Node (data_opt, add_children tl children) - end - and new_node = - function - | [] -> - Leaf sct - | hd :: tl -> - Node (None, MapString.add hd (new_node tl) MapString.empty) - in - add_children (OASISString.nsplit fndlb_fullname '.') mp - in - - let rec group_of_tree mp = - MapString.fold - (fun nm node acc -> - let cur = - match node with - | Node (Some (cs, bs, lib), children) -> - Package (nm, cs, bs, lib, group_of_tree children) - | Node (None, children) -> - Container (nm, group_of_tree children) - | Leaf (cs, bs, lib) -> - Package (nm, cs, bs, lib, []) - in - cur :: acc) - mp [] - in - - let group_mp = - List.fold_left - (fun mp -> - function - | Library (cs, bs, lib) -> - add (cs, bs, `Library lib) mp - | Object (cs, bs, obj) -> - add (cs, bs, `Object obj) mp - | _ -> - mp) - MapString.empty - pkg.sections - in - - let groups = - group_of_tree group_mp - in - - let library_name_of_findlib_name = - lazy begin - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty - end - in - let library_name_of_findlib_name fndlb_nm = - try - MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) - with Not_found -> - raise (FindlibPackageNotFound fndlb_nm) - in - - groups, - findlib_name_of_library_name, - library_name_of_findlib_name - - - let findlib_of_group = - function - | Container (fndlb_nm, _) - | Package (fndlb_nm, _, _, _, _) -> fndlb_nm - - - let root_of_group grp = - let rec root_lib_aux = - (* We do a DFS in the group. *) - function - | Container (_, children) -> - List.fold_left - (fun res grp -> - if res = None then - root_lib_aux grp - else - res) - None - children - | Package (_, cs, bs, lib, _) -> - Some (cs, bs, lib) - in - match root_lib_aux grp with - | Some res -> - res - | None -> - failwithf - (f_ "Unable to determine root library of findlib library '%s'") - (findlib_of_group grp) - - -end - -module OASISFlag = struct -(* # 22 "src/oasis/OASISFlag.ml" *) - - -end - -module OASISPackage = struct -(* # 22 "src/oasis/OASISPackage.ml" *) - - -end - -module OASISSourceRepository = struct -(* # 22 "src/oasis/OASISSourceRepository.ml" *) - - -end - -module OASISTest = struct -(* # 22 "src/oasis/OASISTest.ml" *) - - -end - -module OASISDocument = struct -(* # 22 "src/oasis/OASISDocument.ml" *) - - -end - -module OASISExec = struct -(* # 22 "src/oasis/OASISExec.ml" *) - - - open OASISGettext - open OASISUtils - open OASISMessage - - - (* TODO: I don't like this quote, it is there because $(rm) foo expands to - * 'rm -f' foo... - *) - let run ~ctxt ?f_exit_code ?(quote=true) cmd args = - let cmd = - if quote then - if Sys.os_type = "Win32" then - if String.contains cmd ' ' then - (* Double the 1st double quote... win32... sigh *) - "\""^(Filename.quote cmd) - else - cmd - else - Filename.quote cmd - else - cmd - in - let cmdline = - String.concat " " (cmd :: args) - in - info ~ctxt (f_ "Running command '%s'") cmdline; - match f_exit_code, Sys.command cmdline with - | None, 0 -> () - | None, i -> - failwithf - (f_ "Command '%s' terminated with error code %d") - cmdline i - | Some f, i -> - f i - - - let run_read_output ~ctxt ?f_exit_code cmd args = - let fn = - Filename.temp_file "oasis-" ".txt" - in - try - begin - let () = - run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) - in - let chn = - open_in fn - in - let routput = - ref [] - in - begin - try - while true do - routput := (input_line chn) :: !routput - done - with End_of_file -> - () - end; - close_in chn; - Sys.remove fn; - List.rev !routput - end - with e -> - (try Sys.remove fn with _ -> ()); - raise e - - - let run_read_one_line ~ctxt ?f_exit_code cmd args = - match run_read_output ~ctxt ?f_exit_code cmd args with - | [fst] -> - fst - | lst -> - failwithf - (f_ "Command return unexpected output %S") - (String.concat "\n" lst) -end - -module OASISFileUtil = struct -(* # 22 "src/oasis/OASISFileUtil.ml" *) - - - open OASISGettext - - - let file_exists_case fn = - let dirname = Filename.dirname fn in - let basename = Filename.basename fn in - if Sys.file_exists dirname then - if basename = Filename.current_dir_name then - true - else - List.mem - basename - (Array.to_list (Sys.readdir dirname)) - else - false - - - let find_file ?(case_sensitive=true) paths exts = - - (* Cardinal product of two list *) - let ( * ) lst1 lst2 = - List.flatten - (List.map - (fun a -> - List.map - (fun b -> a, b) - lst2) - lst1) - in - - let rec combined_paths lst = - match lst with - | p1 :: p2 :: tl -> - let acc = - (List.map - (fun (a, b) -> Filename.concat a b) - (p1 * p2)) - in - combined_paths (acc :: tl) - | [e] -> - e - | [] -> - [] - in - - let alternatives = - List.map - (fun (p, e) -> - if String.length e > 0 && e.[0] <> '.' then - p ^ "." ^ e - else - p ^ e) - ((combined_paths paths) * exts) - in - List.find (fun file -> - (if case_sensitive then - file_exists_case file - else - Sys.file_exists file) - && not (Sys.is_directory file) - ) alternatives - - - let which ~ctxt prg = - let path_sep = - match Sys.os_type with - | "Win32" -> - ';' - | _ -> - ':' - in - let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in - let exec_ext = - match Sys.os_type with - | "Win32" -> - "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) - | _ -> - [""] - in - find_file ~case_sensitive:false [path_lst; [prg]] exec_ext - - - (**/**) - let rec fix_dir dn = - (* Windows hack because Sys.file_exists "src\\" = false when - * Sys.file_exists "src" = true - *) - let ln = - String.length dn - in - if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then - fix_dir (String.sub dn 0 (ln - 1)) - else - dn - - - let q = Filename.quote - (**/**) - - - let cp ~ctxt ?(recurse=false) src tgt = - if recurse then - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt - "xcopy" [q src; q tgt; "/E"] - | _ -> - OASISExec.run ~ctxt - "cp" ["-r"; q src; q tgt] - else - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "copy" - | _ -> "cp") - [q src; q tgt] - - - let mkdir ~ctxt tgt = - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "md" - | _ -> "mkdir") - [q tgt] - - - let rec mkdir_parent ~ctxt f tgt = - let tgt = - fix_dir tgt - in - if Sys.file_exists tgt then - begin - if not (Sys.is_directory tgt) then - OASISUtils.failwithf - (f_ "Cannot create directory '%s', a file of the same name already \ - exists") - tgt - end - else - begin - mkdir_parent ~ctxt f (Filename.dirname tgt); - if not (Sys.file_exists tgt) then - begin - f tgt; - mkdir ~ctxt tgt - end - end - - - let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end else begin - OASISMessage.error ~ctxt - (f_ "Cannot remove directory '%s': not empty.") - tgt - end - - - let glob ~ctxt fn = - let basename = - Filename.basename fn - in - if String.length basename >= 2 && - basename.[0] = '*' && - basename.[1] = '.' then - begin - let ext_len = - (String.length basename) - 2 - in - let ext = - String.sub basename 2 ext_len - in - let dirname = - Filename.dirname fn - in - Array.fold_left - (fun acc fn -> - try - let fn_ext = - String.sub - fn - ((String.length fn) - ext_len) - ext_len - in - if fn_ext = ext then - (Filename.concat dirname fn) :: acc - else - acc - with Invalid_argument _ -> - acc) - [] - (Sys.readdir dirname) - end - else - begin - if file_exists_case fn then - [fn] - else - [] - end -end - - -# 2893 "setup.ml" -module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - - - module MapString = Map.Make(String) - - - type t = string MapString.t - - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - - let rec var_expand str env = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = - var_expand (MapString.find name env) env - - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -# 2998 "setup.ml" -module BaseContext = struct -(* # 22 "src/base/BaseContext.ml" *) - - (* TODO: get rid of this module. *) - open OASISContext - - - let args () = fst (fspecs ()) - - - let default = default - -end - -module BaseMessage = struct -(* # 22 "src/base/BaseMessage.ml" *) - - - (** Message to user, overrid for Base - @author Sylvain Le Gall - *) - open OASISMessage - open BaseContext - - - let debug fmt = debug ~ctxt:!default fmt - - - let info fmt = info ~ctxt:!default fmt - - - let warning fmt = warning ~ctxt:!default fmt - - - let error fmt = error ~ctxt:!default fmt - -end - -module BaseEnv = struct -(* # 22 "src/base/BaseEnv.ml" *) - - open OASISGettext - open OASISUtils - open PropList - - - module MapString = BaseEnvLight.MapString - - - type origin_t = - | ODefault - | OGetEnv - | OFileLoad - | OCommandLine - - - type cli_handle_t = - | CLINone - | CLIAuto - | CLIWith - | CLIEnable - | CLIUser of (Arg.key * Arg.spec * Arg.doc) list - - - type definition_t = - { - hide: bool; - dump: bool; - cli: cli_handle_t; - arg_help: string option; - group: string option; - } - - - let schema = - Schema.create "environment" - - - (* Environment data *) - let env = - Data.create () - - - (* Environment data from file *) - let env_from_file = - ref MapString.empty - - - (* Lexer for var *) - let var_lxr = - Genlex.make_lexer [] - - - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - (* TODO: this is a quick hack to allow calling Test.Command - * without defining executable name really. I.e. if there is - * an exec Executable toto, then $(toto) should be replace - * by its real name. It is however useful to have this function - * for other variable that depend on the host and should be - * written better than that. - *) - let st = - var_lxr (Stream.of_string var) - in - match Stream.npeek 3 st with - | [Genlex.Ident "utoh"; Genlex.Ident nm] -> - OASISHostPath.of_unix (var_get nm) - | [Genlex.Ident "utoh"; Genlex.String s] -> - OASISHostPath.of_unix s - | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> - String.escaped (var_get nm) - | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> - String.escaped s - | [Genlex.Ident nm] -> - var_get nm - | _ -> - failwithf - (f_ "Unknown expression '%s' in variable expansion of %s.") - var - str - with - | Unknown_field (_, _) -> - failwithf - (f_ "No variable %s defined when trying to expand %S.") - var - str - | Stream.Error e -> - failwithf - (f_ "Syntax error when parsing '%s' when trying to \ - expand %S: %s") - var - str - e) - str; - Buffer.contents buff - - - and var_get name = - let vl = - try - Schema.get schema env name - with Unknown_field _ as e -> - begin - try - MapString.find name !env_from_file - with Not_found -> - raise e - end - in - var_expand vl - - - let var_choose ?printer ?name lst = - OASISExpr.choose - ?printer - ?name - var_get - lst - - - let var_protect vl = - let buff = - Buffer.create (String.length vl) - in - String.iter - (function - | '$' -> Buffer.add_string buff "\\$" - | c -> Buffer.add_char buff c) - vl; - Buffer.contents buff - - - let var_define - ?(hide=false) - ?(dump=true) - ?short_desc - ?(cli=CLINone) - ?arg_help - ?group - name (* TODO: type constraint on the fact that name must be a valid OCaml - id *) - dflt = - - let default = - [ - OFileLoad, (fun () -> MapString.find name !env_from_file); - ODefault, dflt; - OGetEnv, (fun () -> Sys.getenv name); - ] - in - - let extra = - { - hide = hide; - dump = dump; - cli = cli; - arg_help = arg_help; - group = group; - } - in - - (* Try to find a value that can be defined - *) - let var_get_low lst = - let errors, res = - List.fold_left - (fun (errors, res) (o, v) -> - if res = None then - begin - try - errors, Some (v ()) - with - | Not_found -> - errors, res - | Failure rsn -> - (rsn :: errors), res - | e -> - (Printexc.to_string e) :: errors, res - end - else - errors, res) - ([], None) - (List.sort - (fun (o1, _) (o2, _) -> - Pervasives.compare o2 o1) - lst) - in - match res, errors with - | Some v, _ -> - v - | None, [] -> - raise (Not_set (name, None)) - | None, lst -> - raise (Not_set (name, Some (String.concat (s_ ", ") lst))) - in - - let help = - match short_desc with - | Some fs -> Some fs - | None -> None - in - - let var_get_lst = - FieldRO.create - ~schema - ~name - ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) - ~print:var_get_low - ~default - ~update:(fun ?context x old_x -> x @ old_x) - ?help - extra - in - - fun () -> - var_expand (var_get_low (var_get_lst env)) - - - let var_redefine - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt = - if Schema.mem schema name then - begin - (* TODO: look suspsicious, we want to memorize dflt not dflt () *) - Schema.set schema env ~context:ODefault name (dflt ()); - fun () -> var_get name - end - else - begin - var_define - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt - end - - - let var_ignore (e: unit -> string) = () - - - let print_hidden = - var_define - ~hide:true - ~dump:false - ~cli:CLIAuto - ~arg_help:"Print even non-printable variable. (debug)" - "print_hidden" - (fun () -> "false") - - - let var_all () = - List.rev - (Schema.fold - (fun acc nm def _ -> - if not def.hide || bool_of_string (print_hidden ()) then - nm :: acc - else - acc) - [] - schema) - - - let default_filename = - BaseEnvLight.default_filename - - - let load ?allow_empty ?filename () = - env_from_file := BaseEnvLight.load ?allow_empty ?filename () - - - let unload () = - env_from_file := MapString.empty; - Data.clear env - - - let dump ?(filename=default_filename) () = - let chn = - open_out_bin filename - in - let output nm value = - Printf.fprintf chn "%s=%S\n" nm value - in - let mp_todo = - (* Dump data from schema *) - Schema.fold - (fun mp_todo nm def _ -> - if def.dump then - begin - try - let value = - Schema.get - schema - env - nm - in - output nm value - with Not_set _ -> - () - end; - MapString.remove nm mp_todo) - !env_from_file - schema - in - (* Dump data defined outside of schema *) - MapString.iter output mp_todo; - - (* End of the dump *) - close_out chn - - - let print () = - let printable_vars = - Schema.fold - (fun acc nm def short_descr_opt -> - if not def.hide || bool_of_string (print_hidden ()) then - begin - try - let value = - Schema.get - schema - env - nm - in - let txt = - match short_descr_opt with - | Some s -> s () - | None -> nm - in - (txt, value) :: acc - with Not_set _ -> - acc - end - else - acc) - [] - schema - in - let max_length = - List.fold_left max 0 - (List.rev_map String.length - (List.rev_map fst printable_vars)) - in - let dot_pad str = - String.make ((max_length - (String.length str)) + 3) '.' - in - - Printf.printf "\nConfiguration: \n"; - List.iter - (fun (name, value) -> - Printf.printf "%s: %s %s\n" name (dot_pad name) value) - (List.rev printable_vars); - Printf.printf "\n%!" - - - let args () = - let arg_concat = - OASISUtils.varname_concat ~hyphen:'-' - in - [ - "--override", - Arg.Tuple - ( - let rvr = ref "" - in - let rvl = ref "" - in - [ - Arg.Set_string rvr; - Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set - schema - env - ~context:OCommandLine - !rvr - !rvl) - ] - ), - "var+val Override any configuration variable."; - - ] - @ - List.flatten - (Schema.fold - (fun acc name def short_descr_opt -> - let var_set s = - Schema.set - schema - env - ~context:OCommandLine - name - s - in - - let arg_name = - OASISUtils.varname_of_string ~hyphen:'-' name - in - - let hlp = - match short_descr_opt with - | Some txt -> txt () - | None -> "" - in - - let arg_hlp = - match def.arg_help with - | Some s -> s - | None -> "str" - in - - let default_value = - try - Printf.sprintf - (f_ " [%s]") - (Schema.get - schema - env - name) - with Not_set _ -> - "" - in - - let args = - match def.cli with - | CLINone -> - [] - | CLIAuto -> - [ - arg_concat "--" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIWith -> - [ - arg_concat "--with-" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIEnable -> - let dflt = - if default_value = " [true]" then - s_ " [default: enabled]" - else - s_ " [default: disabled]" - in - [ - arg_concat "--enable-" arg_name, - Arg.Unit (fun () -> var_set "true"), - Printf.sprintf (f_ " %s%s") hlp dflt; - - arg_concat "--disable-" arg_name, - Arg.Unit (fun () -> var_set "false"), - Printf.sprintf (f_ " %s%s") hlp dflt - ] - | CLIUser lst -> - lst - in - args :: acc) - [] - schema) -end - -module BaseArgExt = struct -(* # 22 "src/base/BaseArgExt.ml" *) - - - open OASISUtils - open OASISGettext - - - let parse argv args = - (* Simulate command line for Arg *) - let current = - ref 0 - in - - try - Arg.parse_argv - ~current:current - (Array.concat [[|"none"|]; argv]) - (Arg.align args) - (failwithf (f_ "Don't know what to do with arguments: '%s'")) - (s_ "configure options:") - with - | Arg.Help txt -> - print_endline txt; - exit 0 - | Arg.Bad txt -> - prerr_endline txt; - exit 1 -end - -module BaseCheck = struct -(* # 22 "src/base/BaseCheck.ml" *) - - - open BaseEnv - open BaseMessage - open OASISUtils - open OASISGettext - - - let prog_best prg prg_lst = - var_redefine - prg - (fun () -> - let alternate = - List.fold_left - (fun res e -> - match res with - | Some _ -> - res - | None -> - try - Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) - with Not_found -> - None) - None - prg_lst - in - match alternate with - | Some prg -> prg - | None -> raise Not_found) - - - let prog prg = - prog_best prg [prg] - - - let prog_opt prg = - prog_best prg [prg^".opt"; prg] - - - let ocamlfind = - prog "ocamlfind" - - - let version - var_prefix - cmp - fversion - () = - (* Really compare version provided *) - let var = - var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) - in - var_redefine - ~hide:true - var - (fun () -> - let version_str = - match fversion () with - | "[Distributed with OCaml]" -> - begin - try - (var_get "ocaml_version") - with Not_found -> - warning - (f_ "Variable ocaml_version not defined, fallback \ - to default"); - Sys.ocaml_version - end - | res -> - res - in - let version = - OASISVersion.version_of_string version_str - in - if OASISVersion.comparator_apply version cmp then - version_str - else - failwithf - (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") - var_prefix - (OASISVersion.string_of_comparator cmp) - version_str) - () - - - let package_version pkg = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%v"; pkg] - - - let package ?version_comparator pkg () = - let var = - OASISUtils.varname_concat - "pkg_" - (OASISUtils.varname_of_string pkg) - in - let findlib_dir pkg = - let dir = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%d"; pkg] - in - if Sys.file_exists dir && Sys.is_directory dir then - dir - else - failwithf - (f_ "When looking for findlib package %s, \ - directory %s return doesn't exist") - pkg dir - in - let vl = - var_redefine - var - (fun () -> findlib_dir pkg) - () - in - ( - match version_comparator with - | Some ver_cmp -> - ignore - (version - var - ver_cmp - (fun _ -> package_version pkg) - ()) - | None -> - () - ); - vl -end - -module BaseOCamlcConfig = struct -(* # 22 "src/base/BaseOCamlcConfig.ml" *) - - - open BaseEnv - open OASISUtils - open OASISGettext - - - module SMap = Map.Make(String) - - - let ocamlc = - BaseCheck.prog_opt "ocamlc" - - - let ocamlc_config_map = - (* Map name to value for ocamlc -config output - (name ^": "^value) - *) - let rec split_field mp lst = - match lst with - | line :: tl -> - let mp = - try - let pos_semicolon = - String.index line ':' - in - if pos_semicolon > 1 then - ( - let name = - String.sub line 0 pos_semicolon - in - let linelen = - String.length line - in - let value = - if linelen > pos_semicolon + 2 then - String.sub - line - (pos_semicolon + 2) - (linelen - pos_semicolon - 2) - else - "" - in - SMap.add name value mp - ) - else - ( - mp - ) - with Not_found -> - ( - mp - ) - in - split_field mp tl - | [] -> - mp - in - - let cache = - lazy - (var_protect - (Marshal.to_string - (split_field - SMap.empty - (OASISExec.run_read_output - ~ctxt:!BaseContext.default - (ocamlc ()) ["-config"])) - [])) - in - var_redefine - "ocamlc_config_map" - ~hide:true - ~dump:false - (fun () -> - (* TODO: update if ocamlc change !!! *) - Lazy.force cache) - - - let var_define nm = - (* Extract data from ocamlc -config *) - let avlbl_config_get () = - Marshal.from_string - (ocamlc_config_map ()) - 0 - in - let chop_version_suffix s = - try - String.sub s 0 (String.index s '+') - with _ -> - s - in - - let nm_config, value_config = - match nm with - | "ocaml_version" -> - "version", chop_version_suffix - | _ -> nm, (fun x -> x) - in - var_redefine - nm - (fun () -> - try - let map = - avlbl_config_get () - in - let value = - SMap.find nm_config map - in - value_config value - with Not_found -> - failwithf - (f_ "Cannot find field '%s' in '%s -config' output") - nm - (ocamlc ())) - -end - -module BaseStandardVar = struct -(* # 22 "src/base/BaseStandardVar.ml" *) - - - open OASISGettext - open OASISTypes - open OASISExpr - open BaseCheck - open BaseEnv - - - let ocamlfind = BaseCheck.ocamlfind - let ocamlc = BaseOCamlcConfig.ocamlc - let ocamlopt = prog_opt "ocamlopt" - let ocamlbuild = prog "ocamlbuild" - - - (**/**) - let rpkg = - ref None - - - let pkg_get () = - match !rpkg with - | Some pkg -> pkg - | None -> failwith (s_ "OASIS Package is not set") - - - let var_cond = ref [] - - - let var_define_cond ~since_version f dflt = - let holder = ref (fun () -> dflt) in - let since_version = - OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) - in - var_cond := - (fun ver -> - if OASISVersion.comparator_apply ver since_version then - holder := f ()) :: !var_cond; - fun () -> !holder () - - - (**/**) - - - let pkg_name = - var_define - ~short_desc:(fun () -> s_ "Package name") - "pkg_name" - (fun () -> (pkg_get ()).name) - - - let pkg_version = - var_define - ~short_desc:(fun () -> s_ "Package version") - "pkg_version" - (fun () -> - (OASISVersion.string_of_version (pkg_get ()).version)) - - - let c = BaseOCamlcConfig.var_define - - - let os_type = c "os_type" - let system = c "system" - let architecture = c "architecture" - let ccomp_type = c "ccomp_type" - let ocaml_version = c "ocaml_version" - - - (* TODO: Check standard variable presence at runtime *) - - - let standard_library_default = c "standard_library_default" - let standard_library = c "standard_library" - let standard_runtime = c "standard_runtime" - let bytecomp_c_compiler = c "bytecomp_c_compiler" - let native_c_compiler = c "native_c_compiler" - let model = c "model" - let ext_obj = c "ext_obj" - let ext_asm = c "ext_asm" - let ext_lib = c "ext_lib" - let ext_dll = c "ext_dll" - let default_executable_name = c "default_executable_name" - let systhread_supported = c "systhread_supported" - - - let flexlink = - BaseCheck.prog "flexlink" - - - let flexdll_version = - var_define - ~short_desc:(fun () -> "FlexDLL version (Win32)") - "flexdll_version" - (fun () -> - let lst = - OASISExec.run_read_output ~ctxt:!BaseContext.default - (flexlink ()) ["-help"] - in - match lst with - | line :: _ -> - Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) - | [] -> - raise Not_found) - - - (**/**) - let p name hlp dflt = - var_define - ~short_desc:hlp - ~cli:CLIAuto - ~arg_help:"dir" - name - dflt - - - let (/) a b = - if os_type () = Sys.os_type then - Filename.concat a b - else if os_type () = "Unix" then - OASISUnixPath.concat a b - else - OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") - (os_type ()) - (**/**) - - - let prefix = - p "prefix" - (fun () -> s_ "Install architecture-independent files dir") - (fun () -> - match os_type () with - | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) - | _ -> - "/usr/local") - - - let exec_prefix = - p "exec_prefix" - (fun () -> s_ "Install architecture-dependent files in dir") - (fun () -> "$prefix") - - - let bindir = - p "bindir" - (fun () -> s_ "User executables") - (fun () -> "$exec_prefix"/"bin") - - - let sbindir = - p "sbindir" - (fun () -> s_ "System admin executables") - (fun () -> "$exec_prefix"/"sbin") - - - let libexecdir = - p "libexecdir" - (fun () -> s_ "Program executables") - (fun () -> "$exec_prefix"/"libexec") - - - let sysconfdir = - p "sysconfdir" - (fun () -> s_ "Read-only single-machine data") - (fun () -> "$prefix"/"etc") - - - let sharedstatedir = - p "sharedstatedir" - (fun () -> s_ "Modifiable architecture-independent data") - (fun () -> "$prefix"/"com") - - - let localstatedir = - p "localstatedir" - (fun () -> s_ "Modifiable single-machine data") - (fun () -> "$prefix"/"var") - - - let libdir = - p "libdir" - (fun () -> s_ "Object code libraries") - (fun () -> "$exec_prefix"/"lib") - - - let datarootdir = - p "datarootdir" - (fun () -> s_ "Read-only arch-independent data root") - (fun () -> "$prefix"/"share") - - - let datadir = - p "datadir" - (fun () -> s_ "Read-only architecture-independent data") - (fun () -> "$datarootdir") - - - let infodir = - p "infodir" - (fun () -> s_ "Info documentation") - (fun () -> "$datarootdir"/"info") - - - let localedir = - p "localedir" - (fun () -> s_ "Locale-dependent data") - (fun () -> "$datarootdir"/"locale") - - - let mandir = - p "mandir" - (fun () -> s_ "Man documentation") - (fun () -> "$datarootdir"/"man") - - - let docdir = - p "docdir" - (fun () -> s_ "Documentation root") - (fun () -> "$datarootdir"/"doc"/"$pkg_name") - - - let htmldir = - p "htmldir" - (fun () -> s_ "HTML documentation") - (fun () -> "$docdir") - - - let dvidir = - p "dvidir" - (fun () -> s_ "DVI documentation") - (fun () -> "$docdir") - - - let pdfdir = - p "pdfdir" - (fun () -> s_ "PDF documentation") - (fun () -> "$docdir") - - - let psdir = - p "psdir" - (fun () -> s_ "PS documentation") - (fun () -> "$docdir") - - - let destdir = - p "destdir" - (fun () -> s_ "Prepend a path when installing package") - (fun () -> - raise - (PropList.Not_set - ("destdir", - Some (s_ "undefined by construct")))) - - - let findlib_version = - var_define - "findlib_version" - (fun () -> - BaseCheck.package_version "findlib") - - - let is_native = - var_define - "is_native" - (fun () -> - try - let _s: string = - ocamlopt () - in - "true" - with PropList.Not_set _ -> - let _s: string = - ocamlc () - in - "false") - - - let ext_program = - var_define - "suffix_program" - (fun () -> - match os_type () with - | "Win32" | "Cygwin" -> ".exe" - | _ -> "") - - - let rm = - var_define - ~short_desc:(fun () -> s_ "Remove a file.") - "rm" - (fun () -> - match os_type () with - | "Win32" -> "del" - | _ -> "rm -f") - - - let rmdir = - var_define - ~short_desc:(fun () -> s_ "Remove a directory.") - "rmdir" - (fun () -> - match os_type () with - | "Win32" -> "rd" - | _ -> "rm -rf") - - - let debug = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") - ~cli:CLIEnable - "debug" - (fun () -> "true") - - - let profile = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") - ~cli:CLIEnable - "profile" - (fun () -> "false") - - - let tests = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> - s_ "Compile tests executable and library and run them") - ~cli:CLIEnable - "tests" - (fun () -> "false")) - "true" - - - let docs = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> s_ "Create documentations") - ~cli:CLIEnable - "docs" - (fun () -> "true")) - "true" - - - let native_dynlink = - var_define - ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") - ~cli:CLINone - "native_dynlink" - (fun () -> - let res = - let ocaml_lt_312 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "3.12.0")) - in - let flexdll_lt_030 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (flexdll_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "0.30")) - in - let has_native_dynlink = - let ocamlfind = ocamlfind () in - try - let fn = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ocamlfind - ["query"; "-predicates"; "native"; "dynlink"; - "-format"; "%d/%a"] - in - Sys.file_exists fn - with _ -> - false - in - if not has_native_dynlink then - false - else if ocaml_lt_312 () then - false - else if (os_type () = "Win32" || os_type () = "Cygwin") - && flexdll_lt_030 () then - begin - BaseMessage.warning - (f_ ".cmxs generation disabled because FlexDLL needs to be \ - at least 0.30. Please upgrade FlexDLL from %s to 0.30.") - (flexdll_version ()); - false - end - else - true - in - string_of_bool res) - - - let init pkg = - rpkg := Some pkg; - List.iter (fun f -> f pkg.oasis_version) !var_cond - -end - -module BaseFileAB = struct -(* # 22 "src/base/BaseFileAB.ml" *) - - - open BaseEnv - open OASISGettext - open BaseMessage - - - let to_filename fn = - let fn = - OASISHostPath.of_unix fn - in - if not (Filename.check_suffix fn ".ab") then - warning - (f_ "File '%s' doesn't have '.ab' extension") - fn; - Filename.chop_extension fn - - - let replace fn_lst = - let buff = - Buffer.create 13 - in - List.iter - (fun fn -> - let fn = - OASISHostPath.of_unix fn - in - let chn_in = - open_in fn - in - let chn_out = - open_out (to_filename fn) - in - ( - try - while true do - Buffer.add_string buff (var_expand (input_line chn_in)); - Buffer.add_char buff '\n' - done - with End_of_file -> - () - ); - Buffer.output_buffer chn_out buff; - Buffer.clear buff; - close_in chn_in; - close_out chn_out) - fn_lst -end - -module BaseLog = struct -(* # 22 "src/base/BaseLog.ml" *) - - - open OASISUtils - - - let default_filename = - Filename.concat - (Filename.dirname BaseEnv.default_filename) - "setup.log" - - - module SetTupleString = - Set.Make - (struct - type t = string * string - let compare (s11, s12) (s21, s22) = - match String.compare s11 s21 with - | 0 -> String.compare s12 s22 - | n -> n - end) - - - let load () = - if Sys.file_exists default_filename then - begin - let chn = - open_in default_filename - in - let scbuf = - Scanf.Scanning.from_file default_filename - in - let rec read_aux (st, lst) = - if not (Scanf.Scanning.end_of_input scbuf) then - begin - let acc = - try - Scanf.bscanf scbuf "%S %S\n" - (fun e d -> - let t = - e, d - in - if SetTupleString.mem t st then - st, lst - else - SetTupleString.add t st, - t :: lst) - with Scanf.Scan_failure _ -> - failwith - (Scanf.bscanf scbuf - "%l" - (fun line -> - Printf.sprintf - "Malformed log file '%s' at line %d" - default_filename - line)) - in - read_aux acc - end - else - begin - close_in chn; - List.rev lst - end - in - read_aux (SetTupleString.empty, []) - end - else - begin - [] - end - - - let register event data = - let chn_out = - open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename - in - Printf.fprintf chn_out "%S %S\n" event data; - close_out chn_out - - - let unregister event data = - if Sys.file_exists default_filename then - begin - let lst = - load () - in - let chn_out = - open_out default_filename - in - let write_something = - ref false - in - List.iter - (fun (e, d) -> - if e <> event || d <> data then - begin - write_something := true; - Printf.fprintf chn_out "%S %S\n" e d - end) - lst; - close_out chn_out; - if not !write_something then - Sys.remove default_filename - end - - - let filter events = - let st_events = - List.fold_left - (fun st e -> - SetString.add e st) - SetString.empty - events - in - List.filter - (fun (e, _) -> SetString.mem e st_events) - (load ()) - - - let exists event data = - List.exists - (fun v -> (event, data) = v) - (load ()) -end - -module BaseBuilt = struct -(* # 22 "src/base/BaseBuilt.ml" *) - - - open OASISTypes - open OASISGettext - open BaseStandardVar - open BaseMessage - - - type t = - | BExec (* Executable *) - | BExecLib (* Library coming with executable *) - | BLib (* Library *) - | BObj (* Library *) - | BDoc (* Document *) - - - let to_log_event_file t nm = - "built_"^ - (match t with - | BExec -> "exec" - | BExecLib -> "exec_lib" - | BLib -> "lib" - | BObj -> "obj" - | BDoc -> "doc")^ - "_"^nm - - - let to_log_event_done t nm = - "is_"^(to_log_event_file t nm) - - - let register t nm lst = - BaseLog.register - (to_log_event_done t nm) - "true"; - List.iter - (fun alt -> - let registered = - List.fold_left - (fun registered fn -> - if OASISFileUtil.file_exists_case fn then - begin - BaseLog.register - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end - else - registered) - false - alt - in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) - lst - - - let unregister t nm = - List.iter - (fun (e, d) -> - BaseLog.unregister e d) - (BaseLog.filter - [to_log_event_file t nm; - to_log_event_done t nm]) - - - let fold t nm f acc = - List.fold_left - (fun acc (_, fn) -> - if OASISFileUtil.file_exists_case fn then - begin - f acc fn - end - else - begin - warning - (f_ "File '%s' has been marked as built \ - for %s but doesn't exist") - fn - (Printf.sprintf - (match t with - | BExec | BExecLib -> - (f_ "executable %s") - | BLib -> - (f_ "library %s") - | BObj -> - (f_ "object %s") - | BDoc -> - (f_ "documentation %s")) - nm); - acc - end) - acc - (BaseLog.filter - [to_log_event_file t nm]) - - - let is_built t nm = - List.fold_left - (fun is_built (_, d) -> - (try - bool_of_string d - with _ -> - false)) - false - (BaseLog.filter - [to_log_event_done t nm]) - - - let of_executable ffn (cs, bs, exec) = - let unix_exec_is, unix_dll_opt = - OASISExecutable.unix_exec_is - (cs, bs, exec) - (fun () -> - bool_of_string - (is_native ())) - ext_dll - ext_program - in - let evs = - (BExec, cs.cs_name, [[ffn unix_exec_is]]) - :: - (match unix_dll_opt with - | Some fn -> - [BExecLib, cs.cs_name, [[ffn fn]]] - | None -> - []) - in - evs, - unix_exec_is, - unix_dll_opt - - - let of_library ffn (cs, bs, lib) = - let unix_lst = - OASISLibrary.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - ~has_native_dynlink:(bool_of_string (native_dynlink ())) - ~ext_lib:(ext_lib ()) - ~ext_dll:(ext_dll ()) - (cs, bs, lib) - in - let evs = - [BLib, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - - - let of_object ffn (cs, bs, obj) = - let unix_lst = - OASISObject.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - (cs, bs, obj) - in - let evs = - [BObj, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - -end - -module BaseCustom = struct -(* # 22 "src/base/BaseCustom.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let run cmd args extra_args = - OASISExec.run ~ctxt:!BaseContext.default ~quote:false - (var_expand cmd) - (List.map - var_expand - (args @ (Array.to_list extra_args))) - - - let hook ?(failsafe=false) cstm f e = - let optional_command lst = - let printer = - function - | Some (cmd, args) -> String.concat " " (cmd :: args) - | None -> s_ "No command" - in - match - var_choose - ~name:(s_ "Pre/Post Command") - ~printer - lst with - | Some (cmd, args) -> - begin - try - run cmd args [||] - with e when failsafe -> - warning - (f_ "Command '%s' fail with error: %s") - (String.concat " " (cmd :: args)) - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - end - | None -> - () - in - let res = - optional_command cstm.pre_command; - f e - in - optional_command cstm.post_command; - res -end - -module BaseDynVar = struct -(* # 22 "src/base/BaseDynVar.ml" *) - - - open OASISTypes - open OASISGettext - open BaseEnv - open BaseBuilt - - - let init pkg = - (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) - (* TODO: provide compile option for library libary_byte_args_VARNAME... *) - List.iter - (function - | Executable (cs, bs, exec) -> - if var_choose bs.bs_build then - var_ignore - (var_redefine - (* We don't save this variable *) - ~dump:false - ~short_desc:(fun () -> - Printf.sprintf - (f_ "Filename of executable '%s'") - cs.cs_name) - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - let fn_opt = - fold - BExec cs.cs_name - (fun _ fn -> Some fn) - None - in - match fn_opt with - | Some fn -> fn - | None -> - raise - (PropList.Not_set - (cs.cs_name, - Some (Printf.sprintf - (f_ "Executable '%s' not yet built.") - cs.cs_name))))) - - | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> - ()) - pkg.sections -end - -module BaseTest = struct -(* # 22 "src/base/BaseTest.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISExpr - open OASISGettext - - - let test lst pkg extra_args = - - let one_test (failure, n) (test_plugin, cs, test) = - if var_choose - ~name:(Printf.sprintf - (f_ "test %s run") - cs.cs_name) - ~printer:string_of_bool - test.test_run then - begin - let () = - info (f_ "Running test '%s'") cs.cs_name - in - let back_cwd = - match test.test_working_directory with - | Some dir -> - let cwd = - Sys.getcwd () - in - let chdir d = - info (f_ "Changing directory to '%s'") d; - Sys.chdir d - in - chdir dir; - fun () -> chdir cwd - - | None -> - fun () -> () - in - try - let failure_percent = - BaseCustom.hook - test.test_custom - (test_plugin pkg (cs, test)) - extra_args - in - back_cwd (); - (failure_percent +. failure, n + 1) - with e -> - begin - back_cwd (); - raise e - end - end - else - begin - info (f_ "Skipping test '%s'") cs.cs_name; - (failure, n) - end - in - let failed, n = - List.fold_left - one_test - (0.0, 0) - lst - in - let failure_percent = - if n = 0 then - 0.0 - else - failed /. (float_of_int n) - in - let msg = - Printf.sprintf - (f_ "Tests had a %.2f%% failure rate") - (100. *. failure_percent) - in - if failure_percent > 0.0 then - failwith msg - else - info "%s" msg; - - (* Possible explanation why the tests where not run. *) - if OASISFeatures.package_test OASISFeatures.flag_tests pkg && - not (bool_of_string (BaseStandardVar.tests ())) && - lst <> [] then - BaseMessage.warning - "Tests are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-tests'" -end - -module BaseDoc = struct -(* # 22 "src/base/BaseDoc.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let doc lst pkg extra_args = - - let one_doc (doc_plugin, cs, doc) = - if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") - cs.cs_name) - ~printer:string_of_bool - doc.doc_build then - begin - info (f_ "Building documentation '%s'") cs.cs_name; - BaseCustom.hook - doc.doc_custom - (doc_plugin pkg (cs, doc)) - extra_args - end - in - List.iter one_doc lst; - - if OASISFeatures.package_test OASISFeatures.flag_docs pkg && - not (bool_of_string (BaseStandardVar.docs ())) && - lst <> [] then - BaseMessage.warning - "Docs are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-docs'" -end - -module BaseSetup = struct -(* # 22 "src/base/BaseSetup.ml" *) - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISSection - open OASISGettext - open OASISUtils - - - type std_args_fun = - package -> string array -> unit - - - type ('a, 'b) section_args_fun = - name * (package -> (common_section * 'a) -> string array -> 'b) - - - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } - - - (* Associate a plugin function with data from package *) - let join_plugin_sections filter_map lst = - List.rev - (List.fold_left - (fun acc sct -> - match filter_map sct with - | Some e -> - e :: acc - | None -> - acc) - [] - lst) - - - (* Search for plugin data associated with a section name *) - let lookup_plugin_section plugin action nm lst = - try - List.assoc nm lst - with Not_found -> - failwithf - (f_ "Cannot find plugin %s matching section %s for %s action") - plugin - nm - action - - - let configure t args = - (* Run configure *) - BaseCustom.hook - t.package.conf_custom - (fun () -> - (* Reload if preconf has changed it *) - begin - try - unload (); - load (); - with _ -> - () - end; - - (* Run plugin's configure *) - t.configure t.package args; - - (* Dump to allow postconf to change it *) - dump ()) - (); - - (* Reload environment *) - unload (); - load (); - - (* Save environment *) - print (); - - (* Replace data in file *) - BaseFileAB.replace t.package.files_ab - - - let build t args = - BaseCustom.hook - t.package.build_custom - (t.build t.package) - args - - - let doc t args = - BaseDoc.doc - (join_plugin_sections - (function - | Doc (cs, e) -> - Some - (lookup_plugin_section - "documentation" - (s_ "build") - cs.cs_name - t.doc, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let test t args = - BaseTest.test - (join_plugin_sections - (function - | Test (cs, e) -> - Some - (lookup_plugin_section - "test" - (s_ "run") - cs.cs_name - t.test, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let all t args = - let rno_doc = - ref false - in - let rno_test = - ref false - in - let arg_rest = - ref [] - in - Arg.parse_argv - ~current:(ref 0) - (Array.of_list - ((Sys.executable_name^" all") :: - (Array.to_list args))) - [ - "-no-doc", - Arg.Set rno_doc, - s_ "Don't run doc target"; - - "-no-test", - Arg.Set rno_test, - s_ "Don't run test target"; - - "--", - Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), - s_ "All arguments for configure."; - ] - (failwithf (f_ "Don't know what to do with '%s'")) - ""; - - info "Running configure step"; - configure t (Array.of_list (List.rev !arg_rest)); - - info "Running build step"; - build t [||]; - - (* Load setup.log dynamic variables *) - BaseDynVar.init t.package; - - if not !rno_doc then - begin - info "Running doc step"; - doc t [||]; - end - else - begin - info "Skipping doc step" - end; - - if not !rno_test then - begin - info "Running test step"; - test t [||] - end - else - begin - info "Skipping test step" - end - - - let install t args = - BaseCustom.hook - t.package.install_custom - (t.install t.package) - args - - - let uninstall t args = - BaseCustom.hook - t.package.uninstall_custom - (t.uninstall t.package) - args - - - let reinstall t args = - uninstall t args; - install t args - - - let clean, distclean = - let failsafe f a = - try - f a - with e -> - warning - (f_ "Action fail with error: %s") - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - in - - let generic_clean t cstm mains docs tests args = - BaseCustom.hook - ~failsafe:true - cstm - (fun () -> - (* Clean section *) - List.iter - (function - | Test (cs, test) -> - let f = - try - List.assoc cs.cs_name tests - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, test)) - args - | Doc (cs, doc) -> - let f = - try - List.assoc cs.cs_name docs - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, doc)) - args - | Library _ - | Object _ - | Executable _ - | Flag _ - | SrcRepo _ -> - ()) - t.package.sections; - (* Clean whole package *) - List.iter - (fun f -> - failsafe - (f t.package) - args) - mains) - () - in - - let clean t args = - generic_clean - t - t.package.clean_custom - t.clean - t.clean_doc - t.clean_test - args - in - - let distclean t args = - (* Call clean *) - clean t args; - - (* Call distclean code *) - generic_clean - t - t.package.distclean_custom - t.distclean - t.distclean_doc - t.distclean_test - args; - - (* Remove generated file *) - List.iter - (fun fn -> - if Sys.file_exists fn then - begin - info (f_ "Remove '%s'") fn; - Sys.remove fn - end) - (BaseEnv.default_filename - :: - BaseLog.default_filename - :: - (List.rev_map BaseFileAB.to_filename t.package.files_ab)) - in - - clean, distclean - - - let version t _ = - print_endline t.oasis_version - - - let update_setup_ml, no_update_setup_ml_cli = - let b = ref true in - b, - ("-no-update-setup-ml", - Arg.Clear b, - s_ " Don't try to update setup.ml, even if _oasis has changed.") - - - let default_oasis_fn = "_oasis" - - - let update_setup_ml t = - let oasis_fn = - match t.oasis_fn with - | Some fn -> fn - | None -> default_oasis_fn - in - let oasis_exec = - match t.oasis_exec with - | Some fn -> fn - | None -> "oasis" - in - let ocaml = - Sys.executable_name - in - let setup_ml, args = - match Array.to_list Sys.argv with - | setup_ml :: args -> - setup_ml, args - | [] -> - failwith - (s_ "Expecting non-empty command line arguments.") - in - let ocaml, setup_ml = - if Sys.executable_name = Sys.argv.(0) then - (* We are not running in standard mode, probably the script - * is precompiled. - *) - "ocaml", "setup.ml" - else - ocaml, setup_ml - in - let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in - let do_update () = - let oasis_exec_version = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | 1 -> - failwithf - (f_ "Executable '%s' is probably an old version \ - of oasis (< 0.3.0), please update to version \ - v%s.") - oasis_exec t.oasis_version - | 127 -> - failwithf - (f_ "Cannot find executable '%s', please install \ - oasis v%s.") - oasis_exec t.oasis_version - | n -> - failwithf - (f_ "Command '%s version' exited with code %d.") - oasis_exec n) - oasis_exec ["version"] - in - if OASISVersion.comparator_apply - (OASISVersion.version_of_string oasis_exec_version) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string t.oasis_version)) then - begin - (* We have a version >= for the executable oasis, proceed with - * update. - *) - (* TODO: delegate this check to 'oasis setup'. *) - if Sys.os_type = "Win32" then - failwithf - (f_ "It is not possible to update the running script \ - setup.ml on Windows. Please update setup.ml by \ - running '%s'.") - (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) - else - begin - OASISExec.run - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | n -> - failwithf - (f_ "Unable to update setup.ml using '%s', \ - please fix the problem and retry.") - oasis_exec) - oasis_exec ("setup" :: t.oasis_setup_args); - OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) - end - end - else - failwithf - (f_ "The version of '%s' (v%s) doesn't match the version of \ - oasis used to generate the %s file. Please install at \ - least oasis v%s.") - oasis_exec oasis_exec_version setup_ml t.oasis_version - in - - if !update_setup_ml then - begin - try - match t.oasis_digest with - | Some dgst -> - if Sys.file_exists oasis_fn && - dgst <> Digest.file default_oasis_fn then - begin - do_update (); - true - end - else - false - | None -> - false - with e -> - error - (f_ "Error when updating setup.ml. If you want to avoid this error, \ - you can bypass the update of %s by running '%s %s %s %s'") - setup_ml ocaml setup_ml no_update_setup_ml_cli - (String.concat " " args); - raise e - end - else - false - - - let setup t = - let catch_exn = - ref true - in - try - let act_ref = - ref (fun _ -> - failwithf - (f_ "No action defined, run '%s %s -help'") - Sys.executable_name - Sys.argv.(0)) - - in - let extra_args_ref = - ref [] - in - let allow_empty_env_ref = - ref false - in - let arg_handle ?(allow_empty_env=false) act = - Arg.Tuple - [ - Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); - - Arg.Unit - (fun () -> - allow_empty_env_ref := allow_empty_env; - act_ref := act); - ] - in - - Arg.parse - (Arg.align - ([ - "-configure", - arg_handle ~allow_empty_env:true configure, - s_ "[options*] Configure the whole build process."; - - "-build", - arg_handle build, - s_ "[options*] Build executables and libraries."; - - "-doc", - arg_handle doc, - s_ "[options*] Build documents."; - - "-test", - arg_handle test, - s_ "[options*] Run tests."; - - "-all", - arg_handle ~allow_empty_env:true all, - s_ "[options*] Run configure, build, doc and test targets."; - - "-install", - arg_handle install, - s_ "[options*] Install libraries, data, executables \ - and documents."; - - "-uninstall", - arg_handle uninstall, - s_ "[options*] Uninstall libraries, data, executables \ - and documents."; - - "-reinstall", - arg_handle reinstall, - s_ "[options*] Uninstall and install libraries, data, \ - executables and documents."; - - "-clean", - arg_handle ~allow_empty_env:true clean, - s_ "[options*] Clean files generated by a build."; - - "-distclean", - arg_handle ~allow_empty_env:true distclean, - s_ "[options*] Clean files generated by a build and configure."; - - "-version", - arg_handle ~allow_empty_env:true version, - s_ " Display version of OASIS used to generate this setup.ml."; - - "-no-catch-exn", - Arg.Clear catch_exn, - s_ " Don't catch exception, useful for debugging."; - ] - @ - (if t.setup_update then - [no_update_setup_ml_cli] - else - []) - @ (BaseContext.args ()))) - (failwithf (f_ "Don't know what to do with '%s'")) - (s_ "Setup and run build process current package\n"); - - (* Build initial environment *) - load ~allow_empty:!allow_empty_env_ref (); - - (** Initialize flags *) - List.iter - (function - | Flag (cs, {flag_description = hlp; - flag_default = choices}) -> - begin - let apply ?short_desc () = - var_ignore - (var_define - ~cli:CLIEnable - ?short_desc - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - string_of_bool - (var_choose - ~name:(Printf.sprintf - (f_ "default value of flag %s") - cs.cs_name) - ~printer:string_of_bool - choices))) - in - match hlp with - | Some hlp -> - apply ~short_desc:(fun () -> hlp) () - | None -> - apply () - end - | _ -> - ()) - t.package.sections; - - BaseStandardVar.init t.package; - - BaseDynVar.init t.package; - - if t.setup_update && update_setup_ml t then - () - else - !act_ref t (Array.of_list (List.rev !extra_args_ref)) - - with e when !catch_exn -> - error "%s" (Printexc.to_string e); - exit 1 - - -end - - -# 5409 "setup.ml" -module InternalConfigurePlugin = struct -(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) - - - (** Configure using internal scheme - @author Sylvain Le Gall - *) - - - open BaseEnv - open OASISTypes - open OASISUtils - open OASISGettext - open BaseMessage - - - (** Configure build using provided series of check to be done - * and then output corresponding file. - *) - let configure pkg argv = - let var_ignore_eval var = let _s: string = var () in () in - let errors = ref SetString.empty in - let buff = Buffer.create 13 in - - let add_errors fmt = - Printf.kbprintf - (fun b -> - errors := SetString.add (Buffer.contents b) !errors; - Buffer.clear b) - buff - fmt - in - - let warn_exception e = - warning "%s" (Printexc.to_string e) - in - - (* Check tools *) - let check_tools lst = - List.iter - (function - | ExternalTool tool -> - begin - try - var_ignore_eval (BaseCheck.prog tool) - with e -> - warn_exception e; - add_errors (f_ "Cannot find external tool '%s'") tool - end - | InternalExecutable nm1 -> - (* Check that matching tool is built *) - List.iter - (function - | Executable ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal executable \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - lst - in - - let build_checks sct bs = - if var_choose bs.bs_build then - begin - if bs.bs_compiled_object = Native then - begin - try - var_ignore_eval BaseStandardVar.ocamlopt - with e -> - warn_exception e; - add_errors - (f_ "Section %s requires native compilation") - (OASISSection.string_of_section sct) - end; - - (* Check tools *) - check_tools bs.bs_build_tools; - - (* Check depends *) - List.iter - (function - | FindlibPackage (findlib_pkg, version_comparator) -> - begin - try - var_ignore_eval - (BaseCheck.package ?version_comparator findlib_pkg) - with e -> - warn_exception e; - match version_comparator with - | None -> - add_errors - (f_ "Cannot find findlib package %s") - findlib_pkg - | Some ver_cmp -> - add_errors - (f_ "Cannot find findlib package %s (%s)") - findlib_pkg - (OASISVersion.string_of_comparator ver_cmp) - end - | InternalLibrary nm1 -> - (* Check that matching library is built *) - List.iter - (function - | Library ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal library \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - bs.bs_build_depends - end - in - - (* Parse command line *) - BaseArgExt.parse argv (BaseEnv.args ()); - - (* OCaml version *) - begin - match pkg.ocaml_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "ocaml" - ver_cmp - BaseStandardVar.ocaml_version) - with e -> - warn_exception e; - add_errors - (f_ "OCaml version %s doesn't match version constraint %s") - (BaseStandardVar.ocaml_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* Findlib version *) - begin - match pkg.findlib_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "findlib" - ver_cmp - BaseStandardVar.findlib_version) - with e -> - warn_exception e; - add_errors - (f_ "Findlib version %s doesn't match version constraint %s") - (BaseStandardVar.findlib_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - (* Make sure the findlib version is fine for the OCaml compiler. *) - begin - let ocaml_ge4 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) - (OASISVersion.version_of_string "4.0.0") >= 0 in - if ocaml_ge4 then - let findlib_lt132 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) - (OASISVersion.version_of_string "1.3.2") < 0 in - if findlib_lt132 then - add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" - end; - - (* FlexDLL *) - if BaseStandardVar.os_type () = "Win32" || - BaseStandardVar.os_type () = "Cygwin" then - begin - try - var_ignore_eval BaseStandardVar.flexlink - with e -> - warn_exception e; - add_errors (f_ "Cannot find 'flexlink'") - end; - - (* Check build depends *) - List.iter - (function - | Executable (_, bs, _) - | Library (_, bs, _) as sct -> - build_checks sct bs - | Doc (_, doc) -> - if var_choose doc.doc_build then - check_tools doc.doc_build_tools - | Test (_, test) -> - if var_choose test.test_run then - check_tools test.test_tools - | _ -> - ()) - pkg.sections; - - (* Check if we need native dynlink (presence of libraries that compile to - * native) - *) - begin - let has_cmxa = - List.exists - (function - | Library (_, bs, _) -> - var_choose bs.bs_build && - (bs.bs_compiled_object = Native || - (bs.bs_compiled_object = Best && - bool_of_string (BaseStandardVar.is_native ()))) - | _ -> - false) - pkg.sections - in - if has_cmxa then - var_ignore_eval BaseStandardVar.native_dynlink - end; - - (* Check errors *) - if SetString.empty != !errors then - begin - List.iter - (fun e -> error "%s" e) - (SetString.elements !errors); - failwithf - (fn_ - "%d configuration error" - "%d configuration errors" - (SetString.cardinal !errors)) - (SetString.cardinal !errors) - end - - -end - -module InternalInstallPlugin = struct -(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) - - - (** Install using internal scheme - @author Sylvain Le Gall - *) - - - open BaseEnv - open BaseStandardVar - open BaseMessage - open OASISTypes - open OASISFindlib - open OASISGettext - open OASISUtils - - - let exec_hook = - ref (fun (cs, bs, exec) -> cs, bs, exec) - - - let lib_hook = - ref (fun (cs, bs, lib) -> cs, bs, lib, []) - - - let obj_hook = - ref (fun (cs, bs, obj) -> cs, bs, obj, []) - - - let doc_hook = - ref (fun (cs, doc) -> cs, doc) - - - let install_file_ev = - "install-file" - - - let install_dir_ev = - "install-dir" - - - let install_findlib_ev = - "install-findlib" - - - let win32_max_command_line_length = 8000 - - - let split_install_command ocamlfind findlib_name meta files = - if Sys.os_type = "Win32" then - (* Arguments for the first command: *) - let first_args = ["install"; findlib_name; meta] in - (* Arguments for remaining commands: *) - let other_args = ["install"; findlib_name; "-add"] in - (* Extract as much files as possible from [files], [len] is - the current command line length: *) - let rec get_files len acc files = - match files with - | [] -> - (List.rev acc, []) - | file :: rest -> - let len = len + 1 + String.length file in - if len > win32_max_command_line_length then - (List.rev acc, files) - else - get_files len (file :: acc) rest - in - (* Split the command into several commands. *) - let rec split args files = - match files with - | [] -> - [] - | _ -> - (* Length of "ocamlfind install [META|-add]" *) - let len = - List.fold_left - (fun len arg -> - len + 1 (* for the space *) + String.length arg) - (String.length ocamlfind) - args - in - match get_files len [] files with - | ([], _) -> - failwith (s_ "Command line too long.") - | (firsts, others) -> - let cmd = args @ firsts in - (* Use -add for remaining commands: *) - let () = - let findlib_ge_132 = - OASISVersion.comparator_apply - (OASISVersion.version_of_string - (BaseStandardVar.findlib_version ())) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string "1.3.2")) - in - if not findlib_ge_132 then - failwithf - (f_ "Installing the library %s require to use the \ - flag '-add' of ocamlfind because the command \ - line is too long. This flag is only available \ - for findlib 1.3.2. Please upgrade findlib from \ - %s to 1.3.2") - findlib_name (BaseStandardVar.findlib_version ()) - in - let cmds = split other_args others in - cmd :: cmds - in - (* The first command does not use -add: *) - split first_args files - else - ["install" :: findlib_name :: meta :: files] - - - let install pkg argv = - - let in_destdir = - try - let destdir = - destdir () - in - (* Practically speaking destdir is prepended - * at the beginning of the target filename - *) - fun fn -> destdir^fn - with PropList.Not_set _ -> - fun fn -> fn - in - - let install_file ?tgt_fn src_file envdir = - let tgt_dir = - in_destdir (envdir ()) - in - let tgt_file = - Filename.concat - tgt_dir - (match tgt_fn with - | Some fn -> - fn - | None -> - Filename.basename src_file) - in - (* Create target directory if needed *) - OASISFileUtil.mkdir_parent - ~ctxt:!BaseContext.default - (fun dn -> - info (f_ "Creating directory '%s'") dn; - BaseLog.register install_dir_ev dn) - tgt_dir; - - (* Really install files *) - info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; - BaseLog.register install_file_ev tgt_file - in - - (* Install data into defined directory *) - let install_data srcdir lst tgtdir = - let tgtdir = - OASISHostPath.of_unix (var_expand tgtdir) - in - List.iter - (fun (src, tgt_opt) -> - let real_srcs = - OASISFileUtil.glob - ~ctxt:!BaseContext.default - (Filename.concat srcdir src) - in - if real_srcs = [] then - failwithf - (f_ "Wildcard '%s' doesn't match any files") - src; - List.iter - (fun fn -> - install_file - fn - (fun () -> - match tgt_opt with - | Some s -> - OASISHostPath.of_unix (var_expand s) - | None -> - tgtdir)) - real_srcs) - lst - in - - let make_fnames modul sufx = - List.fold_right - begin fun sufx accu -> - (String.capitalize modul ^ sufx) :: - (String.uncapitalize modul ^ sufx) :: - accu - end - sufx - [] - in - - (** Install all libraries *) - let install_libs pkg = - - let files_of_library (f_data, acc) data_lib = - let cs, bs, lib, lib_extra = - !lib_hook data_lib - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then - begin - let acc = - (* Start with acc + lib_extra *) - List.rev_append lib_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - OASISHostPath.of_unix bs.bs_path - in - List.fold_left - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ acc - end - acc - lib.lib_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the library *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - and files_of_object (f_data, acc) data_obj = - let cs, bs, obj, obj_extra = - !obj_hook data_obj - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then - begin - let acc = - (* Start with acc + obj_extra *) - List.rev_append obj_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - OASISHostPath.of_unix bs.bs_path - in - List.fold_left - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ acc - end - acc - obj.obj_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BObj - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the object *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - - in - - (* Install one group of library *) - let install_group_lib grp = - (* Iterate through all group nodes *) - let rec install_group_lib_aux data_and_files grp = - let data_and_files, children = - match grp with - | Container (_, children) -> - data_and_files, children - | Package (_, cs, bs, `Library lib, children) -> - files_of_library data_and_files (cs, bs, lib), children - | Package (_, cs, bs, `Object obj, children) -> - files_of_object data_and_files (cs, bs, obj), children - in - List.fold_left - install_group_lib_aux - data_and_files - children - in - - (* Findlib name of the root library *) - let findlib_name = - findlib_of_group grp - in - - (* Determine root library *) - let root_lib = - root_of_group grp - in - - (* All files to install for this library *) - let f_data, files = - install_group_lib_aux (ignore, []) grp - in - - (* Really install, if there is something to install *) - if files = [] then - begin - warning - (f_ "Nothing to install for findlib library '%s'") - findlib_name - end - else - begin - let meta = - (* Search META file *) - let _, bs, _ = - root_lib - in - let res = - Filename.concat bs.bs_path "META" - in - if not (OASISFileUtil.file_exists_case res) then - failwithf - (f_ "Cannot find file '%s' for findlib library %s") - res - findlib_name; - res - in - let files = - (* Make filename shorter to avoid hitting command max line length - * too early, esp. on Windows. - *) - let remove_prefix p n = - let plen = String.length p in - let nlen = String.length n in - if plen <= nlen && String.sub n 0 plen = p then - begin - let fn_sep = - if Sys.os_type = "Win32" then - '\\' - else - '/' - in - let cutpoint = plen + - (if plen < nlen && n.[plen] = fn_sep then - 1 - else - 0) - in - String.sub n cutpoint (nlen - cutpoint) - end - else - n - in - List.map (remove_prefix (Sys.getcwd ())) files - in - info - (f_ "Installing findlib library '%s'") - findlib_name; - let ocamlfind = ocamlfind () in - let commands = - split_install_command - ocamlfind - findlib_name - meta - files - in - List.iter - (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) - commands; - BaseLog.register install_findlib_ev findlib_name - end; - - (* Install data files *) - f_data (); - - in - - let group_libs, _, _ = - findlib_mapping pkg - in - - (* We install libraries in groups *) - List.iter install_group_lib group_libs - in - - let install_execs pkg = - let install_exec data_exec = - let cs, bs, exec = - !exec_hook data_exec - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then - begin - let exec_libdir () = - Filename.concat - (libdir ()) - pkg.name - in - BaseBuilt.fold - BaseBuilt.BExec - cs.cs_name - (fun () fn -> - install_file - ~tgt_fn:(cs.cs_name ^ ext_program ()) - fn - bindir) - (); - BaseBuilt.fold - BaseBuilt.BExecLib - cs.cs_name - (fun () fn -> - install_file - fn - exec_libdir) - (); - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name) - end - in - List.iter - (function - | Executable (cs, bs, exec)-> - install_exec (cs, bs, exec) - | _ -> - ()) - pkg.sections - in - - let install_docs pkg = - let install_doc data = - let cs, doc = - !doc_hook data - in - if var_choose doc.doc_install && - BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then - begin - let tgt_dir = - OASISHostPath.of_unix (var_expand doc.doc_install_dir) - in - BaseBuilt.fold - BaseBuilt.BDoc - cs.cs_name - (fun () fn -> - install_file - fn - (fun () -> tgt_dir)) - (); - install_data - Filename.current_dir_name - doc.doc_data_files - doc.doc_install_dir - end - in - List.iter - (function - | Doc (cs, doc) -> - install_doc (cs, doc) - | _ -> - ()) - pkg.sections - in - - install_libs pkg; - install_execs pkg; - install_docs pkg - - - (* Uninstall already installed data *) - let uninstall _ argv = - List.iter - (fun (ev, data) -> - if ev = install_file_ev then - begin - if OASISFileUtil.file_exists_case data then - begin - info - (f_ "Removing file '%s'") - data; - Sys.remove data - end - else - begin - warning - (f_ "File '%s' doesn't exist anymore") - data - end - end - else if ev = install_dir_ev then - begin - if Sys.file_exists data && Sys.is_directory data then - begin - if Sys.readdir data = [||] then - begin - info - (f_ "Removing directory '%s'") - data; - OASISFileUtil.rmdir ~ctxt:!BaseContext.default data - end - else - begin - warning - (f_ "Directory '%s' is not empty (%s)") - data - (String.concat - ", " - (Array.to_list - (Sys.readdir data))) - end - end - else - begin - warning - (f_ "Directory '%s' doesn't exist anymore") - data - end - end - else if ev = install_findlib_ev then - begin - info (f_ "Removing findlib library '%s'") data; - OASISExec.run ~ctxt:!BaseContext.default - (ocamlfind ()) ["remove"; data] - end - else - failwithf (f_ "Unknown log event '%s'") ev; - BaseLog.unregister ev data) - (* We process event in reverse order *) - (List.rev - (BaseLog.filter - [install_file_ev; - install_dir_ev; - install_findlib_ev])) - - -end - - -# 6273 "setup.ml" -module OCamlbuildCommon = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) - - - (** Functions common to OCamlbuild build and doc plugin - *) - - - open OASISGettext - open BaseEnv - open BaseStandardVar - open OASISTypes - - - - - type extra_args = string list - - - let ocamlbuild_clean_ev = "ocamlbuild-clean" - - - let ocamlbuildflags = - var_define - ~short_desc:(fun () -> "OCamlbuild additional flags") - "ocamlbuildflags" - (fun () -> "") - - - (** Fix special arguments depending on environment *) - let fix_args args extra_argv = - List.flatten - [ - if (os_type ()) = "Win32" then - [ - "-classic-display"; - "-no-log"; - "-no-links"; - "-install-lib-dir"; - (Filename.concat (standard_library ()) "ocamlbuild") - ] - else - []; - - if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then - [ - "-byte-plugin" - ] - else - []; - args; - - if bool_of_string (debug ()) then - ["-tag"; "debug"] - else - []; - - if bool_of_string (tests ()) then - ["-tag"; "tests"] - else - []; - - if bool_of_string (profile ()) then - ["-tag"; "profile"] - else - []; - - OASISString.nsplit (ocamlbuildflags ()) ' '; - - Array.to_list extra_argv; - ] - - - (** Run 'ocamlbuild -clean' if not already done *) - let run_clean extra_argv = - let extra_cli = - String.concat " " (Array.to_list extra_argv) - in - (* Run if never called with these args *) - if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then - begin - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args ["-clean"] extra_argv); - BaseLog.register ocamlbuild_clean_ev extra_cli; - at_exit - (fun () -> - try - BaseLog.unregister ocamlbuild_clean_ev extra_cli - with _ -> - ()) - end - - - (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild args extra_argv = - (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args args extra_argv); - (* Remove any clean event, we must run it again *) - List.iter - (fun (e, d) -> BaseLog.unregister e d) - (BaseLog.filter [ocamlbuild_clean_ev]) - - - (** Determine real build directory *) - let build_dir extra_argv = - let rec search_args dir = - function - | "-build-dir" :: dir :: tl -> - search_args dir tl - | _ :: tl -> - search_args dir tl - | [] -> - dir - in - search_args "_build" (fix_args [] extra_argv) - - -end - -module OCamlbuildPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) - - - (** Build using ocamlbuild - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OASISUtils - open OASISString - open BaseEnv - open OCamlbuildCommon - open BaseStandardVar - open BaseMessage - - - - - - let cond_targets_hook = - ref (fun lst -> lst) - - - let build extra_args pkg argv = - (* Return the filename in build directory *) - let in_build_dir fn = - Filename.concat - (build_dir argv) - fn - in - - (* Return the unix filename in host build directory *) - let in_build_dir_of_unix fn = - in_build_dir (OASISHostPath.of_unix fn) - in - - let cond_targets = - List.fold_left - (fun acc -> - function - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_library - in_build_dir_of_unix - (cs, bs, lib) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ~what:".cma" fn - || ends_with ~what:".cmxs" fn - || ends_with ~what:".cmxa" fn - || ends_with ~what:(ext_lib ()) fn - || ends_with ~what:(ext_dll ()) fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for library %s") - cs.cs_name - end - - | Object (cs, bs, obj) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_object - in_build_dir_of_unix - (cs, bs, obj) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ".cmo" fn - || ends_with ".cmx" fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for object %s") - cs.cs_name - end - - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, unix_exec_is, unix_dll_opt = - BaseBuilt.of_executable - in_build_dir_of_unix - (cs, bs, exec) - in - - let target ext = - let unix_tgt = - (OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.chop_extension - exec.exec_main_is))^ext - in - let evs = - (* Fix evs, we want to use the unix_tgt, without copying *) - List.map - (function - | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> - BaseBuilt.BExec, nm, - [[in_build_dir_of_unix unix_tgt]] - | ev -> - ev) - evs - in - evs, [unix_tgt] - in - - (* Add executable *) - let acc = - match bs.bs_compiled_object with - | Native -> - (target ".native") :: acc - | Best when bool_of_string (is_native ()) -> - (target ".native") :: acc - | Byte - | Best -> - (target ".byte") :: acc - in - acc - end - - | Library _ | Object _ | Executable _ | Test _ - | SrcRepo _ | Flag _ | Doc _ -> - acc) - [] - (* Keep the pkg.sections ordered *) - (List.rev pkg.sections); - in - - (* Check and register built files *) - let check_and_register (bt, bnm, lst) = - List.iter - (fun fns -> - if not (List.exists OASISFileUtil.file_exists_case fns) then - failwithf - (fn_ - "Expected built file %s doesn't exist." - "None of expected built files %s exists." - (List.length fns)) - (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) - lst; - (BaseBuilt.register bt bnm lst) - in - - (* Run the hook *) - let cond_targets = !cond_targets_hook cond_targets in - - (* Run a list of target... *) - run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; - (* ... and register events *) - List.iter check_and_register (List.flatten (List.map fst cond_targets)) - - - let clean pkg extra_args = - run_clean extra_args; - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - -end - -module OCamlbuildDocPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) - - - (* Create documentation using ocamlbuild .odocl files - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OASISMessage - open OCamlbuildCommon - open BaseStandardVar - - - - - type run_t = - { - extra_args: string list; - run_path: unix_filename; - } - - - let doc_build run pkg (cs, doc) argv = - let index_html = - OASISUnixPath.make - [ - run.run_path; - cs.cs_name^".docdir"; - "index.html"; - ] - in - let tgt_dir = - OASISHostPath.make - [ - build_dir argv; - OASISHostPath.of_unix run.run_path; - cs.cs_name^".docdir"; - ] - in - run_ocamlbuild (index_html :: run.extra_args) argv; - List.iter - (fun glb -> - BaseBuilt.register - BaseBuilt.BDoc - cs.cs_name - [OASISFileUtil.glob ~ctxt:!BaseContext.default - (Filename.concat tgt_dir glb)]) - ["*.html"; "*.css"] - - - let doc_clean run pkg (cs, doc) argv = - run_clean argv; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - - -end - - -# 6651 "setup.ml" -module CustomPlugin = struct -(* # 22 "src/plugins/custom/CustomPlugin.ml" *) - - - (** Generate custom configure/build/doc/test/install system - @author - *) - - - open BaseEnv - open OASISGettext - open OASISTypes - - - - - - type t = - { - cmd_main: command_line conditional; - cmd_clean: (command_line option) conditional; - cmd_distclean: (command_line option) conditional; - } - - - let run = BaseCustom.run - - - let main t _ extra_args = - let cmd, args = - var_choose - ~name:(s_ "main command") - t.cmd_main - in - run cmd args extra_args - - - let clean t pkg extra_args = - match var_choose t.cmd_clean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - - let distclean t pkg extra_args = - match var_choose t.cmd_distclean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - - module Build = - struct - let main t pkg extra_args = - main t pkg extra_args; - List.iter - (fun sct -> - let evs = - match sct with - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, _ = - BaseBuilt.of_library - OASISHostPath.of_unix - (cs, bs, lib) - in - evs - end - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, _, _ = - BaseBuilt.of_executable - OASISHostPath.of_unix - (cs, bs, exec) - in - evs - end - | _ -> - [] - in - List.iter - (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) - evs) - pkg.sections - - let clean t pkg extra_args = - clean t pkg extra_args; - (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild - * considering moving this to BaseSetup? - *) - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - let distclean t pkg extra_args = - distclean t pkg extra_args - end - - - module Test = - struct - let main t pkg (cs, test) extra_args = - try - main t pkg extra_args; - 0.0 - with Failure s -> - BaseMessage.warning - (f_ "Test '%s' fails: %s") - cs.cs_name - s; - 1.0 - - let clean t pkg (cs, test) extra_args = - clean t pkg extra_args - - let distclean t pkg (cs, test) extra_args = - distclean t pkg extra_args - end - - - module Doc = - struct - let main t pkg (cs, _) extra_args = - main t pkg extra_args; - BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] - - let clean t pkg (cs, _) extra_args = - clean t pkg extra_args; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - - let distclean t pkg (cs, _) extra_args = - distclean t pkg extra_args - end - - -end - - -# 6799 "setup.ml" -open OASISTypes;; - -let setup_t = - { - BaseSetup.configure = InternalConfigurePlugin.configure; - build = OCamlbuildPlugin.build []; - test = - [ - ("all", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - doc = - [ - ("gen", - OCamlbuildDocPlugin.doc_build - {OCamlbuildDocPlugin.extra_args = []; run_path = "."}) - ]; - install = InternalInstallPlugin.install; - uninstall = InternalInstallPlugin.uninstall; - clean = [OCamlbuildPlugin.clean]; - clean_test = - [ - ("all", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - clean_doc = - [ - ("gen", - OCamlbuildDocPlugin.doc_clean - {OCamlbuildDocPlugin.extra_args = []; run_path = "."}) - ]; - distclean = []; - distclean_test = - [ - ("all", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - distclean_doc = []; - package = - { - oasis_version = "0.3"; - ocaml_version = None; - findlib_version = None; - alpha_features = []; - beta_features = []; - name = "gen"; - version = "0.2.2"; - license = - OASISLicense.DEP5License - (OASISLicense.DEP5Unit - { - OASISLicense.license = "BSD-3-clause"; - excption = None; - version = OASISLicense.NoVersion - }); - license_file = Some "LICENSE"; - copyrights = []; - maintainers = []; - authors = ["Simon Cruanes"]; - homepage = Some "https://github.com/c-cube/gen"; - synopsis = "Simple, efficient iterators for OCaml"; - description = None; - categories = []; - conf_type = (`Configure, "internal", Some "0.4"); - conf_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - build_type = (`Build, "ocamlbuild", Some "0.4"); - build_custom = - { - pre_command = - [(OASISExpr.EBool true, Some (("make", ["qtest-gen"])))]; - post_command = [(OASISExpr.EBool true, None)] - }; - install_type = (`Install, "internal", Some "0.4"); - install_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - uninstall_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - clean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - distclean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - files_ab = []; - sections = - [ - Flag - ({ - cs_name = "bench"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = Some "build benchmark"; - flag_default = [(OASISExpr.EBool true, false)] - }); - Library - ({ - cs_name = "gen"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "."; - bs_compiled_object = Best; - bs_build_depends = []; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["Gen"; "Gen_intf"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = None; - lib_findlib_containers = [] - }); - Doc - ({ - cs_name = "gen"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "Containers docs"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Executable - ({ - cs_name = "run_tests"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "tests", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "gen"; - FindlibPackage ("oUnit", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "run_tests.ml"}); - Executable - ({ - cs_name = "run_qtest"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "tests", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "qtest/"; - bs_compiled_object = Native; - bs_build_depends = - [ - FindlibPackage ("containers", None); - FindlibPackage ("containers.misc", None); - FindlibPackage ("containers.string", None); - FindlibPackage ("oUnit", None); - FindlibPackage ("QTest2Lib", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "run_qtest.ml"}); - Test - ({ - cs_name = "all"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - test_type = (`Test, "custom", Some "0.4"); - test_command = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); - (OASISExpr.EFlag "tests", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "tests"), - true) - ]; - test_tools = - [ - ExternalTool "ocamlbuild"; - InternalExecutable "run_tests"; - InternalExecutable "run_qtest" - ] - }); - Executable - ({ - cs_name = "bench_persistent"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "bench", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "bench/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "gen"; - FindlibPackage ("benchmark", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "bench_persistent.ml" - }); - SrcRepo - ({ - cs_name = "head"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - src_repo_type = Git; - src_repo_location = "https://github.com/c-cube/gen"; - src_repo_browser = - Some "https://github.com/c-cube/gen/tree/master/src"; - src_repo_module = None; - src_repo_branch = None; - src_repo_tag = None; - src_repo_subdir = None - }) - ]; - plugins = - [(`Extra, "META", Some "0.3"); (`Extra, "DevFiles", Some "0.3")]; - disable_oasis_section = []; - schema_data = PropList.Data.create (); - plugin_data = [] - }; - oasis_fn = Some "_oasis"; - oasis_version = "0.4.5"; - oasis_digest = Some "&R\193\241\164\161\179\006\021\1643N\0163\245K"; - oasis_exec = None; - oasis_setup_args = []; - setup_update = false - };; - -let setup () = BaseSetup.setup setup_t;; - -# 7149 "setup.ml" -(* OASIS_STOP *) -let () = setup ();; diff --git a/gen/tests/run_tests.ml b/gen/tests/run_tests.ml deleted file mode 100644 index 19afd2ed..00000000 --- a/gen/tests/run_tests.ml +++ /dev/null @@ -1,4 +0,0 @@ - -let () = - let _ = OUnit.run_test_tt_main Test_gen.suite in - () diff --git a/gen/tests/test_gen.ml b/gen/tests/test_gen.ml deleted file mode 100644 index fc968ab1..00000000 --- a/gen/tests/test_gen.ml +++ /dev/null @@ -1,146 +0,0 @@ - -open OUnit -open Gen.Infix - -module GR = Gen.Restart - -let pint i = string_of_int i -let pilist l = - let b = Buffer.create 15 in - let fmt = Format.formatter_of_buffer b in - Format.fprintf fmt "%a@?" - (Gen.pp Format.pp_print_int) (Gen.of_list l); - Buffer.contents b -let pi2list l = - let b = Buffer.create 15 in - let fmt = Format.formatter_of_buffer b in - Format.fprintf fmt "%a@?" - (Gen.pp (fun fmt (a,b) -> Format.fprintf fmt "%d,%d" a b)) - (Gen.of_list l); - Buffer.contents b -let pstrlist l = - let b = Buffer.create 15 in - let fmt = Format.formatter_of_buffer b in - Format.fprintf fmt "%a@?" - (Gen.pp Format.pp_print_string) (Gen.of_list l); - Buffer.contents b - -let test_singleton () = - let gen = Gen.singleton 42 in - OUnit.assert_equal (Some 42) (Gen.get gen); - OUnit.assert_equal None (Gen.get gen); - let gen = Gen.singleton 42 in - OUnit.assert_equal 1 (Gen.length gen); - () - -let test_iter () = - let e = GR.(1 -- 10) in - OUnit.assert_equal ~printer:pint 10 (GR.length e); - OUnit.assert_equal [1;2] GR.(to_list (1 -- 2)); - OUnit.assert_equal [1;2;3;4;5] (GR.to_list (GR.take 5 e)); - () - -let test_map () = - let e = 1 -- 10 in - let e' = Gen.map string_of_int e in - OUnit.assert_equal ~printer:pstrlist ["9"; "10"] (Gen.to_list (Gen.drop 8 e')); - () - -let test_append () = - let e = Gen.append (1 -- 5) (6 -- 10) in - OUnit.assert_equal [10;9;8;7;6;5;4;3;2;1] (Gen.to_rev_list e); - () - -let test_flat_map () = - let e = 1 -- 3 in - let e' = e >>= (fun x -> x -- (x+1)) in - OUnit.assert_equal [1;2;2;3;3;4] (Gen.to_list e'); - () - -let test_zip () = - let e = Gen.zip_with (+) (Gen.repeat 1) (4--7) in - OUnit.assert_equal [5;6;7;8] (Gen.to_list e); - () - -let test_filter_map () = - let f x = if x mod 2 = 0 then Some (string_of_int x) else None in - let e = Gen.filter_map f (1 -- 10) in - OUnit.assert_equal ["2"; "4"; "6"; "8"; "10"] (Gen.to_list e); - () - -let test_merge () = - let e = Gen.of_list [1--3; 4--6; 7--9] in - let e' = Gen.merge e in - OUnit.assert_equal [1;2;3;4;5;6;7;8;9] (Gen.to_list e' |> List.sort compare); - () - -let test_persistent () = - let i = ref 0 in - let gen () = - let j = !i in - if j > 5 then None else (incr i; Some j) - in - let e = Gen.persistent gen in - OUnit.assert_equal [0;1;2;3;4;5] (GR.to_list e); - OUnit.assert_equal [0;1;2;3;4;5] (GR.to_list e); - OUnit.assert_equal [0;1;2;3;4;5] (GR.to_list e); - () - -let test_round_robin () = - let e = GR.round_robin ~n:2 GR.(1--10) in - match e with - | [a;b] -> - OUnit.assert_equal [1;3;5;7;9] (Gen.to_list a); - OUnit.assert_equal [2;4;6;8;10] (Gen.to_list b) - | _ -> OUnit.assert_failure "wrong list lenght" - -let test_big_rr () = - let e = GR.round_robin ~n:3 GR.(1 -- 999) in - let l = List.map Gen.length e in - OUnit.assert_equal [333;333;333] l; - () - -let test_merge_sorted () = - [Gen.of_list [1;3;5]; Gen.of_list [0;1;1;3;4;6;10]; Gen.of_list [2;2;11]] - |> Gen.sorted_merge_n ?cmp:None - |> Gen.to_list - |> OUnit.assert_equal ~printer:pilist [0;1;1;1;2;2;3;3;4;5;6;10;11] - -let test_interleave () = - let e1 = Gen.of_list [1;3;5;7;9] in - let e2 = Gen.of_list [2;4;6;8;10] in - let e = Gen.interleave e1 e2 in - OUnit.assert_equal [1;2;3;4;5;6;7;8;9;10] (Gen.to_list e); - () - -let test_intersperse () = - let e = 1 -- 5 in - let e' = Gen.intersperse 0 e in - OUnit.assert_equal [1;0;2;0;3;0;4;0;5] (Gen.to_list e'); - () - -let test_product () = - let printer = pi2list in - let e = Gen.product (1--3) (4--5) in - OUnit.assert_equal ~printer [1,4; 1,5; 2,4; 2,5; 3,4; 3,5] - (List.sort compare (Gen.to_list e)); - () - -let suite = - "test_gen" >::: - [ "test_singleton" >:: test_singleton; - "test_iter" >:: test_iter; - "test_map" >:: test_map; - "test_append" >:: test_append; - "test_flat_map" >:: test_flat_map; - "test_zip" >:: test_zip; - "test_filter_map" >:: test_filter_map; - "test_merge" >:: test_merge; - "test_persistent" >:: test_persistent; - "test_round_robin" >:: test_round_robin; - "test_big_rr" >:: test_big_rr; - "test_merge_sorted" >:: test_merge_sorted; - "test_interleave" >:: test_interleave; - "test_intersperse" >:: test_intersperse; - "test_product" >:: test_product; - ] diff --git a/lwt/behavior.ml b/lwt/behavior.ml deleted file mode 100644 index dbf1e168..00000000 --- a/lwt/behavior.ml +++ /dev/null @@ -1,164 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Behavior Trees for React} *) - -(** {2 Behavior tree} *) - -type tree = - | Test of (unit -> bool) (* call and test value *) - | Wait of (unit -> bool Lwt.t) (* wait for the future to complete *) - | Do of (unit -> bool) (* perform an action *) - | If of (unit -> bool) * tree * tree (* switch *) - | Sequence of bool * tree list (* yield to subtrees sequentially. bool: loop? *) - | Select of select_strategy * tree list (* select one subtree *) - | Parallel of parallel_strategy * tree list (* run all subtrees in parallel *) - | Closure of (unit -> tree) (* build a tree dynamically *) - | Succeed (* always succeed *) - | Fail (* always fail *) - (** A behavior tree *) -and select_strategy = tree list -> (unit -> tree option) - (** How to select a subtree to run. It yields a subtree until it - decides to fail *) -and parallel_strategy = - | PSForall (** succeeds when all subtrees succeed *) - | PSExists (** succeeds when some subtree succeeds *) - -let strategy_inorder l = - let cur = ref l in - fun () -> match !cur with - | [] -> None - | t::l' -> - cur := l'; - Some t - -let strategy_random ?(proba_fail=0.05) l = - let a = Array.of_list l in - fun () -> - if Random.float 1. < proba_fail - then None - else (* choose in array *) - let t = a.(Random.int (Array.length a)) in - Some t - -let succeed = Succeed - -let fail = Fail - -let test f = Test f - -let wait fut = Wait (fun () -> fut) - -let wait_ fut = Wait (fun () -> Lwt.bind fut (fun () -> Lwt.return_true)) - -let wait_closure f = Wait f - -let timeout f = Wait (fun () -> Lwt.bind (Lwt_unix.sleep f) (fun () -> Lwt.return_false)) - -let delay f = Wait (fun () -> Lwt.bind (Lwt_unix.sleep f) (fun () -> Lwt.return_true)) - -let do_ act = Do act - -let do_succeed act = Do (fun () -> act (); true) - -let if_ s then_ else_ = If (s, then_, else_) - -let when_ s t = if_ s t succeed - -let while_ f l = Sequence (true, (test f) :: l) - -let sequence ?(loop=false) l = - assert (l <> []); - Sequence (loop, l) - -let repeat t = sequence ~loop:true [t] - -let select ?(strat=strategy_inorder) l = - assert (l <> []); - Select (strat, l) - -let or_else t1 t2 = - select ~strat:strategy_inorder [t1; t2] - -let parallel ?(strat=PSForall) l = - assert (l <> []); - Parallel (strat, l) - -let closure f = - Closure f - -(** {2 Run a tree} *) - -type result = bool Lwt.t - -let run tree = - let (>>=) = Lwt.(>>=) in - (* run given tree *) - let rec run tree = - match tree with - | Test f -> Lwt.return (f ()) - | Wait f -> f () - | Do act -> if act () then Lwt.return_true else Lwt.return_false - | If (s, then_, else_) -> (* depends on value returned by [s] *) - if s () then run then_ else run else_ - | Sequence (loop, l) -> run_sequence ~loop l - | Select (strat, l) -> run_select ~strat l - | Parallel (strat, l) -> run_parallel ~strat l - | Closure f -> let tree' = f () in run tree' - | Succeed -> Lwt.return_true - | Fail -> Lwt.return_false - and run_sequence ~loop start = - let rec process l = match l with - | [] when loop -> run_sequence ~loop start - | [] -> Lwt.return_true (* success *) - | t::l' -> - let res_t = run t in - res_t >>= fun t_succeeded -> - if t_succeeded - then process l' - else Lwt.return_false - in - process start - and run_select ~strat l = - (* choice function *) - let choose = strat l in - (* try a subtree *) - let rec try_one () = - match choose () with - | None -> Lwt.return_false (* failure *) - | Some t -> - run t >>= fun t_succeeded -> - if t_succeeded - then Lwt.return_true - else try_one () - in - try_one () - and run_parallel ~strat l = - let results = List.map run l in - match strat with - | PSExists -> Lwt_list.exists_p (fun x -> x) results - | PSForall -> Lwt_list.for_all_p (fun x -> x) results - in - run tree diff --git a/lwt/behavior.mli b/lwt/behavior.mli deleted file mode 100644 index 18903df5..00000000 --- a/lwt/behavior.mli +++ /dev/null @@ -1,142 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Behavior Trees for Lwt} *) - -(** Behavior trees are a modular alternative to state machines for controlling - dynamic behavior in time. They are primarily used in video games to - implement non-player AI. - - A tree is composed of basic actions, basic tests, and combinators. During - execution, some subset of the nodes of a tree may be {b running}; at some - point the execution of a given node will terminate with either - {b success} or {b failure}. Depending on the kind of node, this result - may propagate to parent nodes, or set other nodes running. - - For instance, a {i sequence} node runs its subtrees one by one. If a - subtree succeeds, the next one is activated; if it fails, the whole - sequence will fail. - - Here, we build them on top of - {{: http://ocsigen.org/lwt/} Lwt}. - - Documentation source: - {{: http://aigamedev.com/open/article/bt-overview/} aigamedev (and links)} -*) - -(** {2 Behavior tree} *) - -(** A behavior tree *) -type tree = private - | Test of (unit -> bool) (* call and test value *) - | Wait of (unit -> bool Lwt.t) (* wait for the future to complete *) - | Do of (unit -> bool) (* perform an action *) - | If of (unit -> bool) * tree * tree (* switch *) - | Sequence of bool * tree list (* yield to subtrees sequentially. bool: loop? *) - | Select of select_strategy * tree list (* select one subtree *) - | Parallel of parallel_strategy * tree list (* run all subtrees in parallel *) - | Closure of (unit -> tree) (* build a tree dynamically *) - | Succeed (* always succeed *) - | Fail (* always fail *) - -and select_strategy = tree list -> (unit -> tree option) - (** How to select a subtree to run. It may yield a different result each - time it is called. *) - -and parallel_strategy = - | PSForall (** succeeds when all subtrees succeed *) - | PSExists (** succeeds when some subtree succeeds (kill the others) *) - -val strategy_inorder : select_strategy - (** Select subnodes one after the other, then fails *) - -val strategy_random : ?proba_fail:float -> select_strategy - (** Randomly chooses a subtree. May fail at each point with - a probability of [proba_fail]. *) - -val succeed : tree - (** Behavior that always succeeds *) - -val fail : tree - (** Behavior that always fails *) - -val test : (unit -> bool) -> tree - (** Fails or succeeds based on the next occurrence of the event *) - -val wait : bool Lwt.t -> tree - (** Returns the same result as the future *) - -val wait_ : unit Lwt.t -> tree - (** Wait for the future to complete, then succeed *) - -val wait_closure : (unit -> bool Lwt.t) -> tree - -val timeout : float -> tree - (** Fails after the given amount of seconds *) - -val delay : float -> tree - (** Wait for the given amount of seconds, then succeed *) - -val do_ : (unit -> bool) -> tree - (** Perform an action, then succeed iff it returned true *) - -val do_succeed : (unit -> unit) -> tree - (** Perform an action and succeed (unless it raises an exception) *) - -val if_ : (unit -> bool) -> tree -> tree -> tree - (** Conditional choice, based on the current value of the signal *) - -val when_ : (unit -> bool) -> tree -> tree - (** Run the given tree if the signal is true, else succeed *) - -val while_ : (unit -> bool) -> tree list -> tree - (** While the signal is true, run the subtrees *) - -val sequence : ?loop:bool -> tree list -> tree - (** Sequence of sub-trees to run *) - -val repeat : tree -> tree - (** Repeat the same tree indefinitely *) - -val select : ?strat:select_strategy -> tree list -> tree - (** Choice among the subtrees. The strategy defines in which order subtrees - are tried. *) - -val or_else : tree -> tree -> tree - (** Binary choice, favoring the left one *) - -val parallel : ?strat:parallel_strategy -> tree list -> tree - (** Run subtrees in parallel (default strat: PSForall) *) - -val closure : (unit -> tree) -> tree - (** Produce a tree dynamically, at each call. *) - -(** {2 Run a tree} *) - -type result = bool Lwt.t - -val run : tree -> result - (** Run the tree. It returns a {! result}, which wraps - either true (success) or false (failure). *) diff --git a/media/logo.png b/media/logo.png new file mode 100644 index 00000000..df7b3d7f Binary files /dev/null and b/media/logo.png differ diff --git a/myocamlbuild.ml b/myocamlbuild.ml index f5059687..1ac57545 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 533979157febab9fa15b0b406be9633e) *) +(* DO NOT EDIT (digest: e3363561f51c33bc1d07d0c9f2bd631a) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -609,31 +609,52 @@ let package_default = { MyOCamlbuildBase.lib_ocaml = [ - ("containers", ["core"], []); - ("containers_string", ["string"], []); - ("containers_advanced", ["advanced"], []); - ("containers_pervasives", ["pervasives"], []); - ("containers_misc", ["misc"], []); - ("containers_thread", ["threads"], []); - ("containers_lwt", ["lwt"], []); - ("containers_cgi", ["cgi"], []) + ("containers", ["src/core"], []); + ("containers_io", ["src/io"], []); + ("containers_sexp", ["src/sexp"], []); + ("containers_data", ["src/data"], []); + ("containers_iter", ["src/iter"], []); + ("containers_string", ["src/string"], []); + ("containers_advanced", ["src/advanced"], []); + ("containers_bigarray", ["src/bigarray"], []); + ("containers_pervasives", ["src/pervasives"], []); + ("containers_misc", ["src/misc"], []); + ("containers_thread", ["src/threads"], []); + ("containers_lwt", ["src/lwt"], []) ]; lib_c = []; flags = []; includes = [ - ("threads", ["core"]); - ("tests/lwt", ["core"; "lwt"]); - ("tests", ["core"; "misc"; "string"]); - ("qtest", ["core"; "misc"; "string"]); - ("pervasives", ["core"]); - ("misc", ["core"]); - ("lwt", ["core"; "misc"]); - ("examples/cgi", ["cgi"; "core"]); - ("examples", ["core"; "misc"]); - ("cgi", ["core"]); - ("benchs", ["advanced"; "core"; "misc"; "string"]); - ("advanced", ["core"]) + ("tests/lwt", ["src/core"; "src/lwt"]); + ("tests", ["src/core"; "src/data"; "src/misc"; "src/string"]); + ("src/threads", ["src/core"]); + ("src/pervasives", ["src/core"]); + ("src/misc", ["src/core"; "src/data"]); + ("src/lwt", ["src/core"; "src/misc"]); + ("src/bigarray", ["src/core"]); + ("src/advanced", ["src/core"]); + ("qtest", + [ + "src/advanced"; + "src/bigarray"; + "src/core"; + "src/io"; + "src/iter"; + "src/misc"; + "src/sexp"; + "src/string" + ]); + ("examples", ["src/core"; "src/misc"; "src/sexp"]); + ("benchs", + [ + "src/advanced"; + "src/core"; + "src/data"; + "src/iter"; + "src/misc"; + "src/string" + ]) ] } ;; @@ -642,8 +663,11 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 646 "myocamlbuild.ml" +# 667 "myocamlbuild.ml" (* OASIS_STOP *) + +let doc_intro = "doc/intro.txt" ;; + Ocamlbuild_plugin.dispatch dispatch_default;; dispatch @@ -652,17 +676,17 @@ dispatch | After_rules -> (* replace with Ocamlbuild_cppo.dispatch when 4.00 is not supported anymore *) - let dep = "%(name).cppo.ml" in + let dep_cppo = "%(name).cppo.ml" in let prod1 = "%(name: <*> and not <*.cppo>).ml" in let prod2 = "%(name: <**/*> and not <**/*.cppo>).ml" in let f prod env _build = - let dep = env dep in + let dep = env dep_cppo in let prod = env prod in let tags = tags_of_pathname prod ++ "cppo" in Cmd (S[A "cppo"; T tags; S [A "-o"; P prod]; P dep ]) in - rule "cppo1" ~dep ~prod:prod1 (f prod1) ; - rule "cppo2" ~dep ~prod:prod2 (f prod2) ; + rule "cppo1" ~dep:dep_cppo ~prod:prod1 (f prod1) ; + rule "cppo2" ~dep:dep_cppo ~prod:prod2 (f prod2) ; pflag ["cppo"] "cppo_D" (fun s -> S [A "-D"; A s]) ; pflag ["cppo"] "cppo_U" (fun s -> S [A "-U"; A s]) ; pflag ["cppo"] "cppo_I" (fun s -> @@ -683,7 +707,15 @@ dispatch let ocaml_major = "OCAML_MAJOR " ^ string_of_int major in let ocaml_minor = "OCAML_MINOR " ^ string_of_int minor in - flag ["cppo"] & S[A"-D"; A ocaml_major; A"-D"; A ocaml_minor] + flag ["cppo"] & S[A"-D"; A ocaml_major; A"-D"; A ocaml_minor] ; + + (* Documentation index *) + dep ["ocaml"; "doc"; "extension:html"] & [doc_intro] ; + flag ["ocaml"; "doc"; "extension:html"] & + (S[A"-t"; A"Containers doc"; + A"-intro"; P doc_intro; + ]); + | _ -> () end; dispatch_default diff --git a/opam b/opam index 2e55f8ea..e20b12c0 100644 --- a/opam +++ b/opam @@ -3,7 +3,8 @@ author: "Simon Cruanes" maintainer: "simon.cruanes@inria.fr" build: [ ["./configure" "--prefix" prefix "--disable-thread" "--disable-bench" - "--disable-tests" "--disable-cgi" "--%{lwt:enable}%-lwt" + "--disable-tests" "--%{lwt:enable}%-lwt" + "--%{base-bigarray:enable}%-bigarray" "--enable-docs" "--enable-misc"] [make "build"] ] @@ -16,7 +17,10 @@ remove: [ ["ocamlfind" "remove" "containers"] ] post-messages: [ - "in containers, modules start with 'CC' (stands for 'core containers')" + "containers is now split into finer-grained sub-libraries, including + `containers.io`, `containers.iter`, `containers.sexp`, `containers.data`. + CCGen and CCSequence have been removed, consider using the libraries + `gen` and `sequence` on opam." ] depends: [ "ocamlfind" {build} diff --git a/sequence/.gitignore b/sequence/.gitignore deleted file mode 100644 index 96cadb3a..00000000 --- a/sequence/.gitignore +++ /dev/null @@ -1,9 +0,0 @@ -.*.swp -_build -*.native -*.docdir -*.html -man/ -sequence.install -setup.log -setup.data diff --git a/sequence/.merlin b/sequence/.merlin deleted file mode 100644 index d9043276..00000000 --- a/sequence/.merlin +++ /dev/null @@ -1,9 +0,0 @@ -S . -S bench/ -S tests/ -B _build -B _build/tests/ -B _build/bench/ -PKG oUnit -PKG benchmark -FLAG -safe-string diff --git a/sequence/.ocamlinit b/sequence/.ocamlinit deleted file mode 100644 index 7123b8dc..00000000 --- a/sequence/.ocamlinit +++ /dev/null @@ -1,9 +0,0 @@ -#directory "_build";; -#load "sequence.cma";; - -open Sequence.Infix;; - -#directory "_build/bigarray/";; -#load "bigarray.cma";; - -(* vim:syntax=ocaml *) diff --git a/sequence/CHANGELOG.md b/sequence/CHANGELOG.md deleted file mode 100644 index 08c0e5a1..00000000 --- a/sequence/CHANGELOG.md +++ /dev/null @@ -1,65 +0,0 @@ -# Changelog - -## 0.5 - -- conversion with `klist` -- add monadic, choice and applicative infix operators and `>|=` -- add several functions: - * `product2` - * `find`, `mem` - * `doubleton`, `cons`, `snoc` - * `drop_while`, `take_while`... - * `concat_str` -- aliases to existing functions -- use `delimcc` in a new module, `SequenceInvert`, in order to reverse the - control flow (here with conversion to Gen) -- fix examples, tests and doc (about `product`) -- reading benchmark for persistent sequences. -- replace `Bench` with `Benchmark` - -## 0.4.1 - -- `persistent_lazy` -- use bin_annot - -## 0.4 - -- API change for `persistent` -- more efficient implementation for `persistent` -- remove `TypeClass` -- API change for `min`/`max` (in case the sequence is empty) -- conversion with `Gen` -- use Oasis - -## 0.3.7 - -- decreasing int range -- printing functions - -## 0.3.6.1 - -- documentation -- bugfixes - -## 0.3.6 - -- `fmap` -- functors to adapt `Set` and `Map` - -## 0.3.5 - -- tests and benchmarks -- `join` combinator -- optimization for `Sequence.persistent` - -## 0.3.4 - -- `sort`, `uniq`, `group` and `sort_uniq` combinators implemented -- some conversion functions that use `Sequence.t2` -- infix operators in `Sequence.Infix` -- `Sequence.t2` type for efficient iteration on pairs of elements -- some combinators are adapted to `Sequence.t2` -- `zip`, `unzip` and `zip_i` to convert between `t` and `t2` -- added `scan` combinator - -note: git log --no-merges previous_version..HEAD --pretty=%s diff --git a/sequence/LICENSE b/sequence/LICENSE deleted file mode 100644 index 7e29992c..00000000 --- a/sequence/LICENSE +++ /dev/null @@ -1,22 +0,0 @@ -Copyright (c) 2012, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and -the following disclaimer in the documentation and/or other materials -provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/sequence/META b/sequence/META deleted file mode 100644 index e2f9a7da..00000000 --- a/sequence/META +++ /dev/null @@ -1,11 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 1e28d93f3671e8db9acf63b73cdbca82) -version = "0.4.1" -description = "Simple sequence (iterator) datatype and combinators" -archive(byte) = "sequence.cma" -archive(byte, plugin) = "sequence.cma" -archive(native) = "sequence.cmxa" -archive(native, plugin) = "sequence.cmxs" -exists_if = "sequence.cma" -# OASIS_STOP - diff --git a/sequence/Makefile b/sequence/Makefile deleted file mode 100644 index db135eec..00000000 --- a/sequence/Makefile +++ /dev/null @@ -1,67 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) - -SETUP = ocaml setup.ml - -build: setup.data - $(SETUP) -build $(BUILDFLAGS) - -doc: setup.data build - $(SETUP) -doc $(DOCFLAGS) - -test: setup.data build - $(SETUP) -test $(TESTFLAGS) - -all: - $(SETUP) -all $(ALLFLAGS) - -install: setup.data - $(SETUP) -install $(INSTALLFLAGS) - -uninstall: setup.data - $(SETUP) -uninstall $(UNINSTALLFLAGS) - -reinstall: setup.data - $(SETUP) -reinstall $(REINSTALLFLAGS) - -clean: - $(SETUP) -clean $(CLEANFLAGS) - -distclean: - $(SETUP) -distclean $(DISTCLEANFLAGS) - -setup.data: - $(SETUP) -configure $(CONFIGUREFLAGS) - -configure: - $(SETUP) -configure $(CONFIGUREFLAGS) - -.PHONY: build doc test all install uninstall reinstall clean distclean configure - -# OASIS_STOP - -run-tests: - ./run_tests.native - -examples: - ocamlbuild examples/test_sexpr.native - -push_doc: all doc - scp -r sequence.docdir/* cedeela.fr:~/simon/root/software/sequence/ - -push_stable: all - git checkout stable - git merge master -m 'merge from master' - oasis setup - git commit -a -m 'oasis files' - git push origin - git checkout master - -VERSION=$(shell awk '^/Version:/ {print $$2}' _oasis) - -update_next_tag: - @echo "update version to $(VERSION)..." - sed -i "s/NEXT_VERSION/$(VERSION)/g" *.ml *.mli - sed -i "s/NEXT_RELEASE/$(VERSION)/g" *.ml *.mli - -.PHONY: benchs tests examples update_next_tag push_doc push_stable diff --git a/sequence/README.md b/sequence/README.md deleted file mode 100644 index 0ca32192..00000000 --- a/sequence/README.md +++ /dev/null @@ -1,50 +0,0 @@ -Sequence -======== - -Simple sequence abstract datatype, intended to transfer a finite number of -elements from one data structure to another. Some transformations on sequences, -like `filter`, `map`, `take`, `drop` and `append` can be performed before the -sequence is iterated/folded on. - -Sequence is not designed to be as general-purpose or flexible as, say, -Batteries' `Enum.t`. Rather, it aims at providing a very simple and efficient -way of iterating on a finite number of values, only allocating (most of the time) -one intermediate closure to do so. For instance, iterating on keys, or values, -of a `Hashtbl.t`, without creating a list. - -Documentation -============= - -See [the online API](http://cedeela.fr/~simon/software/sequence/Sequence.html). - -Build -===== - -1. via opam `opam install sequence` -2. manually (need OCaml >= 3.12): `make all install` - -If you have `OUnit` installed, you can build and run tests with - - $ make tests - $ ./run_tests.native - -If you have `Bench` installed, you can build and run benchmarks with - - $ make benchs - $ ./benchs.native - -To see how to use the library, check the `examples` directory. -`tests.ml` has a few examples of how to convert basic data structures into -sequences, and conversely. - -Examples -======== - -The module `examples/sexpr.mli` exposes the interface of the S-expression -example library. It requires OCaml>=4.0 to compile, because of the GADT -structure used in the monadic parser combinators part of `examples/sexpr.ml`. - -License -======= - -Sequence is available under the BSD license. diff --git a/sequence/_oasis b/sequence/_oasis deleted file mode 100644 index b84e7253..00000000 --- a/sequence/_oasis +++ /dev/null @@ -1,102 +0,0 @@ -OASISFormat: 0.4 -Name: sequence -Version: dev -Homepage: https://github.com/c-cube/sequence -Authors: Simon Cruanes -License: BSD-2-clause -LicenseFile: LICENSE -Plugins: META (0.3), DevFiles (0.3) -BuildTools: ocamlbuild - -Synopsis: Simple sequence (iterator) datatype and combinators -Description: - Simple sequence datatype, intended to transfer a finite number of - elements from one data structure to another. Some transformations on sequences, - like `filter`, `map`, `take`, `drop` and `append` can be performed before the - sequence is iterated/folded on. - -Flag bench - Description: enable benchmarks (require library Benchmark) - Default: false - -Flag invert - Description: build sequence.invert (requires Delimcc) - Default: false - -Flag bigarray - Description: build sequence.bigarray (requires bigarray) - Default: true - -Library "sequence" - Path: . - Modules: Sequence - BuildDepends: bytes - -Library "invert" - Path: invert - Build$: flag(invert) - Install$: flag(invert) - Modules: SequenceInvert - FindlibName: invert - FindlibParent: sequence - BuildDepends: sequence,delimcc - -Library "bigarray" - Path: bigarray - Build$: flag(bigarray) - Install$: flag(bigarray) - Modules: SequenceBigarray - FindlibName: bigarray - FindlibParent: sequence - BuildDepends: sequence,bigarray - -Document sequence - Title: Sequence docs - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Install: true - XOCamlbuildPath: . - XOCamlbuildLibraries: sequence - -Test all - Type: custom - Command: make run-tests - TestTools: run_tests - Run$: flag(tests) - -Executable run_tests - Path: tests/ - Install: false - CompiledObject: native - MainIs: run_tests.ml - Build$: flag(tests) - BuildDepends: sequence,oUnit - -Executable benchs - Path: bench - Install: false - CompiledObject: native - Build$: flag(bench) - BuildDepends: sequence,benchmark - MainIs: benchs.ml - -Executable bench_persistent - Path: bench - Install: false - CompiledObject: native - Build$: flag(bench) - BuildDepends: sequence,benchmark - MainIs: bench_persistent.ml - -Executable bench_persistent_read - Path: bench - Install: false - CompiledObject: native - Build$: flag(bench) - BuildDepends: sequence,benchmark - MainIs: bench_persistent_read.ml - -SourceRepository head - Type: git - Location: https://github.com/c-cube/sequence - Browser: https://github.com/c-cube/sequence/tree/master/src diff --git a/sequence/_tags b/sequence/_tags deleted file mode 100644 index a9971c20..00000000 --- a/sequence/_tags +++ /dev/null @@ -1,31 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: ffd3fbaf00b431777fea1b8279203bf9) -# Ignore VCS directories, you can use the same kind of rule outside -# OASIS_START/STOP if you want to exclude directories that contains -# useless stuff for the build process -<**/.svn>: -traverse -<**/.svn>: not_hygienic -".bzr": -traverse -".bzr": not_hygienic -".hg": -traverse -".hg": not_hygienic -".git": -traverse -".git": not_hygienic -"_darcs": -traverse -"_darcs": not_hygienic -# Library sequence -"sequence.cmxs": use_sequence -# Executable benchs -"bench/benchs.native": pkg_benchmark -"bench/benchs.native": use_sequence -# Executable bench_persistent -"bench/bench_persistent.native": pkg_benchmark -"bench/bench_persistent.native": use_sequence -# Executable bench_persistent_read -"bench/bench_persistent_read.native": pkg_benchmark -"bench/bench_persistent_read.native": use_sequence -: pkg_benchmark -: use_sequence -# OASIS_STOP -true: bin_annot -<**/*.ml>: warn_A, warn(-4) diff --git a/sequence/bench/bench_persistent.ml b/sequence/bench/bench_persistent.ml deleted file mode 100644 index 022b6b37..00000000 --- a/sequence/bench/bench_persistent.ml +++ /dev/null @@ -1,128 +0,0 @@ -module MList = struct - type 'a t = { - content : 'a array; (* elements of the node *) - mutable len : int; (* number of elements in content *) - mutable tl : 'a t; (* tail *) - } (** A list that contains some elements, and may point to another list *) - - let _empty () : 'a t = Obj.magic 0 - (** Empty list, for the tl field *) - - let make n = - assert (n > 0); - { content = Array.make n (Obj.magic 0); - len = 0; - tl = _empty (); - } - - let rec is_empty l = - l.len = 0 && (l.tl == _empty () || is_empty l.tl) - - let rec iter f l = - for i = 0 to l.len - 1 do f l.content.(i); done; - if l.tl != _empty () then iter f l.tl - - let iteri f l = - let rec iteri i f l = - for j = 0 to l.len - 1 do f (i+j) l.content.(j); done; - if l.tl != _empty () then iteri (i+l.len) f l.tl - in iteri 0 f l - - let rec iter_rev f l = - (if l.tl != _empty () then iter_rev f l.tl); - for i = l.len - 1 downto 0 do f l.content.(i); done - - let length l = - let rec len acc l = - if l.tl == _empty () then acc+l.len else len (acc+l.len) l.tl - in len 0 l - - (** Get element by index *) - let rec get l i = - if i < l.len then l.content.(i) - else if i >= l.len && l.tl == _empty () then raise (Invalid_argument "MList.get") - else get l.tl (i - l.len) - - (** Push [x] at the end of the list. It returns the block in which the - element is inserted. *) - let rec push x l = - if l.len = Array.length l.content - then begin (* insert in the next block *) - (if l.tl == _empty () then - let n = Array.length l.content in - l.tl <- make (n + n lsr 1)); - push x l.tl - end else begin (* insert in l *) - l.content.(l.len) <- x; - l.len <- l.len + 1; - l - end - - (** Reverse list (in place), and returns the new head *) - let rev l = - let rec rev prev l = - (* reverse array *) - for i = 0 to (l.len-1) / 2 do - let x = l.content.(i) in - l.content.(i) <- l.content.(l.len - i - 1); - l.content.(l.len - i - 1) <- x; - done; - (* reverse next block *) - let l' = l.tl in - l.tl <- prev; - if l' == _empty () then l else rev l l' - in - rev (_empty ()) l - - (** Build a MList of elements of the Seq. The optional argument indicates - the size of the blocks *) - let of_seq ?(size=8) seq = - (* read sequence into a MList.t *) - let start = make size in - let l = ref start in - seq (fun x -> l := push x !l); - start - - let to_seq l = - fun k -> iter k l -end - -(** Store content of the seqerator in an enum *) -let persistent_mlist seq = - let l = MList.of_seq seq in - MList.to_seq l - -let bench_mlist n = - for i = 0 to 100 do - let _ = persistent_mlist Sequence.(1 -- n) in - () - done - -let bench_naive n = - for i = 0 to 100 do - let l = Sequence.to_rev_list Sequence.(1 -- n) in - let _ = Sequence.of_list (List.rev l) in - () - done - -let bench_current n = - for i = 0 to 100 do - let _ = Sequence.persistent Sequence.(1 -- n) in - () - done - -let () = - let bench_n n = - Printf.printf "BENCH for %d\n" n; - let res = Benchmark.throughputN 5 - [ "mlist", bench_mlist, n - ; "naive", bench_naive, n - ; "current", bench_current, n - ] - in Benchmark.tabulate res - in - bench_n 100; - bench_n 100_000; - () - -(* vim:Use benchmark: *) diff --git a/sequence/bench/bench_persistent_read.ml b/sequence/bench/bench_persistent_read.ml deleted file mode 100644 index 8e0dea66..00000000 --- a/sequence/bench/bench_persistent_read.ml +++ /dev/null @@ -1,139 +0,0 @@ -module MList = struct - type 'a t = { - content : 'a array; (* elements of the node *) - mutable len : int; (* number of elements in content *) - mutable tl : 'a t; (* tail *) - } (** A list that contains some elements, and may point to another list *) - - let _empty () : 'a t = Obj.magic 0 - (** Empty list, for the tl field *) - - let make n = - assert (n > 0); - { content = Array.make n (Obj.magic 0); - len = 0; - tl = _empty (); - } - - let rec is_empty l = - l.len = 0 && (l.tl == _empty () || is_empty l.tl) - - let rec iter f l = - for i = 0 to l.len - 1 do f l.content.(i); done; - if l.tl != _empty () then iter f l.tl - - let iteri f l = - let rec iteri i f l = - for j = 0 to l.len - 1 do f (i+j) l.content.(j); done; - if l.tl != _empty () then iteri (i+l.len) f l.tl - in iteri 0 f l - - let rec iter_rev f l = - (if l.tl != _empty () then iter_rev f l.tl); - for i = l.len - 1 downto 0 do f l.content.(i); done - - let length l = - let rec len acc l = - if l.tl == _empty () then acc+l.len else len (acc+l.len) l.tl - in len 0 l - - (** Get element by index *) - let rec get l i = - if i < l.len then l.content.(i) - else if i >= l.len && l.tl == _empty () then raise (Invalid_argument "MList.get") - else get l.tl (i - l.len) - - (** Push [x] at the end of the list. It returns the block in which the - element is inserted. *) - let rec push x l = - if l.len = Array.length l.content - then begin (* insert in the next block *) - (if l.tl == _empty () then - let n = Array.length l.content in - l.tl <- make (n + n lsr 1)); - push x l.tl - end else begin (* insert in l *) - l.content.(l.len) <- x; - l.len <- l.len + 1; - l - end - - (** Reverse list (in place), and returns the new head *) - let rev l = - let rec rev prev l = - (* reverse array *) - for i = 0 to (l.len-1) / 2 do - let x = l.content.(i) in - l.content.(i) <- l.content.(l.len - i - 1); - l.content.(l.len - i - 1) <- x; - done; - (* reverse next block *) - let l' = l.tl in - l.tl <- prev; - if l' == _empty () then l else rev l l' - in - rev (_empty ()) l - - (** Build a MList of elements of the Seq. The optional argument indicates - the size of the blocks *) - let of_seq ?(size=8) seq = - (* read sequence into a MList.t *) - let start = make size in - let l = ref start in - seq (fun x -> l := push x !l); - start - - let to_seq l = - fun k -> iter k l -end - -(** Store content of the seqerator in an enum *) -let persistent_mlist seq = - let l = MList.of_seq seq in - MList.to_seq l - -let bench_mlist n = - persistent_mlist Sequence.(1 -- n) - -let bench_list n = - let l = Sequence.to_rev_list Sequence.(1 -- n) in - Sequence.of_list (List.rev l) - -let bench_naive n = - let s = Sequence.(1 -- n) in - Sequence.iter ignore s ; - s - -let bench_current n = - Sequence.persistent Sequence.(1 -- n) - -let bench_array n = - let a = Sequence.to_array Sequence.(1 -- n) in - Sequence.of_array a - -let read s = - Sequence.map (fun x -> x + 1) s - -let () = - let bench_n n = - Printf.printf "BENCH for %d\n" n; - let res = - let mlist = bench_mlist n in - let list = bench_list n in - let current = bench_current n in - let array = bench_current n in - let naive = bench_naive n in - Benchmark.throughputN 5 - [ "mlist", read, mlist - ; "list", read, list - ; "current", read, current - ; "array", read, array - ; "naive", read, naive - ] - in Benchmark.tabulate res - in - bench_n 100; - bench_n 100_000; - () - -(* vim:Use benchmark: *) diff --git a/sequence/bench/benchs.ml b/sequence/bench/benchs.ml deleted file mode 100644 index af8b5db9..00000000 --- a/sequence/bench/benchs.ml +++ /dev/null @@ -1,34 +0,0 @@ - -module S = Sequence -open Sequence.Infix - -let small = [10;20;50;100;500] -let medium = small @ [1000;10_000;100_000] -let big = medium @ [500_000; 1_000_000; 2_000_000] - -let bench_fold n = - 0 -- n |> S.fold (+) 0 |> ignore - -let bench_flatmap n = - 0 -- n |> S.flatMap (fun i -> i -- (i+5)) |> (fun _ -> ()) - -let bench_product n = - S.product (0 -- n) (0 -- n) (fun (i,j) -> ()) - -let _ = - List.iter - (fun (name,bench,sizes) -> - Format.printf "-------------------------------------------------------@."; - Format.printf "bench %s@." name; - List.iter - (fun n -> - let name = name ^ " on " ^ string_of_int n in - let res = Benchmark.throughput1 2 ~name bench n in - Benchmark.tabulate res; - ) sizes - ) - [ "fold", bench_fold, big - ; "flatmap", bench_flatmap, medium - ; "product", bench_product, small - ]; - () diff --git a/sequence/bench/simple_bench.ml b/sequence/bench/simple_bench.ml deleted file mode 100644 index 96611d7b..00000000 --- a/sequence/bench/simple_bench.ml +++ /dev/null @@ -1,11 +0,0 @@ - -open Sequence.Infix - -let _ = - let n = int_of_string Sys.argv.(1) in - let seq = 0 -- n in - let start = Unix.gettimeofday () in - seq |> Sequence.persistent |> Sequence.fold (+) 0 |> ignore; - let stop = Unix.gettimeofday () in - Format.printf "iter on %d: %.4f@." n (stop -. start); - () diff --git a/sequence/bigarray/sequenceBigarray.ml b/sequence/bigarray/sequenceBigarray.ml deleted file mode 100644 index fd61b86b..00000000 --- a/sequence/bigarray/sequenceBigarray.ml +++ /dev/null @@ -1,45 +0,0 @@ -(* -Copyright (c) 2014, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Interface and Helpers for bigarrays} *) - -let of_bigarray b yield = - let len = Bigarray.Array1.dim b in - for i=0 to len-1 do - yield b.{i} - done - -let mmap filename = - fun yield -> - let fd = Unix.openfile filename [Unix.O_RDONLY] 0 in - let len = Unix.lseek fd 0 Unix.SEEK_END in - let _ = Unix.lseek fd 0 Unix.SEEK_SET in - let b = Bigarray.Array1.map_file fd Bigarray.Char Bigarray.C_layout false len in - try - of_bigarray b yield; - Unix.close fd - with e -> - Unix.close fd; - raise e diff --git a/sequence/bigarray/sequenceBigarray.mli b/sequence/bigarray/sequenceBigarray.mli deleted file mode 100644 index a9c78808..00000000 --- a/sequence/bigarray/sequenceBigarray.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* -Copyright (c) 2014, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Interface and Helpers for bigarrays} - -@since 0.5.4 *) - -val of_bigarray : ('a, _, _) Bigarray.Array1.t -> 'a Sequence.t -(** Iterate on the elements of a 1-D array *) - -val mmap : string -> char Sequence.t -(** Map the file into memory, and read the characters. *) diff --git a/sequence/configure b/sequence/configure deleted file mode 100755 index 6acfaeb9..00000000 --- a/sequence/configure +++ /dev/null @@ -1,27 +0,0 @@ -#!/bin/sh - -# OASIS_START -# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) -set -e - -FST=true -for i in "$@"; do - if $FST; then - set -- - FST=false - fi - - case $i in - --*=*) - ARG=${i%%=*} - VAL=${i##*=} - set -- "$@" "$ARG" "$VAL" - ;; - *) - set -- "$@" "$i" - ;; - esac -done - -ocaml setup.ml -configure "$@" -# OASIS_STOP diff --git a/sequence/examples/sexpr.ml b/sequence/examples/sexpr.ml deleted file mode 100644 index 615f468d..00000000 --- a/sequence/examples/sexpr.ml +++ /dev/null @@ -1,305 +0,0 @@ -(* -Zipperposition: a functional superposition prover for prototyping -Copyright (C) 2012 Simon Cruanes - -This is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public License -as published by the Free Software Foundation; either version 2 -of the License, or (at your option) any later version. - -This is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -02110-1301 USA. -*) - -(* {1 Basic S-expressions, with printing and parsing} *) - -(** S-expression *) -type t = - | Atom of string (** An atom *) - | List of t list (** A list of S-expressions *) - -(** Token that compose a Sexpr once serialized *) -type token = [`Open | `Close | `Atom of string] - -(** {2 Traverse a sequence of tokens} *) - -(** Iterate on the S-expression, calling the callback with tokens *) -let rec iter f s = match s with - | Atom a -> f (`Atom a) - | List l -> f `Open; iter_list f l; f `Close -and iter_list f l = match l with - | [] -> () - | x::l' -> iter f x; iter_list f l' - -(** Traverse. This yields a sequence of tokens *) -let traverse s = Sequence.from_iter (fun k -> iter k s) - -(** Returns the same sequence of tokens, but during iteration, if - the structure of the Sexpr corresponding to the sequence - is wrong (bad parenthesing), Invalid_argument is raised - and iteration is stoped *) -let validate seq = - let depth = ref 0 in - Sequence.map - (fun tok -> match tok with - | `Open -> incr depth; tok - | `Close -> if !depth = 0 - then raise (Invalid_argument "wrong parenthesing") - else decr depth; tok - | _ -> tok) - seq - -(** {2 Text <-> tokens} *) - -(** Lex: create a sequence of tokens from the given in_channel. *) -let lex input = - let seq_fun k = - let in_word = ref false in - let buf = Buffer.create 128 in - (* loop. TODO handle escaping of (), and "" *) - let rec next c = - match c with - | '(' -> k `Open - | ')' -> flush_word(); k `Close - | ' ' | '\t' | '\n' -> flush_word () - | c -> in_word := true; Buffer.add_char buf c - (* finish the previous word token *) - and flush_word () = - if !in_word then begin - (* this whitespace follows a word *) - let word = Buffer.contents buf in - Buffer.clear buf; - in_word := false; - k (`Atom word) - end - in - Sequence.iter next input - in - Sequence.from_iter seq_fun - -(** Build a Sexpr from a sequence of tokens *) -let of_seq seq = - (* called on every token *) - let rec k stack token = match token with - | `Open -> `Open :: stack - | `Close -> collapse [] stack - | `Atom a -> (`Expr (Atom a)) :: stack - (* collapse last list into an `Expr *) - and collapse acc stack = match stack with - | `Open::stack' -> `Expr (List acc) :: stack' - | `Expr a::stack' -> collapse (a :: acc) stack' - | _ -> assert false - in - (* iterate on the sequence, given an empty initial stack *) - let stack = Sequence.fold k [] seq in - (* stack should contain exactly one expression *) - match stack with - | [`Expr expr] -> expr - | [] -> failwith "no Sexpr could be parsed" - | _ -> failwith "too many elements on the stack" - -(** {2 Printing} *) - -(** Print a token on the given formatter *) -let pp_token formatter token = match token with - | `Open -> Format.fprintf formatter "@[(" - | `Close -> Format.fprintf formatter ")@]" - | `Atom s -> Format.pp_print_string formatter s - -(** Print a sequence of Sexpr tokens on the given formatter *) -let pp_tokens formatter tokens = - let first = ref true in - let last = ref false in - Sequence.iter - (fun token -> - (match token with - | `Open -> (if not !first then Format.fprintf formatter " "); first := true - | `Close -> first := false; last := true - | _ -> if !first then first := false else Format.fprintf formatter " "); - pp_token formatter token; - if !last then last := false) - tokens - -(** Pretty-print the S-expr. If [indent] is true, the S-expression - is printed with indentation. *) -let pp_sexpr ?(indent=false) formatter s = - if indent - then Format.fprintf formatter "@[%a@]" pp_tokens (traverse s) - else pp_tokens formatter (traverse s) - -(** {2 Serializing} *) - -let output_seq name subexpr k = - k `Open; - k (`Atom name); - Sequence.iter k subexpr; - k `Close - -let output_str name str k = - k `Open; - k (`Atom name); - k (`Atom str); - k `Close - -(** {2 Parsing} *) - -(** Monadic combinators for parsing data from a sequence of tokens, - without converting to concrete S-expressions. - - The [one] parser can raise ParseFailure if it fails to parse - the atomic type. *) - -(** parser that returns a 'a *) -type 'a parser = - | Return : 'a -> 'a parser - | One : (token -> 'a) -> 'a parser - | Zero : (token -> 'a parser) -> 'a parser - (* | Maybe of (token -> 'a option) *) - | Bind : ('b parser * ('b -> 'a parser)) -> 'a parser - | Fail : string -> 'a parser - -exception ParseFailure of string - -let (>>=) p f = Bind (p, f) - -let (>>) p p' = p >>= fun _ -> p' - -let return x = Return x - -let fail reason = Fail reason - -let one f = One f - -let skip = One (fun _ -> ()) - -let lookahead f = Zero f - -let left = One (function | `Open -> () - | _ -> raise (ParseFailure "expected '('")) - -let right = One (function | `Close -> () - | _ -> raise (ParseFailure "expected ')'")) - -let pair f g = - f >>= fun x -> - g >>= fun y -> - return (x, y) - -let triple f g h = - f >>= fun x -> - g >>= fun y -> - h >>= fun z -> - return (x, y, z) - -(** [(name,p) ^|| p'] behaves as p if the next token is [`Atom name], and - like [p'] otherwise *) -let (^||) (name,p) p' = - lookahead - (fun token -> match token with - | `Atom s when s = name -> skip >> p () - | _ -> p') - -(** Maps the value returned by the parser *) -let map p f = p >>= fun x -> return (f x) - -let p_str = one - (function | `Atom s -> s | _ -> raise (ParseFailure "expected string")) - -let p_int = one - (function | `Atom s -> (try int_of_string s - with Failure _ -> raise (ParseFailure "expected int")) - | _ -> raise (ParseFailure "expected int")) - -let p_bool = one - (function | `Atom s -> (try bool_of_string s - with Failure _ -> raise (ParseFailure "expected bool")) - | _ -> raise (ParseFailure "expected bool")) - -let p_float = one - (function | `Atom s -> (try float_of_string s - with Failure _ -> raise (ParseFailure "expected float")) - | _ -> raise (ParseFailure "expected float")) - -let many p = - let rec elements token = - match token with - | `Close -> return [] - | _ -> - p >>= fun x -> - lookahead elements >>= fun l -> - return (x :: l) - in - left >> lookahead elements >>= fun l -> right >> return l - -let many1 p = - p >>= fun x -> - many p >>= fun l -> - return (x::l) - -(** parsing state that returns a 'a *) -type 'a state = - | Bottom : 'a state - | Push : ('b parser * ('b -> 'a state)) -> 'a state - -(** Actually parse the sequence of tokens, with a callback to be called - on every parsed value. The callback decides whether to push another - state or whether to continue. *) -let parse_k p tokens k = - let rec state = Push(p, fun x -> match k x with `Stop -> Bottom | `Continue -> state) in - (* Token handler. It also takes the current parser. *) - let rec one_step state token = - match reduce state with - | Bottom -> (* should not happen, unless there are too many tokens *) - raise (ParseFailure "unexpected ')'") - | Push (Return _, cont) -> - assert false (* should be reduced *) - | Push (Zero f, cont) -> - let p' = f token in - let state' = Push (p', cont) in - one_step state' token (* do not consume token *) - | Push (One f, cont) -> - let x = f token in - let state' = cont x in - reduce state' (* consume token *) - (* | Maybe f, _ -> let x = f token in (Obj.magic cont) x *) - | Push (Bind (p', cont'), cont) -> - let cont'' x = - let p'' = cont' x in - Push (p'', cont) - in - let state' = Push (p', cont'') in - one_step state' token (* do not consume token *) - | Push (Fail reason, _) -> raise (ParseFailure reason) - (* Reduce parser state *) - and reduce state = match state with - | Push (Return x, cont) -> - let state' = cont x in - reduce state' - | _ -> state - in - (* iterate on the tokens *) - ignore (Sequence.fold one_step state tokens) - -(** Parse one value *) -let parse p tokens = - let res = ref None in - parse_k p tokens (fun x -> res := Some x; `Stop); - (* return result *) - match !res with - | None -> raise (ParseFailure "incomplete input") - | Some x -> x - -(** Parse a sequence of values *) -let parse_seq p tokens = - let seq_fun k = - parse_k p tokens (fun x -> k x; `Continue) - in - Sequence.from_iter seq_fun - diff --git a/sequence/examples/sexpr.mli b/sequence/examples/sexpr.mli deleted file mode 100644 index 6a8a53c0..00000000 --- a/sequence/examples/sexpr.mli +++ /dev/null @@ -1,132 +0,0 @@ -(* -Zipperposition: a functional superposition prover for prototyping -Copyright (C) 2012 Simon Cruanes - -This is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public License -as published by the Free Software Foundation; either version 2 -of the License, or (at your option) any later version. - -This is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -02110-1301 USA. -*) - -(* {1 Basic S-expressions, with printing and parsing} *) - -type t = - | Atom of string (** An atom *) - | List of t list (** A list of S-expressions *) - (** S-expression *) - -type token = [`Open | `Close | `Atom of string] - (** Token that compose a Sexpr once serialized *) - -(** {2 Traverse a sequence of tokens} *) - -val iter : (token -> unit) -> t -> unit - (** Iterate on the S-expression, calling the callback with tokens *) - -val traverse : t -> token Sequence.t - (** Traverse. This yields a sequence of tokens *) - -val validate : token Sequence.t -> token Sequence.t - (** Returns the same sequence of tokens, but during iteration, if - the structure of the Sexpr corresponding to the sequence - is wrong (bad parenthesing), Invalid_argument is raised - and iteration is stoped *) - -(** {2 Text <-> tokens} *) - -val lex : char Sequence.t -> token Sequence.t - (** Lex: create a sequence of tokens from the given sequence of chars. *) - -val of_seq : token Sequence.t -> t - (** Build a Sexpr from a sequence of tokens, or raise Failure *) - -(** {2 Printing} *) - -val pp_token : Format.formatter -> token -> unit - (** Print a token on the given formatter *) - -val pp_tokens : Format.formatter -> token Sequence.t -> unit - (** Print a sequence of Sexpr tokens on the given formatter *) - -val pp_sexpr : ?indent:bool -> Format.formatter -> t -> unit - (** Pretty-print the S-expr. If [indent] is true, the S-expression - is printed with indentation. *) - -(** {2 Serializing} *) - -val output_seq : string -> token Sequence.t -> (token -> unit) -> unit - (** print a pair "(name @,sequence)" *) - -val output_str : string -> string -> (token -> unit) -> unit - (** print a pair "(name str)" *) - -(** {2 Parsing} *) - -(** Monadic combinators for parsing data from a sequence of tokens, - without converting to concrete S-expressions. *) - -type 'a parser - -exception ParseFailure of string - -val (>>=) : 'a parser -> ('a -> 'b parser) -> 'b parser - (** Monadic bind: computes a parser from the result of - the first parser *) - -val (>>) : 'a parser -> 'b parser -> 'b parser - (** Like (>>=), but ignores the result of the first parser *) - -val return : 'a -> 'a parser - (** Parser that consumes no input and return the given value *) - -val fail : string -> 'a parser - (** Fails parsing with the given message *) - -val one : (token -> 'a) -> 'a parser - (** consumes one token with the function *) - -val skip : unit parser - (** Skip the token *) - -val lookahead : (token -> 'a parser) -> 'a parser - (** choose parser given current token *) - -val left : unit parser - (** Parses a `Open *) - -val right : unit parser - (** Parses a `Close *) - -val pair : 'a parser -> 'b parser -> ('a * 'b) parser -val triple : 'a parser -> 'b parser -> 'c parser -> ('a * 'b * 'c) parser - -val (^||) : (string * (unit -> 'a parser)) -> 'a parser -> 'a parser - (** [(name,p) ^|| p'] behaves as [p ()] if the next token is [`Atom name], and - like [p'] otherwise *) - -val map : 'a parser -> ('a -> 'b) -> 'b parser - (** Maps the value returned by the parser *) - -val p_str : string parser -val p_int : int parser -val p_bool : bool parser - -val many : 'a parser -> 'a list parser -val many1 : 'a parser -> 'a list parser - -val parse : 'a parser -> token Sequence.t -> 'a - (** Parses exactly one value from the sequence of tokens. Raises - ParseFailure if anything goes wrong. *) - -val parse_seq : 'a parser -> token Sequence.t -> 'a Sequence.t - (** Parses a sequence of values *) diff --git a/sequence/examples/test_sexpr.ml b/sequence/examples/test_sexpr.ml deleted file mode 100644 index 75de0685..00000000 --- a/sequence/examples/test_sexpr.ml +++ /dev/null @@ -1,131 +0,0 @@ - -(** {2 Test sequences} *) - -(** print a list of items using the printing function *) -let pp_list ?(sep=", ") pp_item formatter l = - Sequence.pp_seq ~sep pp_item formatter (Sequence.of_list l) - -(** Set of integers *) -module ISet = Set.Make(struct type t = int let compare = compare end) -let iset = (module ISet : Set.S with type elt = int and type t = ISet.t) - -module OrderedString = struct type t = string let compare = compare end -module SMap = Sequence.Map.Make(OrderedString) - -let my_map = SMap.of_seq (Sequence.of_list ["1", 1; "2", 2; "3", 3; "answer", 42]) - -let sexpr = "(foo bar (bazz quux hello 42) world (zoo foo bar (1 2 (3 4))))" - -type term = | Lambda of term | Const of string | Var of int | Apply of term * term - -let random_term () = - let max = 10 - and num = ref 0 in - let rec build depth = - if depth > 4 || !num > max then Const (random_const ()) else - match Random.int 6 with - | 0 -> if depth > 0 then Var (Random.int depth) else Const (random_const ()) - | 1 -> incr num; Lambda (build (depth+1)) - | 2 -> Const (random_const ()) - | _ -> incr num; Apply ((build depth), (build depth)) - and random_const () = [|"a"; "b"; "c"; "f"; "g"; "h"|].(Random.int 6) - in build 0 - -let rec sexpr_of_term t = - let f t k = match t with - | Var i -> Sexpr.output_str "var" (string_of_int i) k - | Lambda t' -> Sexpr.output_seq "lambda" (sexpr_of_term t') k - | Apply (t1, t2) -> Sexpr.output_seq "apply" (Sequence.append (sexpr_of_term t1) (sexpr_of_term t2)) k - | Const s -> Sexpr.output_str "const" s k - in Sequence.from_iter (f t) - -let term_parser = - let open Sexpr in - let rec p_term () = - left >> - (("lambda", p_lambda) ^|| ("var", p_var) ^|| ("const", p_const) ^|| - ("apply", p_apply) ^|| fail "bad term") >>= fun x -> - right >> return x - and p_apply () = - p_term () >>= fun x -> - p_term () >>= fun y -> - return (Apply (x,y)) - and p_var () = p_int >>= fun i -> return (Var i) - and p_const () = p_str >>= fun s -> return (Const s) - and p_lambda () = p_term () >>= fun t -> return (Lambda t) - in p_term () - -let term_of_sexp seq = Sexpr.parse term_parser seq - -let test_term () = - let t = random_term () in - Format.printf "@[random term: %a@]@." Sexpr.pp_tokens (sexpr_of_term t); - let tokens = sexpr_of_term t in - let t' = term_of_sexp tokens in - Format.printf "@[parsed: %a@]@." Sexpr.pp_tokens (sexpr_of_term t'); - () - -let _ = - (* lists *) - let l = [0;1;2;3;4;5;6] in - let l' = Sequence.to_list - (Sequence.filter (fun x -> x mod 2 = 0) (Sequence.of_list l)) in - let l'' = Sequence.to_list - (Sequence.take 3 (Sequence.drop 1 (Sequence.of_list l))) in - let h = Hashtbl.create 3 in - for i = 0 to 5 do - Hashtbl.add h i (i*i); - done; - let l2 = Sequence.to_list - (Sequence.map (fun (x, y) -> (string_of_int x) ^ " -> " ^ (string_of_int y)) - (Sequence.of_hashtbl h)) - in - let l3 = Sequence.to_list (Sequence.rev (Sequence.int_range ~start:0 ~stop:42)) in - let set = List.fold_left (fun set x -> ISet.add x set) ISet.empty [4;3;100;42] in - let l4 = Sequence.to_list (Sequence.of_set iset set) in - Format.printf "l=@[[%a]@]@." (pp_list Format.pp_print_int) l; - Format.printf "l'=@[[%a]@]@." (pp_list Format.pp_print_int) l'; - Format.printf "l''=@[[%a]@]@." (pp_list Format.pp_print_int) l''; - Format.printf "l2=@[[%a]@]@." (pp_list Format.pp_print_string) l2; - Format.printf "l3=@[[%a]@]@." (pp_list Format.pp_print_int) l3; - Format.printf "s={@[%a@]}@." (Sequence.pp_seq Format.pp_print_int) (Sequence.of_set iset set); - Format.printf "l4=@[[%a]@]@." (pp_list Format.pp_print_int) l4; - Format.printf "l3[:5]+l4=@[[%a]@]@." (Sequence.pp_seq Format.pp_print_int) - (Sequence.of_array - (Sequence.to_array (Sequence.append - (Sequence.take 5 (Sequence.of_list l3)) (Sequence.of_list l4)))); - (* sequence, persistent, etc *) - let seq = Sequence.int_range ~start:0 ~stop:100000 in - let seq' = Sequence.persistent seq in - let stream = Sequence.to_stream seq' in - Format.printf "test length [0..100000]: persistent1 %d, stream %d, persistent2 %d" - (Sequence.length seq') (Sequence.length (Sequence.of_stream stream)) (Sequence.length seq'); - (* maps *) - Format.printf "@[map: %a@]@." - (Sequence.pp_seq (fun formatter (k,v) -> Format.fprintf formatter "\"%s\" -> %d" k v)) - (SMap.to_seq my_map); - let module MyMapSeq = Sequence.Map.Adapt(Map.Make(OrderedString)) in - let my_map' = MyMapSeq.of_seq (Sequence.of_list ["1", 1; "2", 2; "3", 3; "answer", 42]) in - Format.printf "@[map: %a@]@." - (Sequence.pp_seq (fun formatter (k,v) -> Format.fprintf formatter "\"%s\" -> %d" k v)) - (MyMapSeq.to_seq my_map'); - (* sum *) - let n = 1000000 in - let sum = Sequence.fold (+) 0 (Sequence.take n (Sequence.repeat 1)) in - Format.printf "%dx1 = %d@." n sum; - assert (n=sum); - (* sexpr *) - let s = Sexpr.of_seq (Sexpr.lex (Sequence.of_str sexpr)) in - let s = Sexpr.of_seq (Sequence.map - (function | `Atom s -> `Atom (String.capitalize s) | tok -> tok) - (Sexpr.traverse s)) - in - Format.printf "@[transform @[%s@] into @[%a@]@]@." sexpr (Sexpr.pp_sexpr ~indent:false) s; - Format.printf "@[ cycle:%a@]@." Sexpr.pp_tokens - (Sequence.concat (Sequence.take 10 (Sequence.repeat (Sexpr.traverse s)))); - (* sexpr parsing/printing *) - for i = 0 to 20 do - Format.printf "%d-th term test@." i; - test_term (); - done; - () diff --git a/sequence/invert/.merlin b/sequence/invert/.merlin deleted file mode 100644 index 3b9a31d9..00000000 --- a/sequence/invert/.merlin +++ /dev/null @@ -1,2 +0,0 @@ -REC -PKG delimcc diff --git a/sequence/invert/sequenceInvert.ml b/sequence/invert/sequenceInvert.ml deleted file mode 100644 index 46efc693..00000000 --- a/sequence/invert/sequenceInvert.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* -Copyright (c) 2014, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Interface to Delimcc (Invert control flow)} *) - -type 'a gen = unit -> 'a option - -type 'a res = - | Start - | Yield of 'a - | Stop - -let _ret_none () = None -let _ret_unit () = () - -let to_gen seq = - let p = Delimcc.new_prompt () in - let _next = ref None in - ignore (Delimcc.push_prompt p - (fun () -> - Delimcc.take_subcont p (fun c () -> _next := Some c; Start); - seq - (fun x -> - Delimcc.take_subcont p (fun c () -> _next := Some c; Yield x) - ); - _next := None; - Stop - )); - (* call next subcont *) - let rec next () = - match !_next with - | None -> None - | Some f -> - begin match Delimcc.push_delim_subcont f _ret_unit with - | Start -> next () - | Yield x -> Some x - | Stop -> None - end - in - next diff --git a/sequence/invert/sequenceInvert.mli b/sequence/invert/sequenceInvert.mli deleted file mode 100644 index bd3c8433..00000000 --- a/sequence/invert/sequenceInvert.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* -Copyright (c) 2014, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Interface to Delimcc (Invert control flow)} *) - -type 'a gen = unit -> 'a option - -val to_gen : 'a Sequence.t -> 'a gen -(** Use delimited continuations to iterate on the sequence step by step. - Relatively costly but still useful *) diff --git a/sequence/myocamlbuild.ml b/sequence/myocamlbuild.ml deleted file mode 100644 index 1f969666..00000000 --- a/sequence/myocamlbuild.ml +++ /dev/null @@ -1,609 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: 958ece46307b808952e439e1cc47a739) *) -module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) - - - let ns_ str = - str - - - let s_ str = - str - - - let f_ (str: ('a, 'b, 'c, 'd) format4) = - str - - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - - let init = - [] - - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - - - - open OASISGettext - - - type test = string - - - type flag = string - - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - - type 'a choices = (t * 'a) list - - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - - -end - - -# 132 "myocamlbuild.ml" -module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - - - module MapString = Map.Make(String) - - - type t = string MapString.t - - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - - let rec var_expand str env = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = - var_expand (MapString.find name env) env - - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -# 237 "myocamlbuild.ml" -module MyOCamlbuildFindlib = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) - - - (** OCamlbuild extension, copied from - * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild - * by N. Pouillard and others - * - * Updated on 2009/02/28 - * - * Modified by Sylvain Le Gall - *) - open Ocamlbuild_plugin - - - (* these functions are not really officially exported *) - let run_and_read = - Ocamlbuild_pack.My_unix.run_and_read - - - let blank_sep_strings = - Ocamlbuild_pack.Lexers.blank_sep_strings - - - let exec_from_conf exec = - let exec = - let env_filename = Pathname.basename BaseEnvLight.default_filename in - let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in - try - BaseEnvLight.var_get exec env - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" exec; - exec - in - let fix_win32 str = - if Sys.os_type = "Win32" then begin - let buff = Buffer.create (String.length str) in - (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. - *) - String.iter - (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) - str; - Buffer.contents buff - end else begin - str - end - in - fix_win32 exec - - let split s ch = - let buf = Buffer.create 13 in - let x = ref [] in - let flush () = - x := (Buffer.contents buf) :: !x; - Buffer.clear buf - in - String.iter - (fun c -> - if c = ch then - flush () - else - Buffer.add_char buf c) - s; - flush (); - List.rev !x - - - let split_nl s = split s '\n' - - - let before_space s = - try - String.before s (String.index s ' ') - with Not_found -> s - - (* ocamlfind command *) - let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] - - (* This lists all supported packages. *) - let find_packages () = - List.map before_space (split_nl & run_and_read "ocamlfind list") - - - (* Mock to list available syntaxes. *) - let find_syntaxes () = ["camlp4o"; "camlp4r"] - - - let well_known_syntax = [ - "camlp4.quotations.o"; - "camlp4.quotations.r"; - "camlp4.exceptiontracer"; - "camlp4.extend"; - "camlp4.foldgenerator"; - "camlp4.listcomprehension"; - "camlp4.locationstripper"; - "camlp4.macro"; - "camlp4.mapgenerator"; - "camlp4.metagenerator"; - "camlp4.profiler"; - "camlp4.tracer" - ] - - - let dispatch = - function - | After_options -> - (* By using Before_options one let command line options have an higher - * priority on the contrary using After_options will guarantee to have - * the higher priority override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop"; - Options.ocamlmklib := ocamlfind & A"ocamlmklib" - - | After_rules -> - - (* When one link an OCaml library/binary/package, one should use - * -linkpkg *) - flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - let base_args = [A"-package"; A pkg] in - (* TODO: consider how to really choose camlp4o or camlp4r. *) - let syn_args = [A"-syntax"; A "camlp4o"] in - let args = - (* Heuristic to identify syntax extensions: whether they end in - ".syntax"; some might not. - *) - if Filename.check_suffix pkg "syntax" || - List.mem pkg well_known_syntax then - syn_args @ base_args - else - base_args - in - flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; - flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; - end - (find_packages ()); - - (* Like -package but for extensions syntax. Morover -syntax is useless - * when linking. *) - List.iter begin fun syntax -> - flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & - S[A"-syntax"; A syntax]; - end (find_syntaxes ()); - - (* The default "thread" tag is not compatible with ocamlfind. - * Indeed, the default rules add the "threads.cma" or "threads.cmxa" - * options when using this tag. When using the "-linkpkg" option with - * ocamlfind, this module will then be added twice on the command line. - * - * To solve this, one approach is to add the "-thread" option when using - * the "threads" package using the previous plugin. - *) - flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); - - | _ -> - () -end - -module MyOCamlbuildBase = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - - (** Base functions for writing myocamlbuild.ml - @author Sylvain Le Gall - *) - - - - - - open Ocamlbuild_plugin - module OC = Ocamlbuild_pack.Ocaml_compiler - - - type dir = string - type file = string - type name = string - type tag = string - - -(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - - type t = - { - lib_ocaml: (name * dir list * string list) list; - lib_c: (name * dir * file list) list; - flags: (tag list * (spec OASISExpr.choices)) list; - (* Replace the 'dir: include' from _tags by a precise interdepends in - * directory. - *) - includes: (dir * dir list) list; - } - - - let env_filename = - Pathname.basename - BaseEnvLight.default_filename - - - let dispatch_combine lst = - fun e -> - List.iter - (fun dispatch -> dispatch e) - lst - - - let tag_libstubs nm = - "use_lib"^nm^"_stubs" - - - let nm_libstubs nm = - nm^"_stubs" - - - let dispatch t e = - let env = - BaseEnvLight.load - ~filename:env_filename - ~allow_empty:true - () - in - match e with - | Before_options -> - let no_trailing_dot s = - if String.length s >= 1 && s.[0] = '.' then - String.sub s 1 ((String.length s) - 1) - else - s - in - List.iter - (fun (opt, var) -> - try - opt := no_trailing_dot (BaseEnvLight.var_get var env) - with Not_found -> - Printf.eprintf "W: Cannot get variable %s\n" var) - [ - Options.ext_obj, "ext_obj"; - Options.ext_lib, "ext_lib"; - Options.ext_dll, "ext_dll"; - ] - - | After_rules -> - (* Declare OCaml libraries *) - List.iter - (function - | nm, [], intf_modules -> - ocaml_lib nm; - let cmis = - List.map (fun m -> (String.uncapitalize m) ^ ".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis - | nm, dir :: tl, intf_modules -> - ocaml_lib ~dir:dir (dir^"/"^nm); - List.iter - (fun dir -> - List.iter - (fun str -> - flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) - ["compile"; "infer_interface"; "doc"]) - tl; - let cmis = - List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") - intf_modules in - dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] - cmis) - t.lib_ocaml; - - (* Declare directories dependencies, replace "include" in _tags. *) - List.iter - (fun (dir, include_dirs) -> - Pathname.define_context dir include_dirs) - t.includes; - - (* Declare C libraries *) - List.iter - (fun (lib, dir, headers) -> - (* Handle C part of library *) - flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; - A("-l"^(nm_libstubs lib))]); - - flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] - (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - - flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); - - (* When ocaml link something that use the C library, then one - need that file to be up to date. - *) - dep ["link"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - dep ["compile"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - - (* TODO: be more specific about what depends on headers *) - (* Depends on .h files *) - dep ["compile"; "c"] - headers; - - (* Setup search path for lib *) - flag ["link"; "ocaml"; "use_"^lib] - (S[A"-I"; P(dir)]); - ) - t.lib_c; - - (* Add flags *) - List.iter - (fun (tags, cond_specs) -> - let spec = BaseEnvLight.var_choose cond_specs env in - let rec eval_specs = - function - | S lst -> S (List.map eval_specs lst) - | A str -> A (BaseEnvLight.var_expand str env) - | spec -> spec - in - flag tags & (eval_specs spec)) - t.flags - | _ -> - () - - - let dispatch_default t = - dispatch_combine - [ - dispatch t; - MyOCamlbuildFindlib.dispatch; - ] - - -end - - -# 594 "myocamlbuild.ml" -open Ocamlbuild_plugin;; -let package_default = - { - MyOCamlbuildBase.lib_ocaml = [("sequence", [], [])]; - lib_c = []; - flags = []; - includes = [] - } - ;; - -let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; - -# 608 "myocamlbuild.ml" -(* OASIS_STOP *) -Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/sequence/sequence.ml b/sequence/sequence.ml deleted file mode 100644 index 6c6bd3b8..00000000 --- a/sequence/sequence.ml +++ /dev/null @@ -1,787 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Transient iterators, that abstract on a finite sequence of elements.} *) - -(** Sequence abstract iterator type *) -type 'a t = ('a -> unit) -> unit - -type 'a sequence = 'a t - -type (+'a, +'b) t2 = ('a -> 'b -> unit) -> unit - (** Sequence of pairs of values of type ['a] and ['b]. *) - -(** Build a sequence from a iter function *) -let from_iter f = f - -let rec from_fun f k = match f () with - | None -> () - | Some x -> k x; from_fun f k - -let empty _ = () - -let singleton x k = k x -let return x k = k x -let pure f k = k f - -let doubleton x y k = k x; k y - -let cons x l k = k x; l k -let snoc l x k = l k; k x - -let repeat x k = while true do k x done - -let rec iterate f x k = - k x; - iterate f (f x) k - -let rec forever f k = - k (f ()); - forever f k - -let cycle s k = while true do s k; done - -let iter f seq = seq f - -let iteri f seq = - let r = ref 0 in - seq - (fun x -> - f !r x; - incr r) - -let fold f init seq = - let r = ref init in - seq (fun elt -> r := f !r elt); - !r - -let foldi f init seq = - let i = ref 0 in - let r = ref init in - seq - (fun elt -> - r := f !r !i elt; - incr i); - !r - -let map f seq k = seq (fun x -> k (f x)) - -let mapi f seq k = - let i = ref 0 in - seq (fun x -> k (f !i x); incr i) - -let filter p seq k = seq (fun x -> if p x then k x) - -let append s1 s2 k = s1 k; s2 k - -let concat s k = s (fun s' -> s' k) - -let flatten s = concat s - -let flatMap f seq k = seq (fun x -> f x k) - -let flat_map = flatMap - -let fmap f seq k = - seq (fun x -> match f x with - | None -> () - | Some y -> k y - ) - -let filter_map = fmap - -let intersperse elem seq k = - let first = ref true in - seq (fun x -> (if !first then first := false else k elem); k x) - -(** Mutable unrolled list to serve as intermediate storage *) -module MList = struct - type 'a node = - | Nil - | Cons of 'a array * int ref * 'a node ref - - (* build and call callback on every element *) - let of_seq_with seq k = - let start = ref Nil in - let chunk_size = ref 8 in - (* fill the list. prev: tail-reference from previous node *) - let prev, cur = ref start, ref Nil in - seq - (fun x -> - k x; (* callback *) - match !cur with - | Nil -> - let n = !chunk_size in - if n < 4096 then chunk_size := 2 * !chunk_size; - cur := Cons (Array.make n x, ref 1, ref Nil) - | Cons (a,n,next) -> - assert (!n < Array.length a); - a.(!n) <- x; - incr n; - if !n = Array.length a then begin - !prev := !cur; - prev := next; - cur := Nil - end - ); - !prev := !cur; - !start - - let of_seq seq = - of_seq_with seq (fun _ -> ()) - - let rec iter f l = match l with - | Nil -> () - | Cons (a, n, tl) -> - for i=0 to !n - 1 do f a.(i) done; - iter f !tl - - let iteri f l = - let rec iteri i f l = match l with - | Nil -> () - | Cons (a, n, tl) -> - for j=0 to !n - 1 do f (i+j) a.(j) done; - iteri (i+ !n) f !tl - in iteri 0 f l - - let rec iter_rev f l = match l with - | Nil -> () - | Cons (a, n, tl) -> - iter_rev f !tl; - for i = !n-1 downto 0 do f a.(i) done - - let length l = - let rec len acc l = match l with - | Nil -> acc - | Cons (_, n, tl) -> len (acc+ !n) !tl - in len 0 l - - (** Get element by index *) - let rec get l i = match l with - | Nil -> raise (Invalid_argument "MList.get") - | Cons (a, n, _) when i < !n -> a.(i) - | Cons (_, n, tl) -> get !tl (i- !n) - - let to_seq l k = iter k l - - let _to_next arg l = - let cur = ref l in - let i = ref 0 in (* offset in cons *) - let rec get_next _ = match !cur with - | Nil -> None - | Cons (_, n, tl) when !i = !n -> - cur := !tl; - i := 0; - get_next arg - | Cons (a, _, _) -> - let x = a.(!i) in - incr i; - Some x - in get_next - - let to_gen l = _to_next () l - - let to_stream l = - Stream.from (_to_next 42 l) (* 42=magic cookiiiiiie *) - - let to_klist l = - let rec make (l,i) () = match l with - | Nil -> `Nil - | Cons (_, n, tl) when i = !n -> make (!tl,0) () - | Cons (a, _, _) -> `Cons (a.(i), make (l,i+1)) - in make (l,0) -end - -let persistent seq = - let l = MList.of_seq seq in - MList.to_seq l - -type 'a lazy_state = - | LazySuspend - | LazyCached of 'a t - -let persistent_lazy (seq:'a t) = - let r = ref LazySuspend in - fun k -> - match !r with - | LazyCached seq' -> seq' k - | LazySuspend -> - (* here if this traversal is interruted, no caching occurs *) - let seq' = MList.of_seq_with seq k in - r := LazyCached (MList.to_seq seq') - -let sort ?(cmp=Pervasives.compare) seq = - (* use an intermediate list, then sort the list *) - let l = fold (fun l x -> x::l) [] seq in - let l = List.fast_sort cmp l in - fun k -> List.iter k l - -let group ?(eq=fun x y -> x = y) seq k = - let cur = ref [] in - seq (fun x -> - match !cur with - | [] -> cur := [x] - | (y::_) as l when eq x y -> - cur := x::l (* [x] belongs to the group *) - | (_::_) as l -> - k l; (* yield group, and start another one *) - cur := [x]); - (* last list *) - if !cur <> [] then k !cur - -let uniq ?(eq=fun x y -> x = y) seq k = - let has_prev = ref false - and prev = ref (Obj.magic 0) in (* avoid option type, costly *) - seq (fun x -> - if !has_prev && eq !prev x - then () (* duplicate *) - else begin - has_prev := true; - prev := x; - k x - end) - -let sort_uniq (type elt) ?(cmp=Pervasives.compare) seq = - let module S = Set.Make(struct - type t = elt - let compare = cmp - end) in - let set = fold (fun acc x -> S.add x acc) S.empty seq in - fun k -> S.iter k set - -let product outer inner k = - outer (fun x -> - inner (fun y -> k (x,y)) - ) - -let product2 outer inner k = - outer (fun x -> - inner (fun y -> k x y) - ) - -let join ~join_row s1 s2 k = - s1 (fun a -> - s2 (fun b -> - match join_row a b with - | None -> () - | Some c -> k c - ) - ) (* yield the combination of [a] and [b] *) - -let rec unfoldr f b k = match f b with - | None -> () - | Some (x, b') -> - k x; - unfoldr f b' k - -let scan f acc seq k = - k acc; - let acc = ref acc in - seq (fun elt -> let acc' = f !acc elt in k acc'; acc := acc') - -let max ?(lt=fun x y -> x < y) seq = - let ret = ref None in - seq (fun x -> match !ret with - | None -> ret := Some x - | Some y -> if lt y x then ret := Some x); - !ret - -let min ?(lt=fun x y -> x < y) seq = - let ret = ref None in - seq (fun x -> match !ret with - | None -> ret := Some x - | Some y -> if lt x y then ret := Some x); - !ret - -exception ExitHead - -let head seq = - let r = ref None in - try - seq (fun x -> r := Some x; raise ExitHead); None - with ExitHead -> !r - -let head_exn seq = - match head seq with - | None -> invalid_arg "Sequence.head_exn" - | Some x -> x - -exception ExitTake - -let take n seq k = - let count = ref 0 in - try - seq (fun x -> - if !count = n then raise ExitTake; - incr count; - k x; - ) - with ExitTake -> () - -exception ExitTakeWhile - -let take_while p seq k = - try - seq (fun x -> if p x then k x else raise ExitTakeWhile) - with ExitTakeWhile -> () - -let drop n seq k = - let count = ref 0 in - seq (fun x -> if !count >= n then k x else incr count) - -let drop_while p seq k = - let drop = ref true in - seq (fun x -> - if !drop - then if p x then () else (drop := false; k x) - else k x) - -let rev seq = - let l = MList.of_seq seq in - fun k -> MList.iter_rev k l - -exception ExitForall - -let for_all p seq = - try - seq (fun x -> if not (p x) then raise ExitForall); - true - with ExitForall -> false - -exception ExitExists - -(** Exists there some element satisfying the predicate? *) -let exists p seq = - try - seq (fun x -> if p x then raise ExitExists); - false - with ExitExists -> true - -let mem ?(eq=(=)) x seq = exists (eq x) seq - -exception ExitFind - -let find f seq = - let r = ref None in - begin try - seq (fun x -> match f x with - | None -> () - | Some _ as res -> r := res; raise ExitFind - ); - with ExitFind -> () - end; - !r - -let length seq = - let r = ref 0 in - seq (fun _ -> incr r); - !r - -exception ExitIsEmpty - -let is_empty seq = - try seq (fun _ -> raise ExitIsEmpty); true - with ExitIsEmpty -> false - -(** {2 Transform a sequence} *) - -let empty2 _ = () - -let is_empty2 seq2 = - try ignore (seq2 (fun _ _ -> raise ExitIsEmpty)); true - with ExitIsEmpty -> false - -let length2 seq2 = - let r = ref 0 in - seq2 (fun _ _ -> incr r); - !r - -let zip seq2 k = seq2 (fun x y -> k (x,y)) - -let unzip seq k = seq (fun (x,y) -> k x y) - -let zip_i seq k = - let r = ref 0 in - seq (fun x -> let n = !r in incr r; k n x) - -let fold2 f acc seq2 = - let acc = ref acc in - seq2 (fun x y -> acc := f !acc x y); - !acc - -let iter2 f seq2 = seq2 f - -let map2 f seq2 k = seq2 (fun x y -> k (f x y)) - -let map2_2 f g seq2 k = - seq2 (fun x y -> k (f x y) (g x y)) - -(** {2 Basic data structures converters} *) - -let to_list seq = List.rev (fold (fun y x -> x::y) [] seq) - -let to_rev_list seq = fold (fun y x -> x :: y) [] seq - -let of_list l k = List.iter k l - -let on_list f l = - to_list (f (of_list l)) - -let to_opt = head - -let of_opt o k = match o with - | None -> () - | Some x -> k x - -let to_array seq = - let l = MList.of_seq seq in - let n = MList.length l in - if n = 0 - then [||] - else begin - let a = Array.make n (MList.get l 0) in - MList.iteri (fun i x -> a.(i) <- x) l; - a - end - -let of_array a k = - for i = 0 to Array.length a - 1 do - k (Array.unsafe_get a i) - done - -let of_array_i a k = - for i = 0 to Array.length a - 1 do - k (i, Array.unsafe_get a i) - done - -let of_array2 a k = - for i = 0 to Array.length a - 1 do - k i (Array.unsafe_get a i) - done - -let array_slice a i j k = - assert (i >= 0 && j < Array.length a); - for idx = i to j do - k a.(idx); (* iterate on sub-array *) - done - -let of_stream s k = Stream.iter k s - -let to_stream seq = - let l = MList.of_seq seq in - MList.to_stream l - -let to_stack s seq = iter (fun x -> Stack.push x s) seq - -let of_stack s k = Stack.iter k s - -let to_queue q seq = seq (fun x -> Queue.push x q) - -let of_queue q k = Queue.iter k q - -let hashtbl_add h seq = - seq (fun (k,v) -> Hashtbl.add h k v) - -let hashtbl_replace h seq = - seq (fun (k,v) -> Hashtbl.replace h k v) - -let to_hashtbl seq = - let h = Hashtbl.create 3 in - hashtbl_replace h seq; - h - -let to_hashtbl2 seq2 = - let h = Hashtbl.create 3 in - seq2 (fun k v -> Hashtbl.replace h k v); - h - -let of_hashtbl h k = Hashtbl.iter (fun a b -> k (a, b)) h - -let of_hashtbl2 h k = Hashtbl.iter k h - -let hashtbl_keys h k = Hashtbl.iter (fun a _ -> k a) h - -let hashtbl_values h k = Hashtbl.iter (fun _ b -> k b) h - -let of_str s k = String.iter k s - -let to_str seq = - let b = Buffer.create 64 in - iter (fun c -> Buffer.add_char b c) seq; - Buffer.contents b - -let concat_str seq = - let b = Buffer.create 64 in - iter (Buffer.add_string b) seq; - Buffer.contents b - -exception OneShotSequence - -let of_in_channel ic = - let first = ref true in - fun k -> - if not !first - then raise OneShotSequence - else ( - first := false; - try - while true do - let c = input_char ic in k c - done - with End_of_file -> () - ) - -let to_buffer seq buf = - seq (fun c -> Buffer.add_char buf c) - -(** Iterator on integers in [start...stop] by steps 1 *) -let int_range ~start ~stop k = - for i = start to stop do k i done - -let int_range_dec ~start ~stop k = - for i = start downto stop do k i done - -let of_set (type s) (type v) m set = - let module S = (val m : Set.S with type t = s and type elt = v) in - fun k -> S.iter k set - -let to_set (type s) (type v) m seq = - let module S = (val m : Set.S with type t = s and type elt = v) in - fold - (fun set x -> S.add x set) - S.empty seq - -type 'a gen = unit -> 'a option -type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] - -let of_gen g = - (* consume the generator to build a MList *) - let rec iter1 k = match g () with - | None -> () - | Some x -> k x; iter1 k - in - let l = MList.of_seq iter1 in - MList.to_seq l - -let to_gen seq = - let l = MList.of_seq seq in - MList.to_gen l - -let rec of_klist l k = match l() with - | `Nil -> () - | `Cons (x,tl) -> k x; of_klist tl k - -let to_klist seq = - let l = MList.of_seq seq in - MList.to_klist l - -(** {2 Functorial conversions between sets and sequences} *) - -module Set = struct - module type S = sig - include Set.S - val of_seq : elt sequence -> t - val to_seq : t -> elt sequence - val to_list : t -> elt list - val of_list : elt list -> t - end - - (** Create an enriched Set module from the given one *) - module Adapt(X : Set.S) : S with type elt = X.elt and type t = X.t = struct - let to_seq set k = X.iter k set - - let of_seq seq = fold (fun set x -> X.add x set) X.empty seq - - let to_list set = to_list (to_seq set) - - include X - - let of_list l = List.fold_left (fun set x -> add x set) empty l - end - - (** Functor to build an extended Set module from an ordered type *) - module Make(X : Set.OrderedType) = struct - module MySet = Set.Make(X) - include Adapt(MySet) - end -end - -(** {2 Conversion between maps and sequences.} *) - -module Map = struct - module type S = sig - include Map.S - val to_seq : 'a t -> (key * 'a) sequence - val of_seq : (key * 'a) sequence -> 'a t - val keys : 'a t -> key sequence - val values : 'a t -> 'a sequence - val to_list : 'a t -> (key * 'a) list - val of_list : (key * 'a) list -> 'a t - end - - (** Adapt a pre-existing Map module to make it sequence-aware *) - module Adapt(M : Map.S) = struct - let to_seq m = from_iter (fun k -> M.iter (fun x y -> k (x,y)) m) - - let of_seq seq = fold (fun m (k,v) -> M.add k v m) M.empty seq - - let keys m = from_iter (fun k -> M.iter (fun x _ -> k x) m) - - let values m = from_iter (fun k -> M.iter (fun _ y -> k y) m) - - let of_list l = of_seq (of_list l) - - let to_list x = to_list (to_seq x) - - include M - end - - (** Create an enriched Map module, with sequence-aware functions *) - module Make(V : Map.OrderedType) : S with type key = V.t = struct - module M = Map.Make(V) - include Adapt(M) - end -end - -(** {2 Infinite sequences of random values} *) - -let random_int bound = forever (fun () -> Random.int bound) - -let random_bool = forever Random.bool - -let random_float bound = forever (fun () -> Random.float bound) - -let random_array a k = - assert (Array.length a > 0); - while true do - let i = Random.int (Array.length a) in - k a.(i); - done - -let random_list l = random_array (Array.of_list l) - -(** {2 Infix functions} *) - -module Infix = struct - let (--) i j = int_range ~start:i ~stop:j - - let (--^) i j = int_range_dec ~start:i ~stop:j - - let (>>=) x f = flat_map f x - - let (>|=) x f = map f x - - let (<*>) funs args k = - funs (fun f -> args (fun x -> k (f x))) - - let (<+>) = append -end - -include Infix - -(** {2 Pretty printing of sequences} *) - -(** Pretty print a sequence of ['a], using the given pretty printer - to print each elements. An optional separator string can be provided. *) -let pp_seq ?(sep=", ") pp_elt formatter seq = - let first = ref true in - seq - (fun x -> - (if !first then first := false - else begin - Format.pp_print_string formatter sep; - Format.pp_print_cut formatter (); - end); - pp_elt formatter x) - -let pp_buf ?(sep=", ") pp_elt buf seq = - let first = ref true in - seq - (fun x -> - if !first then first := false else Buffer.add_string buf sep; - pp_elt buf x) - -let to_string ?sep pp_elt seq = - let buf = Buffer.create 25 in - pp_buf ?sep (fun buf x -> Buffer.add_string buf (pp_elt x)) buf seq; - Buffer.contents buf - -(** {2 Basic IO} *) - -module IO = struct - let lines_of ?(mode=0o644) ?(flags=[Open_rdonly]) filename = - fun k -> - let ic = open_in_gen flags mode filename in - try - while true do - let line = input_line ic in - k line - done - with - | End_of_file -> close_in ic - | e -> close_in_noerr ic; raise e - - let chunks_of ?(mode=0o644) ?(flags=[]) ?(size=1024) filename = - fun k -> - let ic = open_in_gen flags mode filename in - try - let buf = Bytes.create size in - let n = ref 0 in - let stop = ref false in - while not !stop do - n := 0; - (* try to read [size] chars. If [input] returns [0] it means - the end of file, so we stop, but first we yield the current chunk *) - while !n < size && not !stop do - let n' = input ic buf !n (size - !n) in - if n' = 0 then stop := true else n := !n + n'; - done; - if !n > 0 - then k (Bytes.sub_string buf 0 !n) - done; - close_in ic - with e -> - close_in_noerr ic; - raise e - - let write_bytes_to ?(mode=0o644) ?(flags=[Open_creat;Open_wronly]) filename seq = - let oc = open_out_gen flags mode filename in - try - seq (fun s -> output oc s 0 (Bytes.length s)); - close_out oc - with e -> - close_out oc; - raise e - - let write_to ?mode ?flags filename seq = - write_bytes_to ?mode ?flags filename (map Bytes.unsafe_of_string seq) - - let write_bytes_lines ?mode ?flags filename seq = - let ret = Bytes.unsafe_of_string "\n" in - write_bytes_to ?mode ?flags filename (snoc (intersperse ret seq) ret) - - let write_lines ?mode ?flags filename seq = - write_bytes_lines ?mode ?flags filename (map Bytes.unsafe_of_string seq) -end diff --git a/sequence/sequence.mldylib b/sequence/sequence.mldylib deleted file mode 100644 index 2f635d2a..00000000 --- a/sequence/sequence.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5) -Sequence -# OASIS_STOP diff --git a/sequence/sequence.mli b/sequence/sequence.mli deleted file mode 100644 index 677f79ce..00000000 --- a/sequence/sequence.mli +++ /dev/null @@ -1,606 +0,0 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Simple and Efficient Iterators} *) - -(** The iterators are designed to allow easy transfer (mappings) between data - structures, without defining [n^2] conversions between the [n] types. The - implementation relies on the assumption that a sequence can be iterated - on as many times as needed; this choice allows for high performance - of many combinators. However, for transient iterators, the {!persistent} - function is provided, storing elements of a transient iterator - in memory; the iterator can then be used several times (See further). - - Note that some combinators also return sequences (e.g. {!group}). The - transformation is computed on the fly every time one iterates over - the resulting sequence. If a transformation performs heavy computation, - {!persistent} can also be used as intermediate storage. - - Most functions are {b lazy}, i.e. they do not actually use their arguments - until their result is iterated on. For instance, if one calls {!map} - on a sequence, one gets a new sequence, but nothing else happens until - this new sequence is used (by folding or iterating on it). - - If a sequence is built from an iteration function that is {b repeatable} - (i.e. calling it several times always iterates on the same set of - elements, for instance List.iter or Map.iter), then - the resulting {!t} object is also repeatable. For {b one-time iter functions} - such as iteration on a file descriptor or a {!Stream}, - the {!persistent} function can be used to iterate and store elements in - a memory structure; the result is a sequence that iterates on the elements - of this memory structure, cheaply and repeatably. *) - -type +'a t = ('a -> unit) -> unit - (** A sequence of values of type ['a]. If you give it a function ['a -> unit] - it will be applied to every element of the sequence successively. *) - -type +'a sequence = 'a t - -type (+'a, +'b) t2 = ('a -> 'b -> unit) -> unit - (** Sequence of pairs of values of type ['a] and ['b]. *) - -(** {2 Build a sequence} *) - -val from_iter : (('a -> unit) -> unit) -> 'a t - (** Build a sequence from a iter function *) - -val from_fun : (unit -> 'a option) -> 'a t - (** Call the function repeatedly until it returns None. This - sequence is transient, use {!persistent} if needed! *) - -val empty : 'a t - (** Empty sequence. It contains no element. *) - -val singleton : 'a -> 'a t - (** Singleton sequence, with exactly one element. *) - -val doubleton : 'a -> 'a -> 'a t - (** Sequence with exactly two elements *) - -val cons : 'a -> 'a t -> 'a t - (** [cons x l] yields [x], then yields from [l]. - Same as [append (singleton x) l] *) - -val snoc : 'a t -> 'a -> 'a t - (** Same as {!cons} but yields the element after iterating on [l] *) - -val return : 'a -> 'a t - (** Synonym to {!singleton} *) - -val pure : 'a -> 'a t - (** Synonym to {!singleton} *) - -val repeat : 'a -> 'a t - (** Infinite sequence of the same element. You may want to look - at {!take} and the likes if you iterate on it. *) - -val iterate : ('a -> 'a) -> 'a -> 'a t - (** [iterate f x] is the infinite sequence [x, f(x), f(f(x)), ...] *) - -val forever : (unit -> 'b) -> 'b t - (** Sequence that calls the given function to produce elements. - The sequence may be transient (depending on the function), and definitely - is infinite. You may want to use {!take} and {!persistent}. *) - -val cycle : 'a t -> 'a t - (** Cycle forever through the given sequence. Assume the given sequence can - be traversed any amount of times (not transient). This yields an - infinite sequence, you should use something like {!take} not to loop - forever. *) - -(** {2 Consume a sequence} *) - -val iter : ('a -> unit) -> 'a t -> unit - (** Consume the sequence, passing all its arguments to the function. - Basically [iter f seq] is just [seq f]. *) - -val iteri : (int -> 'a -> unit) -> 'a t -> unit - (** Iterate on elements and their index in the sequence *) - -val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold over elements of the sequence, consuming it *) - -val foldi : ('b -> int -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold over elements of the sequence and their index, consuming it *) - -val map : ('a -> 'b) -> 'a t -> 'b t - (** Map objects of the sequence into other elements, lazily *) - -val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t - (** Map objects, along with their index in the sequence *) - -val for_all : ('a -> bool) -> 'a t -> bool - (** Do all elements satisfy the predicate? *) - -val exists : ('a -> bool) -> 'a t -> bool - (** Exists there some element satisfying the predicate? *) - -val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool - (** Is the value a member of the sequence? - @param eq the equality predicate to use (default [(=)]) - @since 0.5 *) - -val find : ('a -> 'b option) -> 'a t -> 'b option - (** Find the first element on which the function doesn't return [None] - @since 0.5 *) - -val length : 'a t -> int - (** How long is the sequence? Forces the sequence. *) - -val is_empty : 'a t -> bool - (** Is the sequence empty? Forces the sequence. *) - -(** {2 Transform a sequence} *) - -val filter : ('a -> bool) -> 'a t -> 'a t - (** Filter on elements of the sequence *) - -val append : 'a t -> 'a t -> 'a t - (** Append two sequences. Iterating on the result is like iterating - on the first, then on the second. *) - -val concat : 'a t t -> 'a t - (** Concatenate a sequence of sequences into one sequence. *) - -val flatten : 'a t t -> 'a t - (** Alias for {!concat} *) - -val flatMap : ('a -> 'b t) -> 'a t -> 'b t - (** Monadic bind. Intuitively, it applies the function to every element of the - initial sequence, and calls {!concat}. *) - -val flat_map : ('a -> 'b t) -> 'a t -> 'b t - (** Alias to {!flatMap} with a more explicit name - @since 0.5 *) - -val fmap : ('a -> 'b option) -> 'a t -> 'b t - (** Specialized version of {!flatMap} for options. *) - -val filter_map : ('a -> 'b option) -> 'a t -> 'b t - (** Alias to {!fmap} with a more explicit name - @since 0.5 *) - -val intersperse : 'a -> 'a t -> 'a t - (** Insert the single element between every element of the sequence *) - -(** {2 Caching} *) - -val persistent : 'a t -> 'a t - (** Iterate on the sequence, storing elements in an efficient internal structure.. - The resulting sequence can be iterated on as many times as needed. - {b Note}: calling persistent on an already persistent sequence - will still make a new copy of the sequence! *) - -val persistent_lazy : 'a t -> 'a t - (** Lazy version of {!persistent}. When calling [persistent_lazy s], - a new sequence [s'] is immediately returned (without actually consuming - [s]) in constant time; the first time [s'] is iterated on, - it also consumes [s] and caches its content into a inner data - structure that will back [s'] for future iterations. - - {b warning}: on the first traversal of [s'], if the traversal - is interrupted prematurely ({!take}, etc.) then [s'] will not be - memorized, and the next call to [s'] will traverse [s] again. *) - -(** {2 Misc} *) - -val sort : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t - (** Sort the sequence. Eager, O(n) ram and O(n ln(n)) time. - It iterates on elements of the argument sequence immediately, - before it sorts them. *) - -val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t - (** Sort the sequence and remove duplicates. Eager, same as [sort] *) - -val group : ?eq:('a -> 'a -> bool) -> 'a t -> 'a list t - (** Group equal consecutive elements. *) - -val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t - (** Remove consecutive duplicate elements. Basically this is - like [fun seq -> map List.hd (group seq)]. *) - -val product : 'a t -> 'b t -> ('a * 'b) t - (** Cartesian product of the sequences. When calling [product a b], - the caller {b MUST} ensure that [b] can be traversed as many times - as required (several times), possibly by calling {!persistent} on it - beforehand. *) - -val product2 : 'a t -> 'b t -> ('a, 'b) t2 - (** Binary version of {!product}. Same requirements. - @since 0.5 *) - -val join : join_row:('a -> 'b -> 'c option) -> 'a t -> 'b t -> 'c t - (** [join ~join_row a b] combines every element of [a] with every - element of [b] using [join_row]. If [join_row] returns None, then - the two elements do not combine. Assume that [b] allows for multiple - iterations. *) - -val unfoldr : ('b -> ('a * 'b) option) -> 'b -> 'a t - (** [unfoldr f b] will apply [f] to [b]. If it - yields [Some (x,b')] then [x] is returned - and unfoldr recurses with [b']. *) - -val scan : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t - (** Sequence of intermediate results *) - -val max : ?lt:('a -> 'a -> bool) -> 'a t -> 'a option - (** Max element of the sequence, using the given comparison function. - @return None if the sequence is empty, Some [m] where [m] is the maximal - element otherwise *) - -val min : ?lt:('a -> 'a -> bool) -> 'a t -> 'a option - (** Min element of the sequence, using the given comparison function. - see {!max} for more details. *) - -val head : 'a t -> 'a option - (** First element, if any, otherwise [None] - @since 0.5.1 *) - -val head_exn : 'a t -> 'a - (** First element, if any, fails - @raise Invalid_argument if the sequence is empty - @since 0.5.1 *) - -val take : int -> 'a t -> 'a t - (** Take at most [n] elements from the sequence. Works on infinite - sequences. *) - -val take_while : ('a -> bool) -> 'a t -> 'a t - (** Take elements while they satisfy the predicate, then stops iterating. - Will work on an infinite sequence [s] if the predicate is false for at - least one element of [s]. *) - -val drop : int -> 'a t -> 'a t - (** Drop the [n] first elements of the sequence. Lazy. *) - -val drop_while : ('a -> bool) -> 'a t -> 'a t - (** Predicate version of {!drop} *) - -val rev : 'a t -> 'a t - (** Reverse the sequence. O(n) memory and time, needs the - sequence to be finite. The result is persistent and does - not depend on the input being repeatable. *) - -(** {2 Binary sequences} *) - -val empty2 : ('a, 'b) t2 - -val is_empty2 : (_, _) t2 -> bool - -val length2 : (_, _) t2 -> int - -val zip : ('a, 'b) t2 -> ('a * 'b) t - -val unzip : ('a * 'b) t -> ('a, 'b) t2 - -val zip_i : 'a t -> (int, 'a) t2 - (** Zip elements of the sequence with their index in the sequence *) - -val fold2 : ('c -> 'a -> 'b -> 'c) -> 'c -> ('a, 'b) t2 -> 'c - -val iter2 : ('a -> 'b -> unit) -> ('a, 'b) t2 -> unit - -val map2 : ('a -> 'b -> 'c) -> ('a, 'b) t2 -> 'c t - -val map2_2 : ('a -> 'b -> 'c) -> ('a -> 'b -> 'd) -> ('a, 'b) t2 -> ('c, 'd) t2 - (** [map2_2 f g seq2] maps each [x, y] of seq2 into [f x y, g x y] *) - -(** {2 Basic data structures converters} *) - -val to_list : 'a t -> 'a list - (** Convert the sequence into a list. Preserves order of elements. - This function is tail-recursive, but consumes 2*n memory. - If order doesn't matter to you, consider {!to_rev_list}. *) - -val to_rev_list : 'a t -> 'a list - (** Get the list of the reversed sequence (more efficient than {!to_list}) *) - -val of_list : 'a list -> 'a t - -val on_list : ('a t -> 'b t) -> 'a list -> 'b list -(** [on_list f l] is equivalent to [to_list @@ f @@ of_list l]. - @since 0.5.2 -*) - -val to_opt : 'a t -> 'a option - (** Alias to {!head} - @since 0.5.1 *) - -val to_array : 'a t -> 'a array - (** Convert to an array. Currently not very efficient because - an intermediate list is used. *) - -val of_array : 'a array -> 'a t - -val of_array_i : 'a array -> (int * 'a) t - (** Elements of the array, with their index *) - -val of_array2 : 'a array -> (int, 'a) t2 - -val array_slice : 'a array -> int -> int -> 'a t - (** [array_slice a i j] Sequence of elements whose indexes range - from [i] to [j] *) - -val of_opt : 'a option -> 'a t - (** Iterate on 0 or 1 values. - @since 0.5.1 *) - -val of_stream : 'a Stream.t -> 'a t - (** Sequence of elements of a stream (usable only once) *) - -val to_stream : 'a t -> 'a Stream.t - (** Convert to a stream. linear in memory and time (a copy is made in memory) *) - -val to_stack : 'a Stack.t -> 'a t -> unit - (** Push elements of the sequence on the stack *) - -val of_stack : 'a Stack.t -> 'a t - (** Sequence of elements of the stack (same order as [Stack.iter]) *) - -val to_queue : 'a Queue.t -> 'a t -> unit - (** Push elements of the sequence into the queue *) - -val of_queue : 'a Queue.t -> 'a t - (** Sequence of elements contained in the queue, FIFO order *) - -val hashtbl_add : ('a, 'b) Hashtbl.t -> ('a * 'b) t -> unit - (** Add elements of the sequence to the hashtable, with - Hashtbl.add *) - -val hashtbl_replace : ('a, 'b) Hashtbl.t -> ('a * 'b) t -> unit - (** Add elements of the sequence to the hashtable, with - Hashtbl.replace (erases conflicting bindings) *) - -val to_hashtbl : ('a * 'b) t -> ('a, 'b) Hashtbl.t - (** Build a hashtable from a sequence of key/value pairs *) - -val to_hashtbl2 : ('a, 'b) t2 -> ('a, 'b) Hashtbl.t - (** Build a hashtable from a sequence of key/value pairs *) - -val of_hashtbl : ('a, 'b) Hashtbl.t -> ('a * 'b) t - (** Sequence of key/value pairs from the hashtable *) - -val of_hashtbl2 : ('a, 'b) Hashtbl.t -> ('a, 'b) t2 - (** Sequence of key/value pairs from the hashtable *) - -val hashtbl_keys : ('a, 'b) Hashtbl.t -> 'a t -val hashtbl_values : ('a, 'b) Hashtbl.t -> 'b t - -val of_str : string -> char t -val to_str : char t -> string - -val concat_str : string t -> string - (** Concatenate strings together, eagerly. - Also see {!intersperse} to add a separator. - @since 0.5 *) - -exception OneShotSequence - (** Raised when the user tries to iterate several times on - a transient iterator *) - -val of_in_channel : in_channel -> char t - (** Iterates on characters of the input (can block when one - iterates over the sequence). If you need to iterate - several times on this sequence, use {!persistent}. - @raise OneShotSequence when used more than once. *) - -val to_buffer : char t -> Buffer.t -> unit - (** Copy content of the sequence into the buffer *) - -val int_range : start:int -> stop:int -> int t - (** Iterator on integers in [start...stop] by steps 1. Also see - {!(--)} for an infix version. *) - -val int_range_dec : start:int -> stop:int -> int t - (** Iterator on decreasing integers in [stop...start] by steps -1. - See {!(--^)} for an infix version *) - -val of_set : (module Set.S with type elt = 'a and type t = 'b) -> 'b -> 'a t - (** Convert the given set to a sequence. The set module must be provided. *) - -val to_set : (module Set.S with type elt = 'a and type t = 'b) -> 'a t -> 'b - (** Convert the sequence to a set, given the proper set module *) - -type 'a gen = unit -> 'a option -type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] - -val of_gen : 'a gen -> 'a t - (** Traverse eagerly the generator and build a sequence from it *) - -val to_gen : 'a t -> 'a gen - (** Make the sequence persistent (O(n)) and then iterate on it. Eager. *) - -val of_klist : 'a klist -> 'a t - (** Iterate on the lazy list *) - -val to_klist : 'a t -> 'a klist - (** Make the sequence persistent and then iterate on it. Eager. *) - -(** {2 Functorial conversions between sets and sequences} *) - -module Set : sig - module type S = sig - include Set.S - val of_seq : elt sequence -> t - val to_seq : t -> elt sequence - val to_list : t -> elt list - val of_list : elt list -> t - end - - (** Create an enriched Set module from the given one *) - module Adapt(X : Set.S) : S with type elt = X.elt and type t = X.t - - (** Functor to build an extended Set module from an ordered type *) - module Make(X : Set.OrderedType) : S with type elt = X.t -end - -(** {2 Conversion between maps and sequences.} *) - -module Map : sig - module type S = sig - include Map.S - val to_seq : 'a t -> (key * 'a) sequence - val of_seq : (key * 'a) sequence -> 'a t - val keys : 'a t -> key sequence - val values : 'a t -> 'a sequence - val to_list : 'a t -> (key * 'a) list - val of_list : (key * 'a) list -> 'a t - end - - (** Adapt a pre-existing Map module to make it sequence-aware *) - module Adapt(M : Map.S) : S with type key = M.key and type 'a t = 'a M.t - - (** Create an enriched Map module, with sequence-aware functions *) - module Make(V : Map.OrderedType) : S with type key = V.t -end - -(** {2 Infinite sequences of random values} *) - -val random_int : int -> int t - (** Infinite sequence of random integers between 0 and - the given higher bound (see Random.int) *) - -val random_bool : bool t - (** Infinite sequence of random bool values *) - -val random_float : float -> float t - -val random_array : 'a array -> 'a t - (** Sequence of choices of an element in the array *) - -val random_list : 'a list -> 'a t - (** Infinite sequence of random elements of the list. Basically the - same as {!random_array}. *) - -(** {2 Infix functions} *) - -module Infix : sig - val (--) : int -> int -> int t - (** [a -- b] is the range of integers from [a] to [b], both included, - in increasing order. It will therefore be empty if [a > b]. *) - - val (--^) : int -> int -> int t - (** [a --^ b] is the range of integers from [b] to [a], both included, - in decreasing order (starts from [a]). - It will therefore be empty if [a < b]. *) - - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - (** Monadic bind (infix version of {!flat_map} - @since 0.5 *) - - val (>|=) : 'a t -> ('a -> 'b) -> 'b t - (** Infix version of {!map} - @since 0.5 *) - - val (<*>) : ('a -> 'b) t -> 'a t -> 'b t - (** Applicative operator (product+application) - @since 0.5 *) - - val (<+>) : 'a t -> 'a t -> 'a t - (** Concatenation of sequences - @since 0.5 *) -end - -include module type of Infix - - -(** {2 Pretty printing of sequences} *) - -val pp_seq : ?sep:string -> (Format.formatter -> 'a -> unit) -> - Format.formatter -> 'a t -> unit - (** Pretty print a sequence of ['a], using the given pretty printer - to print each elements. An optional separator string can be provided. *) - -val pp_buf : ?sep:string -> (Buffer.t -> 'a -> unit) -> - Buffer.t -> 'a t -> unit - (** Print into a buffer *) - -val to_string : ?sep:string -> ('a -> string) -> 'a t -> string - (** Print into a string *) - -(** {2 Basic IO} - -Very basic interface to manipulate files as sequence of chunks/lines. The -sequences take care of opening and closing files properly; every time -one iterates over a sequence, the file is opened/closed again. - -Example: copy a file ["a"] into file ["b"], removing blank lines: - -{[ - Sequence.(IO.lines_of "a" |> filter (fun l-> l<> "") |> IO.write_lines "b");; -]} - -By chunks of [4096] bytes: - -{[ - Sequence.IO.(chunks_of ~size:4096 "a" |> write_to "b");; -]} - -Read the lines of a file into a list: - -{[ - Sequence.IO.lines "a" |> Sequence.to_list -]} - -@since 0.5.1 *) - -module IO : sig - val lines_of : ?mode:int -> ?flags:open_flag list -> - string -> string t - (** [lines_of filename] reads all lines of the given file. It raises the - same exception as would opening the file and read from it, except - from [End_of_file] (which is caught). The file is {b always} properly - closed. - Every time the sequence is iterated on, the file is opened again, so - different iterations might return different results - @param mode default [0o644] - @param flags default: [[Open_rdonly]] *) - - val chunks_of : ?mode:int -> ?flags:open_flag list -> ?size:int -> - string -> string t - (** Read chunks of the given [size] from the file. The last chunk might be - smaller. Behaves like {!lines_of} regarding errors and options. - Every time the sequence is iterated on, the file is opened again, so - different iterations might return different results *) - - val write_to : ?mode:int -> ?flags:open_flag list -> - string -> string t -> unit - (** [write_to filename seq] writes all strings from [seq] into the given - file. It takes care of opening and closing the file. - @param mode default [0o644] - @param flags used by [open_out_gen]. Default: [[Open_creat;Open_wronly]]. *) - - val write_bytes_to : ?mode:int -> ?flags:open_flag list -> - string -> Bytes.t t -> unit - (** @since 0.5.4 *) - - val write_lines : ?mode:int -> ?flags:open_flag list -> - string -> string t -> unit - (** Same as {!write_to}, but intercales ['\n'] between each string *) - - val write_bytes_lines : ?mode:int -> ?flags:open_flag list -> - string -> Bytes.t t -> unit - (** @since 0.5.4 *) -end diff --git a/sequence/sequence.mllib b/sequence/sequence.mllib deleted file mode 100644 index 2f635d2a..00000000 --- a/sequence/sequence.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5) -Sequence -# OASIS_STOP diff --git a/sequence/sequence.odocl b/sequence/sequence.odocl deleted file mode 100644 index 2f635d2a..00000000 --- a/sequence/sequence.odocl +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 3ff39d3acb327553070a64ef0cb321d5) -Sequence -# OASIS_STOP diff --git a/sequence/setup.ml b/sequence/setup.ml deleted file mode 100644 index fe8169fe..00000000 --- a/sequence/setup.ml +++ /dev/null @@ -1,37 +0,0 @@ -(* setup.ml generated for the first time by OASIS v0.4.4 *) - -(* OASIS_START *) -(* DO NOT EDIT (digest: 9852805d5c19ca1cb6abefde2dcea323) *) -(******************************************************************************) -(* OASIS: architecture for building OCaml libraries and applications *) -(* *) -(* Copyright (C) 2011-2013, Sylvain Le Gall *) -(* Copyright (C) 2008-2011, OCamlCore SARL *) -(* *) -(* This library is free software; you can redistribute it and/or modify it *) -(* under the terms of the GNU Lesser General Public License as published by *) -(* the Free Software Foundation; either version 2.1 of the License, or (at *) -(* your option) any later version, with the OCaml static compilation *) -(* exception. *) -(* *) -(* This library is distributed in the hope that it will be useful, but *) -(* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *) -(* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *) -(* details. *) -(* *) -(* You should have received a copy of the GNU Lesser General Public License *) -(* along with this library; if not, write to the Free Software Foundation, *) -(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) -(******************************************************************************) - -let () = - try - Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") - with Not_found -> () -;; -#use "topfind";; -#require "oasis.dynrun";; -open OASISDynRun;; - -(* OASIS_STOP *) -let () = setup ();; diff --git a/sequence/tests/run_tests.ml b/sequence/tests/run_tests.ml deleted file mode 100644 index 0fa3d58c..00000000 --- a/sequence/tests/run_tests.ml +++ /dev/null @@ -1,9 +0,0 @@ - -open OUnit - -let suite = - "run_tests" >::: - [ Test_sequence.suite; ] - -let _ = - OUnit.run_test_tt_main suite diff --git a/sequence/tests/test_sequence.ml b/sequence/tests/test_sequence.ml deleted file mode 100644 index 30f0f1c9..00000000 --- a/sequence/tests/test_sequence.ml +++ /dev/null @@ -1,235 +0,0 @@ - -open OUnit - -module S = Sequence - -let pp_ilist l = - let b = Buffer.create 15 in - let fmt = Format.formatter_of_buffer b in - Format.fprintf fmt "@[%a@]" (S.pp_seq Format.pp_print_int) (S.of_list l); - Buffer.contents b - -let test_empty () = - let seq = S.empty in - OUnit.assert_bool "empty" (S.is_empty seq); - OUnit.assert_bool "empty" - (try S.iter (fun _ -> raise Exit) seq; true with Exit -> false); - () - -let test_repeat () = - let seq = S.repeat "hello" in - OUnit.assert_equal ["hello"; "hello"; "hello"] - (seq |> S.take 3 |> S.to_list); - () - -let test_concat () = - let s1 = S.(1 -- 5) in - let s2 = S.(6 -- 10) in - let l = [1;2;3;4;5;6;7;8;9;10] in - OUnit.assert_equal l (S.to_list (S.append s1 s2)); - () - -let test_fold () = - let n = S.(1 -- 10) - |> S.fold (+) 0 in - OUnit.assert_equal 55 n; - () - -let test_foldi () = - let l = ["hello"; "world"] - |> S.of_list - |> S.foldi (fun acc i x -> (i,x) :: acc) [] in - OUnit.assert_equal [1, "world"; 0, "hello"] l; - () - -let test_exists () = - S.(1 -- 100) - |> S.exists (fun x -> x = 59) - |> OUnit.assert_bool "exists"; - S.(1 -- 100) - |> S.exists (fun x -> x < 0) - |> (fun x -> not x) - |> OUnit.assert_bool "not exists"; - () - -let test_length () = - S.(1 -- 1000) |> S.length |> OUnit.assert_equal 1000 - -let test_concat2 () = - S.(1 -- 1000) - |> S.map (fun i -> S.(i -- (i+1))) - |> S.concat - |> S.length - |> OUnit.assert_equal 2000 - -let test_flatMap () = - S.(1 -- 1000) - |> S.flatMap (fun i -> S.(i -- (i+1))) - |> S.length - |> OUnit.assert_equal 2000 - -let test_intersperse () = - S.(1 -- 100) - |> (fun seq -> S.intersperse 0 seq) - |> S.take 10 - |> S.to_list - |> OUnit.assert_equal [1;0;2;0;3;0;4;0;5;0] - -let test_not_persistent () = - let printer = pp_ilist in - let stream = Stream.from (fun i -> if i < 5 then Some i else None) in - let seq = S.of_stream stream in - OUnit.assert_equal ~printer [0;1;2;3;4] (seq |> S.to_list); - OUnit.assert_equal ~printer [] (seq |> S.to_list); - () - -let test_persistent () = - let printer = pp_ilist in - let stream = Stream.from (fun i -> if i < 5 then Some i else None) in - let seq = S.of_stream stream in - (* consume seq into a persistent version of itself *) - let seq' = S.persistent seq in - OUnit.assert_equal ~printer [] (seq |> S.to_list); - OUnit.assert_equal ~printer [0;1;2;3;4] (seq' |> S.to_list); - OUnit.assert_equal ~printer [0;1;2;3;4] (seq' |> S.to_list); - OUnit.assert_equal ~printer [0;1;2;3;4] (seq' |> S.to_stream |> S.of_stream |> S.to_list); - () - -let test_big_persistent () = - let printer = pp_ilist in - let seq = S.(0 -- 10_000) in - let seq' = S.persistent seq in - OUnit.assert_equal 10_001 (S.length seq'); - OUnit.assert_equal 10_001 (S.length seq'); - OUnit.assert_equal ~printer [0;1;2;3] (seq' |> S.take 4 |> S.to_list); - () - -let test_sort () = - S.(1 -- 100) - |> S.sort ~cmp:(fun i j -> j - i) - |> S.take 4 - |> S.to_list - |> OUnit.assert_equal [100;99;98;97] - -let test_sort_uniq () = - [42;1;2;3;4;5;4;3;2;1] - |> S.of_list - |> S.sort_uniq ?cmp:None - |> S.to_list - |> OUnit.assert_equal [1;2;3;4;5;42] - -let test_group () = - [1;2;3;3;2;2;3;4] - |> S.of_list |> S.group ?eq:None |> S.to_list - |> OUnit.assert_equal [[1];[2];[3;3];[2;2];[3];[4]] - -let test_uniq () = - [1;2;2;3;4;4;4;3;3] - |> S.of_list |> S.uniq ?eq:None |> S.to_list - |> OUnit.assert_equal [1;2;3;4;3] - -let test_product () = - let stream = Stream.from (fun i -> if i < 3 then Some i else None) in - let a = S.of_stream stream in - let b = S.of_list ["a";"b";"c"] in - let s = S.product a b |> S.map (fun (x,y) -> y,x) - |> S.to_list |> List.sort compare in - OUnit.assert_equal ["a",0; "a", 1; "a", 2; - "b",0; "b", 1; "b", 2; - "c",0; "c", 1; "c", 2;] s - -let test_join () = - let s1 = S.(1 -- 3) in - let s2 = S.of_list ["1"; "2"] in - let join_row i j = - if string_of_int i = j then Some (string_of_int i ^ " = " ^ j) else None - in - let s = S.join ~join_row s1 s2 in - OUnit.assert_equal ["1 = 1"; "2 = 2"] (S.to_list s); - () - -let test_scan () = - S.(1 -- 5) - |> S.scan (+) 0 - |> S.to_list - |> OUnit.assert_equal ~printer:pp_ilist [0;1;3;6;10;15] - -let test_drop () = - S.(1 -- 5) |> S.drop 2 |> S.to_list |> OUnit.assert_equal [3;4;5] - -let test_rev () = - S.(1 -- 5) |> S.rev |> S.to_list |> OUnit.assert_equal [5;4;3;2;1] - -let test_unfoldr () = - let f x = if x < 5 then Some (string_of_int x,x+1) else None in - S.unfoldr f 0 - |> S.to_list - |> OUnit.assert_equal ["0"; "1"; "2"; "3"; "4"] - -let test_hashtbl () = - let h = S.(1 -- 5) - |> S.zip_i - |> S.to_hashtbl2 in - S.(0 -- 4) - |> S.iter (fun i -> OUnit.assert_equal (i+1) (Hashtbl.find h i)); - OUnit.assert_equal [0;1;2;3;4] (S.hashtbl_keys h |> S.sort ?cmp:None |> S.to_list); - () - -let test_buff () = - let b = Buffer.create 4 in - "hello world" - |> S.of_str |> S.rev |> S.map Char.uppercase - |> (fun seq -> S.to_buffer seq b); - OUnit.assert_equal "DLROW OLLEH" (Buffer.contents b); - () - -let test_int_range () = - OUnit.assert_equal ~printer:pp_ilist [1;2;3;4] S.(to_list (1--4)); - OUnit.assert_equal ~printer:pp_ilist [10;9;8;7;6] S.(to_list (10 --^ 6)); - OUnit.assert_equal ~printer:pp_ilist [] S.(to_list (10--4)); - OUnit.assert_equal ~printer:pp_ilist [] S.(to_list (10 --^ 60)); - () - -let test_take () = - let l = S.(to_list (take 0 (of_list [1]))) in - OUnit.assert_equal ~printer:pp_ilist [] l; - let l = S.(to_list (take 5 (of_list [1;2;3;4;5;6;7;8;9;10]))) in - OUnit.assert_equal ~printer:pp_ilist [1;2;3;4;5] l; - () - -let test_regression1 () = - let s = S.(take 10 (repeat 1)) in - OUnit.assert_bool "not empty" (not (S.is_empty s)); - () - -let suite = - "test_sequence" >::: - [ "test_empty" >:: test_empty; - "test_repeat" >:: test_repeat; - "test_concat" >:: test_concat; - "test_concat2" >:: test_concat2; - "test_fold" >:: test_fold; - "test_foldi" >:: test_foldi; - "test_exists" >:: test_exists; - "test_length" >:: test_length; - "test_concat" >:: test_concat; - "test_flatMap" >:: test_flatMap; - "test_intersperse" >:: test_intersperse; - "test_not_persistent" >:: test_not_persistent; - "test_persistent" >:: test_persistent; - "test_big_persistent" >:: test_big_persistent; - "test_sort" >:: test_sort; - "test_sort_uniq" >:: test_sort; - "test_group" >:: test_group; - "test_uniq" >:: test_uniq; - "test_product" >:: test_product; - "test_join" >:: test_join; - "test_scan" >:: test_scan; - "test_drop" >:: test_drop; - "test_rev" >:: test_rev; - "test_unfoldr" >:: test_unfoldr; - "test_hashtbl" >:: test_hashtbl; - "test_int_range" >:: test_int_range; - "test_take" >:: test_take; - "test_regression1" >:: test_regression1; - ] diff --git a/setup.ml b/setup.ml index 883fd52e..74763e94 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 4828f89967677c4737a4a949042a8d4c) *) +(* DO NOT EDIT (digest: 43c616e040b0bb8b601c67da9e06ec15) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6819,31 +6819,11 @@ let setup_t = ("containers", OCamlbuildDocPlugin.doc_build { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_misc", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_string", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_advanced", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_lwt", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; + OCamlbuildDocPlugin.extra_args = + [ + "-use-ocamlfind"; + "-docflags '-colorize-code -short-functors -charset utf-8'" + ]; run_path = "." }) ]; @@ -6866,31 +6846,11 @@ let setup_t = ("containers", OCamlbuildDocPlugin.doc_clean { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_misc", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_string", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_advanced", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_lwt", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; + OCamlbuildDocPlugin.extra_args = + [ + "-use-ocamlfind"; + "-docflags '-colorize-code -short-functors -charset utf-8'" + ]; run_path = "." }) ]; @@ -6912,10 +6872,10 @@ let setup_t = oasis_version = "0.4"; ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1"); findlib_version = None; - alpha_features = []; + alpha_features = ["ocamlbuild_more_args"]; beta_features = []; name = "containers"; - version = "0.6.1"; + version = "0.7"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6986,18 +6946,6 @@ let setup_t = "Build the misc library, containing everything from the rotating kitchen sink to automatic banana distributors"; flag_default = [(OASISExpr.EBool true, false)] }); - Flag - ({ - cs_name = "cgi"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some - "Build modules related to FastCGI, depending on CamlGI"; - flag_default = [(OASISExpr.EBool true, false)] - }); Flag ({ cs_name = "lwt"; @@ -7030,6 +6978,17 @@ let setup_t = flag_description = Some "Build and run benchmarks"; flag_default = [(OASISExpr.EBool true, false)] }); + Flag + ({ + cs_name = "bigarray"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + flag_description = + Some "Build modules that depend on bigarrays"; + flag_default = [(OASISExpr.EBool true, false)] + }); Library ({ cs_name = "containers"; @@ -7039,7 +6998,7 @@ let setup_t = { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "core"; + bs_path = "src/core"; bs_compiled_object = Best; bs_build_depends = [FindlibPackage ("bytes", None)]; bs_build_tools = [ExternalTool "ocamlbuild"]; @@ -7056,16 +7015,7 @@ let setup_t = lib_modules = [ "CCVector"; - "CCDeque"; - "CCGen"; - "Gen_intf"; - "CCSequence"; - "CCFQueue"; - "CCMultiMap"; - "CCMultiSet"; - "CCBV"; "CCPrint"; - "CCPersistentHashtbl"; "CCError"; "CCHeap"; "CCList"; @@ -7073,22 +7023,15 @@ let setup_t = "CCPair"; "CCFun"; "CCHash"; - "CCKList"; "CCInt"; "CCBool"; "CCFloat"; "CCArray"; "CCOrd"; - "CCIO"; "CCRandom"; - "CCKTree"; - "CCTrie"; "CCString"; "CCHashtbl"; - "CCFlatHashtbl"; - "CCSexp"; - "CCMap"; - "CCCache" + "CCMap" ]; lib_pack = false; lib_internal_modules = []; @@ -7096,6 +7039,138 @@ let setup_t = lib_findlib_name = None; lib_findlib_containers = [] }); + Library + ({ + cs_name = "containers_io"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "src/io"; + bs_compiled_object = Best; + bs_build_depends = [FindlibPackage ("bytes", 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 = ["CCIO"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "containers"; + lib_findlib_name = Some "io"; + lib_findlib_containers = [] + }); + Library + ({ + cs_name = "containers_sexp"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "src/sexp"; + bs_compiled_object = Best; + bs_build_depends = [FindlibPackage ("bytes", 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 = ["CCSexp"; "CCSexpStream"; "CCSexpM"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "containers"; + lib_findlib_name = Some "sexp"; + lib_findlib_containers = [] + }); + Library + ({ + cs_name = "containers_data"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "src/data"; + 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 = + [ + "CCMultiMap"; + "CCMultiSet"; + "CCTrie"; + "CCFlatHashtbl"; + "CCCache"; + "CCPersistentHashtbl"; + "CCDeque"; + "CCFQueue"; + "CCBV"; + "CCMixtbl" + ]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "containers"; + lib_findlib_name = Some "data"; + lib_findlib_containers = [] + }); + Library + ({ + cs_name = "containers_iter"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "src/iter"; + 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 = ["CCKTree"; "CCKList"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "containers"; + lib_findlib_name = Some "iter"; + lib_findlib_containers = [] + }); Library ({ cs_name = "containers_string"; @@ -7105,7 +7180,7 @@ let setup_t = { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "string"; + bs_path = "src/string"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "ocamlbuild"]; @@ -7135,9 +7210,13 @@ let setup_t = { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "advanced"; + bs_path = "src/advanced"; bs_compiled_object = Best; - bs_build_depends = [InternalLibrary "containers"]; + bs_build_depends = + [ + InternalLibrary "containers"; + FindlibPackage ("sequence", None) + ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -7157,6 +7236,41 @@ let setup_t = lib_findlib_name = Some "advanced"; lib_findlib_containers = [] }); + Library + ({ + cs_name = "containers_bigarray"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "src/bigarray"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "containers"; + FindlibPackage ("bigarray", None); + FindlibPackage ("bytes", 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 = ["CCBigstring"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "containers"; + lib_findlib_name = Some "bigarray"; + lib_findlib_containers = [] + }); Library ({ cs_name = "containers_pervasives"; @@ -7166,7 +7280,7 @@ let setup_t = { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "pervasives"; + bs_path = "src/pervasives"; bs_compiled_object = Best; bs_build_depends = [InternalLibrary "containers"]; bs_build_tools = [ExternalTool "ocamlbuild"]; @@ -7196,12 +7310,12 @@ let setup_t = { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "misc"; + bs_path = "src/misc"; bs_compiled_object = Best; bs_build_depends = [ - FindlibPackage ("unix", None); - InternalLibrary "containers" + InternalLibrary "containers"; + InternalLibrary "containers_data" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7245,8 +7359,7 @@ let setup_t = "Ty"; "Cause"; "AVL"; - "ParseReact"; - "Mixtbl" + "ParseReact" ]; lib_pack = true; lib_internal_modules = []; @@ -7271,7 +7384,7 @@ let setup_t = (OASISExpr.EBool true, false); (OASISExpr.EFlag "thread", true) ]; - bs_path = "threads/"; + bs_path = "src/threads/"; bs_compiled_object = Best; bs_build_depends = [ @@ -7317,13 +7430,12 @@ let setup_t = (OASISExpr.EFlag "lwt", OASISExpr.EFlag "misc"), true) ]; - bs_path = "lwt"; + bs_path = "src/lwt"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "containers"; FindlibPackage ("lwt", None); - FindlibPackage ("lwt.unix", None); InternalLibrary "containers_misc" ]; bs_build_tools = [ExternalTool "ocamlbuild"]; @@ -7337,55 +7449,13 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["Behavior"; "Lwt_automaton"; "Lwt_actor"]; + lib_modules = ["Lwt_automaton"; "Lwt_actor"]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = Some "containers"; lib_findlib_name = Some "lwt"; lib_findlib_containers = [] }); - Library - ({ - cs_name = "containers_cgi"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "cgi", true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "cgi", true) - ]; - bs_path = "cgi"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("CamlGI", 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 = ["ToWeb"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "cgi"; - lib_findlib_containers = [] - }); Doc ({ cs_name = "containers"; @@ -7414,118 +7484,6 @@ let setup_t = doc_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] }); - Doc - ({ - cs_name = "containers_misc"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "Containers_misc docs"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Doc - ({ - cs_name = "containers_string"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "Containers_string docs"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Doc - ({ - cs_name = "containers_advanced"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "Containers_advanced docs"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Doc - ({ - cs_name = "containers_lwt"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "Containers_lwt docs"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); Executable ({ cs_name = "run_benchs"; @@ -7549,7 +7507,11 @@ let setup_t = InternalLibrary "containers"; InternalLibrary "containers_misc"; InternalLibrary "containers_advanced"; + InternalLibrary "containers_data"; InternalLibrary "containers_string"; + InternalLibrary "containers_iter"; + FindlibPackage ("sequence", None); + FindlibPackage ("gen", None); FindlibPackage ("benchmark", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; @@ -7615,7 +7577,8 @@ let setup_t = bs_build_depends = [ InternalLibrary "containers"; - FindlibPackage ("benchmark", None) + FindlibPackage ("benchmark", None); + FindlibPackage ("gen", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7661,43 +7624,6 @@ let setup_t = }, {exec_custom = false; exec_main_is = "test_levenshtein.ml" }); - Executable - ({ - cs_name = "test_lwt"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "lwt"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/lwt/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("lwt", None); - FindlibPackage ("lwt.unix", None); - FindlibPackage ("oUnit", None); - InternalLibrary "containers_lwt" - ]; - 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 = "test_Behavior.ml"}); Executable ({ cs_name = "test_threads"; @@ -7754,6 +7680,13 @@ let setup_t = InternalLibrary "containers"; InternalLibrary "containers_misc"; InternalLibrary "containers_string"; + InternalLibrary "containers_iter"; + InternalLibrary "containers_io"; + InternalLibrary "containers_advanced"; + InternalLibrary "containers_sexp"; + InternalLibrary "containers_bigarray"; + FindlibPackage ("sequence", None); + FindlibPackage ("gen", None); FindlibPackage ("oUnit", None); FindlibPackage ("QTest2Lib", None) ]; @@ -7789,7 +7722,10 @@ let setup_t = bs_build_depends = [ InternalLibrary "containers"; + InternalLibrary "containers_data"; FindlibPackage ("oUnit", None); + FindlibPackage ("sequence", None); + FindlibPackage ("gen", None); FindlibPackage ("qcheck", None); InternalLibrary "containers_misc" ]; @@ -7838,39 +7774,6 @@ let setup_t = InternalExecutable "run_qtest" ] }); - Executable - ({ - cs_name = "web_pwd"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "cgi", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "examples/cgi/"; - bs_compiled_object = Byte; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_cgi"; - FindlibPackage ("threads", None); - FindlibPackage ("CamlGI", 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 = "web_pwd.ml"}); Executable ({ cs_name = "lambda"; @@ -7917,7 +7820,7 @@ let setup_t = bs_install = [(OASISExpr.EBool true, false)]; bs_path = "examples/"; bs_compiled_object = Native; - bs_build_depends = [InternalLibrary "containers"]; + bs_build_depends = [InternalLibrary "containers_sexp"]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -7929,6 +7832,33 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "id_sexp.ml"}); + Executable + ({ + cs_name = "id_sexp2"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "misc", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples/"; + bs_compiled_object = Native; + bs_build_depends = [InternalLibrary "containers_sexp"]; + 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 = "id_sexp2.ml"}); SrcRepo ({ cs_name = "head"; @@ -7956,7 +7886,8 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "\224Im\201\235\195\005\221\244\022\209\165\168XI>"; + oasis_digest = + Some "\031\146\017A\213\149\236\192\252\238\156-\202*`\143"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7964,6 +7895,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7968 "setup.ml" +# 7899 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/advanced/CCBatch.ml b/src/advanced/CCBatch.ml similarity index 100% rename from advanced/CCBatch.ml rename to src/advanced/CCBatch.ml diff --git a/advanced/CCBatch.mli b/src/advanced/CCBatch.mli similarity index 100% rename from advanced/CCBatch.mli rename to src/advanced/CCBatch.mli diff --git a/advanced/CCCat.ml b/src/advanced/CCCat.ml similarity index 100% rename from advanced/CCCat.ml rename to src/advanced/CCCat.ml diff --git a/advanced/CCCat.mli b/src/advanced/CCCat.mli similarity index 100% rename from advanced/CCCat.mli rename to src/advanced/CCCat.mli diff --git a/advanced/CCLinq.ml b/src/advanced/CCLinq.ml similarity index 90% rename from advanced/CCLinq.ml rename to src/advanced/CCLinq.ml index 17cf74de..fd2e79a1 100644 --- a/advanced/CCLinq.ml +++ b/src/advanced/CCLinq.ml @@ -38,12 +38,12 @@ let _id x = x exception ExitWithError of string let _exit_with_error s = raise (ExitWithError s) -let _error_of_exn f = try `Ok (f ()) with ExitWithError s -> `Error +let _error_of_exn f = try `Ok (f ()) with ExitWithError s -> `Error s type 'a collection = | Seq : 'a sequence -> 'a collection | List : 'a list -> 'a collection - | Set : (module CCSequence.Set.S + | Set : (module Sequence.Set.S with type elt = 'a and type t = 'b) * 'b -> 'a collection module PMap = struct @@ -103,7 +103,7 @@ module PMap = struct } let make_cmp (type key) ?(cmp=Pervasives.compare) () = - let module M = CCSequence.Map.Make(struct + let module M = Sequence.Map.Make(struct type t = key let compare = cmp end) in @@ -167,26 +167,26 @@ module PMap = struct | None -> None | Some v -> Some (f v) ); - to_seq = CCSequence.map (fun (x,y) -> x, f y) m.to_seq; + to_seq = Sequence.map (fun (x,y) -> x, f y) m.to_seq; fold = (fun f' acc -> m.fold (fun acc x y -> f' acc x (f y)) acc ); } - let to_list m = CCSequence.to_rev_list m.to_seq + let to_list m = Sequence.to_rev_list m.to_seq let to_coll m = Seq m.to_seq let reverse ~build m = let build = make ~build () in - let seq = CCSequence.map (fun (x,y) -> y,x) (to_seq m) in + let seq = Sequence.map (fun (x,y) -> y,x) (to_seq m) in multimap_of_seq ~build seq let reverse_multimap ~build m = let build = make ~build () in let seq = to_seq m in - let seq = CCSequence.flat_map - (fun (x,l) -> CCSequence.map (fun y -> y,x) (CCSequence.of_list l) + let seq = Sequence.flat_map + (fun (x,l) -> Sequence.map (fun y -> y,x) (Sequence.of_list l) ) seq in multimap_of_seq ~build seq @@ -211,10 +211,10 @@ type ('a,'b) group_join_descr = { module Coll = struct let of_seq s = Seq s let of_list l = List l - let of_array a = Seq (CCSequence.of_array a) + let of_array a = Seq (Sequence.of_array a) let set_of_seq (type elt) ?(cmp=Pervasives.compare) seq = - let module S = CCSequence.Set.Make(struct + let module S = Sequence.Set.Make(struct type t = elt let compare = cmp end) in @@ -225,15 +225,15 @@ module Coll = struct | Seq s -> s | List l -> (fun k -> List.iter k l) | Set (m, set) -> - let module S = (val m : CCSequence.Set.S + let module S = (val m : Sequence.Set.S with type elt = elt and type t = 'b) in S.to_seq set let to_list (type elt) = function - | Seq s -> CCSequence.to_list s + | Seq s -> Sequence.to_list s | List l -> l | Set (m, set) -> - let module S = (val m : CCSequence.Set.S + let module S = (val m : Sequence.Set.S with type elt = elt and type t = 'b) in S.elements set @@ -245,30 +245,30 @@ module Coll = struct let fold (type elt) f acc c = match c with | List l -> List.fold_left f acc l - | Seq s -> CCSequence.fold f acc s + | Seq s -> Sequence.fold f acc s | Set (m, set) -> - let module S = (val m : CCSequence.Set.S + let module S = (val m : Sequence.Set.S with type elt = elt and type t = 'b) in S.fold (fun x acc -> f acc x) set acc let map f c = - _fmap ~lst:(List.map f) ~seq:(CCSequence.map f) c + _fmap ~lst:(List.map f) ~seq:(Sequence.map f) c let filter p c = - _fmap ~lst:(List.filter p) ~seq:(CCSequence.filter p) c + _fmap ~lst:(List.filter p) ~seq:(Sequence.filter p) c let flat_map f c = let c' = to_seq c in - Seq (CCSequence.flatMap (fun x -> to_seq (f x)) c') + Seq (Sequence.flatMap (fun x -> to_seq (f x)) c') let filter_map f c = - _fmap ~lst:(CCList.filter_map f) ~seq:(CCSequence.fmap f) c + _fmap ~lst:(CCList.filter_map f) ~seq:(Sequence.fmap f) c let size (type elt) = function | List l -> List.length l - | Seq s -> CCSequence.length s + | Seq s -> Sequence.length s | Set (m, set) -> - let module S = (val m : CCSequence.Set.S + let module S = (val m : Sequence.Set.S with type elt = elt and type t = 'b) in S.cardinal set @@ -278,12 +278,12 @@ module Coll = struct | List [] -> fail () | List (x::_) -> x | Seq s -> - begin match CCSequence.to_list (CCSequence.take 1 s) with + begin match Sequence.to_list (Sequence.take 1 s) with | [x] -> x | _ -> fail () end | Set (m, set) -> - let module S = (val m : CCSequence.Set.S + let module S = (val m : Sequence.Set.S with type elt = elt and type t = 'b) in try S.choose set with Not_found -> fail () @@ -292,7 +292,7 @@ module Coll = struct with ExitWithError s -> `Error s let take n c = - _fmap ~lst:(CCList.take n) ~seq:(CCSequence.take n) c + _fmap ~lst:(CCList.take n) ~seq:(Sequence.take n) c exception MySurpriseExit @@ -308,7 +308,7 @@ module Coll = struct let sort cmp c = match c with | List l -> List (List.sort cmp l) - | Seq s -> List (List.sort cmp (CCSequence.to_rev_list s)) + | Seq s -> List (List.sort cmp (Sequence.to_rev_list s)) | _ -> set_of_seq ~cmp (to_seq c) let search obj c = @@ -328,9 +328,9 @@ module Coll = struct let contains (type elt) ~eq x c = match c with | List l -> List.exists (eq x) l - | Seq s -> CCSequence.exists (eq x) s + | Seq s -> Sequence.exists (eq x) s | Set (m, set) -> - let module S = (val m : CCSequence.Set.S + let module S = (val m : Sequence.Set.S with type elt = elt and type t = 'b) in (* XXX: here we don't use the equality relation *) S.mem x set @@ -338,10 +338,10 @@ module Coll = struct let do_join ~join c1 c2 = let build1 = let seq = to_seq c1 in - let seq = CCSequence.map (fun x -> join.join_key1 x, x) seq in + let seq = Sequence.map (fun x -> join.join_key1 x, x) seq in PMap.multimap_of_seq ~build:(PMap.make ~build:join.join_build ()) seq in - let l = CCSequence.fold + let l = Sequence.fold (fun acc y -> let key = join.join_key2 y in match PMap.get build1 key with @@ -373,14 +373,14 @@ module Coll = struct let do_product c1 c2 = let s1 = to_seq c1 and s2 = to_seq c2 in - of_seq (CCSequence.product s1 s2) + of_seq (Sequence.product s1 s2) let do_union ~build c1 c2 = let build = PMap.make ~build () in to_seq c1 (fun x -> PMap.add build x ()); to_seq c2 (fun x -> PMap.add build x ()); let seq = PMap.to_seq (PMap.build_get build) in - of_seq (CCSequence.map fst seq) + of_seq (Sequence.map fst seq) type inter_status = | InterLeft @@ -408,7 +408,7 @@ module Coll = struct let map = PMap.build_get build in (* output elements of [c1] not in [map] *) let seq = to_seq c1 in - of_seq (CCSequence.filter (fun x -> not (PMap.mem map x)) seq) + of_seq (Sequence.filter (fun x -> not (PMap.mem map x)) seq) end (** {2 Query operators} *) @@ -478,22 +478,22 @@ let of_array a = Start (Coll.of_array a) let of_array_i a = - Start (Coll.of_seq (CCSequence.of_array_i a)) + Start (Coll.of_seq (Sequence.of_array_i a)) let of_hashtbl h = - Start (Coll.of_seq (CCSequence.of_hashtbl h)) + Start (Coll.of_seq (Sequence.of_hashtbl h)) let of_seq seq = Start (Coll.of_seq seq) let of_queue q = - Start (Coll.of_seq (CCSequence.of_queue q)) + Start (Coll.of_seq (Sequence.of_queue q)) let of_stack s = - Start (Coll.of_seq (CCSequence.of_stack s)) + Start (Coll.of_seq (Sequence.of_stack s)) let of_string s = - Start (Coll.of_seq (CCSequence.of_str s)) + Start (Coll.of_seq (Sequence.of_str s)) (** {6 Execution} *) @@ -519,9 +519,9 @@ and _optimize_unary : type a b. (a,b) unary -> a t -> b t _optimize_unary (FilterMap (fun x -> if p x then Some (f x) else None)) cont - | PMap f, Binary (Append, q1, q2) -> + | PMap _, Binary (Append, q1, q2) -> _optimize_binary Append (Unary (u, q1)) (Unary (u, q2)) - | Filter p, Binary (Append, q1, q2) -> + | Filter _, Binary (Append, q1, q2) -> _optimize_binary Append (Unary (u, q1)) (Unary (u, q2)) | Fold (f,acc), Unary (PMap f', cont) -> _optimize_unary @@ -553,7 +553,7 @@ let _do_unary : type a b. (a,b) unary -> a -> b | Fold (f, acc) -> Coll.fold f acc c | FoldMap (f, acc) -> PMap.fold f acc c | Reduce (safety, start, mix, stop) -> - let acc = CCSequence.fold + let acc = Sequence.fold (fun acc x -> match acc with | None -> Some (start x) | Some acc -> Some (mix x acc) @@ -578,7 +578,7 @@ let _do_unary : type a b. (a,b) unary -> a -> b | Get (Implicit, k) -> PMap.get_exn c k | Get (Explicit, k) -> PMap.get_err c k | GroupBy (build,f) -> - let seq = CCSequence.map (fun x -> f x, x) (Coll.to_seq c) in + let seq = Sequence.map (fun x -> f x, x) (Coll.to_seq c) in PMap.multimap_of_seq ~build:(PMap.make ~build ()) seq | Contains (eq, x) -> Coll.contains ~eq x c | Count build -> @@ -591,7 +591,7 @@ let _do_binary : type a b c. (a, b, c) binary -> a -> b -> c | GroupJoin gjoin -> Coll.do_group_join ~gjoin c1 c2 | Product -> Coll.do_product c1 c2 | Append -> - Coll.of_seq (CCSequence.append (Coll.to_seq c1) (Coll.to_seq c2)) + Coll.of_seq (Sequence.append (Coll.to_seq c1) (Coll.to_seq c2)) | SetOp (Inter,build) -> Coll.do_inter ~build c1 c2 | SetOp (Union,build) -> Coll.do_union ~build c1 c2 | SetOp (Diff,build) -> Coll.do_diff ~build c1 c2 @@ -695,8 +695,8 @@ module M = struct let flatten q = let f m = - let seq = CCSequence.flat_map - (fun (k,v) -> CCSequence.map (fun v' -> k,v') (Coll.to_seq v)) + let seq = Sequence.flat_map + (fun (k,v) -> Sequence.map (fun v' -> k,v') (Coll.to_seq v)) m.PMap.to_seq in Coll.of_seq seq in @@ -704,8 +704,8 @@ module M = struct let flatten' q = let f m = - let seq = CCSequence.flatMap - (fun (k,v) -> CCSequence.map (fun v' -> k,v') (CCSequence.of_list v)) + let seq = Sequence.flatMap + (fun (k,v) -> Sequence.map (fun v' -> k,v') (Sequence.of_list v)) m.PMap.to_seq in Coll.of_seq seq in @@ -739,7 +739,7 @@ let group_by ?cmp ?eq ?hash f q = Unary (GroupBy (_make_build ?cmp ?eq ?hash (),f), q) let group_by' ?cmp ?eq ?hash f q = - M.iter (group_by ?cmp f q) + M.iter (group_by ?cmp ?eq ?hash f q) let count ?cmp ?eq ?hash () q = Unary (Count (_make_build ?cmp ?eq ?hash ()), q) @@ -885,16 +885,16 @@ let to_array q = QueryMap ((fun c -> Array.of_list (Coll.to_list c)), q) let to_seq q = - QueryMap ((fun c -> CCSequence.persistent (Coll.to_seq c)), q) + QueryMap ((fun c -> Sequence.persistent (Coll.to_seq c)), q) let to_hashtbl q = - QueryMap ((fun c -> CCSequence.to_hashtbl (Coll.to_seq c)), q) + QueryMap ((fun c -> Sequence.to_hashtbl (Coll.to_seq c)), q) let to_queue q = - QueryMap ((fun c q -> CCSequence.to_queue q (Coll.to_seq c)), q) + QueryMap ((fun c q -> Sequence.to_queue q (Coll.to_seq c)), q) let to_stack q = - QueryMap ((fun c s -> CCSequence.to_stack s (Coll.to_seq c)), q) + QueryMap ((fun c s -> Sequence.to_stack s (Coll.to_seq c)), q) module L = struct let of_list l = Start (Coll.of_list l) @@ -909,7 +909,7 @@ module AdaptSet(S : Set.S) = struct return (Coll.of_seq (fun k -> S.iter k set)) let to_set q = - let f c = CCSequence.fold (fun set x -> S.add x set) S.empty (Coll.to_seq c) in + let f c = Sequence.fold (fun set x -> S.add x set) S.empty (Coll.to_seq c) in query_map f q let run q = run (to_set q) @@ -932,7 +932,7 @@ module AdaptMap(M : Map.S) = struct let to_map q = let f c = - CCSequence.fold (fun m (x,y) -> M.add x y m) M.empty (Coll.to_seq c) + Sequence.fold (fun m (x,y) -> M.add x y m) M.empty (Coll.to_seq c) in query_map f q @@ -1008,13 +1008,13 @@ module IO = struct query_map f q let lines' q = - let f s = lazy (CCSequence.to_list (_lines s 0)) in + let f s = lazy (Sequence.to_list (_lines s 0)) in lazy_ (query_map f q) let _join ~sep ?(stop="") l = let buf = Buffer.create 128 in let seq = Coll.to_seq l in - CCSequence.iteri + Sequence.iteri (fun i x -> if i>0 then Buffer.add_string buf sep; Buffer.add_string buf x) @@ -1035,7 +1035,7 @@ module IO = struct let out_lines oc q = let x = run_exn q in - CCSequence.iter (fun l -> output_string oc l; output_char oc '\n') (Coll.to_seq x) + Sequence.iter (fun l -> output_string oc l; output_char oc '\n') (Coll.to_seq x) let to_file_exn filename q = _with_file_out filename (fun oc -> out oc q) diff --git a/advanced/CCLinq.mli b/src/advanced/CCLinq.mli similarity index 100% rename from advanced/CCLinq.mli rename to src/advanced/CCLinq.mli diff --git a/advanced/CCMonadIO.ml b/src/advanced/CCMonadIO.ml similarity index 100% rename from advanced/CCMonadIO.ml rename to src/advanced/CCMonadIO.ml diff --git a/advanced/CCMonadIO.mli b/src/advanced/CCMonadIO.mli similarity index 100% rename from advanced/CCMonadIO.mli rename to src/advanced/CCMonadIO.mli diff --git a/src/advanced/containers_advanced.mldylib b/src/advanced/containers_advanced.mldylib new file mode 100644 index 00000000..0f1163e0 --- /dev/null +++ b/src/advanced/containers_advanced.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 0f1ca0e2b031ae1710e26abf02cca256) +Containers_advanced +# OASIS_STOP diff --git a/src/advanced/containers_advanced.mllib b/src/advanced/containers_advanced.mllib new file mode 100644 index 00000000..0f1163e0 --- /dev/null +++ b/src/advanced/containers_advanced.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 0f1ca0e2b031ae1710e26abf02cca256) +Containers_advanced +# OASIS_STOP diff --git a/src/advanced/containers_advanced.mlpack b/src/advanced/containers_advanced.mlpack new file mode 100644 index 00000000..7c96f38e --- /dev/null +++ b/src/advanced/containers_advanced.mlpack @@ -0,0 +1,7 @@ +# OASIS_START +# DO NOT EDIT (digest: 5a399cd532edb84596f3034081578694) +CCLinq +CCBatch +CCCat +CCMonadIO +# OASIS_STOP diff --git a/src/bigarray/CCBigstring.ml b/src/bigarray/CCBigstring.ml new file mode 100644 index 00000000..efa37a74 --- /dev/null +++ b/src/bigarray/CCBigstring.ml @@ -0,0 +1,223 @@ + +(* +copyright (c) 2013-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 1-dimension Bigarrays of bytes (char)} *) + +module B = Bigarray.Array1 + +type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + +let create size = B.create Bigarray.char Bigarray.c_layout size + +let empty = create 0 + +let init size f = + let a = create size in + for i = 0 to size-1 do + B.unsafe_set a i (f i) + done; + a + +let fill = B.fill + +let get = B.get + +let set = B.set + +let size = B.dim + +let sub = B.sub + +let blit a i b j len = + let a' = sub a i len in + let b' = sub b j len in + B.blit a' b' + +let copy a = + let b = create (size a) in + B.blit a b; + b + +(*$T + copy (of_string "abcd") |> to_string = "abcd" + *) + +let fold f acc a = + let rec fold' f acc a i len = + if i = len then acc + else + let acc = f acc (get a i) in + fold' f acc a (i+1) len + in + fold' f acc a 0 (size a) + +let iter f a = + let n = size a in + for i = 0 to n-1 do + f (get a i) + done + +let rec equal_rec a b i len = + i = len + || + ( get a i = get b i && equal_rec a b (i+1) len) + +let equal a b = + size a = size b + && + equal_rec a b 0 (size a) + +(*$Q + Q.(pair printable_string printable_string) (fun (s1, s2) -> \ + let a1 = of_string s1 and a2 = of_string s2 in \ + equal a1 a2 = (s1 = s2)) +*) + +let rec compare_rec a b i len_a len_b = + if i=len_a && i=len_b then 0 + else if i=len_a then -1 + else if i=len_b then 1 + else + match Char.compare (get a i) (get b i) with + | 0 -> compare_rec a b (i+1) len_a len_b + | n -> n + +let compare a b = + compare_rec a b 0 (size a) (size b) + +(*$T + compare (of_string "abc") (of_string "abd") < 0 + compare (of_string "abc") (of_string "abcd") < 0 + compare (of_string "abcd") (of_string "abc") > 0 + compare (of_string "abc") (of_string "b") < 0 +*) + +(*$Q + Q.(pair string string) (fun (s1, s2) -> \ + let a1 = of_string s1 and a2 = of_string s2 in \ + CCInt.sign (compare a1 a2) = CCInt.sign (String.compare s1 s2)) +*) + +(** {2 Conversions} *) + +let to_bytes a = + Bytes.init (size a) (fun i -> B.unsafe_get a i) + +let of_bytes b = + init (Bytes.length b) (fun i -> Bytes.get b i) + +let of_bytes_slice b i len = + if i < 0 || i+len > Bytes.length b then invalid_arg "CCBigstring"; + init len (fun j -> Bytes.get b (i+j)) + +let sub_bytes a i len = + if i < 0 || i+len > size a then invalid_arg "CCBigstring"; + Bytes.init len (fun j -> B.get a (i+j)) + +let blit_to_bytes a i b j len = + if i < 0 || j < 0 || i+len > size a || j+len > Bytes.length b + then invalid_arg "CCBigstring"; + for x=0 to len-1 do + Bytes.set b (j+x) (B.get a (i+x)) + done + +let blit_of_bytes a i b j len = + if i < 0 || j < 0 || i+len > Bytes.length a || j+len > size b + then invalid_arg "CCBigstring"; + for x=0 to len-1 do + B.set b (j+x) (Bytes.get a (i+x)) + done + +let to_string a = + CCString.init (size a) (fun i -> B.unsafe_get a i) + +let of_string s = + init (String.length s) (fun i -> String.get s i) + +let of_string_slice s i len = + if i < 0 || i+len > String.length s then invalid_arg "CCBigstring"; + init len (fun j -> String.get s (i+j)) + +let sub_string a i len = + if i < 0 || i+len > size a then invalid_arg "CCBigstring"; + CCString.init len (fun j -> B.get a (i+j)) + +(*$T + of_string_slice "abcde" 1 3 |> to_string = "bcd" +*) + +let blit_of_string a i b j len = + if i < 0 || j < 0 || i+len > String.length a || j+len > size b + then invalid_arg "CCBigstring"; + for x=0 to len-1 do + B.set b (j+x) (String.get a (i+x)) + done + +type 'a gen = unit -> 'a option +type 'a sequence = ('a -> unit) -> unit + +let to_seq a k = iter k a + +let to_gen a = + let i = ref 0 in + let n = size a in + fun () -> + if !i = n then None + else ( + let x = get a !i in + incr i; + Some x + ) + +(*$T + of_string "abcd" |> to_gen |> Gen.to_string = "abcd" +*) + +let to_seq_slice a i len = + to_seq (sub a i len) + +let to_gen_slice a i len = + to_gen (sub a i len) + +(** {2 Memory-map} *) + +let map_file_descr ?pos ?(shared=false) fd len = + B.map_file fd ?pos Bigarray.char Bigarray.c_layout shared len + +let with_map_file ?pos ?len ?(mode=0o644) ?(flags=[Open_rdonly]) ?shared name f = + let ic = open_in_gen flags mode name in + let len = match len with + | None -> in_channel_length ic + | Some n -> n + in + let a = map_file_descr ?pos ?shared (Unix.descr_of_in_channel ic) len in + try + let x = f a in + close_in ic; + x + with e -> + close_in ic; + raise e diff --git a/src/bigarray/CCBigstring.mli b/src/bigarray/CCBigstring.mli new file mode 100644 index 00000000..6f0582e1 --- /dev/null +++ b/src/bigarray/CCBigstring.mli @@ -0,0 +1,127 @@ + +(* +copyright (c) 2013-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 1-dimension Bigarrays of bytes (char)} + +@since 0.7 *) + +type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + +val create : int -> t +(** Create a new bigstring of the given size. *) + +val empty : t +(** Empty string *) + +val init : int -> (int -> char) -> t +(** Initialize with the given function (called at every index) *) + +val fill : t -> char -> unit +(** Fill with a single byte *) + +val size : t -> int +(** Number of bytes *) + +val get : t -> int -> char + +val set : t -> int -> char -> unit + +val blit : t -> int -> t -> int -> int -> unit +(** Blit a slice of the bigstring into another *) + +val copy : t -> t +(** Copy of the string *) + +val sub : t -> int -> int -> t +(** [sub s i len] takes a slice of length [len] from the string [s], starting + at offset [i]. + @raise Invalid_argument if [i, len] doesn't designate a valid substring *) + +val fold : ('a -> char -> 'a) -> 'a -> t -> 'a + +val iter : (char -> unit) -> t -> unit + +val equal : t -> t -> bool + +val compare : t -> t -> int +(** Lexicographic order *) + +(** {2 Conversions} *) + +val to_bytes : t -> Bytes.t + +val of_bytes : Bytes.t -> t + +val of_bytes_slice : Bytes.t -> int -> int -> t + +val sub_bytes : t -> int -> int -> Bytes.t + +val blit_to_bytes : t -> int -> Bytes.t -> int -> int -> unit + +val blit_of_bytes : Bytes.t -> int -> t -> int -> int -> unit + +val to_string : t -> string + +val of_string : string -> t + +val of_string_slice : string -> int -> int -> t + +val sub_string : t -> int -> int -> string + +val blit_of_string : string -> int -> t -> int -> int -> unit + +type 'a gen = unit -> 'a option +type 'a sequence = ('a -> unit) -> unit + +val to_seq : t -> char sequence + +val to_gen : t -> char gen + +val to_seq_slice : t -> int -> int -> char sequence + +val to_gen_slice : t -> int -> int -> char gen + +(** {2 Memory-map} *) + +val with_map_file : + ?pos:int64 -> ?len:int -> ?mode:int -> ?flags:open_flag list -> ?shared:bool -> + string -> (t -> 'a) -> 'a +(** [with_map_file name f] maps the file into memory, opening it, and + call [f] with a slice [pos.... pos+len] of the bytes of the file + where [len] is the length of the file if not provided. + When [f] returns, the file is closed. + @param pos offset in the file (default 0) + @param shared if true, modifications are shared between processes that + have mapped this file (requires the filedescr to be open in write mode). + @param mode the mode for the file, if it's created + @param flags opening flags (default rdonly) + see {!Bigarray.Array1.map_file} for more details *) + +val map_file_descr : ?pos:int64 -> ?shared:bool -> Unix.file_descr -> int -> t +(** [map_file_descr descr len] is a lower-level access to an underlying file descriptor. + @param shared if true, modifications are shared between processes that + have mapped this file (requires the filedescr to be open in write mode). + see {!Bigarray.Array1.map_file} for more details *) diff --git a/src/bigarray/containers_bigarray.mldylib b/src/bigarray/containers_bigarray.mldylib new file mode 100644 index 00000000..10f13676 --- /dev/null +++ b/src/bigarray/containers_bigarray.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 6398fca785a51b3ad28defb36820d456) +CCBigstring +# OASIS_STOP diff --git a/src/bigarray/containers_bigarray.mllib b/src/bigarray/containers_bigarray.mllib new file mode 100644 index 00000000..10f13676 --- /dev/null +++ b/src/bigarray/containers_bigarray.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 6398fca785a51b3ad28defb36820d456) +CCBigstring +# OASIS_STOP diff --git a/core/CCArray.ml b/src/core/CCArray.ml similarity index 100% rename from core/CCArray.ml rename to src/core/CCArray.ml diff --git a/core/CCArray.mli b/src/core/CCArray.mli similarity index 100% rename from core/CCArray.mli rename to src/core/CCArray.mli diff --git a/core/CCBool.ml b/src/core/CCBool.ml similarity index 100% rename from core/CCBool.ml rename to src/core/CCBool.ml diff --git a/core/CCBool.mli b/src/core/CCBool.mli similarity index 100% rename from core/CCBool.mli rename to src/core/CCBool.mli diff --git a/core/CCError.ml b/src/core/CCError.ml similarity index 100% rename from core/CCError.ml rename to src/core/CCError.ml diff --git a/core/CCError.mli b/src/core/CCError.mli similarity index 100% rename from core/CCError.mli rename to src/core/CCError.mli diff --git a/core/CCFloat.ml b/src/core/CCFloat.ml similarity index 92% rename from core/CCFloat.ml rename to src/core/CCFloat.ml index 6749913a..ad8ad32b 100644 --- a/core/CCFloat.ml +++ b/src/core/CCFloat.ml @@ -76,6 +76,17 @@ let sign (a:float) = else if a > 0.0 then 1 else 0 +let fsign a = + if is_nan a then nan + else if a = 0. then a + else Pervasives.copysign 1. a + +exception TrapNaN of string + +let sign_exn (a:float) = + if is_nan a then raise (TrapNaN "sign") + else compare a 0. + let to_int (a:float) = Pervasives.int_of_float a let of_int (a:int) = Pervasives.float_of_int a diff --git a/core/CCFloat.mli b/src/core/CCFloat.mli similarity index 82% rename from core/CCFloat.mli rename to src/core/CCFloat.mli index 02da623e..bf1cd0f3 100644 --- a/core/CCFloat.mli +++ b/src/core/CCFloat.mli @@ -77,7 +77,20 @@ val random_small : t random_gen val random_range : t -> t -> t random_gen val sign : t -> int -(** [sign t] is one of [-1, 0, 1] *) +(** [sign t] is one of [-1, 0, 1], depending on how the float + compares to [0.] + @deprecated use {! fsign} or {!sign_exn} since it's more accurate *) + +val fsign : t -> float +(** [fsign x] is one of [-1., -0., +0., +1.], or [nan] if [x] is NaN. + @since 0.7 *) + +exception TrapNaN of string +val sign_exn : t -> int +(** [sign_exn x] will return the sign of [x] as [1, 0] or [-1], or raise an + exception [TrapNaN] if [x] is a NaN. + Note that infinities have defined signs in OCaml. + @since 0.7 *) val to_int : t -> int val of_int : int -> t diff --git a/core/CCFun.cppo.ml b/src/core/CCFun.cppo.ml similarity index 100% rename from core/CCFun.cppo.ml rename to src/core/CCFun.cppo.ml diff --git a/core/CCFun.mli b/src/core/CCFun.mli similarity index 100% rename from core/CCFun.mli rename to src/core/CCFun.mli diff --git a/core/CCHash.ml b/src/core/CCHash.ml similarity index 100% rename from core/CCHash.ml rename to src/core/CCHash.ml diff --git a/core/CCHash.mli b/src/core/CCHash.mli similarity index 100% rename from core/CCHash.mli rename to src/core/CCHash.mli diff --git a/core/CCHashtbl.ml b/src/core/CCHashtbl.ml similarity index 93% rename from core/CCHashtbl.ml rename to src/core/CCHashtbl.ml index 1a00239a..fe5289b7 100644 --- a/core/CCHashtbl.ml +++ b/src/core/CCHashtbl.ml @@ -40,6 +40,16 @@ let keys tbl k = Hashtbl.iter (fun key _ -> k key) tbl let values tbl k = Hashtbl.iter (fun _ v -> k v) tbl +let map_list f h = + Hashtbl.fold + (fun x y acc -> f x y :: acc) + h [] + +(*$T + of_list [1,"a"; 2,"b"] |> map_list (fun x y -> string_of_int x ^ y) \ + |> List.sort Pervasives.compare = ["1a"; "2b"] +*) + let to_seq tbl k = Hashtbl.iter (fun key v -> k (key,v)) tbl let of_seq seq = @@ -71,6 +81,9 @@ module type S = sig val values : 'a t -> 'a sequence (** Iterate on values in the table *) + val map_list : (key -> 'a -> 'b) -> 'a t -> 'b list + (** Map on a hashtable's items, collect into a list *) + val to_seq : 'a t -> (key * 'a) sequence (** Iterate on values in the table *) @@ -95,6 +108,11 @@ module Make(X : Hashtbl.HashedType) = struct let values tbl k = iter (fun _ v -> k v) tbl + let map_list f h = + fold + (fun x y acc -> f x y :: acc) + h [] + let to_seq tbl k = iter (fun key v -> k (key,v)) tbl let of_seq seq = @@ -215,7 +233,7 @@ module MakeCounter(X : Hashtbl.HashedType) = struct let n = get tbl x in T.replace tbl x (n+1) - let incr_by tbl n x = + let incr_by tbl n x = let n' = get tbl x in if n' + n <= 0 then T.remove tbl x diff --git a/core/CCHashtbl.mli b/src/core/CCHashtbl.mli similarity index 94% rename from core/CCHashtbl.mli rename to src/core/CCHashtbl.mli index 5eb6acf1..abee28de 100644 --- a/core/CCHashtbl.mli +++ b/src/core/CCHashtbl.mli @@ -25,7 +25,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(** {1 Extension to the standard Hashtbl} +(** {1 Extension to the standard Hashtbl} @since 0.4 *) @@ -44,6 +44,9 @@ val keys : ('a,'b) Hashtbl.t -> 'a sequence val values : ('a,'b) Hashtbl.t -> 'b sequence (** Iterate on values in the table *) +val map_list : ('a -> 'b -> 'c) -> ('a, 'b) Hashtbl.t -> 'c list +(** Map on a hashtable's items, collect into a list *) + val to_seq : ('a,'b) Hashtbl.t -> ('a * 'b) sequence (** Iterate on bindings in the table *) @@ -70,6 +73,9 @@ module type S = sig val values : 'a t -> 'a sequence (** Iterate on values in the table *) + val map_list : (key -> 'a -> 'b) -> 'a t -> 'b list + (** Map on a hashtable's items, collect into a list *) + val to_seq : 'a t -> (key * 'a) sequence (** Iterate on values in the table *) diff --git a/core/CCHeap.ml b/src/core/CCHeap.ml similarity index 100% rename from core/CCHeap.ml rename to src/core/CCHeap.ml diff --git a/core/CCHeap.mli b/src/core/CCHeap.mli similarity index 100% rename from core/CCHeap.mli rename to src/core/CCHeap.mli diff --git a/core/CCInt.ml b/src/core/CCInt.ml similarity index 100% rename from core/CCInt.ml rename to src/core/CCInt.ml diff --git a/core/CCInt.mli b/src/core/CCInt.mli similarity index 100% rename from core/CCInt.mli rename to src/core/CCInt.mli diff --git a/core/CCList.ml b/src/core/CCList.ml similarity index 100% rename from core/CCList.ml rename to src/core/CCList.ml diff --git a/core/CCList.mli b/src/core/CCList.mli similarity index 100% rename from core/CCList.mli rename to src/core/CCList.mli diff --git a/core/CCMap.ml b/src/core/CCMap.ml similarity index 100% rename from core/CCMap.ml rename to src/core/CCMap.ml diff --git a/core/CCMap.mli b/src/core/CCMap.mli similarity index 100% rename from core/CCMap.mli rename to src/core/CCMap.mli diff --git a/core/CCOpt.ml b/src/core/CCOpt.ml similarity index 100% rename from core/CCOpt.ml rename to src/core/CCOpt.ml diff --git a/core/CCOpt.mli b/src/core/CCOpt.mli similarity index 100% rename from core/CCOpt.mli rename to src/core/CCOpt.mli diff --git a/core/CCOrd.ml b/src/core/CCOrd.ml similarity index 100% rename from core/CCOrd.ml rename to src/core/CCOrd.ml diff --git a/core/CCOrd.mli b/src/core/CCOrd.mli similarity index 100% rename from core/CCOrd.mli rename to src/core/CCOrd.mli diff --git a/core/CCPair.ml b/src/core/CCPair.ml similarity index 100% rename from core/CCPair.ml rename to src/core/CCPair.ml diff --git a/core/CCPair.mli b/src/core/CCPair.mli similarity index 100% rename from core/CCPair.mli rename to src/core/CCPair.mli diff --git a/core/CCPrint.ml b/src/core/CCPrint.ml similarity index 100% rename from core/CCPrint.ml rename to src/core/CCPrint.ml diff --git a/core/CCPrint.mli b/src/core/CCPrint.mli similarity index 100% rename from core/CCPrint.mli rename to src/core/CCPrint.mli diff --git a/core/CCRandom.ml b/src/core/CCRandom.ml similarity index 100% rename from core/CCRandom.ml rename to src/core/CCRandom.ml diff --git a/core/CCRandom.mli b/src/core/CCRandom.mli similarity index 100% rename from core/CCRandom.mli rename to src/core/CCRandom.mli diff --git a/core/CCString.cppo.ml b/src/core/CCString.cppo.ml similarity index 91% rename from core/CCString.cppo.ml rename to src/core/CCString.cppo.ml index 3948c8a2..097cd078 100644 --- a/core/CCString.cppo.ml +++ b/src/core/CCString.cppo.ml @@ -38,6 +38,8 @@ module type S = sig val blit : t -> int -> t -> int -> int -> unit (** See {!String.blit} *) + val fold : ('a -> char -> 'a) -> 'a -> t -> 'a + (** {2 Conversions} *) val to_gen : t -> char gen @@ -62,9 +64,8 @@ let init = String.init #else let init n f = - let buf = Buffer.create n in - for i = 0 to n-1 do Buffer.add_char buf (f i) done; - Buffer.contents buf + let buf = Bytes.init n f in + Bytes.unsafe_to_string buf #endif @@ -182,10 +183,26 @@ let prefix ~pre s = String.length pre <= String.length s && (let i = ref 0 in while !i < String.length pre && s.[!i] = pre.[!i] do incr i done; - !i = String.length pre) + !i = String.length pre + ) + +let suffix ~suf s = + String.length suf <= String.length s && + let off = String.length s - String.length suf in + (let i = ref 0 in + while !i < String.length suf && s.[off + !i] = suf.[!i] do incr i done; + !i = String.length suf + ) + let blit = String.blit +let fold f acc s = + let rec fold_rec f acc s i = + if i = String.length s then acc + else fold_rec f (f acc s.[i]) s (i+1) + in fold_rec f acc s 0 + let _to_gen s i0 len = let i = ref i0 in fun () -> @@ -277,6 +294,12 @@ module Sub = struct if o1+len>len1 || o2+len>len2 then invalid_arg "CCString.Sub.blit"; String.blit a1 (i1+o1) a2 (i2+o2) len + let fold f acc (s,i,len) = + let rec fold_rec f acc s i j = + if i = j then acc + else fold_rec f (f acc s.[i]) s (i+1) j + in fold_rec f acc s i (i+len) + let to_gen (s,i,len) = _to_gen s i len let to_seq (s,i,len) k = for i=i to i+len-1 do k s.[i] done diff --git a/core/CCString.mli b/src/core/CCString.mli similarity index 80% rename from core/CCString.mli rename to src/core/CCString.mli index 8945e525..807bb938 100644 --- a/core/CCString.mli +++ b/src/core/CCString.mli @@ -25,6 +25,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) (** {1 Basic String Utils} + Consider using {!Containers_string.KMP} for pattern search, or Regex libraries. *) @@ -42,6 +43,10 @@ module type S = sig val blit : t -> int -> t -> int -> int -> unit (** See {!String.blit} *) + val fold : ('a -> char -> 'a) -> 'a -> t -> 'a + (** Fold on chars by increasing index. + @since 0.7 *) + (** {2 Conversions} *) val to_gen : t -> char gen @@ -65,6 +70,11 @@ val init : int -> (int -> char) -> string (** Analog to [Array.init]. @since 0.3.3 *) +(*$T + init 3 (fun i -> [|'a'; 'b'; 'c'|].(i)) = "abc" + init 0 (fun _ -> assert false) = "" +*) + val of_gen : char gen -> string val of_seq : char sequence -> string val of_klist : char klist -> string @@ -74,19 +84,34 @@ val of_array : char array -> string val to_array : string -> char array val find : ?start:int -> sub:string -> string -> int -(** Find [sub] in stringhe string, returns its first index or -1. +(** Find [sub] in string, returns its first index or [-1]. Should only be used with very small [sub] *) val is_sub : sub:string -> int -> string -> int -> len:int -> bool -(** [is_sub ~sub i s j ~len] returns [true] iff stringhe substring of - [sub] starting at position [i] and of length [len], - is a substring of [s] starting at position [j] *) +(** [is_sub ~sub i s j ~len] returns [true] iff the substring of + [sub] starting at position [i] and of length [len] *) val repeat : string -> int -> string -(** The same string, repeated n stringimes *) +(** The same string, repeated n times *) val prefix : pre:string -> string -> bool -(** [str_prefix ~pre s] returns [true] iff [pre] is a prefix of [s] *) +(** [prefix ~pre s] returns [true] iff [pre] is a prefix of [s] *) + +(*$T + prefix ~pre:"aab" "aabcd" + not (prefix ~pre:"ab" "aabcd") + not (prefix ~pre:"abcd" "abc") +*) + +val suffix : suf:string -> string -> bool +(** [suffix ~suf s] returns [true] iff [suf] is a suffix of [s] + @since 0.7 *) + +(*$T + suffix ~suf:"cd" "abcd" + not (suffix ~suf:"cd" "abcde") + not (suffix ~suf:"abcd" "cd") +*) include S with type t := string @@ -148,4 +173,11 @@ module Sub : sig (** Sub-slice *) include S with type t := t + + (*$T + let s = Sub.make "abcde" 1 3 in \ + Sub.fold (fun acc x -> x::acc) [] s = ['d'; 'c'; 'b'] + Sub.make "abcde" 1 3 |> Sub.copy = "bcd" + Sub.full "abcde" |> Sub.copy = "abcde" + *) end diff --git a/core/CCVector.ml b/src/core/CCVector.ml similarity index 99% rename from core/CCVector.ml rename to src/core/CCVector.ml index 143a5a55..f6cc9234 100644 --- a/core/CCVector.ml +++ b/src/core/CCVector.ml @@ -451,7 +451,7 @@ let of_seq ?(init=create ()) seq = init (*$T - of_seq CCSequence.(1 -- 10) |> to_list = CCList.(1 -- 10) + of_seq Sequence.(1 -- 10) |> to_list = CCList.(1 -- 10) *) let to_seq v k = iter k v @@ -524,7 +524,7 @@ let to_gen v = ) else None (*$T - let v = (1--10) in to_list v = CCGen.to_list (to_gen v) + let v = (1--10) in to_list v = Gen.to_list (to_gen v) *) let of_klist ?(init=create ()) l = diff --git a/core/CCVector.mli b/src/core/CCVector.mli similarity index 100% rename from core/CCVector.mli rename to src/core/CCVector.mli diff --git a/src/core/META b/src/core/META new file mode 100644 index 00000000..f90c5b91 --- /dev/null +++ b/src/core/META @@ -0,0 +1,129 @@ +# OASIS_START +# DO NOT EDIT (digest: 9c70d2a3b15d841d97052a6ac9fe3a5f) +version = "0.7" +description = "A modular standard library focused on data structures." +requires = "bytes" +archive(byte) = "containers.cma" +archive(byte, plugin) = "containers.cma" +archive(native) = "containers.cmxa" +archive(native, plugin) = "containers.cmxs" +exists_if = "containers.cma" +package "thread" ( + version = "0.7" + description = "A modular standard library focused on data structures." + requires = "containers threads" + archive(byte) = "containers_thread.cma" + archive(byte, plugin) = "containers_thread.cma" + archive(native) = "containers_thread.cmxa" + archive(native, plugin) = "containers_thread.cmxs" + exists_if = "containers_thread.cma" +) + +package "string" ( + version = "0.7" + description = "A modular standard library focused on data structures." + archive(byte) = "containers_string.cma" + archive(byte, plugin) = "containers_string.cma" + archive(native) = "containers_string.cmxa" + archive(native, plugin) = "containers_string.cmxs" + exists_if = "containers_string.cma" +) + +package "sexp" ( + version = "0.7" + description = "A modular standard library focused on data structures." + requires = "bytes" + archive(byte) = "containers_sexp.cma" + archive(byte, plugin) = "containers_sexp.cma" + archive(native) = "containers_sexp.cmxa" + archive(native, plugin) = "containers_sexp.cmxs" + exists_if = "containers_sexp.cma" +) + +package "pervasives" ( + version = "0.7" + description = "A modular standard library focused on data structures." + requires = "containers" + archive(byte) = "containers_pervasives.cma" + archive(byte, plugin) = "containers_pervasives.cma" + archive(native) = "containers_pervasives.cmxa" + archive(native, plugin) = "containers_pervasives.cmxs" + exists_if = "containers_pervasives.cma" +) + +package "misc" ( + version = "0.7" + description = "A modular standard library focused on data structures." + requires = "containers containers.data" + archive(byte) = "containers_misc.cma" + archive(byte, plugin) = "containers_misc.cma" + archive(native) = "containers_misc.cmxa" + archive(native, plugin) = "containers_misc.cmxs" + exists_if = "containers_misc.cma" +) + +package "lwt" ( + version = "0.7" + description = "A modular standard library focused on data structures." + requires = "containers lwt containers.misc" + archive(byte) = "containers_lwt.cma" + archive(byte, plugin) = "containers_lwt.cma" + archive(native) = "containers_lwt.cmxa" + archive(native, plugin) = "containers_lwt.cmxs" + exists_if = "containers_lwt.cma" +) + +package "iter" ( + version = "0.7" + description = "A modular standard library focused on data structures." + archive(byte) = "containers_iter.cma" + archive(byte, plugin) = "containers_iter.cma" + archive(native) = "containers_iter.cmxa" + archive(native, plugin) = "containers_iter.cmxs" + exists_if = "containers_iter.cma" +) + +package "io" ( + version = "0.7" + description = "A modular standard library focused on data structures." + requires = "bytes" + archive(byte) = "containers_io.cma" + archive(byte, plugin) = "containers_io.cma" + archive(native) = "containers_io.cmxa" + archive(native, plugin) = "containers_io.cmxs" + exists_if = "containers_io.cma" +) + +package "data" ( + version = "0.7" + description = "A modular standard library focused on data structures." + archive(byte) = "containers_data.cma" + archive(byte, plugin) = "containers_data.cma" + archive(native) = "containers_data.cmxa" + archive(native, plugin) = "containers_data.cmxs" + exists_if = "containers_data.cma" +) + +package "bigarray" ( + version = "0.7" + description = "A modular standard library focused on data structures." + requires = "containers bigarray bytes" + archive(byte) = "containers_bigarray.cma" + archive(byte, plugin) = "containers_bigarray.cma" + archive(native) = "containers_bigarray.cmxa" + archive(native, plugin) = "containers_bigarray.cmxs" + exists_if = "containers_bigarray.cma" +) + +package "advanced" ( + version = "0.7" + description = "A modular standard library focused on data structures." + requires = "containers sequence" + archive(byte) = "containers_advanced.cma" + archive(byte, plugin) = "containers_advanced.cma" + archive(native) = "containers_advanced.cmxa" + archive(native, plugin) = "containers_advanced.cmxs" + exists_if = "containers_advanced.cma" +) +# OASIS_STOP + diff --git a/core/_tags b/src/core/_tags similarity index 100% rename from core/_tags rename to src/core/_tags diff --git a/src/core/containers.mldylib b/src/core/containers.mldylib new file mode 100644 index 00000000..59800ccf --- /dev/null +++ b/src/core/containers.mldylib @@ -0,0 +1,21 @@ +# OASIS_START +# DO NOT EDIT (digest: c6788a9242c3a4f65df901507a530eee) +CCVector +CCPrint +CCError +CCHeap +CCList +CCOpt +CCPair +CCFun +CCHash +CCInt +CCBool +CCFloat +CCArray +CCOrd +CCRandom +CCString +CCHashtbl +CCMap +# OASIS_STOP diff --git a/src/core/containers.mllib b/src/core/containers.mllib new file mode 100644 index 00000000..59800ccf --- /dev/null +++ b/src/core/containers.mllib @@ -0,0 +1,21 @@ +# OASIS_START +# DO NOT EDIT (digest: c6788a9242c3a4f65df901507a530eee) +CCVector +CCPrint +CCError +CCHeap +CCList +CCOpt +CCPair +CCFun +CCHash +CCInt +CCBool +CCFloat +CCArray +CCOrd +CCRandom +CCString +CCHashtbl +CCMap +# OASIS_STOP diff --git a/core/CCBV.ml b/src/data/CCBV.ml similarity index 98% rename from core/CCBV.ml rename to src/data/CCBV.ml index 37eeebb2..ac31693c 100644 --- a/core/CCBV.ml +++ b/src/data/CCBV.ml @@ -172,7 +172,7 @@ let iter_true bv f = done (*$T - of_list [1;5;7] |> iter_true |> CCSequence.to_list |> List.sort CCOrd.compare = [1;5;7] + of_list [1;5;7] |> iter_true |> Sequence.to_list |> List.sort CCOrd.compare = [1;5;7] *) let to_list bv = diff --git a/core/CCBV.mli b/src/data/CCBV.mli similarity index 100% rename from core/CCBV.mli rename to src/data/CCBV.mli diff --git a/core/CCCache.ml b/src/data/CCCache.ml similarity index 100% rename from core/CCCache.ml rename to src/data/CCCache.ml diff --git a/core/CCCache.mli b/src/data/CCCache.mli similarity index 100% rename from core/CCCache.mli rename to src/data/CCCache.mli diff --git a/core/CCDeque.ml b/src/data/CCDeque.ml similarity index 100% rename from core/CCDeque.ml rename to src/data/CCDeque.ml diff --git a/core/CCDeque.mli b/src/data/CCDeque.mli similarity index 100% rename from core/CCDeque.mli rename to src/data/CCDeque.mli diff --git a/core/CCFQueue.ml b/src/data/CCFQueue.ml similarity index 100% rename from core/CCFQueue.ml rename to src/data/CCFQueue.ml diff --git a/core/CCFQueue.mli b/src/data/CCFQueue.mli similarity index 100% rename from core/CCFQueue.mli rename to src/data/CCFQueue.mli diff --git a/core/CCFlatHashtbl.ml b/src/data/CCFlatHashtbl.ml similarity index 100% rename from core/CCFlatHashtbl.ml rename to src/data/CCFlatHashtbl.ml diff --git a/core/CCFlatHashtbl.mli b/src/data/CCFlatHashtbl.mli similarity index 100% rename from core/CCFlatHashtbl.mli rename to src/data/CCFlatHashtbl.mli diff --git a/misc/mixtbl.ml b/src/data/CCMixtbl.ml similarity index 100% rename from misc/mixtbl.ml rename to src/data/CCMixtbl.ml diff --git a/misc/mixtbl.mli b/src/data/CCMixtbl.mli similarity index 84% rename from misc/mixtbl.mli rename to src/data/CCMixtbl.mli index 650c0ab6..67af7755 100644 --- a/misc/mixtbl.mli +++ b/src/data/CCMixtbl.mli @@ -29,27 +29,27 @@ From https://github.com/mjambon/mixtbl , thanks to him. Example: {[ -let inj_int = Mixtbl.access () ;; +let inj_int = CCMixtbl.access () ;; -let tbl = Mixtbl.create 10 ;; +let tbl = CCMixtbl.create 10 ;; -OUnit.assert_equal None (Mixtbl.get ~inj:inj_int tbl "a");; +OUnit.assert_equal None (CCMixtbl.get ~inj:inj_int tbl "a");; -Mixtbl.set inj_int tbl "a" 1;; +CCMixtbl.set inj_int tbl "a" 1;; -OUnit.assert_equal (Some 1) (Mixtbl.get ~inj:inj_int tbl "a");; +OUnit.assert_equal (Some 1) (CCMixtbl.get ~inj:inj_int tbl "a");; -let inj_string = Mixtbl.access () ;; +let inj_string = CCMixtbl.access () ;; -Mixtbl.set inj_string tbl "b" "Hello"; +CCMixtbl.set inj_string tbl "b" "Hello"; -OUnit.assert_equal (Some "Hello") (Mixtbl.get inj_string tbl "b");; -OUnit.assert_equal None (Mixtbl.get inj_string tbl "a");; -OUnit.assert_equal (Some 1) (Mixtbl.get inj_int tbl "a");; -Mixtbl.set inj_string tbl "a" "Bye";; +OUnit.assert_equal (Some "Hello") (CCMixtbl.get inj_string tbl "b");; +OUnit.assert_equal None (CCMixtbl.get inj_string tbl "a");; +OUnit.assert_equal (Some 1) (CCMixtbl.get inj_int tbl "a");; +CCMixtbl.set inj_string tbl "a" "Bye";; -OUnit.assert_equal None (Mixtbl.get inj_int tbl "a");; -OUnit.assert_equal (Some "Bye") (Mixtbl.get inj_string tbl "a");; +OUnit.assert_equal None (CCMixtbl.get inj_int tbl "a");; +OUnit.assert_equal (Some "Bye") (CCMixtbl.get inj_string tbl "a");; ]} @since 0.6 *) diff --git a/core/CCMultiMap.ml b/src/data/CCMultiMap.ml similarity index 100% rename from core/CCMultiMap.ml rename to src/data/CCMultiMap.ml diff --git a/core/CCMultiMap.mli b/src/data/CCMultiMap.mli similarity index 100% rename from core/CCMultiMap.mli rename to src/data/CCMultiMap.mli diff --git a/core/CCMultiSet.ml b/src/data/CCMultiSet.ml similarity index 100% rename from core/CCMultiSet.ml rename to src/data/CCMultiSet.ml diff --git a/core/CCMultiSet.mli b/src/data/CCMultiSet.mli similarity index 100% rename from core/CCMultiSet.mli rename to src/data/CCMultiSet.mli diff --git a/core/CCPersistentHashtbl.ml b/src/data/CCPersistentHashtbl.ml similarity index 100% rename from core/CCPersistentHashtbl.ml rename to src/data/CCPersistentHashtbl.ml diff --git a/core/CCPersistentHashtbl.mli b/src/data/CCPersistentHashtbl.mli similarity index 100% rename from core/CCPersistentHashtbl.mli rename to src/data/CCPersistentHashtbl.mli diff --git a/core/CCTrie.ml b/src/data/CCTrie.ml similarity index 100% rename from core/CCTrie.ml rename to src/data/CCTrie.ml diff --git a/core/CCTrie.mli b/src/data/CCTrie.mli similarity index 100% rename from core/CCTrie.mli rename to src/data/CCTrie.mli diff --git a/src/data/containers_data.mldylib b/src/data/containers_data.mldylib new file mode 100644 index 00000000..90d1274e --- /dev/null +++ b/src/data/containers_data.mldylib @@ -0,0 +1,13 @@ +# OASIS_START +# DO NOT EDIT (digest: 5103c22b99ffdda9689659d2fbcfc489) +CCMultiMap +CCMultiSet +CCTrie +CCFlatHashtbl +CCCache +CCPersistentHashtbl +CCDeque +CCFQueue +CCBV +CCMixtbl +# OASIS_STOP diff --git a/src/data/containers_data.mllib b/src/data/containers_data.mllib new file mode 100644 index 00000000..90d1274e --- /dev/null +++ b/src/data/containers_data.mllib @@ -0,0 +1,13 @@ +# OASIS_START +# DO NOT EDIT (digest: 5103c22b99ffdda9689659d2fbcfc489) +CCMultiMap +CCMultiSet +CCTrie +CCFlatHashtbl +CCCache +CCPersistentHashtbl +CCDeque +CCFQueue +CCBV +CCMixtbl +# OASIS_STOP diff --git a/core/CCIO.ml b/src/io/CCIO.ml similarity index 80% rename from core/CCIO.ml rename to src/io/CCIO.ml index b833275f..61f64cbb 100644 --- a/core/CCIO.ml +++ b/src/io/CCIO.ml @@ -28,6 +28,50 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type 'a gen = unit -> 'a option (** See {!CCGen} *) +let gen_singleton x = + let done_ = ref false in + fun () -> if !done_ then None else (done_ := true; Some x) + +let gen_filter_map f gen = + (* tailrec *) + let rec next () = + match gen() with + | None -> None + | Some x -> + match f x with + | None -> next() + | (Some _) as res -> res + in next + +let gen_of_array arr = + let r = ref 0 in + fun () -> + if !r = Array.length arr then None + else ( + let x = arr.(!r) in + incr r; + Some x + ) + +let gen_flat_map f next_elem = + let state = ref `Init in + let rec next() = + match !state with + | `Init -> get_next_gen() + | `Run gen -> + begin match gen () with + | None -> get_next_gen () + | (Some _) as x -> x + end + | `Stop -> None + and get_next_gen() = match next_elem() with + | None -> state:=`Stop; None + | Some x -> + try state := `Run (f x); next() + with e -> state := `Stop; raise e + in + next + let with_in ?(mode=0o644) ?(flags=[]) filename f = let ic = open_in_gen flags mode filename in try @@ -72,16 +116,14 @@ let read_lines_l ic = with End_of_file -> List.rev !l -let read_all ic = - let buf = ref (Bytes.create 256) in +let read_all ?(size=1024) ic = + let buf = ref (Bytes.create size) in let len = ref 0 in try while true do (* resize *) if !len = Bytes.length !buf then ( - let buf' = Bytes.create (2* !len) in - Bytes.blit !buf 0 buf' 0 !len; - buf := buf' + buf := Bytes.extend !buf 0 !len; ); assert (Bytes.length !buf > !len); let n = input ic !buf !len (Bytes.length !buf - !len) in @@ -171,8 +213,8 @@ module File = struct if Sys.is_directory d then let arr = Sys.readdir d in - CCGen.of_array arr - else CCGen.empty + gen_of_array arr + else fun () -> None let cons_ x tl = let first=ref true in @@ -186,19 +228,19 @@ module File = struct if Sys.is_directory d then let arr = Sys.readdir d in - let tail = CCGen.of_array arr in - let tail = CCGen.flat_map + let tail = gen_of_array arr in + let tail = gen_flat_map (fun s -> walk (Filename.concat d s)) tail in cons_ (`Dir,d) tail - else CCGen.singleton (`File, d) + else gen_singleton (`File, d) type walk_item = [`File | `Dir] * t let read_dir ?(recurse=false) d = if recurse then - CCGen.filter_map + gen_filter_map (function | `File, f -> Some f | `Dir, _ -> None diff --git a/core/CCIO.mli b/src/io/CCIO.mli similarity index 95% rename from core/CCIO.mli rename to src/io/CCIO.mli index 1e29f134..272e4ac0 100644 --- a/core/CCIO.mli +++ b/src/io/CCIO.mli @@ -29,9 +29,6 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Simple utilities to deal with basic Input/Output tasks in a resource-safe way. For advanced IO tasks, the user is advised to use something like Lwt or Async, that are far more comprehensive. -This module depends on {!CCGen}. - -@since 0.6 {b NOTE} this was formerly a monadic IO module. The old module is now in [containers.advanced] under the name [CCMonadIO]. @@ -50,15 +47,20 @@ Examples: # CCIO.( with_in "/tmp/input" (fun ic -> - with_out ~flags:[Open_creat] ~mode:0o644 "/tmp/output" + let chunks = read_chunks ic in + with_out ~flags:[Open_creat; Open_wronly] ~mode:0o644 "/tmp/output" (fun oc -> - Seq.chunks 512 ic |> Seq.to_output oc + write_gen oc chunks ) ) ) ;; ]} + +@since 0.6 + *) + type 'a gen = unit -> 'a option (** See {!CCGen} *) (** {2 Input} *) @@ -82,8 +84,9 @@ val read_lines : in_channel -> string gen val read_lines_l : in_channel -> string list (** Read all lines into a list *) -val read_all : in_channel -> string -(** Read the whole channel into a buffer, then converted into a string *) +val read_all : ?size:int -> in_channel -> string +(** Read the whole channel into a buffer, then converted into a string. + @param size the internal buffer size @since 0.7 *) (** {6 Output} *) diff --git a/src/io/containers_io.mldylib b/src/io/containers_io.mldylib new file mode 100644 index 00000000..54acdc47 --- /dev/null +++ b/src/io/containers_io.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 60d34ed5d3f17d5a8ac1501b3c6db7e7) +CCIO +# OASIS_STOP diff --git a/src/io/containers_io.mllib b/src/io/containers_io.mllib new file mode 100644 index 00000000..54acdc47 --- /dev/null +++ b/src/io/containers_io.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 60d34ed5d3f17d5a8ac1501b3c6db7e7) +CCIO +# OASIS_STOP diff --git a/core/CCKList.ml b/src/iter/CCKList.ml similarity index 100% rename from core/CCKList.ml rename to src/iter/CCKList.ml diff --git a/core/CCKList.mli b/src/iter/CCKList.mli similarity index 100% rename from core/CCKList.mli rename to src/iter/CCKList.mli diff --git a/core/CCKTree.ml b/src/iter/CCKTree.ml similarity index 100% rename from core/CCKTree.ml rename to src/iter/CCKTree.ml diff --git a/core/CCKTree.mli b/src/iter/CCKTree.mli similarity index 100% rename from core/CCKTree.mli rename to src/iter/CCKTree.mli diff --git a/src/iter/containers_iter.mldylib b/src/iter/containers_iter.mldylib new file mode 100644 index 00000000..de0a7859 --- /dev/null +++ b/src/iter/containers_iter.mldylib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 2edfdbafae02fa6210e0c192d7250b1a) +CCKTree +CCKList +# OASIS_STOP diff --git a/src/iter/containers_iter.mllib b/src/iter/containers_iter.mllib new file mode 100644 index 00000000..de0a7859 --- /dev/null +++ b/src/iter/containers_iter.mllib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 2edfdbafae02fa6210e0c192d7250b1a) +CCKTree +CCKList +# OASIS_STOP diff --git a/src/lwt/containers_lwt.mldylib b/src/lwt/containers_lwt.mldylib new file mode 100644 index 00000000..2cafc3b9 --- /dev/null +++ b/src/lwt/containers_lwt.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: bc144ef7b5b54947fab9662a822f9179) +Containers_lwt +# OASIS_STOP diff --git a/src/lwt/containers_lwt.mllib b/src/lwt/containers_lwt.mllib new file mode 100644 index 00000000..2cafc3b9 --- /dev/null +++ b/src/lwt/containers_lwt.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: bc144ef7b5b54947fab9662a822f9179) +Containers_lwt +# OASIS_STOP diff --git a/src/lwt/containers_lwt.mlpack b/src/lwt/containers_lwt.mlpack new file mode 100644 index 00000000..103df89d --- /dev/null +++ b/src/lwt/containers_lwt.mlpack @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 90e18bcaee6d0b33210b35e709b0a41c) +Lwt_automaton +Lwt_actor +# OASIS_STOP diff --git a/lwt/lwt_actor.ml b/src/lwt/lwt_actor.ml similarity index 100% rename from lwt/lwt_actor.ml rename to src/lwt/lwt_actor.ml diff --git a/lwt/lwt_actor.mli b/src/lwt/lwt_actor.mli similarity index 100% rename from lwt/lwt_actor.mli rename to src/lwt/lwt_actor.mli diff --git a/lwt/lwt_automaton.ml b/src/lwt/lwt_automaton.ml similarity index 100% rename from lwt/lwt_automaton.ml rename to src/lwt/lwt_automaton.ml diff --git a/lwt/lwt_automaton.mli b/src/lwt/lwt_automaton.mli similarity index 100% rename from lwt/lwt_automaton.mli rename to src/lwt/lwt_automaton.mli diff --git a/misc/.merlin b/src/misc/.merlin similarity index 100% rename from misc/.merlin rename to src/misc/.merlin diff --git a/misc/AVL.ml b/src/misc/AVL.ml similarity index 100% rename from misc/AVL.ml rename to src/misc/AVL.ml diff --git a/misc/AVL.mli b/src/misc/AVL.mli similarity index 100% rename from misc/AVL.mli rename to src/misc/AVL.mli diff --git a/misc/CSM.ml b/src/misc/CSM.ml similarity index 100% rename from misc/CSM.ml rename to src/misc/CSM.ml diff --git a/misc/CSM.mli b/src/misc/CSM.mli similarity index 100% rename from misc/CSM.mli rename to src/misc/CSM.mli diff --git a/misc/RAL.ml b/src/misc/RAL.ml similarity index 100% rename from misc/RAL.ml rename to src/misc/RAL.ml diff --git a/misc/RAL.mli b/src/misc/RAL.mli similarity index 100% rename from misc/RAL.mli rename to src/misc/RAL.mli diff --git a/misc/absSet.ml b/src/misc/absSet.ml similarity index 95% rename from misc/absSet.ml rename to src/misc/absSet.ml index c8cbb06c..b8603320 100644 --- a/misc/absSet.ml +++ b/src/misc/absSet.ml @@ -25,6 +25,8 @@ for any direct, indirect, incidental, special, exemplary, or consequential (** {1 Abstract set/relation} *) +type 'a sequence = ('a -> unit) -> unit + type 'a t = { mem : 'a -> bool; iter : ('a -> unit) -> unit; @@ -102,8 +104,7 @@ let product s1 s2 = let cardinal () = s1.cardinal () * s2.cardinal () in { mem; iter; cardinal; } -let to_seq set = - CCSequence.from_iter (fun k -> set.iter k) +let to_seq set k = set.iter k let to_list set = let l = ref [] in @@ -154,7 +155,7 @@ let builder_cmp (type k) ?(cmp=Pervasives.compare) () = mk_builder ~add ~get let of_seq_builder ~builder seq = - CCSequence.iter builder.add seq; + seq builder.add; builder.get () let of_seq_hash ?eq ?hash seq = @@ -165,7 +166,7 @@ let of_seq_cmp ?cmp seq = let b = builder_cmp ?cmp () in of_seq_builder b seq -let of_list l = of_seq_hash (CCSequence.of_list l) +let of_list l = of_seq_hash (fun k -> List.iter k l) let map ?(builder=builder_hash ()) set ~f = set.iter @@ -202,7 +203,7 @@ module MakeHash(X : Hashtbl.HashedType) = struct let of_seq ?(size=5) seq = let h = Hashtbl.create size in - CCSequence.iter (fun x -> Hashtbl.add h x ()) seq; + seq (fun x -> Hashtbl.add h x ()); let mem x = Hashtbl.mem h x in let iter k = Hashtbl.iter (fun x () -> k x) h in let cardinal () = Hashtbl.length h in @@ -220,8 +221,9 @@ module MakeSet(S : Set.S) = struct mk_generic ~cardinal ~mem ~iter let of_seq ?(init=S.empty) seq = - let set = CCSequence.fold (fun s x -> S.add x s) init seq in - of_set set + let set = ref init in + seq (fun x -> set := S.add x !set); + of_set !set let to_set set = fold set S.empty (fun set x -> S.add x set) diff --git a/misc/absSet.mli b/src/misc/absSet.mli similarity index 93% rename from misc/absSet.mli rename to src/misc/absSet.mli index 4bcec095..8ff8302a 100644 --- a/misc/absSet.mli +++ b/src/misc/absSet.mli @@ -25,6 +25,8 @@ for any direct, indirect, incidental, special, exemplary, or consequential (** {1 Abstract set/relation} *) +type 'a sequence = ('a -> unit) -> unit + type 'a t val empty : 'a t @@ -67,7 +69,7 @@ val intersection : 'a t -> 'a t -> 'a t val product : 'a t -> 'b t -> ('a * 'b) t (** Cartesian product *) -val to_seq : 'a t -> 'a CCSequence.t +val to_seq : 'a t -> 'a sequence val to_list : 'a t -> 'a list @@ -93,13 +95,13 @@ val builder_hash : ?size:int -> val builder_cmp : ?cmp:('a -> 'a -> int) -> unit -> 'a builder -val of_seq_builder : builder:'a builder -> 'a CCSequence.t -> 'a t +val of_seq_builder : builder:'a builder -> 'a sequence -> 'a t (** Uses the given builder to construct a set from a sequence of elements *) -val of_seq_hash : ?eq:('a -> 'a -> bool) -> ?hash:('a -> int) -> 'a CCSequence.t -> 'a t +val of_seq_hash : ?eq:('a -> 'a -> bool) -> ?hash:('a -> int) -> 'a sequence -> 'a t (** Construction of a set from a sequence of hashable elements *) -val of_seq_cmp : ?cmp:('a -> 'a -> int) -> 'a CCSequence.t -> 'a t +val of_seq_cmp : ?cmp:('a -> 'a -> int) -> 'a sequence -> 'a t (** Construction of a set from a sequence of comparable elements *) val of_list : 'a list -> 'a t @@ -133,7 +135,7 @@ module MakeHash(X : Hashtbl.HashedType) : sig type elt = X.t (** Elements of the set are hashable *) - val of_seq : ?size:int -> elt CCSequence.t -> elt t + val of_seq : ?size:int -> elt sequence -> elt t (** Build a set from a sequence *) end @@ -141,7 +143,7 @@ end module MakeSet(S : Set.S) : sig type elt = S.elt - val of_seq : ?init:S.t -> elt CCSequence.t -> elt t + val of_seq : ?init:S.t -> elt sequence -> elt t (** Build a set from a sequence *) val of_set : S.t -> elt t diff --git a/misc/automaton.ml b/src/misc/automaton.ml similarity index 100% rename from misc/automaton.ml rename to src/misc/automaton.ml diff --git a/misc/automaton.mli b/src/misc/automaton.mli similarity index 100% rename from misc/automaton.mli rename to src/misc/automaton.mli diff --git a/misc/bTree.ml b/src/misc/bTree.ml similarity index 100% rename from misc/bTree.ml rename to src/misc/bTree.ml diff --git a/misc/bTree.mli b/src/misc/bTree.mli similarity index 100% rename from misc/bTree.mli rename to src/misc/bTree.mli diff --git a/misc/bidir.ml b/src/misc/bidir.ml similarity index 100% rename from misc/bidir.ml rename to src/misc/bidir.ml diff --git a/misc/bidir.mli b/src/misc/bidir.mli similarity index 100% rename from misc/bidir.mli rename to src/misc/bidir.mli diff --git a/misc/bij.ml b/src/misc/bij.ml similarity index 100% rename from misc/bij.ml rename to src/misc/bij.ml diff --git a/misc/bij.mli b/src/misc/bij.mli similarity index 100% rename from misc/bij.mli rename to src/misc/bij.mli diff --git a/misc/cC.ml b/src/misc/cC.ml similarity index 100% rename from misc/cC.ml rename to src/misc/cC.ml diff --git a/misc/cC.mli b/src/misc/cC.mli similarity index 100% rename from misc/cC.mli rename to src/misc/cC.mli diff --git a/misc/cause.ml b/src/misc/cause.ml similarity index 100% rename from misc/cause.ml rename to src/misc/cause.ml diff --git a/misc/cause.mli b/src/misc/cause.mli similarity index 100% rename from misc/cause.mli rename to src/misc/cause.mli diff --git a/misc/circList.ml b/src/misc/circList.ml similarity index 98% rename from misc/circList.ml rename to src/misc/circList.ml index 9c795a98..0b0670be 100644 --- a/misc/circList.ml +++ b/src/misc/circList.ml @@ -124,7 +124,7 @@ let gen l = (*$Q (Q.list Q.small_int) (fun l -> \ l = [] || let q = of_list l in \ - gen q |> CCGen.take (List.length l) |> CCGen.to_list = l) + gen q |> Gen.take (List.length l) |> Gen.to_list = l) *) let seq l k = diff --git a/misc/circList.mli b/src/misc/circList.mli similarity index 100% rename from misc/circList.mli rename to src/misc/circList.mli diff --git a/src/misc/containers_misc.mldylib b/src/misc/containers_misc.mldylib new file mode 100644 index 00000000..551a3188 --- /dev/null +++ b/src/misc/containers_misc.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 2df0608accd158542ebcb00720cfe599) +Containers_misc +# OASIS_STOP diff --git a/src/misc/containers_misc.mllib b/src/misc/containers_misc.mllib new file mode 100644 index 00000000..551a3188 --- /dev/null +++ b/src/misc/containers_misc.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 2df0608accd158542ebcb00720cfe599) +Containers_misc +# OASIS_STOP diff --git a/src/misc/containers_misc.mlpack b/src/misc/containers_misc.mlpack new file mode 100644 index 00000000..38299b17 --- /dev/null +++ b/src/misc/containers_misc.mlpack @@ -0,0 +1,33 @@ +# OASIS_START +# DO NOT EDIT (digest: 9cd8890cc1fafa9902cc4f7f8f38c241) +FHashtbl +FlatHashtbl +Hashset +Heap +LazyGraph +PersistentGraph +PHashtbl +SkipList +SplayTree +SplayMap +Univ +Bij +PiCalculus +RAL +UnionFind +SmallSet +AbsSet +CSM +TTree +PrintBox +HGraph +Automaton +Conv +Bidir +Iteratee +BTree +Ty +Cause +AVL +ParseReact +# OASIS_STOP diff --git a/misc/conv.ml b/src/misc/conv.ml similarity index 100% rename from misc/conv.ml rename to src/misc/conv.ml diff --git a/misc/conv.mli b/src/misc/conv.mli similarity index 100% rename from misc/conv.mli rename to src/misc/conv.mli diff --git a/misc/fHashtbl.ml b/src/misc/fHashtbl.ml similarity index 97% rename from misc/fHashtbl.ml rename to src/misc/fHashtbl.ml index fe1b3ea2..a72dd203 100644 --- a/misc/fHashtbl.ml +++ b/src/misc/fHashtbl.ml @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Functional (persistent) hashtable} *) +type 'a sequence = ('a -> unit) -> unit + (** {2 Signatures} *) module type HASH = sig @@ -64,9 +66,9 @@ module type S = sig val size : 'a t -> int (** Number of bindings *) - val to_seq : 'a t -> (key * 'a) CCSequence.t + val to_seq : 'a t -> (key * 'a) sequence - val of_seq : ?size:int -> (key * 'a) CCSequence.t -> 'a t + val of_seq : ?size:int -> (key * 'a) sequence -> 'a t end (** {2 Persistent array} *) @@ -336,13 +338,13 @@ module Tree(X : HASH) = struct let size t = fold (fun n _ _ -> n + 1) 0 t - let to_seq t = - CCSequence.from_iter (fun k -> iter (fun key value -> k (key, value)) t) + let to_seq t k = + iter (fun key value -> k (key, value)) t let of_seq ?(size=32) seq = - CCSequence.fold - (fun t (k,v) -> replace t k v) - (empty size) seq + let cur = ref (empty size) in + seq (fun (k,v) -> cur := replace !cur k v); + !cur end (** {2 Flat hashtable} *) @@ -492,10 +494,10 @@ module Flat(X : HASH) = struct | _ -> acc) acc t.buckets - let to_seq t = - CCSequence.from_iter - (fun k -> iter (fun key value -> k (key, value)) t) + let to_seq t k = iter (fun key value -> k (key, value)) t let of_seq ?(size=32) seq = - CCSequence.fold (fun t (k,v) -> replace t k v) (empty size) seq + let t = ref (empty size) in + seq (fun (k,v) -> t := replace !t k v); + !t end diff --git a/misc/fHashtbl.mli b/src/misc/fHashtbl.mli similarity index 95% rename from misc/fHashtbl.mli rename to src/misc/fHashtbl.mli index 9bb7ca4f..27866813 100644 --- a/misc/fHashtbl.mli +++ b/src/misc/fHashtbl.mli @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Functional (persistent) hashtable} *) +type 'a sequence = ('a -> unit) -> unit + (** {2 Signatures} *) module type HASH = sig @@ -64,9 +66,9 @@ module type S = sig val size : 'a t -> int (** Number of bindings *) - val to_seq : 'a t -> (key * 'a) CCSequence.t + val to_seq : 'a t -> (key * 'a) sequence - val of_seq : ?size:int -> (key * 'a) CCSequence.t -> 'a t + val of_seq : ?size:int -> (key * 'a) sequence -> 'a t end (** {2 Persistent array} *) diff --git a/misc/flatHashtbl.ml b/src/misc/flatHashtbl.ml similarity index 96% rename from misc/flatHashtbl.ml rename to src/misc/flatHashtbl.ml index b2e2ce8d..1ff59a21 100644 --- a/misc/flatHashtbl.ml +++ b/src/misc/flatHashtbl.ml @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** Open addressing hashtable, with linear probing. *) +type 'a sequence = ('a -> unit) -> unit + module type S = sig type key @@ -61,9 +63,9 @@ module type S = val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Fold on bindings *) - val to_seq : 'a t -> (key * 'a) CCSequence.t + val to_seq : 'a t -> (key * 'a) sequence - val of_seq : 'a t -> (key * 'a) CCSequence.t -> unit + val of_seq : 'a t -> (key * 'a) sequence -> unit val stats : 'a t -> int * int * int * int * int * int (** Cf Weak.S *) @@ -218,12 +220,11 @@ module Make(H : Hashtbl.HashedType) = | _ -> fold acc (i+1) in fold acc 0 - let to_seq t = - CCSequence.from_iter - (fun k -> iter (fun key value -> k (key, value)) t) + let to_seq t k = + iter (fun key value -> k (key, value)) t let of_seq t seq = - CCSequence.iter (fun (k,v) -> replace t k v) seq + seq (fun (k,v) -> replace t k v) (** Statistics on the table *) let stats t = (Array.length t.buckets, t.size, t.size, 0, 0, 1) diff --git a/misc/flatHashtbl.mli b/src/misc/flatHashtbl.mli similarity index 95% rename from misc/flatHashtbl.mli rename to src/misc/flatHashtbl.mli index 44f2c1f4..55b462a7 100644 --- a/misc/flatHashtbl.mli +++ b/src/misc/flatHashtbl.mli @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** Open addressing hashtable, with linear probing. *) +type 'a sequence = ('a -> unit) -> unit + module type S = sig type key @@ -61,9 +63,9 @@ module type S = val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Fold on bindings *) - val to_seq : 'a t -> (key * 'a) CCSequence.t + val to_seq : 'a t -> (key * 'a) sequence - val of_seq : 'a t -> (key * 'a) CCSequence.t -> unit + val of_seq : 'a t -> (key * 'a) sequence -> unit val stats : 'a t -> int * int * int * int * int * int (** Cf Weak.S *) diff --git a/misc/hGraph.ml b/src/misc/hGraph.ml similarity index 100% rename from misc/hGraph.ml rename to src/misc/hGraph.ml diff --git a/misc/hGraph.mli b/src/misc/hGraph.mli similarity index 100% rename from misc/hGraph.mli rename to src/misc/hGraph.mli diff --git a/misc/hashset.ml b/src/misc/hashset.ml similarity index 91% rename from misc/hashset.ml rename to src/misc/hashset.ml index 5ff54bfe..110e4994 100644 --- a/misc/hashset.ml +++ b/src/misc/hashset.ml @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Mutable polymorphic hash-set} *) +type 'a sequence = ('a -> unit) -> unit + type 'a t = ('a, unit) PHashtbl.t (** A set is a hashtable, with trivial values *) @@ -49,11 +51,10 @@ let fold f acc set = PHashtbl.fold (fun acc x () -> f acc x) acc set let filter p set = PHashtbl.filter (fun x () -> p x) set -let to_seq set = - CCSequence.from_iter (fun k -> iter k set) +let to_seq set k = iter k set let of_seq set seq = - CCSequence.iter (fun x -> add set x) seq + seq (fun x -> add set x) let union ?into (s1 : 'a t) (s2 : 'a t) = let into = match into with @@ -62,10 +63,13 @@ let union ?into (s1 : 'a t) (s2 : 'a t) = of_seq into (to_seq s2); into +let seq_filter p seq k = + seq (fun x -> if p x then k x) + let inter ?into (s1 : 'a t) (s2 : 'a t) = let into = match into with | Some s -> s | None -> empty ~eq:s1.PHashtbl.eq ~hash:s1.PHashtbl.hash (cardinal s1) in (* add to [into] elements of [s1] that also belong to [s2] *) - of_seq into (CCSequence.filter (fun x -> mem s2 x) (to_seq s1)); + of_seq into (seq_filter (fun x -> mem s2 x) (to_seq s1)); into diff --git a/misc/hashset.mli b/src/misc/hashset.mli similarity index 94% rename from misc/hashset.mli rename to src/misc/hashset.mli index 92af637f..f421c557 100644 --- a/misc/hashset.mli +++ b/src/misc/hashset.mli @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Mutable polymorphic hash-set} *) +type 'a sequence = ('a -> unit) -> unit + type 'a t = ('a, unit) PHashtbl.t (** A set is a hashtable, with trivial values *) @@ -51,9 +53,9 @@ val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b val filter : ('a -> bool) -> 'a t -> unit (** destructive filter (remove elements that do not satisfy the predicate) *) -val to_seq : 'a t -> 'a CCSequence.t +val to_seq : 'a t -> 'a sequence -val of_seq : 'a t -> 'a CCSequence.t -> unit +val of_seq : 'a t -> 'a sequence -> unit val union : ?into:'a t -> 'a t -> 'a t -> 'a t (** Set union. The result is stored in [into] *) diff --git a/misc/heap.ml b/src/misc/heap.ml similarity index 98% rename from misc/heap.ml rename to src/misc/heap.ml index 1b7be900..7b402d51 100644 --- a/misc/heap.ml +++ b/src/misc/heap.ml @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Imperative priority queue} *) +type 'a sequence = ('a -> unit) -> unit + type 'a t = { mutable tree : 'a tree; cmp : 'a -> 'a -> int; diff --git a/misc/heap.mli b/src/misc/heap.mli similarity index 94% rename from misc/heap.mli rename to src/misc/heap.mli index ba901f98..e9adee7c 100644 --- a/misc/heap.mli +++ b/src/misc/heap.mli @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Imperative priority queue} *) +type 'a sequence = ('a -> unit) -> unit + type 'a t (** A heap containing values of type 'a *) @@ -51,6 +53,6 @@ val iter : 'a t -> ('a -> unit) -> unit val size : _ t -> int -val to_seq : 'a t -> 'a CCSequence.t +val to_seq : 'a t -> 'a sequence -val of_seq : 'a t -> 'a CCSequence.t -> unit +val of_seq : 'a t -> 'a sequence -> unit diff --git a/misc/iteratee.ml b/src/misc/iteratee.ml similarity index 100% rename from misc/iteratee.ml rename to src/misc/iteratee.ml diff --git a/misc/iteratee.mli b/src/misc/iteratee.mli similarity index 100% rename from misc/iteratee.mli rename to src/misc/iteratee.mli diff --git a/misc/json.ml b/src/misc/json.ml similarity index 100% rename from misc/json.ml rename to src/misc/json.ml diff --git a/misc/json.mli b/src/misc/json.mli similarity index 100% rename from misc/json.mli rename to src/misc/json.mli diff --git a/misc/lazyGraph.ml b/src/misc/lazyGraph.ml similarity index 88% rename from misc/lazyGraph.ml rename to src/misc/lazyGraph.ml index 3a2f893a..6262096c 100644 --- a/misc/lazyGraph.ml +++ b/src/misc/lazyGraph.ml @@ -29,6 +29,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. a graph is always accessed from a given initial node (so only connected components can be represented by a single value of type ('v,'e) t). *) +type 'a sequence = ('a -> unit) -> unit + (** {2 Type definitions} *) type ('id, 'v, 'e) t = { @@ -41,7 +43,7 @@ type ('id, 'v, 'e) t = { other vertices, or to Empty if the identifier is not part of the graph. *) and ('id, 'v, 'e) node = | Empty - | Node of 'id * 'v * ('e * 'id) CCSequence.t + | Node of 'id * 'v * ('e * 'id) sequence (** A single node of the graph, with outgoing edges *) and ('id, 'e) path = ('id * 'e * 'id) list (** A reverse path (from the last element of the path to the first). *) @@ -56,7 +58,7 @@ let empty = let singleton ?(eq=(=)) ?(hash=Hashtbl.hash) v label = let force v' = - if eq v v' then Node (v, label, CCSequence.empty) else Empty in + if eq v v' then Node (v, label, fun _ -> ()) else Empty in { force; eq; hash; } let make ?(eq=(=)) ?(hash=Hashtbl.hash) force = @@ -66,7 +68,7 @@ let from_fun ?(eq=(=)) ?(hash=Hashtbl.hash) f = let force v = match f v with | None -> Empty - | Some (l, edges) -> Node (v, l, CCSequence.of_list edges) in + | Some (l, edges) -> Node (v, l, fun k -> List.iter k edges) in { eq; hash; force; } (** {2 Polymorphic map} *) @@ -110,7 +112,7 @@ module Mutable = struct let map = mk_map ~eq ~hash in let force v = try let node = map.map_get v in - Node (v, node.mut_v, CCSequence.of_list node.mut_outgoing) + Node (v, node.mut_v, fun k -> List.iter k node.mut_outgoing) with Not_found -> Empty in let graph = { eq; hash; force; } in map, graph @@ -129,12 +131,10 @@ end let from_enum ?(eq=(=)) ?(hash=Hashtbl.hash) ~vertices ~edges = let g, lazy_g = Mutable.create ~eq ~hash () in - CCSequence.iter - (fun (v,label_v) -> Mutable.add_vertex g v label_v;) - vertices; - CCSequence.iter - (fun (v1, e, v2) -> Mutable.add_edge g v1 e v2) - edges; + vertices + (fun (v,label_v) -> Mutable.add_vertex g v label_v;); + edges + (fun (v1, e, v2) -> Mutable.add_edge g v1 e v2); lazy_g let from_list ?(eq=(=)) ?(hash=Hashtbl.hash) l = @@ -174,11 +174,11 @@ module Full = struct | [] -> false let bfs_full graph vertices = - CCSequence.from_iter (fun k -> + fun k -> let explored = mk_map ~eq:graph.eq ~hash:graph.hash in let id = ref 0 in let q = Queue.create () in (* queue of nodes to explore *) - CCSequence.iter (fun v -> Queue.push (FullEnter (v,[])) q) vertices; + vertices (fun v -> Queue.push (FullEnter (v,[])) q); while not (Queue.is_empty q) do match Queue.pop q with | FullEnter (v', path) -> @@ -188,11 +188,11 @@ module Full = struct | Node (_, label, edges) -> explored.map_add v' (); (* explore neighbors *) - CCSequence.iter + edges (fun (e,v'') -> let path' = (v'',e,v') :: path in - Queue.push (FullFollowEdge path') q) - edges; + Queue.push (FullFollowEdge path') q + ); (* exit node afterward *) Queue.push (FullExit v') q; (* return this vertex *) @@ -213,17 +213,17 @@ module Full = struct Queue.push (FullEnter (v'', path')) q; k (MeetEdge (v'', e, v', EdgeForward)) end - done) + done (* TODO: use a set of nodes currently being explored, rather than checking whether the node is in the path (should be faster) *) let dfs_full graph vertices = - CCSequence.from_iter (fun k -> + fun k -> let explored = mk_map ~eq:graph.eq ~hash:graph.hash in let id = ref 0 in let s = Stack.create () in (* stack of nodes to explore *) - CCSequence.iter (fun v -> Stack.push (FullEnter (v,[])) s) vertices; + vertices (fun v -> Stack.push (FullEnter (v,[])) s); while not (Stack.is_empty s) do match Stack.pop s with | FullExit v' -> k (ExitVertex v') @@ -237,10 +237,10 @@ module Full = struct (* prepare to exit later *) Stack.push (FullExit v') s; (* explore neighbors *) - CCSequence.iter + edges (fun (e,v'') -> - Stack.push (FullFollowEdge ((v'', e, v') :: path)) s) - edges; + Stack.push (FullFollowEdge ((v'', e, v') :: path)) s + ); (* return this vertex *) let i = !id in incr id; @@ -258,22 +258,28 @@ module Full = struct Stack.push (FullEnter (v'', path')) s; k (MeetEdge (v'', e, v', EdgeForward)) end - done) + done end +let seq_filter_map f seq k = + seq (fun x -> match f x with + | None -> () + | Some y -> k y + ) + let bfs graph v = - CCSequence.fmap + seq_filter_map (function | Full.EnterVertex (v, l, i, _) -> Some (v, l, i) | _ -> None) - (Full.bfs_full graph (CCSequence.singleton v)) + (Full.bfs_full graph (fun k -> k v)) let dfs graph v = - CCSequence.fmap + seq_filter_map (function | Full.EnterVertex (v, l, i, _) -> Some (v, l, i) | _ -> None) - (Full.dfs_full graph (CCSequence.singleton v)) + (Full.dfs_full graph (fun k -> k v)) (** {3 Mutable heap} *) module Heap = struct @@ -342,7 +348,7 @@ let a_star graph ?(distance=(fun v1 e v2 -> 1.)) ~goal start = - CCSequence.from_iter (fun k -> + fun k -> (* map node -> 'came_from' cell *) let nodes = mk_map ~eq:graph.eq ~hash:graph.hash in (* priority queue for nodes to explore *) @@ -376,7 +382,7 @@ let a_star graph | Empty -> () | Node (_, label, edges) -> (* explore neighbors *) - CCSequence.iter + edges (fun (e,v'') -> let cost = dist +. distance v' e v'' +. heuristic v'' in let cell' = @@ -395,14 +401,20 @@ let a_star graph Heap.insert h (cost, v''); cell'.cf_cost <- cost; (* update best cost/path *) cell'.cf_prev <- CFEdge (e, cell); - end) - edges; + end); (* check whether the node we just explored is a goal node *) if goal v' (* found a goal node! yield it *) then k (dist, mk_path nodes [] v') end - done) + done + +exception ExitHead +let seq_head seq = + let r = ref None in + try + seq (fun x -> r := Some x; raise ExitHead); None + with ExitHead -> !r (** Shortest path from the first node to the second one, according to the given (positive!) distance function. The path is reversed, @@ -413,22 +425,29 @@ let dijkstra graph ?on_explore ?(ignore=fun v -> false) a_star graph ?on_explore ~ignore ~distance ~heuristic:(fun _ -> 0.) ~goal:(fun v -> graph.eq v v2) v1 in - match CCSequence.to_list (CCSequence.take 1 paths) with - | [] -> raise Not_found - | [x] -> x - | _ -> assert false + match seq_head paths with + | None -> raise Not_found + | Some x -> x + +exception ExitForall +let seq_for_all p seq = + try + seq (fun x -> if not (p x) then raise ExitForall); + true + with ExitForall -> false + (** Is the subgraph explorable from the given vertex, a Directed Acyclic Graph? *) let is_dag graph v = - CCSequence.for_all + seq_for_all (function | Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false | _ -> true) - (Full.dfs_full graph (CCSequence.singleton v)) + (Full.dfs_full graph (fun k -> k v)) let is_dag_full graph vs = - CCSequence.for_all + seq_for_all (function | Full.MeetEdge (_, _, _, Full.EdgeBackward) -> false | _ -> true) @@ -443,9 +462,8 @@ let find_cycle graph v = let cycle = ref [] in try let path_stack = Stack.create () in - let seq = Full.dfs_full graph (CCSequence.singleton v) in - CCSequence.iter - (function + let seq = Full.dfs_full graph (fun k -> k v) in + seq (function | Full.EnterVertex (_, _, _, path) -> Stack.push path path_stack | Full.ExitVertex _ -> @@ -456,8 +474,8 @@ let find_cycle graph v = let path = (v1, e, v2) :: path in cycle := path; raise Exit - | Full.MeetEdge _ -> ()) - seq; + | Full.MeetEdge _ -> () + ); raise Not_found with Exit -> !cycle @@ -471,6 +489,9 @@ let rev_path p = (** {2 Lazy transformations} *) +let seq_map f seq k = seq (fun x -> k (f x)) +let seq_append s1 s2 k = s1 k; s2 k + let union ?(combine=fun x y -> x) g1 g2 = let force v = match g1.force v, g2.force v with @@ -478,7 +499,7 @@ let union ?(combine=fun x y -> x) g1 g2 = | ((Node _) as n), Empty -> n | Empty, ((Node _) as n) -> n | Node (_, l1, e1), Node (_, l2, e2) -> - Node (v, combine l1 l2, CCSequence.append e1 e2) + Node (v, combine l1 l2, seq_append e1 e2) in { eq=g1.eq; hash=g1.hash; force; } let map ~vertices ~edges g = @@ -486,10 +507,12 @@ let map ~vertices ~edges g = match g.force v with | Empty -> Empty | Node (_, l, edges_enum) -> - let edges_enum' = CCSequence.map (fun (e,v') -> (edges e), v') edges_enum in + let edges_enum' = seq_map (fun (e,v') -> (edges e), v') edges_enum in Node (v, vertices l, edges_enum') in { eq=g.eq; hash=g.hash; force; } +let seq_flat_map f seq k = seq (fun x -> f x k) + (** Replace each vertex by some vertices. By mapping [v'] to [f v'=v1,...,vn], whenever [v] ---e---> [v'], then [v --e--> vi] for i=1,...,n. *) let flatMap f g = @@ -497,24 +520,29 @@ let flatMap f g = match g.force v with | Empty -> Empty | Node (_, l, edges_enum) -> - let edges_enum' = CCSequence.flatMap + let edges_enum' = seq_flat_map (fun (e, v') -> - CCSequence.map (fun v'' -> e, v'') (f v')) + seq_map (fun v'' -> e, v'') (f v')) edges_enum in Node (v, l, edges_enum') in { eq=g.eq; hash=g.hash; force; } +let seq_filter p seq k = seq (fun x -> if p x then k x) + let filter ?(vertices=(fun v l -> true)) ?(edges=fun v1 e v2 -> true) g = let force v = match g.force v with | Empty -> Empty | Node (_, l, edges_enum) when vertices v l -> (* filter out edges *) - let edges_enum' = CCSequence.filter (fun (e,v') -> edges v e v') edges_enum in + let edges_enum' = seq_filter (fun (e,v') -> edges v e v') edges_enum in Node (v, l, edges_enum') | Node _ -> Empty (* filter out this vertex *) in { eq=g.eq; hash=g.hash; force; } +let seq_product s1 s2 k = + s1 (fun x -> s2 (fun y -> k(x,y))) + let product g1 g2 = let force (v1,v2) = match g1.force v1, g2.force v2 with @@ -522,8 +550,8 @@ let product g1 g2 = | _, Empty -> Empty | Node (_, l1, edges1), Node (_, l2, edges2) -> (* product of edges *) - let edges = CCSequence.product edges1 edges2 in - let edges = CCSequence.map (fun ((e1,v1'),(e2,v2')) -> ((e1,e2),(v1',v2'))) edges in + let edges = seq_product edges1 edges2 in + let edges = seq_map (fun ((e1,v1'),(e2,v2')) -> ((e1,e2),(v1',v2'))) edges in Node ((v1,v2), (l1,l2), edges) and eq (v1,v2) (v1',v2') = g1.eq v1 v1' && g2.eq v2 v2' @@ -574,7 +602,7 @@ module Dot = struct (* print preamble *) Format.fprintf formatter "@[digraph %s {@;" name; (* traverse *) - CCSequence.iter + events (function | Full.EnterVertex (v, attrs, _, _) -> Format.fprintf formatter " @[%a %a;@]@." pp_vertex v @@ -584,8 +612,8 @@ module Dot = struct Format.fprintf formatter " @[%a -> %a %a;@]@." pp_vertex v1 pp_vertex v2 (CCList.print ~start:"[" ~stop:"]" ~sep:"," print_attribute) - attrs) - events; + attrs + ); (* close *) Format.fprintf formatter "}@]@;@?"; () @@ -608,17 +636,17 @@ let divisors_graph = if i > 2 then let l = divisors [] 2 i in - let edges = CCSequence.map (fun i -> (), i) (CCSequence.of_list l) in + let edges = seq_map (fun i -> (), i) (fun k -> List.iter k l) in Node (i, i, edges) else - Node (i, i, CCSequence.empty) + Node (i, i, fun _ -> ()) in make force let collatz_graph = let force i = if i mod 2 = 0 - then Node (i, i, CCSequence.singleton ((), i / 2)) - else Node (i, i, CCSequence.singleton ((), i * 3 + 1)) + then Node (i, i, fun k -> k ((), i / 2)) + else Node (i, i, fun k -> k ((), i * 3 + 1)) in make force let collatz_graph_bis = @@ -628,10 +656,10 @@ let collatz_graph_bis = ; false, i * 2 ] @ if i mod 3 = 1 then [false, (i-1)/3] else [] in - Node (i, i, CCSequence.of_list l) + Node (i, i, fun k -> List.iter k l) in make force let heap_graph = let force i = - Node (i, i, CCSequence.of_list [(), 2*i; (), 2*i+1]) + Node (i, i, fun k -> List.iter k [(), 2*i; (), 2*i+1]) in make force diff --git a/misc/lazyGraph.mli b/src/misc/lazyGraph.mli similarity index 92% rename from misc/lazyGraph.mli rename to src/misc/lazyGraph.mli index 1b33d983..5c88d026 100644 --- a/misc/lazyGraph.mli +++ b/src/misc/lazyGraph.mli @@ -34,6 +34,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {2 Type definitions} *) +type 'a sequence = ('a -> unit) -> unit + type ('id, 'v, 'e) t = { eq : 'id -> 'id -> bool; hash : 'id -> int; @@ -44,7 +46,7 @@ type ('id, 'v, 'e) t = { other vertices, or to Empty if the identifier is not part of the graph. *) and ('id, 'v, 'e) node = | Empty - | Node of 'id * 'v * ('e * 'id) CCSequence.t + | Node of 'id * 'v * ('e * 'id) sequence (** A single node of the graph, with outgoing edges *) and ('id, 'e) path = ('id * 'e * 'id) list (** A reverse path (from the last element of the path to the first). *) @@ -70,8 +72,8 @@ val make : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> (** Build a graph from the [force] function *) val from_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> - vertices:('id * 'v) CCSequence.t -> - edges:('id * 'e * 'id) CCSequence.t -> + vertices:('id * 'v) sequence -> + edges:('id * 'e * 'id) sequence -> ('id, 'v, 'e) t (** Concrete (eager) representation of a Graph *) @@ -117,21 +119,21 @@ module Full : sig | EdgeBackward (* toward the current trail *) | EdgeTransverse (* toward a totally explored part of the graph *) - val bfs_full : ('id, 'v, 'e) t -> 'id CCSequence.t -> - ('id, 'v, 'e) traverse_event CCSequence.t + val bfs_full : ('id, 'v, 'e) t -> 'id sequence -> + ('id, 'v, 'e) traverse_event sequence (** Lazy traversal in breadth first from a finite set of vertices *) - val dfs_full : ('id, 'v, 'e) t -> 'id CCSequence.t -> - ('id, 'v, 'e) traverse_event CCSequence.t + val dfs_full : ('id, 'v, 'e) t -> 'id sequence -> + ('id, 'v, 'e) traverse_event sequence (** Lazy traversal in depth first from a finite set of vertices *) end (** The traversal functions assign a unique ID to every traversed node *) -val bfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) CCSequence.t +val bfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) sequence (** Lazy traversal in breadth first *) -val dfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) CCSequence.t +val dfs : ('id, 'v, 'e) t -> 'id -> ('id * 'v * int) sequence (** Lazy traversal in depth first *) module Heap : sig @@ -149,7 +151,7 @@ val a_star : ('id, 'v, 'e) t -> ?distance:('id -> 'e -> 'id -> float) -> goal:('id -> bool) -> 'id -> - (float * ('id, 'e) path) CCSequence.t + (float * ('id, 'e) path) sequence (** Shortest path from the first node to nodes that satisfy [goal], according to the given (positive!) distance function. The distance is also returned. [ignore] allows one to ignore some vertices during exploration. @@ -174,7 +176,7 @@ val is_dag : ('id, _, _) t -> 'id -> bool (** Is the subgraph explorable from the given vertex, a Directed Acyclic Graph? *) -val is_dag_full : ('id, _, _) t -> 'id CCSequence.t -> bool +val is_dag_full : ('id, _, _) t -> 'id sequence -> bool (** Is the Graph reachable from the given vertices, a DAG? See {! is_dag} *) val find_cycle : ('id, _, 'e) t -> 'id -> ('id, 'e) path @@ -196,7 +198,7 @@ val map : vertices:('v -> 'v2) -> edges:('e -> 'e2) -> ('id, 'v, 'e) t -> ('id, 'v2, 'e2) t (** Map vertice and edge labels *) -val flatMap : ('id -> 'id CCSequence.t) -> +val flatMap : ('id -> 'id sequence) -> ('id, 'v, 'e) t -> ('id, 'v, 'e) t (** Replace each vertex by some vertices. By mapping [v'] to [f v'=v1,...,vn], @@ -231,12 +233,12 @@ module Dot : sig val pp_enum : ?eq:('id -> 'id -> bool) -> ?hash:('id -> int) -> name:string -> Format.formatter -> - ('id,attribute list,attribute list) Full.traverse_event CCSequence.t -> + ('id,attribute list,attribute list) Full.traverse_event sequence -> unit val pp : name:string -> ('id, attribute list, attribute list) t -> Format.formatter -> - 'id CCSequence.t -> unit + 'id sequence -> unit (** Pretty print the given graph (starting from the given set of vertices) to the channel in DOT format *) end diff --git a/misc/pHashtbl.ml b/src/misc/pHashtbl.ml similarity index 98% rename from misc/pHashtbl.ml rename to src/misc/pHashtbl.ml index fc138ecf..86458bcf 100644 --- a/misc/pHashtbl.ml +++ b/src/misc/pHashtbl.ml @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Open addressing hashtable (robin hood hashing)} *) +type 'a sequence = ('a -> unit) -> unit + type ('a, 'b) t = { mutable buckets : ('a, 'b) bucket array; mutable size : int; @@ -77,7 +79,7 @@ let clear t = (** Index of slot, for i-th probing starting from hash [h] in a table of length [n] *) let addr h n i = (h + i) mod n - + (** Insert (key -> value) in table, starting with the hash. *) let insert t key value = let n = Array.length t.buckets in @@ -217,12 +219,10 @@ let filter pred t = (** Add the given pairs to the hashtable *) let of_seq t seq = - CCSequence.iter (fun (k,v) -> add t k v) seq + seq (fun (k,v) -> add t k v) (** CCSequence of pairs *) -let to_seq t = - CCSequence.from_iter - (fun kont -> iter (fun k v -> kont (k,v)) t) +let to_seq t kont = iter (fun k v -> kont (k,v)) t (** Statistics on the table *) let stats t = (Array.length t.buckets, t.size, t.size, 0, 0, 1) diff --git a/misc/pHashtbl.mli b/src/misc/pHashtbl.mli similarity index 95% rename from misc/pHashtbl.mli rename to src/misc/pHashtbl.mli index d5d8bd54..2a9c82c1 100644 --- a/misc/pHashtbl.mli +++ b/src/misc/pHashtbl.mli @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Open addressing hashtable (robin hood hashing)} *) +type 'a sequence = ('a -> unit) -> unit + type ('a, 'b) t = { mutable buckets : ('a, 'b) bucket array; mutable size : int; @@ -90,11 +92,11 @@ val filter : ('a -> 'b -> bool) -> ('a, 'b) t -> unit val fold : ('c -> 'a -> 'b -> 'c) -> 'c -> ('a, 'b) t -> 'c (** Fold on bindings *) -val of_seq : ('a, 'b) t -> ('a * 'b) CCSequence.t -> unit +val of_seq : ('a, 'b) t -> ('a * 'b) sequence -> unit (** Add the given pairs to the hashtable *) -val to_seq : ('a, 'b) t -> ('a * 'b) CCSequence.t - (** CCSequence of pairs *) +val to_seq : ('a, 'b) t -> ('a * 'b) sequence + (** Sequence of pairs *) val stats : (_, _) t -> int * int * int * int * int * int (** Cf Weak.S *) diff --git a/misc/parseReact.ml b/src/misc/parseReact.ml similarity index 99% rename from misc/parseReact.ml rename to src/misc/parseReact.ml index d1eee788..99b7c12e 100644 --- a/misc/parseReact.ml +++ b/src/misc/parseReact.ml @@ -232,6 +232,6 @@ let run p seq = <|> (skip_spaces >> exact '(' >> many1 ~sep:(exact ' ') (delay p) >>= fun l -> skip_spaces >> exact ')' >> return (list_ l)) in - let res = run (p ()) (CCSequence.of_str "(a b (c d))") in + let res = run (p ()) (Sequence.of_str "(a b (c d))") in assert_equal res [list_ [atom "a"; atom "b"; list_ [atom "c"; atom "d"]]] *) diff --git a/misc/parseReact.mli b/src/misc/parseReact.mli similarity index 100% rename from misc/parseReact.mli rename to src/misc/parseReact.mli diff --git a/misc/persistentGraph.ml b/src/misc/persistentGraph.ml similarity index 88% rename from misc/persistentGraph.ml rename to src/misc/persistentGraph.ml index 1928e6f5..fb42ea08 100644 --- a/misc/persistentGraph.ml +++ b/src/misc/persistentGraph.ml @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 A simple polymorphic directed graph.} *) +type 'a sequence = ('a -> unit) -> unit + type ('v, 'e) t = ('v, ('v, 'e) node) PHashtbl.t (** Graph parametrized by a type for vertices, and one for edges *) and ('v, 'e) node = { @@ -83,25 +85,27 @@ let add t v1 e v2 = () let add_seq t seq = - CCSequence.iter (fun (v1,e,v2) -> add t v1 e v2) seq + seq (fun (v1,e,v2) -> add t v1 e v2) -let next t v = - CCSequence.of_list (PHashtbl.find t v).n_next +let next t v k = + List.iter k (PHashtbl.find t v).n_next -let prev t v = - CCSequence.of_list (PHashtbl.find t v).n_prev +let prev t v k = + List.iter k (PHashtbl.find t v).n_prev + +let seq_map f seq k = seq (fun x -> k (f x)) +let seq_filter p seq k = seq (fun x -> if p x then k x) let between t v1 v2 = - let edges = CCSequence.of_list (PHashtbl.find t v1).n_next in - let edges = CCSequence.filter (fun (e, v2') -> (PHashtbl.get_eq t) v2 v2') edges in - CCSequence.map fst edges + let edges k = List.iter k (PHashtbl.find t v1).n_next in + let edges = seq_filter (fun (e, v2') -> (PHashtbl.get_eq t) v2 v2') edges in + seq_map fst edges (** Call [k] on every vertex *) let iter_vertices t k = PHashtbl.iter (fun v _ -> k v) t -let vertices t = - CCSequence.from_iter (iter_vertices t) +let vertices t = iter_vertices t (** Call [k] on every edge *) let iter t k = @@ -109,27 +113,37 @@ let iter t k = (fun v1 node -> List.iter (fun (e, v2) -> k (v1, e, v2)) node.n_next) t -let to_seq t = - CCSequence.from_iter (iter t) +let to_seq t = iter t (** {2 Global operations} *) +exception ExitIsEmpty +let seq_is_empty seq = + try seq (fun _ -> raise ExitIsEmpty); true + with ExitIsEmpty -> false + (** Roots, ie vertices with no incoming edges *) let roots g = let vertices = vertices g in - CCSequence.filter (fun v -> CCSequence.is_empty (prev g v)) vertices + seq_filter (fun v -> seq_is_empty (prev g v)) vertices (** Leaves, ie vertices with no outgoing edges *) let leaves g = let vertices = vertices g in - CCSequence.filter (fun v -> CCSequence.is_empty (next g v)) vertices + seq_filter (fun v -> seq_is_empty (next g v)) vertices + +exception ExitHead +let seq_head seq = + let r = ref None in + try + seq (fun x -> r := Some x; raise ExitHead); None + with ExitHead -> !r (** Pick a vertex, or raise Not_found *) let choose g = - match CCSequence.to_list (CCSequence.take 1 (vertices g)) with - | [x] -> x - | [] -> raise Not_found - | _ -> assert false + match seq_head (vertices g) with + | Some x -> x + | None -> raise Not_found let rev_edge (v,e,v') = (v',e,v) @@ -155,14 +169,12 @@ let bfs graph first k = (* yield current node *) k v; (* explore children *) - CCSequence.iter + next graph v (fun (e, v') -> if not (Hashset.mem explored v') then (Hashset.add explored v'; Queue.push v' q)) - (next graph v) done -let bfs_seq graph first = - CCSequence.from_iter (fun k -> bfs graph first k) +let bfs_seq graph first k = bfs graph first k (** DFS, with callbacks called on each encountered node and edge *) let dfs_full graph ?(labels=mk_v_table graph) @@ -183,7 +195,7 @@ first (* enter the node *) enter trail'; (* explore edges *) - CCSequence.iter + next graph v (fun (e, v') -> try let n' = PHashtbl.find labels v' in if n' < n && List.exists (fun (_,n'') -> n' = n'') trail' @@ -192,8 +204,8 @@ first fwd_edge (v,e,v') (* forward or cross edge *) with Not_found -> tree_edge (v,e,v'); (* tree edge *) - explore trail' v') (* explore the subnode *) - (next graph v); + explore trail' v' (* explore the subnode *) + ); (* exit the node *) exit trail' end @@ -216,10 +228,10 @@ let is_dag g = else try let labels = mk_v_table g in (* do a DFS from each root; any back edge indicates a cycle *) - CCSequence.iter + vertices g (fun v -> - dfs_full g ~labels ~back_edge:(fun _ -> raise Exit) v) - (vertices g); + dfs_full g ~labels ~back_edge:(fun _ -> raise Exit) v + ); true (* complete traversal without back edge *) with Exit -> false (* back edge detected! *) @@ -259,14 +271,13 @@ let min_path_full (type v) (type e) graph else begin Hashset.add explored v; (* explore successors *) - CCSequence.iter + next graph v (fun (e, v') -> if Hashset.mem explored v' || ignore v' then () else let cost_v' = (cost v e v') + cost_v in let path' = (v',e,v) :: path in Heap.insert q (v', cost_v', path')) - (next graph v) end done; (* if a satisfying path was found, Exit would have been raised *) @@ -307,7 +318,7 @@ type attribute = [ (** Pretty print the graph in DOT, on given formatter. Using a sequence allows to easily select which edges are important, - or to combine several graphs with [CCSequence.append]. *) + or to combine several graphs with [seq_append]. *) let pp ~name ?vertices ~(print_edge : 'v -> 'e -> 'v -> attribute list) ~(print_vertex : 'v -> attribute list) formatter (graph : ('v, 'e) t) = @@ -341,14 +352,14 @@ let pp ~name ?vertices (* print preamble *) Format.fprintf formatter "@[digraph %s {@;" name; (* print edges *) - CCSequence.iter + to_seq graph (fun (v1, e, v2) -> let attributes = print_edge v1 e v2 in Format.fprintf formatter " @[%a -> %a [%a];@]@." pp_vertex v1 pp_vertex v2 (CCList.print ~sep:"," print_attribute) - attributes) - (to_seq graph); + attributes + ); (* print vertices *) PHashtbl.iter (fun v _ -> diff --git a/misc/persistentGraph.mli b/src/misc/persistentGraph.mli similarity index 90% rename from misc/persistentGraph.mli rename to src/misc/persistentGraph.mli index 6c061706..8ec044cc 100644 --- a/misc/persistentGraph.mli +++ b/src/misc/persistentGraph.mli @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 A simple polymorphic directed graph.} *) +type 'a sequence = ('a -> unit) -> unit + (** {2 Basics} *) type ('v, 'e) t @@ -51,31 +53,31 @@ val length : (_, _) t -> int val add : ('v,'e) t -> 'v -> 'e -> 'v -> unit (** Add an edge between two vertices *) -val add_seq : ('v,'e) t -> ('v * 'e * 'v) CCSequence.t -> unit +val add_seq : ('v,'e) t -> ('v * 'e * 'v) sequence -> unit (** Add the vertices to the graph *) -val next : ('v, 'e) t -> 'v -> ('e * 'v) CCSequence.t +val next : ('v, 'e) t -> 'v -> ('e * 'v) sequence (** Outgoing edges *) -val prev : ('v, 'e) t -> 'v -> ('e * 'v) CCSequence.t +val prev : ('v, 'e) t -> 'v -> ('e * 'v) sequence (** Incoming edges *) -val between : ('v, 'e) t -> 'v -> 'v -> 'e CCSequence.t +val between : ('v, 'e) t -> 'v -> 'v -> 'e sequence val iter_vertices : ('v, 'e) t -> ('v -> unit) -> unit -val vertices : ('v, 'e) t -> 'v CCSequence.t +val vertices : ('v, 'e) t -> 'v sequence (** Iterate on vertices *) val iter : ('v, 'e) t -> ('v * 'e * 'v -> unit) -> unit -val to_seq : ('v, 'e) t -> ('v * 'e * 'v) CCSequence.t +val to_seq : ('v, 'e) t -> ('v * 'e * 'v) sequence (** Dump the graph as a sequence of vertices *) (** {2 Global operations} *) -val roots : ('v, 'e) t -> 'v CCSequence.t +val roots : ('v, 'e) t -> 'v sequence (** Roots, ie vertices with no incoming edges *) -val leaves : ('v, 'e) t -> 'v CCSequence.t +val leaves : ('v, 'e) t -> 'v sequence (** Leaves, ie vertices with no outgoing edges *) val choose : ('v, 'e) t -> 'v @@ -92,8 +94,8 @@ val rev : ('v, 'e) t -> unit val bfs : ('v, 'e) t -> 'v -> ('v -> unit) -> unit (** Breadth-first search, from given 'v *) -val bfs_seq : ('v, 'e) t -> 'v -> 'v CCSequence.t - (** CCSequence of vertices traversed during breadth-first search *) +val bfs_seq : ('v, 'e) t -> 'v -> 'v sequence + (** Sequence of vertices traversed during breadth-first search *) val dfs_full : ('v, 'e) t -> ?labels:('v, int) PHashtbl.t -> diff --git a/misc/piCalculus.ml b/src/misc/piCalculus.ml similarity index 100% rename from misc/piCalculus.ml rename to src/misc/piCalculus.ml diff --git a/misc/piCalculus.mli b/src/misc/piCalculus.mli similarity index 100% rename from misc/piCalculus.mli rename to src/misc/piCalculus.mli diff --git a/misc/printBox.ml b/src/misc/printBox.ml similarity index 100% rename from misc/printBox.ml rename to src/misc/printBox.ml diff --git a/misc/printBox.mli b/src/misc/printBox.mli similarity index 100% rename from misc/printBox.mli rename to src/misc/printBox.mli diff --git a/misc/puf.ml b/src/misc/puf.ml similarity index 100% rename from misc/puf.ml rename to src/misc/puf.ml diff --git a/misc/puf.mli b/src/misc/puf.mli similarity index 100% rename from misc/puf.mli rename to src/misc/puf.mli diff --git a/misc/skipList.ml b/src/misc/skipList.ml similarity index 97% rename from misc/skipList.ml rename to src/misc/skipList.ml index 60db79a6..c9af6a63 100644 --- a/misc/skipList.ml +++ b/src/misc/skipList.ml @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Imperative skip-list} *) +type 'a gen = unit -> 'a option + (** Most functions are inspired from "A skip list cookbook", William Pugh, 1989. *) @@ -187,6 +189,10 @@ let gen l = x := a.(0); Some (k, !v) +let rec gen_iter f g = match g() with + | None -> () + | Some x -> f x; gen_iter f g + (** Add content of the iterator to the list *) let of_gen l gen = - CCGen.iter (fun (k,v) -> add l k v) gen + gen_iter (fun (k,v) -> add l k v) gen diff --git a/misc/skipList.mli b/src/misc/skipList.mli similarity index 94% rename from misc/skipList.mli rename to src/misc/skipList.mli index 42b357c9..d701e4b9 100644 --- a/misc/skipList.mli +++ b/src/misc/skipList.mli @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Imperative skip-list} *) +type 'a gen = unit -> 'a option + type ('a, 'b) t (** A skip list that maps elements of type 'a to elements of type 'b *) @@ -53,6 +55,6 @@ val remove : ('a, 'b) t -> 'a -> unit val length : (_, _) t -> int (** Number of elements *) -val gen : ('a, 'b) t -> ('a * 'b) CCGen.t +val gen : ('a, 'b) t -> ('a * 'b) gen -val of_gen : ('a, 'b) t -> ('a * 'b) CCGen.t -> unit +val of_gen : ('a, 'b) t -> ('a * 'b) gen -> unit diff --git a/misc/smallSet.ml b/src/misc/smallSet.ml similarity index 94% rename from misc/smallSet.ml rename to src/misc/smallSet.ml index 24b5ae69..23082bfa 100644 --- a/misc/smallSet.ml +++ b/src/misc/smallSet.ml @@ -25,6 +25,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Small set structure} *) +type 'a sequence = ('a -> unit) -> unit + type 'a t = { cmp : 'a -> 'a -> int; nodes : 'a node; @@ -123,11 +125,15 @@ let to_seq set = iter k set let of_seq set seq = - CCSequence.fold add set seq + let set = ref set in + seq (fun x -> set := add !set x); + !set let to_list set = - CCSequence.to_rev_list (to_seq set) + let l = ref [] in + to_seq set (fun x -> l := x :: !l); + !l let of_list set l = - of_seq set (CCSequence.of_list l) + List.fold_left add set l diff --git a/misc/smallSet.mli b/src/misc/smallSet.mli similarity index 94% rename from misc/smallSet.mli rename to src/misc/smallSet.mli index 1582b5e8..0a46593e 100644 --- a/misc/smallSet.mli +++ b/src/misc/smallSet.mli @@ -29,6 +29,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. function. It is implemented as a sorted list, so most operations are in linear time. *) +type 'a sequence = ('a -> unit) -> unit + + type 'a t (** Set of elements of type 'a *) @@ -59,9 +62,9 @@ val iter : ('a -> unit) -> 'a t -> unit val size : _ t -> int (** Number of elements *) -val to_seq : 'a t -> 'a CCSequence.t +val to_seq : 'a t -> 'a sequence -val of_seq : 'a t -> 'a CCSequence.t -> 'a t +val of_seq : 'a t -> 'a sequence -> 'a t val to_list : 'a t -> 'a list diff --git a/misc/splayMap.ml b/src/misc/splayMap.ml similarity index 96% rename from misc/splayMap.ml rename to src/misc/splayMap.ml index 5e6465f9..4a9de67d 100644 --- a/misc/splayMap.ml +++ b/src/misc/splayMap.ml @@ -29,6 +29,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. http://www.cs.cornell.edu/Courses/cs3110/2009fa/recitations/rec-splay.html *) +type 'a sequence = ('a -> unit) -> unit + (** {2 Polymorphic Maps} *) type ('a, 'b) t = { @@ -192,11 +194,12 @@ let choose t = | Node (k, v, _, _) -> k, v let to_seq t = - CCSequence.from_iter - (fun kont -> iter t (fun k v -> kont (k, v))) + fun kont -> iter t (fun k v -> kont (k, v)) let of_seq t seq = - CCSequence.fold (fun t (k, v) -> add t k v) t seq + let t = ref t in + seq (fun (k, v) -> t := add !t k v); + !t (** {2 Functorial interface} *) @@ -238,9 +241,9 @@ module type S = sig val choose : 'a t -> (key * 'a) (** Some binding, or raises Not_found *) - val to_seq : 'a t -> (key * 'a) CCSequence.t + val to_seq : 'a t -> (key * 'a) sequence - val of_seq : 'a t -> (key * 'a) CCSequence.t -> 'a t + val of_seq : 'a t -> (key * 'a) sequence -> 'a t end module type ORDERED = sig @@ -404,9 +407,10 @@ module Make(X : ORDERED) = struct | Node (k, v, _, _) -> k, v let to_seq t = - CCSequence.from_iter - (fun kont -> iter t (fun k v -> kont (k, v))) + fun kont -> iter t (fun k v -> kont (k, v)) let of_seq t seq = - CCSequence.fold (fun t (k, v) -> add t k v) t seq + let t = ref t in + seq (fun (k, v) -> t := add !t k v); + !t end diff --git a/misc/splayMap.mli b/src/misc/splayMap.mli similarity index 93% rename from misc/splayMap.mli rename to src/misc/splayMap.mli index 8d591977..6733f506 100644 --- a/misc/splayMap.mli +++ b/src/misc/splayMap.mli @@ -28,6 +28,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (* TODO: map-wide operations: merge, compare, equal, for_all, exists, batch (sorted) add, partition, split, max_elt, min_elt, map... *) +type 'a sequence = ('a -> unit) -> unit + + (** {2 Polymorphic Maps} *) type ('a, 'b) t @@ -69,9 +72,9 @@ val size : (_, _) t -> int val choose : ('a, 'b) t -> ('a * 'b) (** Some binding, or raises Not_found *) -val to_seq : ('a, 'b) t -> ('a * 'b) CCSequence.t +val to_seq : ('a, 'b) t -> ('a * 'b) sequence -val of_seq : ('a, 'b) t -> ('a * 'b) CCSequence.t -> ('a, 'b) t +val of_seq : ('a, 'b) t -> ('a * 'b) sequence -> ('a, 'b) t (** {2 Functorial interface} *) @@ -113,9 +116,9 @@ module type S = sig val choose : 'a t -> (key * 'a) (** Some binding, or raises Not_found *) - val to_seq : 'a t -> (key * 'a) CCSequence.t + val to_seq : 'a t -> (key * 'a) sequence - val of_seq : 'a t -> (key * 'a) CCSequence.t -> 'a t + val of_seq : 'a t -> (key * 'a) sequence -> 'a t end module type ORDERED = sig diff --git a/misc/splayTree.ml b/src/misc/splayTree.ml similarity index 100% rename from misc/splayTree.ml rename to src/misc/splayTree.ml diff --git a/misc/splayTree.mli b/src/misc/splayTree.mli similarity index 100% rename from misc/splayTree.mli rename to src/misc/splayTree.mli diff --git a/misc/tTree.ml b/src/misc/tTree.ml similarity index 100% rename from misc/tTree.ml rename to src/misc/tTree.ml diff --git a/misc/tTree.mli b/src/misc/tTree.mli similarity index 100% rename from misc/tTree.mli rename to src/misc/tTree.mli diff --git a/misc/ty.ml b/src/misc/ty.ml similarity index 100% rename from misc/ty.ml rename to src/misc/ty.ml diff --git a/misc/ty.mli b/src/misc/ty.mli similarity index 100% rename from misc/ty.mli rename to src/misc/ty.mli diff --git a/misc/unionFind.ml b/src/misc/unionFind.ml similarity index 100% rename from misc/unionFind.ml rename to src/misc/unionFind.ml diff --git a/misc/unionFind.mli b/src/misc/unionFind.mli similarity index 100% rename from misc/unionFind.mli rename to src/misc/unionFind.mli diff --git a/misc/univ.ml b/src/misc/univ.ml similarity index 100% rename from misc/univ.ml rename to src/misc/univ.ml diff --git a/misc/univ.mli b/src/misc/univ.mli similarity index 100% rename from misc/univ.mli rename to src/misc/univ.mli diff --git a/misc/utils.ml b/src/misc/utils.ml similarity index 100% rename from misc/utils.ml rename to src/misc/utils.ml diff --git a/pervasives/CCPervasives.ml b/src/pervasives/CCPervasives.ml similarity index 100% rename from pervasives/CCPervasives.ml rename to src/pervasives/CCPervasives.ml diff --git a/src/pervasives/containers_pervasives.mldylib b/src/pervasives/containers_pervasives.mldylib new file mode 100644 index 00000000..9dc3b5e4 --- /dev/null +++ b/src/pervasives/containers_pervasives.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: ea286cccf88f4c81c7b4627216807d4e) +CCPervasives +# OASIS_STOP diff --git a/src/pervasives/containers_pervasives.mllib b/src/pervasives/containers_pervasives.mllib new file mode 100644 index 00000000..9dc3b5e4 --- /dev/null +++ b/src/pervasives/containers_pervasives.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: ea286cccf88f4c81c7b4627216807d4e) +CCPervasives +# OASIS_STOP diff --git a/src/sexp/CCSexp.ml b/src/sexp/CCSexp.ml new file mode 100644 index 00000000..2387356e --- /dev/null +++ b/src/sexp/CCSexp.ml @@ -0,0 +1,173 @@ +(* +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 S-expression parsing/printing} *) + +type t = [ + | `Atom of string + | `List of t list + ] + +let equal a b = a = b + +let compare a b = Pervasives.compare a b + +let hash a = Hashtbl.hash a + +let of_int x = `Atom (string_of_int x) +let of_float x = `Atom (string_of_float x) +let of_bool x = `Atom (string_of_bool x) +let atom x = `Atom x +let of_unit = `List [] +let of_list l = `List l +let of_rev_list l = `List (List.rev l) +let of_pair (x,y) = `List[x;y] +let of_triple (x,y,z) = `List[x;y;z] +let of_quad (x,y,z,u) = `List[x;y;z;u] + +let of_variant name args = `List (`Atom name :: args) +let of_field name t = `List [`Atom name; t] +let of_record l = + `List (List.map (fun (n,x) -> of_field n x) l) + +(** {6 Traversal of S-exp} *) + +module Traverse = struct + type 'a conv = t -> 'a option + + let return x = Some x + + let (>|=) e f = match e with + | None -> None + | Some x -> Some (f x) + + let (>>=) e f = match e with + | None -> None + | Some x -> f x + + let map_opt f l = + let rec recurse acc l = match l with + | [] -> Some (List.rev acc) + | x::l' -> + match f x with + | None -> None + | Some y -> recurse (y::acc) l' + in recurse [] l + + let rec _list_any f l = match l with + | [] -> None + | x::tl -> + match f x with + | Some _ as res -> res + | None -> _list_any f tl + + let list_any f e = match e with + | `Atom _ -> None + | `List l -> _list_any f l + + let rec _list_all f acc l = match l with + | [] -> List.rev acc + | x::tl -> + match f x with + | Some y -> _list_all f (y::acc) tl + | None -> _list_all f acc tl + + let list_all f e = match e with + | `Atom _ -> [] + | `List l -> _list_all f [] l + + let _try_atom e f = match e with + | `List _ -> None + | `Atom x -> try Some (f x) with _ -> None + + let to_int e = _try_atom e int_of_string + let to_bool e = _try_atom e bool_of_string + let to_float e = _try_atom e float_of_string + let to_string e = _try_atom e (fun x->x) + + let to_pair e = match e with + | `List [x;y] -> Some (x,y) + | _ -> None + + let to_pair_with f1 f2 e = + to_pair e >>= fun (x,y) -> + f1 x >>= fun x -> + f2 y >>= fun y -> + return (x,y) + + let to_triple e = match e with + | `List [x;y;z] -> Some (x,y,z) + | _ -> None + + let to_triple_with f1 f2 f3 e = + to_triple e >>= fun (x,y,z) -> + f1 x >>= fun x -> + f2 y >>= fun y -> + f3 z >>= fun z -> + return (x,y,z) + + let to_list e = match e with + | `List l -> Some l + | `Atom _ -> None + + let to_list_with f (e:t) = match e with + | `List l -> map_opt f l + | `Atom _ -> None + + let rec _get_field name l = match l with + | `List [`Atom n; x] :: _ when name=n -> Some x + | _ :: tl -> _get_field name tl + | [] -> None + + let get_field name e = match e with + | `List l -> _get_field name l + | `Atom _ -> None + + let field name f e = + get_field name e >>= f + + let rec _get_field_list name l = match l with + | `List (`Atom n :: tl) :: _ when name=n -> Some tl + | _ :: tl -> _get_field_list name tl + | [] -> None + + let field_list name f e = match e with + | `List l -> _get_field_list name l >>= f + | `Atom _ -> None + + let rec _get_variant s args l = match l with + | [] -> None + | (s', f) :: _ when s=s' -> f args + | _ :: tl -> _get_variant s args tl + + let get_variant l e = match e with + | `List (`Atom s :: args) -> _get_variant s args l + | `List _ -> None + | `Atom s -> _get_variant s [] l + + let get_exn e = match e with + | None -> failwith "Sexp.Traverse.get_exn" + | Some x -> x +end diff --git a/src/sexp/CCSexp.mli b/src/sexp/CCSexp.mli new file mode 100644 index 00000000..17acdf7b --- /dev/null +++ b/src/sexp/CCSexp.mli @@ -0,0 +1,168 @@ +(* +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 Handling S-expressions} + +@since 0.4 + +@since 0.7 +Moved the streaming parser to CCSexpStream +*) + +(** {2 Basics} *) + +type t = [ + | `Atom of string + | `List of t list + ] + +val equal : t -> t -> bool +val compare : t -> t -> int +val hash : t -> int + +val atom : string -> t (** Build an atom directly from a string *) + +val of_int : int -> t +val of_bool : bool -> t +val of_list : t list -> t +val of_rev_list : t list -> t (** Reverse the list *) +val of_float : float -> t +val of_unit : t +val of_pair : t * t -> t +val of_triple : t * t * t -> t +val of_quad : t * t * t * t -> t + +val of_variant : string -> t list -> t +(** [of_variant name args] is used to encode algebraic variants + into a S-expr. For instance [of_variant "some" [of_int 1]] + represents the value [Some 1] *) + +val of_field : string -> t -> t +(** Used to represent one record field *) + +val of_record : (string * t) list -> t +(** Represent a record by its named fields *) + +(** {6 Traversal of S-exp} + +Example: serializing 2D points +{[ +type pt = {x:int; y:int };; + +let pt_of_sexp e = + Sexp.Traverse.( + field "x" to_int e >>= fun x -> + field "y" to_int e >>= fun y -> + return {x;y} + );; + +let sexp_of_pt pt = Sexp.(of_record ["x", of_int pt.x; "y", of_int pt.y]);; + +let l = [{x=1;y=1}; {x=2;y=10}];; + +let sexp = Sexp.(of_list (List.map sexp_of_pt l));; + +Sexp.Traverse.list_all pt_of_sexp sexp;; +]} + +*) + +module Traverse : sig + type 'a conv = t -> 'a option + (** A converter from S-expressions to 'a is a function [sexp -> 'a option]. + @since 0.4.1 *) + + val map_opt : ('a -> 'b option) -> 'a list -> 'b list option + (** Map over a list, failing as soon as the function fails on any element + @since 0.4.1 *) + + val list_any : 'a conv -> t -> 'a option + (** [list_any f (List l)] tries [f x] for every element [x] in [List l], + and returns the first non-None result (if any). *) + + val list_all : 'a conv -> t -> 'a list + (** [list_all f (List l)] returns the list of all [y] such that [x] in [l] + and [f x = Some y] *) + + val to_int : int conv + (** Expect an integer *) + + val to_string : string conv + (** Expect a string (an atom) *) + + val to_bool : bool conv + (** Expect a boolean *) + + val to_float : float conv + (** Expect a float *) + + val to_list : t list conv + (** Expect a list *) + + val to_list_with : (t -> 'a option) -> 'a list conv + (** Expect a list, applies [f] to all the elements of the list, and succeeds + only if [f] succeeded on every element + @since 0.4.1 *) + + val to_pair : (t * t) conv + (** Expect a list of two elements *) + + val to_pair_with : 'a conv -> 'b conv -> ('a * 'b) conv + (** Same as {!to_pair} but applies conversion functions + @since 0.4.1 *) + + val to_triple : (t * t * t) conv + + val to_triple_with : 'a conv -> 'b conv -> 'c conv -> ('a * 'b * 'c) conv + (* @since 0.4.1 *) + + val get_field : string -> t conv + (** [get_field name e], when [e = List [(n1,x1); (n2,x2) ... ]], extracts + the [xi] such that [name = ni], if it can find it. *) + + val field : string -> 'a conv -> 'a conv + (** Enriched version of {!get_field}, with a converter as argument *) + + val get_variant : (string * (t list -> 'a option)) list -> 'a conv + (** [get_variant l e] checks whether [e = List (Atom s :: args)], and + if some pair of [l] is [s, f]. In this case, it calls [f args] + and returns its result, otherwise it returns None. *) + + val field_list : string -> (t list -> 'a option) -> 'a conv + (** [field_list name f "(... (name a b c d) ...record)"] + will look for a field based on the given [name], and expect it to have a + list of arguments dealt with by [f] (here, "a b c d"). + @since 0.4.1 *) + + val (>>=) : 'a option -> ('a -> 'b option) -> 'b option + + val (>|=) : 'a option -> ('a -> 'b) -> 'b option + + val return : 'a -> 'a option + + val get_exn : 'a option -> 'a + (** Unwrap an option, possibly failing. + @raise Invalid_argument if the argument is [None] *) +end diff --git a/src/sexp/CCSexpM.ml b/src/sexp/CCSexpM.ml new file mode 100644 index 00000000..a6234a5f --- /dev/null +++ b/src/sexp/CCSexpM.ml @@ -0,0 +1,362 @@ +(* +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 S-expression parsing/printing} *) + +type 'a or_error = [ `Ok of 'a | `Error of string ] +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +type t = [ + | `Atom of string + | `List of t list + ] +type sexp = t + +let _with_in filename f = + let ic = open_in filename in + try + let x = f ic in + close_in ic; + x + with e -> + close_in ic; + `Error (Printexc.to_string e) + +let _with_out filename f = + let oc = open_out filename in + try + let x = f oc in + close_out oc; + x + with e -> + close_out oc; + raise e + +(** {2 Serialization (encoding)} *) + +(* shall we escape the string because of one of its chars? *) +let _must_escape s = + try + for i = 0 to String.length s - 1 do + let c = String.unsafe_get s i in + match c with + | ' ' | ';' | ')' | '(' | '"' | '\n' | '\t' -> raise Exit + | _ when Char.code c > 127 -> raise Exit (* non-ascii *) + | _ -> () + done; + false + with Exit -> true + +let rec to_buf b t = match t with + | `Atom s when _must_escape s -> Printf.bprintf b "\"%s\"" (String.escaped s) + | `Atom s -> Buffer.add_string b s + | `List [] -> Buffer.add_string b "()" + | `List [x] -> Printf.bprintf b "(%a)" to_buf x + | `List l -> + Buffer.add_char b '('; + List.iteri + (fun i t' -> (if i > 0 then Buffer.add_char b ' '; to_buf b t')) + l; + Buffer.add_char b ')' + +let to_string t = + let b = Buffer.create 128 in + to_buf b t; + Buffer.contents b + +let rec print fmt t = match t with + | `Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s) + | `Atom s -> Format.pp_print_string fmt s + | `List [] -> Format.pp_print_string fmt "()" + | `List [x] -> Format.fprintf fmt "@[(%a)@]" print x + | `List l -> + Format.open_hovbox 2; + Format.pp_print_char fmt '('; + List.iteri + (fun i t' -> (if i > 0 then Format.fprintf fmt "@ "; print fmt t')) + l; + Format.pp_print_char fmt ')'; + Format.close_box () + +let rec print_noindent fmt t = match t with + | `Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s) + | `Atom s -> Format.pp_print_string fmt s + | `List [] -> Format.pp_print_string fmt "()" + | `List [x] -> Format.fprintf fmt "(%a)" print_noindent x + | `List l -> + Format.pp_print_char fmt '('; + List.iteri + (fun i t' -> (if i > 0 then Format.pp_print_char fmt ' '; print_noindent fmt t')) + l; + Format.pp_print_char fmt ')' + +let to_chan oc t = + let fmt = Format.formatter_of_out_channel oc in + print fmt t; + Format.pp_print_flush fmt () + +let to_file_seq filename seq = + _with_out filename + (fun oc -> + seq (fun t -> to_chan oc t; output_char oc '\n') + ) + +let to_file filename t = to_file_seq filename (fun k -> k t) + +(** {2 Deserialization (decoding)} *) + +module type MONAD = sig + type 'a t + val return : 'a -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +end + +type 'a parse_result = ['a or_error | `End ] + +module MakeDecode(M : MONAD) = struct + let (>>=) = M.(>>=) + + type t = { + buf : Bytes.t; + refill : Bytes.t -> int -> int -> int M.t; + atom : Buffer.t; + mutable i : int; (* offset in [buf] *) + mutable len : int; (* how many bytes of [buf] are usable *) + mutable line : int; + mutable col : int; + } + + let make ?(bufsize=1024) refill = + let bufsize = min (max bufsize 16) Sys.max_string_length in + { buf=Bytes.create bufsize; + refill; + atom = Buffer.create 32; + i=0; + len=0; + line=1; + col=1; + } + + let _is_digit c = Char.code '0' <= Char.code c && Char.code c <= Char.code '9' + let _digit2i c = Char.code c - Char.code '0' + + (* refill buffer. If it works, call k_succ, otherwise call k_fail *) + let _refill t k_succ k_fail = + t.refill t.buf 0 (Bytes.length t.buf) + >>= fun n -> + t.i <- 0; + t.len <- n; + if n = 0 then k_fail t else k_succ t + + (* get next char, assuming t.i < t.len *) + let _get t = + assert (t.i < t.len); + let c = Bytes.get t.buf t.i in + t.i <- t.i + 1; + if c = '\n' then (t.col <- 1; t.line <- t.line + 1) else t.col <- t.col + 1; + c + + (* return an error *) + let _error t msg = + let b = Buffer.create 32 in + Printf.bprintf b "at %d, %d: " t.line t.col; + Printf.kbprintf + (fun b -> + let msg' = Buffer.contents b in + M.return (`Error msg') + ) b msg + + let _error_eof t = _error t "unexpected end of input" + + (* The parsers all take a success continuation, and the decoder as + last arguments. The continuation is used to minimize the + number of calls to [>>=] and take two parameters, the next + char (if not consumed), and the returned expression itself *) + + (* read expression *) + let rec expr k t = + if t.i = t.len then _refill t (expr k) _error_eof + else match _get t with + | ' ' | '\t' | '\n' -> expr k t + | c -> expr_starting_with c k t + + and expr_starting_with c k t = match c with + | ' ' | '\t' | '\n' -> assert false + | ';' -> skip_comment (fun _ () -> expr k t) t + | '(' -> expr_list [] k t + | ')' -> _error t "unexpected ')'" + | '\\' -> _error t "unexpected '\\'" + | '"' -> quoted k t + | c -> + Buffer.add_char t.atom c; + atom k t + + (* parse list *) + and expr_list acc k t = + if t.i = t.len then _refill t (expr_list acc k) _error_eof + else match _get t with + | ' ' | '\t' | '\n' -> expr_list acc k t + | ')' -> k None (`List (List.rev acc)) + | c -> + expr_starting_with c + (fun last e -> match last with + | Some '(' -> expr_list [] (fun _ l -> expr_list (l::acc) k t) t + | Some ')' -> k None (`List (List.rev (e::acc))) + | _ -> expr_list (e::acc) k t + ) t + + (* return the current atom (last char: c) *) + and _return_atom last k t = + let s = Buffer.contents t.atom in + Buffer.clear t.atom; + k last (`Atom s) + + (* parse atom *) + and atom k t = + if t.i = t.len then _refill t (atom k) (_return_atom None k) + else match _get t with + | '\\' -> _error t "unexpected '\\' in non-quoted string" + | '"' -> _error t "unexpected '\"' in the middle of an atom" + | (' ' | '\n' | '\t' | '(' | ')') as c -> + _return_atom (Some c) k t + | c -> + Buffer.add_char t.atom c; + atom k t + + (* quoted string *) + and quoted k t = + if t.i = t.len then _refill t (quoted k) _error_eof + else match _get t with + | '\\' -> + (* read escaped char and continue *) + escaped + (fun c -> + Buffer.add_char t.atom c; + quoted k t + ) t + | '"' -> _return_atom None k t + | c -> + Buffer.add_char t.atom c; + quoted k t + + (* read escaped char *) + and escaped k t = + if t.i = t.len then _refill t (escaped k) _error_eof + else match _get t with + | 'n' -> k '\n' + | 't' -> k '\t' + | 'r' -> k '\r' + | 'b' -> k '\b' + | '\\' -> k '\\' + | '"' -> k '"' + | c when _is_digit c -> + read2int (_digit2i c) (fun n -> k (Char.chr n)) t + | c -> _error t "unexpected escaped char '%c'" c + + and read2int i k t = + if t.i = t.len then _refill t (read2int i k) _error_eof + else match _get t with + | c when _is_digit c -> read1int (10 * i + _digit2i c) k t + | c -> _error t "unexpected char '%c' when reading byte" c + + and read1int i k t = + if t.i = t.len then _refill t (read1int i k) _error_eof + else match _get t with + | c when _is_digit c -> k (10 * i + _digit2i c) + | c -> _error t "unexpected char '%c' when reading byte" c + + (* skip until end of line, then call next() *) + and skip_comment k t = + if t.i = t.len + then _refill t (skip_comment k) _error_eof + else match _get t with + | '\n' -> k None () + | _ -> skip_comment k t + + (* top-level expression *) + let rec expr_or_end k t = + if t.i = t.len + then _refill t (expr_or_end k) (fun _ -> M.return `End) + else match _get t with + | ' ' | '\t' | '\n' -> expr_or_end k t + | c -> expr_starting_with c k t + + (* entry point *) + let next t : sexp parse_result M.t = + expr_or_end (fun _ x -> M.return (`Ok x)) t +end + +module D = MakeDecode(struct + type 'a t = 'a + let return x = x + let (>>=) x f = f x +end) + +let parse_string s : t or_error = + let n = String.length s in + let stop = ref false in + let refill bytes i _len = + if !stop then 0 + else (stop := true; Bytes.blit_string s 0 bytes i n; n) + in + let d = D.make ~bufsize:n refill in + match D.next d with + | `End -> `Error "unexpected end of file" + | (`Ok _ | `Error _) as res -> res + +(*$T + CCError.to_opt (parse_string "(abc d/e/f \"hello \\\" () world\" )") <> None + CCError.to_opt (parse_string "(abc ( d e ffff ) \"hello/world\")") <> None +*) + +let parse_chan ?bufsize ic = + let d = D.make ?bufsize (input ic) in + match D.next d with + | `End -> `Error "unexpected end of file" + | (`Ok _ | `Error _) as res -> res + +let parse_chan_gen ?bufsize ic = + let d = D.make ?bufsize (input ic) in + fun () -> + match D.next d with + | `End -> None + | `Error _ as e -> Some e + | `Ok _ as res -> Some res + +let parse_chan_list ?bufsize ic = + let d = D.make ?bufsize (input ic) in + let rec iter acc = match D.next d with + | `End -> `Ok (List.rev acc) + | `Ok x -> iter (x::acc) + | `Error _ as e -> e + in + iter [] + +let parse_file filename = + _with_in filename (fun ic -> parse_chan ic) + +let parse_file_list filename = + _with_in filename (fun ic -> parse_chan_list ic) diff --git a/src/sexp/CCSexpM.mli b/src/sexp/CCSexpM.mli new file mode 100644 index 00000000..5507fc20 --- /dev/null +++ b/src/sexp/CCSexpM.mli @@ -0,0 +1,106 @@ +(* +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 S-expression parsing/printing} + +@since 0.7 *) + +type 'a or_error = [ `Ok of 'a | `Error of string ] +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +(** {2 Basics} *) + +type t = [ + | `Atom of string + | `List of t list + ] +type sexp = t + +(** {2 Serialization (encoding)} *) + +val to_buf : Buffer.t -> t -> unit + +val to_string : t -> string + +val to_file : string -> t -> unit + +val to_file_seq : string -> t sequence -> unit +(** Print the given sequence of expressions to a file *) + +val to_chan : out_channel -> t -> unit + +val print : Format.formatter -> t -> unit +(** Pretty-printer nice on human eyes (including indentation) *) + +val print_noindent : Format.formatter -> t -> unit +(** Raw, direct printing as compact as possible *) + +(** {2 Deserialization (decoding)} *) + +module type MONAD = sig + type 'a t + val return : 'a -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +end + +type 'a parse_result = ['a or_error | `End ] +(** A parser of ['a] can return [`Ok x] when it parsed a value, + or [`Error e] when a parse error was encountered, or + [`End] if the input was empty *) + +module MakeDecode(M : MONAD) : sig + type t + (** Decoder *) + + val make : ?bufsize:int -> (Bytes.t -> int -> int -> int M.t) -> t + (** Make a decoder with the given function used to refill an + internal buffer. The function might return [0] if the + input is exhausted. + @param bufsize size of internal buffer *) + + val next : t -> sexp parse_result M.t + (** Parse the next S-expression or return an error if the input isn't + long enough or isn't a proper S-expression *) +end + +val parse_string : string -> t or_error +(** Parse a string *) + +val parse_chan : ?bufsize:int -> in_channel -> t or_error +(** Parse a S-expression from the given channel. Can read more data than + necessary, so don't use this if you need finer-grained control (e.g. + to read something else {b after} the S-exp) *) + +val parse_chan_gen : ?bufsize:int -> in_channel -> t or_error gen +(** Parse a channel into a generator of S-expressions *) + +val parse_chan_list : ?bufsize:int -> in_channel -> t list or_error + +val parse_file : string -> t or_error +(** Open the file and read a S-exp from it *) + +val parse_file_list : string -> t list or_error +(** Open the file and read a S-exp from it *) diff --git a/core/CCSexp.ml b/src/sexp/CCSexpStream.ml similarity index 80% rename from core/CCSexp.ml rename to src/sexp/CCSexpStream.ml index c446b374..38f25c15 100644 --- a/core/CCSexp.ml +++ b/src/sexp/CCSexpStream.ml @@ -23,7 +23,10 @@ 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 S-expression parsing/printing} *) +(** {1 S-expressions Parser} + +@since 0.4 +@deprecated consider using {!CCSexpM} *) type 'a or_error = [ `Ok of 'a | `Error of string ] type 'a sequence = ('a -> unit) -> unit @@ -34,28 +37,6 @@ type t = [ | `List of t list ] -let equal a b = a = b - -let compare a b = Pervasives.compare a b - -let hash a = Hashtbl.hash a - -let of_int x = `Atom (string_of_int x) -let of_float x = `Atom (string_of_float x) -let of_bool x = `Atom (string_of_bool x) -let atom x = `Atom x -let of_unit = `List [] -let of_list l = `List l -let of_rev_list l = `List (List.rev l) -let of_pair (x,y) = `List[x;y] -let of_triple (x,y,z) = `List[x;y;z] -let of_quad (x,y,z,u) = `List[x;y;z;u] - -let of_variant name args = `List (`Atom name :: args) -let of_field name t = `List [`Atom name; t] -let of_record l = - `List (List.map (fun (n,x) -> of_field n x) l) - let _with_in filename f = let ic = open_in filename in try @@ -141,7 +122,7 @@ let to_chan oc t = let to_file_seq filename seq = _with_out filename - (fun oc -> + (fun oc -> seq (fun t -> to_chan oc t; output_char oc '\n') ) @@ -167,7 +148,7 @@ module Source = struct mutable stop : bool; buf : Buffer.t; (* accessible chunk of input *) } - + let make() = { i = 0; stop = false; @@ -231,7 +212,7 @@ module Source = struct then ( match g() with | None -> stop := true; NC_end - | Some buf -> s := buf; i := 0; next () + | Some buf -> s := buf; i := 0; next () ) else ( let c = String.get !s !i in incr i; @@ -580,122 +561,3 @@ module L = struct | StopNaow -> `Ok (List.rev !l) end -(** {6 Traversal of S-exp} *) - -module Traverse = struct - type 'a conv = t -> 'a option - - let return x = Some x - - let (>|=) e f = match e with - | None -> None - | Some x -> Some (f x) - - let (>>=) e f = match e with - | None -> None - | Some x -> f x - - let map_opt f l = - let rec recurse acc l = match l with - | [] -> Some (List.rev acc) - | x::l' -> - match f x with - | None -> None - | Some y -> recurse (y::acc) l' - in recurse [] l - - let rec _list_any f l = match l with - | [] -> None - | x::tl -> - match f x with - | Some _ as res -> res - | None -> _list_any f tl - - let list_any f e = match e with - | `Atom _ -> None - | `List l -> _list_any f l - - let rec _list_all f acc l = match l with - | [] -> List.rev acc - | x::tl -> - match f x with - | Some y -> _list_all f (y::acc) tl - | None -> _list_all f acc tl - - let list_all f e = match e with - | `Atom _ -> [] - | `List l -> _list_all f [] l - - let _try_atom e f = match e with - | `List _ -> None - | `Atom x -> try Some (f x) with _ -> None - - let to_int e = _try_atom e int_of_string - let to_bool e = _try_atom e bool_of_string - let to_float e = _try_atom e float_of_string - let to_string e = _try_atom e (fun x->x) - - let to_pair e = match e with - | `List [x;y] -> Some (x,y) - | _ -> None - - let to_pair_with f1 f2 e = - to_pair e >>= fun (x,y) -> - f1 x >>= fun x -> - f2 y >>= fun y -> - return (x,y) - - let to_triple e = match e with - | `List [x;y;z] -> Some (x,y,z) - | _ -> None - - let to_triple_with f1 f2 f3 e = - to_triple e >>= fun (x,y,z) -> - f1 x >>= fun x -> - f2 y >>= fun y -> - f3 z >>= fun z -> - return (x,y,z) - - let to_list e = match e with - | `List l -> Some l - | `Atom _ -> None - - let to_list_with f (e:t) = match e with - | `List l -> map_opt f l - | `Atom _ -> None - - let rec _get_field name l = match l with - | `List [`Atom n; x] :: _ when name=n -> Some x - | _ :: tl -> _get_field name tl - | [] -> None - - let get_field name e = match e with - | `List l -> _get_field name l - | `Atom _ -> None - - let field name f e = - get_field name e >>= f - - let rec _get_field_list name l = match l with - | `List (`Atom n :: tl) :: _ when name=n -> Some tl - | _ :: tl -> _get_field_list name tl - | [] -> None - - let field_list name f e = match e with - | `List l -> _get_field_list name l >>= f - | `Atom _ -> None - - let rec _get_variant s args l = match l with - | [] -> None - | (s', f) :: _ when s=s' -> f args - | _ :: tl -> _get_variant s args tl - - let get_variant l e = match e with - | `List (`Atom s :: args) -> _get_variant s args l - | `List _ -> None - | `Atom s -> _get_variant s [] l - - let get_exn e = match e with - | None -> failwith "Sexp.Traverse.get_exn" - | Some x -> x -end diff --git a/core/CCSexp.mli b/src/sexp/CCSexpStream.mli similarity index 59% rename from core/CCSexp.mli rename to src/sexp/CCSexpStream.mli index 09de18e6..9fecedac 100644 --- a/core/CCSexp.mli +++ b/src/sexp/CCSexpStream.mli @@ -23,48 +23,20 @@ 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 S-expression parsing/printing} +(** {1 S-expressions Parser} -@since 0.4 *) +@since 0.4 +@deprecated consider using {!CCSexpM} *) type 'a or_error = [ `Ok of 'a | `Error of string ] type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option -(** {2 Basics} *) - type t = [ | `Atom of string | `List of t list ] -val equal : t -> t -> bool -val compare : t -> t -> int -val hash : t -> int - -val atom : string -> t (** Build an atom directly from a string *) - -val of_int : int -> t -val of_bool : bool -> t -val of_list : t list -> t -val of_rev_list : t list -> t (** Reverse the list *) -val of_float : float -> t -val of_unit : t -val of_pair : t * t -> t -val of_triple : t * t * t -> t -val of_quad : t * t * t * t -> t - -val of_variant : string -> t list -> t -(** [of_variant name args] is used to encode algebraic variants - into a S-expr. For instance [of_variant "some" [of_int 1]] - represents the value [Some 1] *) - -val of_field : string -> t -> t -(** Used to represent one record field *) - -val of_record : (string * t) list -> t -(** Represent a record by its named fields *) - (** {2 Serialization (encoding)} *) val to_buf : Buffer.t -> t -> unit @@ -225,104 +197,3 @@ module L : sig val of_seq : string sequence -> t list or_error end -(** {6 Traversal of S-exp} - -Example: serializing 2D points -{[ -type pt = {x:int; y:int };; - -let pt_of_sexp e = - Sexp.Traverse.( - field "x" to_int e >>= fun x -> - field "y" to_int e >>= fun y -> - return {x;y} - );; - -let sexp_of_pt pt = Sexp.(of_record ["x", of_int pt.x; "y", of_int pt.y]);; - -let l = [{x=1;y=1}; {x=2;y=10}];; - -let sexp = Sexp.(of_list (List.map sexp_of_pt l));; - -Sexp.Traverse.list_all pt_of_sexp sexp;; -]} - -*) - -module Traverse : sig - type 'a conv = t -> 'a option - (** A converter from S-expressions to 'a is a function [sexp -> 'a option]. - @since 0.4.1 *) - - val map_opt : ('a -> 'b option) -> 'a list -> 'b list option - (** Map over a list, failing as soon as the function fails on any element - @since 0.4.1 *) - - val list_any : 'a conv -> t -> 'a option - (** [list_any f (List l)] tries [f x] for every element [x] in [List l], - and returns the first non-None result (if any). *) - - val list_all : 'a conv -> t -> 'a list - (** [list_all f (List l)] returns the list of all [y] such that [x] in [l] - and [f x = Some y] *) - - val to_int : int conv - (** Expect an integer *) - - val to_string : string conv - (** Expect a string (an atom) *) - - val to_bool : bool conv - (** Expect a boolean *) - - val to_float : float conv - (** Expect a float *) - - val to_list : t list conv - (** Expect a list *) - - val to_list_with : (t -> 'a option) -> 'a list conv - (** Expect a list, applies [f] to all the elements of the list, and succeeds - only if [f] succeeded on every element - @since 0.4.1 *) - - val to_pair : (t * t) conv - (** Expect a list of two elements *) - - val to_pair_with : 'a conv -> 'b conv -> ('a * 'b) conv - (** Same as {!to_pair} but applies conversion functions - @since 0.4.1 *) - - val to_triple : (t * t * t) conv - - val to_triple_with : 'a conv -> 'b conv -> 'c conv -> ('a * 'b * 'c) conv - (* @since 0.4.1 *) - - val get_field : string -> t conv - (** [get_field name e], when [e = List [(n1,x1); (n2,x2) ... ]], extracts - the [xi] such that [name = ni], if it can find it. *) - - val field : string -> 'a conv -> 'a conv - (** Enriched version of {!get_field}, with a converter as argument *) - - val get_variant : (string * (t list -> 'a option)) list -> 'a conv - (** [get_variant l e] checks whether [e = List (Atom s :: args)], and - if some pair of [l] is [s, f]. In this case, it calls [f args] - and returns its result, otherwise it returns None. *) - - val field_list : string -> (t list -> 'a option) -> 'a conv - (** [field_list name f "(... (name a b c d) ...record)"] - will look for a field based on the given [name], and expect it to have a - list of arguments dealt with by [f] (here, "a b c d"). - @since 0.4.1 *) - - val (>>=) : 'a option -> ('a -> 'b option) -> 'b option - - val (>|=) : 'a option -> ('a -> 'b) -> 'b option - - val return : 'a -> 'a option - - val get_exn : 'a option -> 'a - (** Unwrap an option, possibly failing. - @raise Invalid_argument if the argument is [None] *) -end diff --git a/src/sexp/containers_sexp.mldylib b/src/sexp/containers_sexp.mldylib new file mode 100644 index 00000000..d0508313 --- /dev/null +++ b/src/sexp/containers_sexp.mldylib @@ -0,0 +1,6 @@ +# OASIS_START +# DO NOT EDIT (digest: e7d1bfe0f18e27e2b9ff76951f3a9524) +CCSexp +CCSexpStream +CCSexpM +# OASIS_STOP diff --git a/src/sexp/containers_sexp.mllib b/src/sexp/containers_sexp.mllib new file mode 100644 index 00000000..d0508313 --- /dev/null +++ b/src/sexp/containers_sexp.mllib @@ -0,0 +1,6 @@ +# OASIS_START +# DO NOT EDIT (digest: e7d1bfe0f18e27e2b9ff76951f3a9524) +CCSexp +CCSexpStream +CCSexpM +# OASIS_STOP diff --git a/string/KMP.ml b/src/string/KMP.ml similarity index 100% rename from string/KMP.ml rename to src/string/KMP.ml diff --git a/string/KMP.mli b/src/string/KMP.mli similarity index 100% rename from string/KMP.mli rename to src/string/KMP.mli diff --git a/src/string/containers_string.mldylib b/src/string/containers_string.mldylib new file mode 100644 index 00000000..48464c54 --- /dev/null +++ b/src/string/containers_string.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: c89cc456e050edff914368d7fbea4eca) +Containers_string +# OASIS_STOP diff --git a/src/string/containers_string.mllib b/src/string/containers_string.mllib new file mode 100644 index 00000000..48464c54 --- /dev/null +++ b/src/string/containers_string.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: c89cc456e050edff914368d7fbea4eca) +Containers_string +# OASIS_STOP diff --git a/src/string/containers_string.mlpack b/src/string/containers_string.mlpack new file mode 100644 index 00000000..6daaf586 --- /dev/null +++ b/src/string/containers_string.mlpack @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: eed887f169b0c8e02f98f97c676f846c) +KMP +Levenshtein +# OASIS_STOP diff --git a/string/levenshtein.ml b/src/string/levenshtein.ml similarity index 100% rename from string/levenshtein.ml rename to src/string/levenshtein.ml diff --git a/string/levenshtein.mli b/src/string/levenshtein.mli similarity index 100% rename from string/levenshtein.mli rename to src/string/levenshtein.mli diff --git a/threads/CCFuture.ml b/src/threads/CCFuture.ml similarity index 100% rename from threads/CCFuture.ml rename to src/threads/CCFuture.ml diff --git a/threads/CCFuture.mli b/src/threads/CCFuture.mli similarity index 100% rename from threads/CCFuture.mli rename to src/threads/CCFuture.mli diff --git a/src/threads/containers_thread.mldylib b/src/threads/containers_thread.mldylib new file mode 100644 index 00000000..420c8b75 --- /dev/null +++ b/src/threads/containers_thread.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: ede75f11c3857d71e591f7b889f4d09d) +CCFuture +# OASIS_STOP diff --git a/src/threads/containers_thread.mllib b/src/threads/containers_thread.mllib new file mode 100644 index 00000000..420c8b75 --- /dev/null +++ b/src/threads/containers_thread.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: ede75f11c3857d71e591f7b889f4d09d) +CCFuture +# OASIS_STOP diff --git a/tests/lwt/test_Behavior.ml b/tests/lwt/test_Behavior.ml deleted file mode 100644 index 7830655d..00000000 --- a/tests/lwt/test_Behavior.ml +++ /dev/null @@ -1,79 +0,0 @@ - -open OUnit - -module B = Behavior - -let lwt_get fut = match Lwt.state fut with - | Lwt.Sleep - | Lwt.Fail _ -> None - | Lwt.Return x -> Some x - -let test_do () = - let r = ref false in - let t = B.do_succeed (fun () -> r := true) in - let res = B.run t in - OUnit.assert_equal true !r; - OUnit.assert_equal (Some true) (lwt_get res); - () - -let test_seq () = - let l = ref [] in - (* add int to [l] *) - let add x = l := x :: !l in - let t = B.sequence - [ B.do_ (fun () -> add 3; true); - B.do_ (fun () -> add 2; true); - B.test (fun () -> List.length !l = 2); - B.do_ (fun () -> add 1; true); - ] in - let res = B.run t in - OUnit.assert_equal [1;2;3] !l; - OUnit.assert_equal (Some true) (lwt_get res); - () - -let test_wait () = - let e, send_e = Lwt.wait () in - let t = B.run (B.sequence [B.wait_ e; B.succeed]) in - OUnit.assert_equal None (lwt_get t); - Lwt.wakeup send_e (); - OUnit.assert_equal (Some true) (lwt_get t); - () - -let test_parallel () = - (* forall fails *) - let e, send_e = Lwt.wait () in - let t = - B.parallel ~strat:B.PSForall - [ B.sequence [B.wait_ e; B.succeed]; - B.fail - ] in - let t = B.run t in - let res = Lwt_main.run - (let open Lwt in - choose [t; Lwt_unix.sleep 0.1 >>= fun () -> (Lwt.wakeup send_e (); return true)]) - in - OUnit.assert_equal false res; - (* exists succeeds *) - let e, send_e = Lwt.wait () in - let t = - B.parallel ~strat:B.PSExists - [ B.sequence [B.wait_ e; B.succeed]; - B.fail - ] in - let t = B.run t in - let res = Lwt_main.run - (let open Lwt in - choose [t; Lwt_unix.sleep 0.1 >>= fun () -> (Lwt.wakeup send_e (); - Lwt_unix.sleep 0.1 >>= (fun () -> return true))]) - in - OUnit.assert_equal true res; - () - - -let suite = - "test_behavior" >::: - [ "test_do" >:: test_do; - "test_seq" >:: test_seq; - "test_wait" >:: test_wait; - "test_parallel" >:: test_parallel; - ] diff --git a/tests/run_tests.ml b/tests/run_tests.ml index cf4787ac..2641584d 100644 --- a/tests/run_tests.ml +++ b/tests/run_tests.ml @@ -13,7 +13,6 @@ let suite = Test_cc.suite; Test_puf.suite; Test_vector.suite; - Test_gen.suite; Test_deque.suite; Test_fHashtbl.suite; Test_fQueue.suite; diff --git a/tests/test_CCHeap.ml b/tests/test_CCHeap.ml index a0c97a79..3b4547a3 100644 --- a/tests/test_CCHeap.ml +++ b/tests/test_CCHeap.ml @@ -3,8 +3,6 @@ open OUnit -module Sequence = CCSequence - module H = CCHeap.Make(struct type t = int let leq x y =x<=y end) let empty = H.empty diff --git a/tests/test_PersistentHashtbl.ml b/tests/test_PersistentHashtbl.ml index 8d466484..dd84be8a 100644 --- a/tests/test_PersistentHashtbl.ml +++ b/tests/test_PersistentHashtbl.ml @@ -2,7 +2,6 @@ open OUnit module H = CCPersistentHashtbl.Make(CCInt) -module Sequence = CCSequence let test_add () = let h = H.create 32 in diff --git a/tests/test_bv.ml b/tests/test_bv.ml index d6909679..2a7a6152 100644 --- a/tests/test_bv.ml +++ b/tests/test_bv.ml @@ -1,6 +1,6 @@ open OUnit -module Sequence = CCSequence + let test_cardinal () = let bv1 = CCBV.create ~size:87 true in diff --git a/tests/test_deque.ml b/tests/test_deque.ml index aecd15d1..76a5448a 100644 --- a/tests/test_deque.ml +++ b/tests/test_deque.ml @@ -2,7 +2,7 @@ open OUnit module Deque = CCDeque -module Sequence = CCSequence + let plist l = CCPrint.to_string (CCList.pp CCInt.pp) l let pint i = string_of_int i diff --git a/tests/test_fHashtbl.ml b/tests/test_fHashtbl.ml index 1c81e37e..d77d7b13 100644 --- a/tests/test_fHashtbl.ml +++ b/tests/test_fHashtbl.ml @@ -2,7 +2,7 @@ open OUnit open Containers_misc -module Sequence = CCSequence + module Test(SomeHashtbl : FHashtbl.S with type key = int) = struct let test_add () = diff --git a/tests/test_fQueue.ml b/tests/test_fQueue.ml index 33082e5e..7388d551 100644 --- a/tests/test_fQueue.ml +++ b/tests/test_fQueue.ml @@ -2,7 +2,7 @@ open OUnit module FQueue = CCFQueue -module Sequence = CCSequence + let test_empty () = let q = FQueue.empty in diff --git a/tests/test_flatHashtbl.ml b/tests/test_flatHashtbl.ml index 60437386..d0cde3a9 100644 --- a/tests/test_flatHashtbl.ml +++ b/tests/test_flatHashtbl.ml @@ -2,7 +2,7 @@ open OUnit open Containers_misc -module Sequence = CCSequence + module IHashtbl = FlatHashtbl.Make(struct type t = int diff --git a/tests/test_gen.ml b/tests/test_gen.ml deleted file mode 100644 index 17596130..00000000 --- a/tests/test_gen.ml +++ /dev/null @@ -1,132 +0,0 @@ - -open OUnit -open CCFun - -module Gen = CCGen -module GR = Gen.Restart - -let pint i = string_of_int i -let plist l = - CCPrint.to_string (CCList.pp CCInt.pp) l -let pstrlist l = - CCPrint.to_string (CCList.pp Buffer.add_string) l - -let test_singleton () = - let gen = Gen.singleton 42 in - OUnit.assert_equal (Some 42) (Gen.get gen); - OUnit.assert_equal None (Gen.get gen); - let gen = Gen.singleton 42 in - OUnit.assert_equal 1 (Gen.length gen); - () - -let test_iter () = - let e = GR.(1 -- 10) in - OUnit.assert_equal ~printer:pint 10 (GR.length e); - OUnit.assert_equal [1;2] GR.(to_list (1 -- 2)); - OUnit.assert_equal [1;2;3;4;5] (GR.to_list (GR.take 5 e)); - () - -let test_map () = - let e = Gen.(1 -- 10) in - let e' = Gen.map string_of_int e in - OUnit.assert_equal ~printer:pstrlist ["9"; "10"] (Gen.to_list (Gen.drop 8 e')); - () - -let test_append () = - let e = Gen.append Gen.(1 -- 5) Gen.(6 -- 10) in - OUnit.assert_equal [10;9;8;7;6;5;4;3;2;1] (Gen.to_rev_list e); - () - -let test_flatMap () = - let e = Gen.(1 -- 3) in - let e' = Gen.(e >>= (fun x -> x -- (x+1))) in - OUnit.assert_equal [1;2;2;3;3;4] (Gen.to_list e'); - () - -let test_zip () = - let e = Gen.zip_with (+) (Gen.repeat 1) Gen.(4--7) in - OUnit.assert_equal [5;6;7;8] (Gen.to_list e); - () - -let test_filterMap () = - let f x = if x mod 2 = 0 then Some (string_of_int x) else None in - let e = Gen.filter_map f Gen.(1 -- 10) in - OUnit.assert_equal ["2"; "4"; "6"; "8"; "10"] (Gen.to_list e); - () - -let test_merge () = - let e = Gen.of_list [Gen.(1--3); Gen.(4--6); Gen.(7--9)] in - let e' = Gen.merge e in - OUnit.assert_equal [1;2;3;4;5;6;7;8;9] (Gen.to_list e' |> List.sort compare); - () - -let test_persistent () = - let i = ref 0 in - let gen () = - let j = !i in - if j > 5 then None else (incr i; Some j) - in - let e = Gen.persistent gen in - OUnit.assert_equal [0;1;2;3;4;5] (GR.to_list e); - OUnit.assert_equal [0;1;2;3;4;5] (GR.to_list e); - OUnit.assert_equal [0;1;2;3;4;5] (GR.to_list e); - () - -let test_round_robin () = - let e = GR.round_robin ~n:2 GR.(1--10) in - match e with - | [a;b] -> - OUnit.assert_equal [1;3;5;7;9] (Gen.to_list a); - OUnit.assert_equal [2;4;6;8;10] (Gen.to_list b) - | _ -> OUnit.assert_failure "wrong list lenght" - -let test_big_rr () = - let e = GR.round_robin ~n:3 GR.(1 -- 999) in - let l = List.map Gen.length e in - OUnit.assert_equal [333;333;333] l; - () - -let test_merge_sorted () = - [Gen.of_list [1;3;5]; Gen.of_list [0;1;1;3;4;6;10]; Gen.of_list [2;2;11]] - |> Gen.sorted_merge_n ?cmp:None - |> Gen.to_list - |> OUnit.assert_equal ~printer:Helpers.print_int_list [0;1;1;1;2;2;3;3;4;5;6;10;11] - -let test_interleave () = - let e1 = Gen.of_list [1;3;5;7;9] in - let e2 = Gen.of_list [2;4;6;8;10] in - let e = Gen.interleave e1 e2 in - OUnit.assert_equal [1;2;3;4;5;6;7;8;9;10] (Gen.to_list e); - () - -let test_intersperse () = - let e = Gen.(1 -- 5) in - let e' = Gen.intersperse 0 e in - OUnit.assert_equal [1;0;2;0;3;0;4;0;5] (Gen.to_list e'); - () - -let test_product () = - let printer = Helpers.print_int_int_list in - let e = Gen.product Gen.(1--3) Gen.(4--5) in - OUnit.assert_equal ~printer [1,4; 1,5; 2,4; 2,5; 3,4; 3,5] - (List.sort compare (Gen.to_list e)); - () - -let suite = - "test_gen" >::: - [ "test_singleton" >:: test_singleton; - "test_iter" >:: test_iter; - "test_map" >:: test_map; - "test_append" >:: test_append; - "test_flatMap" >:: test_flatMap; - "test_zip" >:: test_zip; - "test_filterMap" >:: test_filterMap; - "test_merge" >:: test_merge; - "test_persistent" >:: test_persistent; - "test_round_robin" >:: test_round_robin; - "test_big_rr" >:: test_big_rr; - "test_merge_sorted" >:: test_merge_sorted; - "test_interleave" >:: test_interleave; - "test_intersperse" >:: test_intersperse; - "test_product" >:: test_product; - ] diff --git a/tests/test_graph.ml b/tests/test_graph.ml index a18913a7..70e126d3 100644 --- a/tests/test_graph.ml +++ b/tests/test_graph.ml @@ -5,7 +5,7 @@ open OUnit open Helpers open Containers_misc -module Sequence = CCSequence + module G = PersistentGraph (* build a graph from a list of pairs of ints *) diff --git a/tests/test_heap.ml b/tests/test_heap.ml index c4162e23..62b62586 100644 --- a/tests/test_heap.ml +++ b/tests/test_heap.ml @@ -3,7 +3,7 @@ open OUnit open Helpers open Containers_misc -module Sequence = CCSequence + let test_empty () = let h = Heap.empty ~cmp:(fun x y -> x - y) in diff --git a/tests/test_mixtbl.ml b/tests/test_mixtbl.ml index f58fc2bb..2e6ee637 100644 --- a/tests/test_mixtbl.ml +++ b/tests/test_mixtbl.ml @@ -3,6 +3,8 @@ open OUnit open Containers_misc open CCFun +module Mixtbl = CCMixtbl + let example () = let inj_int = Mixtbl.create_inj () in let tbl = Mixtbl.create 10 in @@ -66,7 +68,7 @@ let test_keys () = Mixtbl.set ~inj:inj_int tbl "foo" 1; Mixtbl.set ~inj:inj_int tbl "bar" 2; Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; - let l = Mixtbl.keys_seq tbl |> CCSequence.to_list in + let l = Mixtbl.keys_seq tbl |> Sequence.to_list in OUnit.assert_equal ["baaz"; "bar"; "foo"] (List.sort compare l); () @@ -78,9 +80,9 @@ let test_bindings () = Mixtbl.set ~inj:inj_int tbl "bar" 2; Mixtbl.set ~inj:inj_str tbl "baaz" "hello"; Mixtbl.set ~inj:inj_str tbl "str" "rts"; - let l_int = Mixtbl.bindings_of tbl ~inj:inj_int |> CCSequence.to_list in + let l_int = Mixtbl.bindings_of tbl ~inj:inj_int |> Sequence.to_list in OUnit.assert_equal ["bar", 2; "foo", 1] (List.sort compare l_int); - let l_str = Mixtbl.bindings_of tbl ~inj:inj_str |> CCSequence.to_list in + let l_str = Mixtbl.bindings_of tbl ~inj:inj_str |> Sequence.to_list in OUnit.assert_equal ["baaz", "hello"; "str", "rts"] (List.sort compare l_str); () diff --git a/tests/test_pHashtbl.ml b/tests/test_pHashtbl.ml index ce663ecd..c00f0d27 100644 --- a/tests/test_pHashtbl.ml +++ b/tests/test_pHashtbl.ml @@ -2,7 +2,7 @@ open OUnit open Containers_misc -module Sequence = CCSequence + let test_add () = let h = PHashtbl.create 5 in diff --git a/tests/test_splayMap.ml b/tests/test_splayMap.ml index aa22a5a1..fb1d85b8 100644 --- a/tests/test_splayMap.ml +++ b/tests/test_splayMap.ml @@ -2,7 +2,7 @@ open OUnit open Containers_misc -module Sequence = CCSequence + let test1 () = let empty = SplayMap.empty () in diff --git a/tests/test_vector.ml b/tests/test_vector.ml index 878937a4..c8ece7c6 100644 --- a/tests/test_vector.ml +++ b/tests/test_vector.ml @@ -2,7 +2,7 @@ open OUnit module Vector = CCVector -module Sequence = CCSequence + let test_clear () = let v = Vector.of_seq Sequence.(1 -- 10) in diff --git a/tests/threads/test_future.ml b/tests/threads/test_future.ml index 4c7bdf18..cabb7f39 100644 --- a/tests/threads/test_future.ml +++ b/tests/threads/test_future.ml @@ -15,9 +15,9 @@ let test_mvar () = () let test_parallel () = - let l = CCSequence.(1 -- 300) in - let l = CCSequence.map (fun _ -> Future.spawn (fun () -> Thread.delay 0.1; 1)) l in - let l = CCSequence.to_list l in + let l = Sequence.(1 -- 300) in + let l = Sequence.map (fun _ -> Future.spawn (fun () -> Thread.delay 0.1; 1)) l in + let l = Sequence.to_list l in let l' = List.map Future.get l in OUnit.assert_equal 300 (List.fold_left (+) 0 l'); ()