diff --git a/.gitignore b/.gitignore index 8d2ffd6d..40f0e259 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ TAGS setup.* qtest* *.html +.merlin diff --git a/.merlin b/.merlin deleted file mode 100644 index 998a48f5..00000000 --- a/.merlin +++ /dev/null @@ -1,21 +0,0 @@ -S src/core -S src/data/ -S src/iter/ -S src/sexp/ -S src/threads/ -S src/string -S benchs -S examples -S tests -B _build/src/** -B _build/benchs -B _build/examples -B _build/tests -PKG oUnit -PKG benchmark -PKG result -PKG threads -PKG threads.posix -PKG lwt -PKG qcheck -FLG -w +a-4-44-48-60@8 diff --git a/.travis.yml b/.travis.yml index 8a93f975..ab69f2e0 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,5 @@ language: c env: - - OCAML_VERSION=4.01.0 - OCAML_VERSION=4.02.3 - OCAML_VERSION=4.04.2 - OCAML_VERSION=4.05.0 @@ -26,12 +25,9 @@ before_install: install: # Install dependencies - opam pin add --no-action containers . - - opam install oasis + - opam install jbuilder base-bytes result - opam install --deps-only containers script: - - ./configure --enable-unix --enable-thread --disable-tests --disable-bench - make build - opam install sequence qcheck qtest gen - - ./configure --enable-unix --enable-thread --enable-tests --enable-docs --disable-bench - make test - - make doc diff --git a/Makefile b/Makefile index e55727c8..bb854270 100644 --- a/Makefile +++ b/Makefile @@ -1,130 +1,31 @@ -# OASIS_START -# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) +all: build test -SETUP = ocaml setup.ml +build: + jbuilder build @install -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) +test: + jbuilder runtest --no-buffer clean: - $(SETUP) -clean $(CLEANFLAGS) + jbuilder clean -distclean: - $(SETUP) -distclean $(DISTCLEANFLAGS) +doc: + jbuilder build @doc -setup.data: - $(SETUP) -configure $(CONFIGUREFLAGS) +BENCH_TARGETS=run_benchs.exe run_bench_hash.exe -configure: - $(SETUP) -configure $(CONFIGUREFLAGS) +benchs: + jbuilder build $(addprefix bench/, $(BENCH_TARGETS)) -.PHONY: build doc test all install uninstall reinstall clean distclean configure +examples: + jbuilder build examples/id_sexp.exe -# OASIS_STOP - -EXAMPLES = examples/mem_size.native examples/collatz.native \ - examples/bencode_write.native # examples/crawl.native -OPTIONS = -use-ocamlfind -I _build - -examples: all - ocamlbuild $(OPTIONS) -package unix -I . $(EXAMPLES) - -push_doc: doc - rsync -tavu containers.docdir/* cedeela.fr:~/simon/root/software/containers/ - -push_doc_gh: doc - git checkout gh-pages && \ - rm -rf dev/ && \ - mkdir -p dev && \ - cp -r containers.docdir/* dev/ && \ - git add --all dev - -DONTTEST=myocamlbuild.ml setup.ml $(wildcard src/**/*.cppo.*) $(wildcard src/**/*Labels*) -QTESTABLE=$(filter-out $(DONTTEST), \ - $(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/unix/*.ml) \ - $(wildcard src/unix/*.mli) \ - $(wildcard src/sexp/*.ml) \ - $(wildcard src/sexp/*.mli) \ - $(wildcard src/iter/*.ml) \ - $(wildcard src/iter/*.mli) \ - $(wildcard src/bigarray/*.ml) \ - $(wildcard src/bigarray/*.mli) \ - $(wildcard src/threads/*.ml) \ - $(wildcard src/threads/*.mli) \ - ) - -qtest-clean: - @rm -rf qtest/ - -QTEST_PREAMBLE='open CCFun;; ' - -#qtest-build: qtest-clean build -# @mkdir -p qtest -# @qtest extract --preamble $(QTEST_PREAMBLE) \ -# -o qtest/qtest_all.ml \ -# $(QTESTABLE) 2> /dev/null -# @ocamlbuild $(OPTIONS) -pkg oUnit,QTest2Lib,ocamlbuildlib \ -# -I core -I misc -I string \ -# qtest/qtest_all.native - -qtest-gen: - @mkdir -p qtest - @if which qtest > /dev/null ; then \ - qtest extract --preamble $(QTEST_PREAMBLE) \ - -o qtest/run_qtest.ml \ - $(QTESTABLE) 2> /dev/null ; \ - else touch qtest/run_qtest.ml ; \ - fi - -push-stable: - git checkout stable - git merge master -m 'merge from master' - oasis setup - git commit -a -m 'oasis files' - git push origin - git checkout master - -clean-generated: - rm **/*.{mldylib,mlpack,mllib} myocamlbuild.ml -f - -tags: - otags *.ml *.mli - -VERSION=$(shell awk '/^Version:/ {print $$2}' _oasis) +VERSION=$(shell awk '/^version:/ {print $$2}' containers.opam) update_next_tag: @echo "update version to $(VERSION)..." - zsh -c 'sed -i "s/NEXT_VERSION/$(VERSION)/g" **/*.ml **/*.mli' - zsh -c 'sed -i "s/NEXT_RELEASE/$(VERSION)/g" **/*.ml **/*.mli' - -devel: - ./configure --enable-bench --enable-tests --enable-unix \ - --enable-thread - make all + sed -i "s/NEXT_VERSION/$(VERSION)/g" src/*.ml src/*.mli + sed -i "s/NEXT_RELEASE/$(VERSION)/g" src/*.ml src/*.mli watch: while find src/ benchs/ -print0 | xargs -0 inotifywait -e delete_self -e modify ; do \ @@ -137,4 +38,4 @@ reindent: @find src '(' -name '*.ml' -or -name '*.mli' ')' -type f -print0 | xargs -0 echo "reindenting: " @find src '(' -name '*.ml' -or -name '*.mli' ')' -type f -print0 | xargs -0 ocp-indent -i -.PHONY: examples push_doc tags qtest-gen qtest-clean devel update_next_tag +.PHONY: all test clean build doc update_next_tag watch diff --git a/_oasis b/_oasis deleted file mode 100644 index b3eaedcf..00000000 --- a/_oasis +++ /dev/null @@ -1,161 +0,0 @@ -OASISFormat: 0.4 -Name: containers -Version: 1.5.2 -Homepage: https://github.com/c-cube/ocaml-containers -Authors: Simon Cruanes -License: BSD-2-clause -LicenseFile: LICENSE -Plugins: META (0.3), DevFiles (0.3) -OCamlVersion: >= 4.00.1 -BuildTools: ocamlbuild -AlphaFeatures: ocamlbuild_more_args - -# cygwin fails with anything else -XOCamlbuildExtraArgs: "-j 1" - -Synopsis: A modular standard library focused on data structures. -Description: - Containers is a standard library (BSD license) focused on data structures, - combinators and iterators, without dependencies on unix. Every module is - independent and is prefixed with 'CC' in the global namespace. Some modules - extend the stdlib (e.g. CCList provides safe map/fold_right/append, and - additional functions on lists). - - It also features optional libraries for dealing with strings, and - helpers for unix and threads. - -Flag "unix" - Description: Build the containers.unix library (depends on Unix) - Default: true - -Flag "thread" - Description: Build modules that depend on threads - Default: true - -Flag "bench" - Description: Build and run benchmarks - Default: true - -Library "containers" - Path: src/core - Modules: CCVector, CCHeap, CCList, CCOpt, CCPair, - CCFun, CCHash, CCInt, CCBool, CCFloat, CCArray, CCRef, CCSet, - CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat, CCIO, - CCInt64, CCChar, CCResult, CCParse, CCArray_slice, - CCListLabels, CCArrayLabels, CCEqual, - Containers - BuildDepends: bytes, result - # BuildDepends: bytes, bisect_ppx - -Library "containers_unix" - Path: src/unix - Modules: CCUnix - BuildDepends: bytes, result, unix - FindlibParent: containers - FindlibName: unix - -Library "containers_sexp" - Path: src/sexp - Modules: CCSexp, CCSexp_lex - BuildDepends: bytes, result - FindlibParent: containers - FindlibName: sexp - -Library "containers_data" - Path: src/data - Modules: CCMultiMap, CCMultiSet, CCTrie, CCFlatHashtbl, CCCache, - CCPersistentHashtbl, CCDeque, CCFQueue, CCBV, CCMixtbl, - CCMixmap, CCRingBuffer, CCIntMap, CCPersistentArray, - CCMixset, CCGraph, CCHashSet, CCBitField, - CCHashTrie, CCWBTree, CCRAL, CCSimple_queue, - CCImmutArray, CCHet, CCZipper - BuildDepends: bytes - # BuildDepends: bytes, bisect_ppx - FindlibParent: containers - FindlibName: data - -Library "containers_iter" - Path: src/iter - Modules: CCKTree, CCKList, CCLazy_list - FindlibParent: containers - FindlibName: iter - -Library "containers_thread" - Path: src/threads/ - Modules: CCPool, CCLock, CCSemaphore, CCThread, CCBlockingQueue, - CCTimer - FindlibName: thread - FindlibParent: containers - Build$: flag(thread) - Install$: flag(thread) - BuildDepends: containers, threads - XMETARequires: containers, threads - -Library "containers_top" - Path: src/top/ - Modules: Containers_top - FindlibName: top - FindlibParent: containers - BuildDepends: compiler-libs.common, containers, containers.data, - containers.unix, containers.sexp, containers.iter - -Document containers - Title: Containers docs - Type: ocamlbuild (0.3) - BuildTools+: ocamldoc - Build$: flag(docs) && flag(unix) - Install: true - XOCamlbuildPath: . - XOCamlbuildExtraArgs: - "-docflags '-colorize-code -short-functors -charset utf-8'" - XOCamlbuildLibraries: - containers, containers.iter, containers.data, - containers.thread, containers.unix, containers.sexp - -Executable run_benchs - Path: benchs/ - Install: false - CompiledObject: best - Build$: flag(bench) - MainIs: run_benchs.ml - BuildDepends: containers, qcheck, - containers.data, containers.iter, containers.thread, - sequence, gen, benchmark - -Executable run_bench_hash - Path: benchs/ - Install: false - CompiledObject: best - Build$: flag(bench) - MainIs: run_bench_hash.ml - BuildDepends: containers - -PreBuildCommand: make qtest-gen - -Executable run_qtest - Path: qtest/ - Install: false - CompiledObject: best - MainIs: run_qtest.ml - Build$: flag(tests) && flag(unix) - BuildDepends: containers, containers.iter, - containers.sexp, containers.unix, containers.thread, - containers.data, - sequence, gen, unix, oUnit, qcheck - -Test all - Command: ./run_qtest.native - TestTools: run_qtest - Run$: flag(tests) && flag(unix) - -Executable id_sexp - Path: examples/ - Install: false - CompiledObject: best - MainIs: id_sexp.ml - BuildDepends: containers.sexp - -SourceRepository head - Type: git - Location: https://github.com/c-cube/ocaml-containers - Browser: https://github.com/c-cube/ocaml-containers/tree/master/src diff --git a/_tags b/_tags deleted file mode 100644 index 393fa12e..00000000 --- a/_tags +++ /dev/null @@ -1,123 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 8cbdae3079e6ebc5257343569c6e2780) -# 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 containers -"src/core/containers.cmxs": use_containers -: package(bytes) -: package(result) -# Library containers_unix -"src/unix/containers_unix.cmxs": use_containers_unix -: package(bytes) -: package(result) -: package(unix) -# Library containers_sexp -"src/sexp/containers_sexp.cmxs": use_containers_sexp -: package(bytes) -: package(result) -# Library containers_data -"src/data/containers_data.cmxs": use_containers_data -: package(bytes) -# Library containers_iter -"src/iter/containers_iter.cmxs": use_containers_iter -# Library containers_thread -"src/threads/containers_thread.cmxs": use_containers_thread -: package(bytes) -: package(result) -: package(threads) -: use_containers -# Library containers_top -"src/top/containers_top.cmxs": use_containers_top -: package(bytes) -: package(compiler-libs.common) -: package(result) -: package(unix) -: use_containers -: use_containers_data -: use_containers_iter -: use_containers_sexp -: use_containers_unix -# Executable run_benchs -: package(benchmark) -: package(bytes) -: package(gen) -: package(qcheck) -: package(result) -: package(sequence) -: package(threads) -: use_containers -: use_containers_data -: use_containers_iter -: use_containers_thread -: package(benchmark) -: package(gen) -: package(qcheck) -: package(sequence) -: package(threads) -: use_containers_data -: use_containers_iter -: use_containers_thread -# Executable run_bench_hash -: package(bytes) -: package(result) -: use_containers -: package(bytes) -: package(result) -: use_containers -# Executable run_qtest -: package(bytes) -: package(gen) -: package(oUnit) -: package(qcheck) -: package(result) -: package(sequence) -: package(threads) -: package(unix) -: use_containers -: use_containers_data -: use_containers_iter -: use_containers_sexp -: use_containers_thread -: use_containers_unix -: package(bytes) -: package(gen) -: package(oUnit) -: package(qcheck) -: package(result) -: package(sequence) -: package(threads) -: package(unix) -: use_containers -: use_containers_data -: use_containers_iter -: use_containers_sexp -: use_containers_thread -: use_containers_unix -# Executable id_sexp -: package(bytes) -: package(result) -: use_containers_sexp -: package(bytes) -: package(result) -: use_containers_sexp -# OASIS_STOP -: thread -: thread - or : inline(25) - or or : inline(15) - or or : warn(-32) - and not : warn(+a-4-44-58-60@8) -true: no_alias_deps, safe_string, short_paths, color(always) -: nolabels diff --git a/benchs/jbuild b/benchs/jbuild new file mode 100644 index 00000000..82853950 --- /dev/null +++ b/benchs/jbuild @@ -0,0 +1,10 @@ + +(executables + ((names (run_benchs run_bench_hash)) + (libraries (containers containers.data containers.iter + containers.thread benchmark gen sequence)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string -color always)) + (ocamlopt_flags (:standard -O3 -color always + -unbox-closures -unbox-closures-factor 20)) + )) + diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 8e10fc0d..4448b6a9 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -280,7 +280,7 @@ module Arr = struct let a2 = Array.copy a1 in sort_std a1; quicksort ~limit:10 a2; - assert (a1 = a2)) + assert (CCArray.equal CCInt.equal a1 a2)) [ 10; 100; 1000] let bench_sort ?(time=2) n = @@ -366,16 +366,16 @@ module Cache = struct let bench_fib n = let l = - [ "replacing_fib (128)", make_fib (C.replacing 128), n - ; "LRU_fib (128)", make_fib (C.lru 128), n - ; "replacing_fib (16)", make_fib (C.replacing 16), n - ; "LRU_fib (16)", make_fib (C.lru 16), n - ; "unbounded", make_fib (C.unbounded 32), n + [ "replacing_fib (128)", make_fib (C.replacing ~eq:CCInt.equal 128), n + ; "LRU_fib (128)", make_fib (C.lru ~eq:CCInt.equal 128), n + ; "replacing_fib (16)", make_fib (C.replacing ~eq:CCInt.equal 16), n + ; "LRU_fib (16)", make_fib (C.lru ~eq:CCInt.equal 16), n + ; "unbounded", make_fib (C.unbounded ~eq:CCInt.equal 32), n ] in let l = if n <= 20 - then [ "linear_fib (5)", make_fib (C.linear 5), n - ; "linear_fib (32)", make_fib (C.linear 32), n + then [ "linear_fib (5)", make_fib (C.linear ~eq:CCInt.equal 5), n + ; "linear_fib (32)", make_fib (C.linear ~eq:CCInt.equal 32), n ; "dummy_fib", make_fib C.dummy, n ] @ l else l @@ -862,7 +862,7 @@ module Deque = struct let take_back d = match !d with | None -> raise Empty - | Some first when first == first.prev -> + | Some first when Pervasives.(==) first first.prev -> (* only one element *) d := None; first.content @@ -875,7 +875,7 @@ module Deque = struct let take_front d = match !d with | None -> raise Empty - | Some first when first == first.prev -> + | Some first when Pervasives.(==) first first.prev -> (* only one element *) d := None; first.content @@ -1045,7 +1045,7 @@ module Graph = struct let dfs_event n () = let tbl = CCGraph.mk_table ~eq:CCInt.equal ~hash:CCInt.hash (n+10) in - CCGraph.Traverse.Event.dfs ~tbl ~graph:div_graph_ + CCGraph.Traverse.Event.dfs ~tbl ~eq:CCInt.equal ~graph:div_graph_ (Sequence.return n) |> Sequence.fold (fun acc -> function @@ -1154,7 +1154,7 @@ module Str = struct and mk_current () = CCString.find_all_l ~sub:needle haystack and mk_current_compiled = let f = CCString.find_all_l ~start:0 ~sub:needle in fun () -> f haystack in - assert (mk_naive () = mk_current ()); + assert (CCList.equal CCInt.equal (mk_naive ()) (mk_current ())); B.throughputN 3 ~repeat [ "naive", mk_naive, () ; "current", mk_current, () @@ -1168,7 +1168,7 @@ module Str = struct pp_pb needle haystack; let mk_naive () = find_all_l ~sub:needle haystack and mk_current () = CCString.find_all_l ~sub:needle haystack in - assert (mk_naive () = mk_current ()); + assert (CCList.equal CCInt.equal (mk_naive ()) (mk_current ())); B.throughputN 3 ~repeat [ "naive", mk_naive, () ; "current", mk_current, () @@ -1182,7 +1182,7 @@ module Str = struct let rec same s1 s2 i = if i = String.length s1 then true else ( - String.unsafe_get s1 i = String.unsafe_get s2 i && same s1 s2 (i+1) + CCChar.equal (String.unsafe_get s1 i) (String.unsafe_get s2 i) && same s1 s2 (i+1) ) in String.length pre <= String.length s && @@ -1193,7 +1193,7 @@ module Str = struct begin let i = ref 0 in while !i < String.length pre && - String.unsafe_get s !i = String.unsafe_get pre !i + CCChar.equal (String.unsafe_get s !i) (String.unsafe_get pre !i) do incr i done; !i = String.length pre end @@ -1225,7 +1225,7 @@ module Str = struct else let rec loop str p i = if i = len then true - else if String.unsafe_get str i <> String.unsafe_get p i then false + else if not (CCChar.equal (String.unsafe_get str i) (String.unsafe_get p i)) then false else loop str p (i + 1) in loop str p 0 @@ -1256,7 +1256,7 @@ module Str = struct Array.iteri (fun i (pre, y) -> let res = f ~pre y in - assert (res = output.(i))) + assert (CCBool.equal res output.(i))) input in Benchmark.throughputN 3 diff --git a/configure b/configure deleted file mode 100755 index 6acfaeb9..00000000 --- a/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/containers.opam b/containers.opam new file mode 100644 index 00000000..19073ed1 --- /dev/null +++ b/containers.opam @@ -0,0 +1,39 @@ +opam-version: "1.2" +name: "containers" +version: "2.0~alpha1" +author: "Simon Cruanes" +maintainer: "simon.cruanes.2007@m4x.org" +build: [ + ["jbuilder" "build" "-p" name "-j" jobs] +] +build-doc: [ make "doc" ] +build-test: [ make "test" ] +depends: [ + "jbuilder" {build} + "base-bytes" + "result" +] +depopts: [ + "base-unix" + "base-threads" + "qtest" { test } +] +conflicts: [ + "sequence" { < "0.5" } +] +tags: [ "stdlib" "containers" "iterators" "list" "heap" "queue" ] +homepage: "https://github.com/c-cube/ocaml-containers/" +doc: "https://c-cube.github.io/ocaml-containers" +available: [ocaml-version >= "4.02.0"] +dev-repo: "https://github.com/c-cube/ocaml-containers.git" +bug-reports: "https://github.com/c-cube/ocaml-containers/issues/" +post-messages: [ +"Major release with some breaking changes in the API. + +These changes belong to 3 categories: +- make `open Containers` replace polymorphic operators with monomorphic ones +- make most optional arguments relying on polymorphic operators mandatory +- improve consistency of printers + +changelog: https://github.com/c-cube/ocaml-containers/blob/2.0~alpha1/CHANGELOG.adoc" +] diff --git a/examples/jbuild b/examples/jbuild new file mode 100644 index 00000000..e7d75a09 --- /dev/null +++ b/examples/jbuild @@ -0,0 +1,10 @@ + +(executables + ((names (id_sexp)) + (libraries (containers.sexp)) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string -color always)) + (ocamlopt_flags (:standard -O3 -color always + -unbox-closures -unbox-closures-factor 20)) + )) + + diff --git a/myocamlbuild.ml b/myocamlbuild.ml deleted file mode 100644 index 8e708b99..00000000 --- a/myocamlbuild.ml +++ /dev/null @@ -1,938 +0,0 @@ -(* OASIS_START *) -(* DO NOT EDIT (digest: 9ebeddeee0d56b1f8c98544fabcbbd9b) *) -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 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; - !what_idx = String.length what - - - 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; - !what_idx = -1 - - - 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 - - let lowercase_ascii = - replace_chars - (fun c -> - if (c >= 'A' && c <= 'Z') then - Char.chr (Char.code c + 32) - else - c) - - let uncapitalize_ascii s = - if s <> "" then - (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - - let uppercase_ascii = - replace_chars - (fun c -> - if (c >= 'a' && c <= 'z') then - Char.chr (Char.code c - 32) - else - c) - - let capitalize_ascii s = - if s <> "" then - (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - -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 (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) - - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - let equal s1 s2 = (compare_csl s1 s2) = 0 - let hash s = Hashtbl.hash (OASISString.lowercase_ascii 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 - OASISString.lowercase_ascii 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 - - - let rec file_location ?pos1 ?pos2 ?lexbuf () = - match pos1, pos2, lexbuf with - | Some p, None, _ | None, Some p, _ -> - file_location ~pos1:p ~pos2:p ?lexbuf () - | Some p1, Some p2, _ -> - let open Lexing in - let fn, lineno = p1.pos_fname, p1.pos_lnum in - let c1 = p1.pos_cnum - p1.pos_bol in - let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in - Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 - | _, _, Some lexbuf -> - file_location - ~pos1:(Lexing.lexeme_start_p lexbuf) - ~pos2:(Lexing.lexeme_end_p lexbuf) - () - | None, None, None -> - s_ "" - - - let failwithpf ?pos1 ?pos2 ?lexbuf fmt = - let loc = file_location ?pos1 ?pos2 ?lexbuf () in - Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt - - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - open OASISGettext - open OASISUtils - - - 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 - - -# 437 "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) ?stream () = - let line = ref 1 in - let lexer st = - 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 - Genlex.make_lexer ["="] st_line - in - let rec read_file lxr mp = - match Stream.npeek 3 lxr with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; - read_file lxr (MapString.add nm value mp) - | [] -> mp - | _ -> - failwith - (Printf.sprintf "Malformed data file '%s' line %d" filename !line) - in - match stream with - | Some st -> read_file (lexer st) MapString.empty - | None -> - if Sys.file_exists filename then begin - let chn = open_in_bin filename in - let st = Stream.of_channel chn in - try - let mp = read_file (lexer st) MapString.empty in - close_in chn; mp - with e -> - close_in chn; raise e - 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 - - -# 517 "myocamlbuild.ml" -module MyOCamlbuildFindlib = struct -(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) - - - (** OCamlbuild extension, copied from - * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html - * by N. Pouillard and others - * - * Updated on 2016-06-02 - * - * Modified by Sylvain Le Gall - *) - open Ocamlbuild_plugin - - - type conf = {no_automatic_syntax: bool} - - - 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 = BaseEnvLight.load ~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 -> - - (* Avoid warnings for unused tag *) - flag ["tests"] N; - - (* 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, pargs) = - (* Heuristic to identify syntax extensions: whether they end in - ".syntax"; some might not. - *) - if not (conf.no_automatic_syntax) && - (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 ()); - - (* 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 ["c"; "pkg_threads"; "compile"] (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"]); - flag ["c"; "package(threads)"; "compile"] (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 - - - 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; - } - - -(* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) - - - 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 ~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 -> (OASISString.uncapitalize_ascii 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^"/"^(OASISString.uncapitalize_ascii 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))]); - - if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then - 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 - - -# 878 "myocamlbuild.ml" -open Ocamlbuild_plugin;; -let package_default = - { - MyOCamlbuildBase.lib_ocaml = - [ - ("containers", ["src/core"], []); - ("containers_unix", ["src/unix"], []); - ("containers_sexp", ["src/sexp"], []); - ("containers_data", ["src/data"], []); - ("containers_iter", ["src/iter"], []); - ("containers_thread", ["src/threads"], []); - ("containers_top", ["src/top"], []) - ]; - lib_c = []; - flags = []; - includes = - [ - ("src/top", - ["src/core"; "src/data"; "src/iter"; "src/sexp"; "src/unix"]); - ("src/threads", ["src/core"]); - ("qtest", - [ - "src/core"; - "src/data"; - "src/iter"; - "src/sexp"; - "src/threads"; - "src/unix" - ]); - ("examples", ["src/sexp"]); - ("benchs", ["src/core"; "src/data"; "src/iter"; "src/threads"]) - ] - } - ;; - -let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} - -let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; - -# 919 "myocamlbuild.ml" -(* OASIS_STOP *) -let doc_intro = "doc/intro.txt" ;; - -Ocamlbuild_plugin.dispatch dispatch_default;; - -dispatch - (MyOCamlbuildBase.dispatch_combine [ - begin function - | After_rules -> - - (* 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 deleted file mode 100644 index af8c6bd3..00000000 --- a/opam +++ /dev/null @@ -1,49 +0,0 @@ -opam-version: "1.2" -name: "containers" -version: "1.5.2" -author: "Simon Cruanes" -maintainer: "simon.cruanes@inria.fr" -build: [ - ["./configure" - "--prefix" prefix - "--disable-bench" - "--disable-tests" - "--%{base-unix:enable}%-unix" - "--enable-docs" - ] - [make "build"] -] -install: [ - [make "install"] -] -build-doc: [ make "doc" ] -build-test: [ make "test" ] -remove: [ - ["ocamlfind" "remove" "containers"] -] -depends: [ - "ocamlfind" {build} - "base-bytes" - "result" - "ocamlbuild" {build} -] -depopts: [ - "base-unix" - "base-threads" - "qtest" { test } -] -conflicts: [ - "sequence" { < "0.5" } -] -tags: [ "stdlib" "containers" "iterators" "list" "heap" "queue" ] -homepage: "https://github.com/c-cube/ocaml-containers/" -doc: "http://cedeela.fr/~simon/software/containers/" -available: [ocaml-version >= "4.01.0"] -dev-repo: "https://github.com/c-cube/ocaml-containers.git" -bug-reports: "https://github.com/c-cube/ocaml-containers/issues/" -post-messages: [ -"Small release with many bugfixes and a few new functions. - -A summary hub.com/c-cube/ocaml-containers/issues/84 -changelog: https://github.com/c-cube/ocaml-containers/blob/1.3/CHANGELOG.adoc" -] diff --git a/qtest/Makefile b/qtest/Makefile new file mode 100644 index 00000000..8e41bb67 --- /dev/null +++ b/qtest/Makefile @@ -0,0 +1,31 @@ + + +QTEST_PREAMBLE='open CCFun;;' +DONTTEST=$(wildcard ../src/**/*.cppo.*) $(wildcard ../src/**/*Labels*) +QTESTABLE=$(filter-out $(DONTTEST), \ + $(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/unix/*.ml) \ + $(wildcard ../src/unix/*.mli) \ + $(wildcard ../src/sexp/*.ml) \ + $(wildcard ../src/sexp/*.mli) \ + $(wildcard ../src/iter/*.ml) \ + $(wildcard ../src/iter/*.mli) \ + $(wildcard ../src/bigarray/*.ml) \ + $(wildcard ../src/bigarray/*.mli) \ + $(wildcard ../src/threads/*.ml) \ + $(wildcard ../src/threads/*.mli) \ + ) + +qtest-gen: + @if which qtest > /dev/null ; then \ + echo "generate qtest"; \ + qtest extract --preamble $(QTEST_PREAMBLE) \ + -o run_qtest.ml \ + $(QTESTABLE) 2> /dev/null ; \ + else touch qtest/run_qtest.ml ; \ + fi diff --git a/qtest/jbuild b/qtest/jbuild new file mode 100644 index 00000000..124f3061 --- /dev/null +++ b/qtest/jbuild @@ -0,0 +1,23 @@ + +(rule + ((targets (run_qtest.ml)) + (deps ((file Makefile))) + (fallback) + ;(libraries (qtest qcheck)) + (action + (run make qtest-gen)) + )) + +(executable + ((name run_qtest) + (libraries (sequence gen qcheck containers containers.unix + containers.data containers.thread containers.iter + containers.sexp)) + )) + +(alias + ((name runtest) + (deps (run_qtest.exe)) + (action (run ${<})) + )) + diff --git a/setup.ml b/setup.ml deleted file mode 100644 index a6f2a792..00000000 --- a/setup.ml +++ /dev/null @@ -1,8915 +0,0 @@ -(* setup.ml generated for the first time by OASIS v0.4.4 *) - -(* OASIS_START *) -(* DO NOT EDIT (digest: 8a45fbcc3dc1199e20ced83543504d65) *) -(* - Regenerated by OASIS v0.4.10 - 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 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; - !what_idx = String.length what - - - 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; - !what_idx = -1 - - - 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 - - let lowercase_ascii = - replace_chars - (fun c -> - if (c >= 'A' && c <= 'Z') then - Char.chr (Char.code c + 32) - else - c) - - let uncapitalize_ascii s = - if s <> "" then - (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - - let uppercase_ascii = - replace_chars - (fun c -> - if (c >= 'a' && c <= 'z') then - Char.chr (Char.code c - 32) - else - c) - - let capitalize_ascii s = - if s <> "" then - (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) - else - s - -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 (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) - - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - let equal s1 s2 = (compare_csl s1 s2) = 0 - let hash s = Hashtbl.hash (OASISString.lowercase_ascii 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 - OASISString.lowercase_ascii 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 - - - let rec file_location ?pos1 ?pos2 ?lexbuf () = - match pos1, pos2, lexbuf with - | Some p, None, _ | None, Some p, _ -> - file_location ~pos1:p ~pos2:p ?lexbuf () - | Some p1, Some p2, _ -> - let open Lexing in - let fn, lineno = p1.pos_fname, p1.pos_lnum in - let c1 = p1.pos_cnum - p1.pos_bol in - let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in - Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 - | _, _, Some lexbuf -> - file_location - ~pos1:(Lexing.lexeme_start_p lexbuf) - ~pos2:(Lexing.lexeme_end_p lexbuf) - () - | None, None, None -> - s_ "" - - - let failwithpf ?pos1 ?pos2 ?lexbuf fmt = - let loc = file_location ?pos1 ?pos2 ?lexbuf () in - Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt - - -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 (OASISString.capitalize_ascii base) - - - let uncapitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (OASISString.uncapitalize_ascii base) - - -end - -module OASISHostPath = struct -(* # 22 "src/oasis/OASISHostPath.ml" *) - - - open Filename - open OASISGettext - - - module Unix = OASISUnixPath - - - let make = - function - | [] -> - invalid_arg "OASISHostPath.make" - | hd :: tl -> - List.fold_left Filename.concat hd tl - - - let of_unix ufn = - match Sys.os_type with - | "Unix" | "Cygwin" -> ufn - | "Win32" -> - 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 '/')) - | os_type -> - OASISUtils.failwithf - (f_ "Don't know the path format of os_type %S when translating unix \ - filename. %S") - os_type ufn - - -end - -module OASISFileSystem = struct -(* # 22 "src/oasis/OASISFileSystem.ml" *) - - (** File System functions - - @author Sylvain Le Gall - *) - - type 'a filename = string - - class type closer = - object - method close: unit - end - - class type reader = - object - inherit closer - method input: Buffer.t -> int -> unit - end - - class type writer = - object - inherit closer - method output: Buffer.t -> unit - end - - class type ['a] fs = - object - method string_of_filename: 'a filename -> string - method open_out: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> writer - method open_in: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> reader - method file_exists: 'a filename -> bool - method remove: 'a filename -> unit - end - - - module Mode = - struct - let default_in = [Open_rdonly] - let default_out = [Open_wronly; Open_creat; Open_trunc] - - let text_in = Open_text :: default_in - let text_out = Open_text :: default_out - - let binary_in = Open_binary :: default_in - let binary_out = Open_binary :: default_out - end - - let std_length = 4096 (* Standard buffer/read length. *) - let binary_out = Mode.binary_out - let binary_in = Mode.binary_in - - let of_unix_filename ufn = (ufn: 'a filename) - let to_unix_filename fn = (fn: string) - - - let defer_close o f = - try - let r = f o in o#close; r - with e -> - o#close; raise e - - - let stream_of_reader rdr = - let buf = Buffer.create std_length in - let pos = ref 0 in - let eof = ref false in - let rec next idx = - let bpos = idx - !pos in - if !eof then begin - None - end else if bpos < Buffer.length buf then begin - Some (Buffer.nth buf bpos) - end else begin - pos := !pos + Buffer.length buf; - Buffer.clear buf; - begin - try - rdr#input buf std_length; - with End_of_file -> - if Buffer.length buf = 0 then - eof := true - end; - next idx - end - in - Stream.from next - - - let read_all buf rdr = - try - while true do - rdr#input buf std_length - done - with End_of_file -> - () - - class ['a] host_fs rootdir : ['a] fs = - object (self) - method private host_filename fn = Filename.concat rootdir fn - method string_of_filename = self#host_filename - - method open_out ?(mode=Mode.text_out) ?(perm=0o666) fn = - let chn = open_out_gen mode perm (self#host_filename fn) in - object - method close = close_out chn - method output buf = Buffer.output_buffer chn buf - end - - method open_in ?(mode=Mode.text_in) ?(perm=0o666) fn = - (* TODO: use Buffer.add_channel when minimal version of OCaml will - * be >= 4.03.0 (previous version was discarding last chars). - *) - let chn = open_in_gen mode perm (self#host_filename fn) in - let strm = Stream.of_channel chn in - object - method close = close_in chn - method input buf len = - let read = ref 0 in - try - for _i = 0 to len do - Buffer.add_char buf (Stream.next strm); - incr read - done - with Stream.Failure -> - if !read = 0 then - raise End_of_file - end - - method file_exists fn = Sys.file_exists (self#host_filename fn) - method remove fn = Sys.remove (self#host_filename fn) - end - -end - -module OASISContext = struct -(* # 22 "src/oasis/OASISContext.ml" *) - - - open OASISGettext - - - type level = - [ `Debug - | `Info - | `Warning - | `Error] - - - type source - type source_filename = source OASISFileSystem.filename - - - let in_srcdir ufn = OASISFileSystem.of_unix_filename ufn - - - 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; - srcfs: source OASISFileSystem.fs; - load_oasis_plugin: string -> bool; - } - - - 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; - srcfs = new OASISFileSystem.host_fs(Sys.getcwd ()); - load_oasis_plugin = (fun _ -> false); - } - - - 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", - Arg.String - (fun str -> - Sys.chdir str; - default := {!default with srcfs = new OASISFileSystem.host_fs str}), - s_ "dir Change directory before running (affects setup.{data,log})."], - fun () -> {!default with ignore_plugins = !ignore_plugins} -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 - - -(* # 77 "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 - OASISString.lowercase_ascii - 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 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 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) - - -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 - open OASISUtils - - - 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 OASISSourcePatterns = struct -(* # 22 "src/oasis/OASISSourcePatterns.ml" *) - - open OASISUtils - open OASISGettext - - module Templater = - struct - (* TODO: use this module in BaseEnv.var_expand and BaseFileAB, at least. *) - type t = - { - atoms: atom list; - origin: string - } - and atom = - | Text of string - | Expr of expr - and expr = - | Ident of string - | String of string - | Call of string * expr - - - type env = - { - variables: string MapString.t; - functions: (string -> string) MapString.t; - } - - - let eval env t = - let rec eval_expr env = - function - | String str -> str - | Ident nm -> - begin - try - MapString.find nm env.variables - with Not_found -> - (* TODO: add error location within the string. *) - failwithf - (f_ "Unable to find variable %S in source pattern %S") - nm t.origin - end - - | Call (fn, expr) -> - begin - try - (MapString.find fn env.functions) (eval_expr env expr) - with Not_found -> - (* TODO: add error location within the string. *) - failwithf - (f_ "Unable to find function %S in source pattern %S") - fn t.origin - end - in - String.concat "" - (List.map - (function - | Text str -> str - | Expr expr -> eval_expr env expr) - t.atoms) - - - let parse env s = - let lxr = Genlex.make_lexer [] in - let parse_expr s = - let st = lxr (Stream.of_string s) in - match Stream.npeek 3 st with - | [Genlex.Ident fn; Genlex.Ident nm] -> Call(fn, Ident nm) - | [Genlex.Ident fn; Genlex.String str] -> Call(fn, String str) - | [Genlex.String str] -> String str - | [Genlex.Ident nm] -> Ident nm - (* TODO: add error location within the string. *) - | _ -> failwithf (f_ "Unable to parse expression %S") s - in - let parse s = - let lst_exprs = ref [] in - let ss = - let buff = Buffer.create (String.length s) in - Buffer.add_substitute - buff - (fun s -> lst_exprs := (parse_expr s) :: !lst_exprs; "\000") - s; - Buffer.contents buff - in - let rec join = - function - | hd1 :: tl1, hd2 :: tl2 -> Text hd1 :: Expr hd2 :: join (tl1, tl2) - | [], tl -> List.map (fun e -> Expr e) tl - | tl, [] -> List.map (fun e -> Text e) tl - in - join (OASISString.nsplit ss '\000', List.rev (!lst_exprs)) - in - let t = {atoms = parse s; origin = s} in - (* We rely on a simple evaluation for checking variables/functions. - It works because there is no if/loop statement. - *) - let _s : string = eval env t in - t - -(* # 144 "src/oasis/OASISSourcePatterns.ml" *) - end - - - type t = Templater.t - - - let env ~modul () = - { - Templater. - variables = MapString.of_list ["module", modul]; - functions = MapString.of_list - [ - "capitalize_file", OASISUnixPath.capitalize_file; - "uncapitalize_file", OASISUnixPath.uncapitalize_file; - ]; - } - - let all_possible_files lst ~path ~modul = - let eval = Templater.eval (env ~modul ()) in - List.fold_left - (fun acc pat -> OASISUnixPath.concat path (eval pat) :: acc) - [] lst - - - let to_string t = t.Templater.origin - - -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 (* TODO: replace everywhere. *) - type host_dirname = string (* TODO: replace everywhere. *) - type host_filename = string (* TODO: replace everywhere. *) - 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 - - - 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_interface_patterns: OASISSourcePatterns.t list; - bs_implementation_patterns: OASISSourcePatterns.t list; - bs_c_sources: unix_filename list; - bs_data_files: (unix_filename * unix_filename option) list; - bs_findlib_extra_files: unix_filename 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_directory: unix_dirname option; - lib_findlib_containers: findlib_name list; - } - - - type object_ = - { - obj_modules: string list; - obj_findlib_fullname: findlib_name list option; - obj_findlib_directory: unix_dirname 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 (* TODO: source filename. *) - | DocText - | PDF - | PostScript - | Info of unix_filename (* TODO: source 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; (* TODO: dest filename ?. *) - doc_title: string; - doc_authors: string list; - doc_abstract: string option; - doc_format: doc_format; - (* TODO: src filename. *) - 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; (* TODO: source filename. *) - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - bugreports: url option; - synopsis: string; - description: OASISText.t option; - tags: string list; - 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; (* TODO: source filename. *) - sections: section list; - plugins: [`Extra] plugin list; - disable_oasis_section: unix_filename list; (* TODO: source filename. *) - 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: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: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:t).name features in - if not has_feature then - match (origin: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 _ -> 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_ "Make building docs require '-docs' flag at configure.") - - - let flag_tests = - create "flag_tests" - (since_version "0.3") - (fun () -> - s_ "Make 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_ "Compile the setup.ml and speed-up actions done with it.") - - let disable_oasis_section = - create "disable_oasis_section" alpha - (fun () -> - s_ "Allow the OASIS section comments and digests 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).") - - let findlib_directory = - create "findlib_directory" beta - (fun () -> - s_ "Allow to install findlib libraries in sub-directories of the target \ - findlib directory.") - - let findlib_extra_files = - create "findlib_extra_files" beta - (fun () -> - s_ "Allow to install extra files for findlib libraries.") - - let source_patterns = - create "source_patterns" alpha - (fun () -> - s_ "Customize mapping between module name and source file.") -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_kind = - function - | `Library -> "library" - | `Object -> "object" - | `Executable -> "executable" - | `Flag -> "flag" - | `SrcRepo -> "src repository" - | `Test -> "test" - | `Doc -> "doc" - - - let string_of_section sct = - let k, nm = section_id sct in - (string_of_section_kind k)^" "^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" *) - - open OASISTypes - - (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists bs modul = - let possible_lst = - OASISSourcePatterns.all_possible_files - (bs.bs_interface_patterns @ bs.bs_implementation_patterns) - ~path:bs.bs_path - ~modul - in - match List.filter source_file_exists possible_lst with - | (fn :: _) as fn_lst -> `Sources (OASISUnixPath.chop_extension fn, fn_lst) - | [] -> - let open OASISUtils in - let _, rev_lst = - List.fold_left - (fun (set, acc) fn -> - let base_fn = OASISUnixPath.chop_extension fn in - if SetString.mem base_fn set then - set, acc - else - SetString.add base_fn set, base_fn :: acc) - (SetString.empty, []) possible_lst - in - `No_sources (List.rev rev_lst) - - -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 OASISGettext - - let find_module ~ctxt source_file_exists cs bs modul = - match OASISBuildSection.find_module source_file_exists bs modul with - | `Sources _ as res -> res - | `No_sources _ as res -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching module '%s' in library %s.") - modul cs.cs_name; - OASISMessage.warning - ~ctxt - (f_ "Use InterfacePatterns or ImplementationPatterns to define \ - this file with feature %S.") - (OASISFeatures.source_patterns.OASISFeatures.name); - res - - let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = - List.fold_left - (fun acc modul -> - match find_module ~ctxt source_file_exists cs bs modul with - | `Sources (base_fn, lst) -> (base_fn, lst) :: acc - | `No_sources _ -> 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 ~ctxt source_file_exists cs bs modul with - | `Sources (_, [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 -> 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 - (List.fold_left - (fun accu s -> - let dot = String.rindex s '.' in - let base = String.sub s 0 dot in - List.map ((^) base) sufx @ accu) - []) - (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] - :: - if has_native_dynlink then - ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath - else - acc_nopath - end else begin - acc_nopath - end - 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 find_module ~ctxt source_file_exists cs bs modul = - match OASISBuildSection.find_module source_file_exists bs modul with - | `Sources _ as res -> res - | `No_sources _ as res -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching module '%s' in object %s.") - modul cs.cs_name; - OASISMessage.warning - ~ctxt - (f_ "Use InterfacePatterns or ImplementationPatterns to define \ - this file with feature %S.") - (OASISFeatures.source_patterns.OASISFeatures.name); - res - - let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = - List.fold_left - (fun acc modul -> - match find_module ~ctxt source_file_exists cs bs modul with - | `Sources (base_fn, lst) -> (base_fn, lst) :: acc - | `No_sources _ -> acc) - [] - obj.obj_modules - - - let generated_unix_files - ~ctxt - ~is_native - ~source_file_exists - (cs, bs, obj) = - - let find_module ext modul = - match find_module ~ctxt source_file_exists cs bs modul with - | `Sources (base_fn, _) -> [base_fn ^ ext] - | `No_sources lst -> 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 - - - 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_] * - unix_dirname option * - 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 unix_directory dn lib = - let directory = - match lib with - | `Library lib -> lib.lib_findlib_directory - | `Object obj -> obj.obj_findlib_directory - in - match dn, directory with - | None, None -> None - | None, Some dn | Some dn, None -> Some dn - | Some dn1, Some dn2 -> Some (OASISUnixPath.concat dn1 dn2) - in - - let rec group_of_tree dn mp = - MapString.fold - (fun nm node acc -> - let cur = - match node with - | Node (Some (cs, bs, lib), children) -> - let current_dn = unix_directory dn lib in - Package (nm, cs, bs, lib, current_dn, group_of_tree current_dn children) - | Node (None, children) -> - Container (nm, group_of_tree dn children) - | Leaf (cs, bs, lib) -> - let current_dn = unix_directory dn lib in - Package (nm, cs, bs, lib, current_dn, []) - 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 None 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 - - -# 3159 "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) ?stream () = - let line = ref 1 in - let lexer st = - 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 - Genlex.make_lexer ["="] st_line - in - let rec read_file lxr mp = - match Stream.npeek 3 lxr with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; - read_file lxr (MapString.add nm value mp) - | [] -> mp - | _ -> - failwith - (Printf.sprintf "Malformed data file '%s' line %d" filename !line) - in - match stream with - | Some st -> read_file (lexer st) MapString.empty - | None -> - if Sys.file_exists filename then begin - let chn = open_in_bin filename in - let st = Stream.of_channel chn in - try - let mp = read_file (lexer st) MapString.empty in - close_in chn; mp - with e -> - close_in chn; raise e - 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 - - -# 3239 "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 OASISContext - 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) (_, 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 (_: 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 = in_srcdir "setup.data" - - - let load ~ctxt ?(allow_empty=false) ?(filename=default_filename) () = - let open OASISFileSystem in - env_from_file := - let repr_filename = ctxt.srcfs#string_of_filename filename in - if ctxt.srcfs#file_exists filename then begin - let buf = Buffer.create 13 in - defer_close - (ctxt.srcfs#open_in ~mode:binary_in filename) - (read_all buf); - defer_close - (ctxt.srcfs#open_in ~mode:binary_in filename) - (fun rdr -> - OASISMessage.info ~ctxt "Loading environment from %S." repr_filename; - BaseEnvLight.load ~allow_empty - ~filename:(repr_filename) - ~stream:(stream_of_reader rdr) - ()) - end else if allow_empty then begin - BaseEnvLight.MapString.empty - end else begin - failwith - (Printf.sprintf - (f_ "Unable to load environment, the file '%s' doesn't exist.") - repr_filename) - end - - - let unload () = - env_from_file := MapString.empty; - Data.clear env - - - let dump ~ctxt ?(filename=default_filename) () = - let open OASISFileSystem in - defer_close - (ctxt.OASISContext.srcfs#open_out ~mode:binary_out filename) - (fun wrtr -> - let buf = Buffer.create 63 in - let output nm value = - Buffer.add_string buf (Printf.sprintf "%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 - output nm (Schema.get schema env nm) - 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; - wrtr#output buf) - - 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" name (dot_pad name); - if value = "" then - Printf.printf "\n" - else - Printf.printf " %s\n" 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 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" || os_type () = "Cygwin" 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 - open OASISContext - - - let to_filename fn = - if not (Filename.check_suffix fn ".ab") then - warning (f_ "File '%s' doesn't have '.ab' extension") fn; - OASISFileSystem.of_unix_filename (Filename.chop_extension fn) - - - let replace ~ctxt fn_lst = - let open OASISFileSystem in - let ibuf, obuf = Buffer.create 13, Buffer.create 13 in - List.iter - (fun fn -> - Buffer.clear ibuf; Buffer.clear obuf; - defer_close - (ctxt.srcfs#open_in (of_unix_filename fn)) - (read_all ibuf); - Buffer.add_string obuf (var_expand (Buffer.contents ibuf)); - defer_close - (ctxt.srcfs#open_out (to_filename fn)) - (fun wrtr -> wrtr#output obuf)) - fn_lst -end - -module BaseLog = struct -(* # 22 "src/base/BaseLog.ml" *) - - - open OASISUtils - open OASISContext - open OASISGettext - open OASISFileSystem - - - let default_filename = in_srcdir "setup.log" - - - let load ~ctxt () = - let 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) - in - if ctxt.srcfs#file_exists default_filename then begin - defer_close - (ctxt.srcfs#open_in default_filename) - (fun rdr -> - let line = ref 1 in - let lxr = Genlex.make_lexer [] (stream_of_reader rdr) in - let rec read_aux (st, lst) = - match Stream.npeek 2 lxr with - | [Genlex.String e; Genlex.String d] -> - let t = e, d in - Stream.junk lxr; Stream.junk lxr; - if SetTupleString.mem t st then - read_aux (st, lst) - else - read_aux (SetTupleString.add t st, t :: lst) - | [] -> List.rev lst - | _ -> - failwithf - (f_ "Malformed log file '%s' at line %d") - (ctxt.srcfs#string_of_filename default_filename) - !line - in - read_aux (SetTupleString.empty, [])) - end else begin - [] - end - - - let register ~ctxt event data = - defer_close - (ctxt.srcfs#open_out - ~mode:[Open_append; Open_creat; Open_text] - ~perm:0o644 - default_filename) - (fun wrtr -> - let buf = Buffer.create 13 in - Printf.bprintf buf "%S %S\n" event data; - wrtr#output buf) - - - let unregister ~ctxt event data = - let lst = load ~ctxt () in - let buf = Buffer.create 13 in - List.iter - (fun (e, d) -> - if e <> event || d <> data then - Printf.bprintf buf "%S %S\n" e d) - lst; - if Buffer.length buf > 0 then - defer_close - (ctxt.srcfs#open_out default_filename) - (fun wrtr -> wrtr#output buf) - else - ctxt.srcfs#remove default_filename - - - let filter ~ctxt events = - let st_events = SetString.of_list events in - List.filter - (fun (e, _) -> SetString.mem e st_events) - (load ~ctxt ()) - - - let exists ~ctxt event data = - List.exists - (fun v -> (event, data) = v) - (load ~ctxt ()) -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 ~ctxt t nm lst = - BaseLog.register ~ctxt (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 ~ctxt - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end else begin - registered - end) - false - alt - in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) - lst - - - let unregister ~ctxt t nm = - List.iter - (fun (e, d) -> BaseLog.unregister ~ctxt e d) - (BaseLog.filter ~ctxt [to_log_event_file t nm; to_log_event_done t nm]) - - - let fold ~ctxt 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 ~ctxt [to_log_event_file t nm]) - - - let is_built ~ctxt t nm = - List.fold_left - (fun _ (_, d) -> try bool_of_string d with _ -> false) - false - (BaseLog.filter ~ctxt [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 ~ctxt 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, _) -> - 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 ~ctxt 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 OASISGettext - - - let test ~ctxt 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 ~ctxt 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 ~ctxt 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 ~ctxt 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 OASISContext - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - open OASISUtils - - - type std_args_fun = - ctxt:OASISContext.t -> package -> string array -> unit - - - type ('a, 'b) section_args_fun = - name * - (ctxt:OASISContext.t -> - 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 ~ctxt t args = - (* Run configure *) - BaseCustom.hook - t.package.conf_custom - (fun () -> - (* Reload if preconf has changed it *) - begin - try - unload (); - load ~ctxt (); - with _ -> - () - end; - - (* Run plugin's configure *) - t.configure ~ctxt t.package args; - - (* Dump to allow postconf to change it *) - dump ~ctxt ()) - (); - - (* Reload environment *) - unload (); - load ~ctxt (); - - (* Save environment *) - print (); - - (* Replace data in file *) - BaseFileAB.replace ~ctxt t.package.files_ab - - - let build ~ctxt t args = - BaseCustom.hook - t.package.build_custom - (t.build ~ctxt t.package) - args - - - let doc ~ctxt t args = - BaseDoc.doc - ~ctxt - (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 ~ctxt t args = - BaseTest.test - ~ctxt - (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 ~ctxt 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 ~ctxt t (Array.of_list (List.rev !arg_rest)); - - info "Running build step"; - build ~ctxt t [||]; - - (* Load setup.log dynamic variables *) - BaseDynVar.init ~ctxt t.package; - - if not !rno_doc then begin - info "Running doc step"; - doc ~ctxt t [||] - end else begin - info "Skipping doc step" - end; - if not !rno_test then begin - info "Running test step"; - test ~ctxt t [||] - end else begin - info "Skipping test step" - end - - - let install ~ctxt t args = - BaseCustom.hook t.package.install_custom (t.install ~ctxt t.package) args - - - let uninstall ~ctxt t args = - BaseCustom.hook t.package.uninstall_custom (t.uninstall ~ctxt t.package) args - - - let reinstall ~ctxt t args = - uninstall ~ctxt t args; - install ~ctxt 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 ~ctxt 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 ~ctxt:_ _ _ _ -> () - in - failsafe (f ~ctxt t.package (cs, test)) args - | Doc (cs, doc) -> - let f = - try - List.assoc cs.cs_name docs - with Not_found -> - fun ~ctxt:_ _ _ _ -> () - in - failsafe (f ~ctxt t.package (cs, doc)) args - | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) - t.package.sections; - (* Clean whole package *) - List.iter (fun f -> failsafe (f ~ctxt t.package) args) mains) - () - in - - let clean ~ctxt t args = - generic_clean - ~ctxt - t - t.package.clean_custom - t.clean - t.clean_doc - t.clean_test - args - in - - let distclean ~ctxt t args = - (* Call clean *) - clean ~ctxt t args; - - (* Call distclean code *) - generic_clean - ~ctxt - t - t.package.distclean_custom - t.distclean - t.distclean_doc - t.distclean_test - args; - - (* Remove generated source files. *) - List.iter - (fun fn -> - if ctxt.srcfs#file_exists fn then begin - info (f_ "Remove '%s'") (ctxt.srcfs#string_of_filename fn); - ctxt.srcfs#remove fn - end) - ([BaseEnv.default_filename; BaseLog.default_filename] - @ (List.rev_map BaseFileAB.to_filename t.package.files_ab)) - in - - clean, distclean - - - let version ~ctxt:_ (t: 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.") - - (* TODO: srcfs *) - 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: - (fun n -> - if n <> 0 then - 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 - let act_ref = - ref (fun ~ctxt:_ _ -> - 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 - try - let () = - 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") - in - - (* Instantiate the context. *) - let ctxt = !BaseContext.default in - - (* Build initial environment *) - load ~ctxt ~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 ~ctxt t.package; - - if not (t.setup_update && update_setup_ml t) then - !act_ref ~ctxt t (Array.of_list (List.rev !extra_args_ref)) - - with e when !catch_exn -> - error "%s" (Printexc.to_string e); - exit 1 - - -end - -module BaseCompat = struct -(* # 22 "src/base/BaseCompat.ml" *) - - (** Compatibility layer to provide a stable API inside setup.ml. - This layer allows OASIS to change in between minor versions - (e.g. 0.4.6 -> 0.4.7) but still provides a stable API inside setup.ml. This - enables to write functions that manipulate setup_t inside setup.ml. See - deps.ml for an example. - - The module opened by default will depend on the version of the _oasis. E.g. - if we have "OASISFormat: 0.3", the module Compat_0_3 will be opened and - the function Compat_0_3 will be called. If setup.ml is generated with the - -nocompat, no module will be opened. - - @author Sylvain Le Gall - *) - - module Compat_0_4 = - struct - let rctxt = ref !BaseContext.default - - module BaseSetup = - struct - module Original = BaseSetup - - open OASISTypes - - 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; - } - - let setup t = - let mk_std_args_fun f = - fun ~ctxt pkg args -> rctxt := ctxt; f pkg args - in - let mk_section_args_fun l = - List.map - (fun (nm, f) -> - nm, - (fun ~ctxt pkg sct args -> - rctxt := ctxt; - f pkg sct args)) - l - in - let t' = - { - Original. - configure = mk_std_args_fun t.configure; - build = mk_std_args_fun t.build; - doc = mk_section_args_fun t.doc; - test = mk_section_args_fun t.test; - install = mk_std_args_fun t.install; - uninstall = mk_std_args_fun t.uninstall; - clean = List.map mk_std_args_fun t.clean; - clean_doc = mk_section_args_fun t.clean_doc; - clean_test = mk_section_args_fun t.clean_test; - distclean = List.map mk_std_args_fun t.distclean; - distclean_doc = mk_section_args_fun t.distclean_doc; - distclean_test = mk_section_args_fun t.distclean_test; - - package = t.package; - oasis_fn = t.oasis_fn; - oasis_version = t.oasis_version; - oasis_digest = t.oasis_digest; - oasis_exec = t.oasis_exec; - oasis_setup_args = t.oasis_setup_args; - setup_update = t.setup_update; - } - in - Original.setup t' - - end - - let adapt_setup_t setup_t = - let module O = BaseSetup.Original in - let mk_std_args_fun f = fun pkg args -> f ~ctxt:!rctxt pkg args in - let mk_section_args_fun l = - List.map - (fun (nm, f) -> nm, (fun pkg sct args -> f ~ctxt:!rctxt pkg sct args)) - l - in - { - BaseSetup. - configure = mk_std_args_fun setup_t.O.configure; - build = mk_std_args_fun setup_t.O.build; - doc = mk_section_args_fun setup_t.O.doc; - test = mk_section_args_fun setup_t.O.test; - install = mk_std_args_fun setup_t.O.install; - uninstall = mk_std_args_fun setup_t.O.uninstall; - clean = List.map mk_std_args_fun setup_t.O.clean; - clean_doc = mk_section_args_fun setup_t.O.clean_doc; - clean_test = mk_section_args_fun setup_t.O.clean_test; - distclean = List.map mk_std_args_fun setup_t.O.distclean; - distclean_doc = mk_section_args_fun setup_t.O.distclean_doc; - distclean_test = mk_section_args_fun setup_t.O.distclean_test; - - package = setup_t.O.package; - oasis_fn = setup_t.O.oasis_fn; - oasis_version = setup_t.O.oasis_version; - oasis_digest = setup_t.O.oasis_digest; - oasis_exec = setup_t.O.oasis_exec; - oasis_setup_args = setup_t.O.oasis_setup_args; - setup_update = setup_t.O.setup_update; - } - end - - - module Compat_0_3 = - struct - include Compat_0_4 - end - -end - - -# 5662 "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 ~ctxt:_ 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 - *) - - - (* TODO: rewrite this module with OASISFileSystem. *) - - 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, dn, lib) -> cs, bs, dn, lib, []) - let obj_hook = ref (fun (cs, bs, dn, obj) -> cs, bs, dn, 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" - - - (* TODO: this can be more generic and used elsewhere. *) - 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 = - - let in_destdir fn = - try - (* Practically speaking destdir is prepended at the beginning of the - target filename - *) - (destdir ())^fn - with PropList.Not_set _ -> - fn - in - - let install_file ~ctxt ?(prepend_destdir=true) ?tgt_fn src_file envdir = - let tgt_dir = - if prepend_destdir then in_destdir (envdir ()) else 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 - (fun dn -> - info (f_ "Creating directory '%s'") dn; - BaseLog.register ~ctxt install_dir_ev dn) - (Filename.dirname tgt_file); - - (* Really install files *) - info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - OASISFileUtil.cp ~ctxt src_file tgt_file; - BaseLog.register ~ctxt install_file_ev tgt_file - in - - (* Install the files for a library. *) - - let install_lib_files ~ctxt findlib_name files = - let findlib_dir = - let dn = - let findlib_destdir = - OASISExec.run_read_one_line ~ctxt (ocamlfind ()) - ["printconf" ; "destdir"] - in - Filename.concat findlib_destdir findlib_name - in - fun () -> dn - in - let () = - if not (OASISFileUtil.file_exists_case (findlib_dir ())) then - failwithf - (f_ "Directory '%s' doesn't exist for findlib library %s") - (findlib_dir ()) findlib_name - in - let f dir file = - let basename = Filename.basename file in - let tgt_fn = Filename.concat dir basename in - (* Destdir is already include in printconf. *) - install_file ~ctxt ~prepend_destdir:false ~tgt_fn file findlib_dir - in - List.iter (fun (dir, files) -> List.iter (f dir) files) files ; - in - - (* Install data into defined directory *) - let install_data ~ctxt 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 ~ctxt - 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 -> - (OASISString.capitalize_ascii modul ^ sufx) :: - (OASISString.uncapitalize_ascii modul ^ sufx) :: - accu - end - sufx - [] - in - - (** Install all libraries *) - let install_libs ~ctxt pkg = - - let find_first_existing_files_in_path bs lst = - let path = OASISHostPath.of_unix bs.bs_path in - List.find - OASISFileUtil.file_exists_case - (List.map (Filename.concat path) lst) - in - - let files_of_modules new_files typ cs bs modules = - List.fold_left - (fun acc modul -> - begin - try - (* Add uncompiled header from the source tree *) - [find_first_existing_files_in_path - bs (make_fnames modul [".mli"; ".ml"])] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in %s %s") - typ modul cs.cs_name; - [] - end - @ - List.fold_left - (fun acc fn -> - try - find_first_existing_files_in_path bs [fn] :: acc - with Not_found -> - acc) - acc (make_fnames modul [".annot";".cmti";".cmt"])) - new_files - modules - in - - let files_of_build_section (f_data, new_files) typ cs bs = - let extra_files = - List.map - (fun fn -> - try - find_first_existing_files_in_path bs [fn] - with Not_found -> - failwithf - (f_ "Cannot find extra findlib file %S in %s %s ") - fn - typ - cs.cs_name) - bs.bs_findlib_extra_files - in - let f_data () = - (* Install data associated with the library *) - install_data - ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - f_data, new_files @ extra_files - in - - let files_of_library (f_data, acc) data_lib = - let cs, bs, lib, dn, lib_extra = !lib_hook data_lib in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BLib cs.cs_name then begin - (* Start with lib_extra *) - let new_files = lib_extra in - let new_files = - files_of_modules new_files "library" cs bs lib.lib_modules - in - let f_data, new_files = - files_of_build_section (f_data, new_files) "library" cs bs - in - let new_files = - (* Get generated files *) - BaseBuilt.fold - ~ctxt - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - new_files - in - let acc = (dn, new_files) :: acc in - - let f_data () = - (* Install data associated with the library *) - install_data - ~ctxt - 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, dn, obj_extra = !obj_hook data_obj in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BObj cs.cs_name then begin - (* Start with obj_extra *) - let new_files = obj_extra in - let new_files = - files_of_modules new_files "object" cs bs obj.obj_modules - in - let f_data, new_files = - files_of_build_section (f_data, new_files) "object" cs bs - in - - let new_files = - (* Get generated files *) - BaseBuilt.fold - ~ctxt - BaseBuilt.BObj - cs.cs_name - (fun acc fn -> fn :: acc) - new_files - in - let acc = (dn, new_files) :: acc in - - let f_data () = - (* Install data associated with the object *) - install_data - ~ctxt - 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, dn, children) -> - files_of_library data_and_files (cs, bs, lib, dn), children - | Package (_, cs, bs, `Object obj, dn, children) -> - files_of_object data_and_files (cs, bs, obj, dn), 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. - *) - (* TODO: move to OASISHostPath as make_relative. *) - 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 begin - n - end - in - List.map - (fun (dir, fn) -> - (dir, List.map (remove_prefix (Sys.getcwd ())) fn)) - files - in - let ocamlfind = ocamlfind () in - let nodir_files, dir_files = - List.fold_left - (fun (nodir, dir) (dn, lst) -> - match dn with - | Some dn -> nodir, (dn, lst) :: dir - | None -> lst @ nodir, dir) - ([], []) - (List.rev files) - in - info (f_ "Installing findlib library '%s'") findlib_name; - List.iter - (OASISExec.run ~ctxt ocamlfind) - (split_install_command ocamlfind findlib_name meta nodir_files); - install_lib_files ~ctxt findlib_name dir_files; - BaseLog.register ~ctxt 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 ~ctxt pkg = - let install_exec data_exec = - let cs, bs, _ = !exec_hook data_exec in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BExec cs.cs_name then begin - let exec_libdir () = Filename.concat (libdir ()) pkg.name in - BaseBuilt.fold - ~ctxt - BaseBuilt.BExec - cs.cs_name - (fun () fn -> - install_file ~ctxt - ~tgt_fn:(cs.cs_name ^ ext_program ()) - fn - bindir) - (); - BaseBuilt.fold - ~ctxt - BaseBuilt.BExecLib - cs.cs_name - (fun () fn -> install_file ~ctxt fn exec_libdir) - (); - install_data ~ctxt - 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 ~ctxt pkg = - let install_doc data = - let cs, doc = !doc_hook data in - if var_choose doc.doc_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BDoc cs.cs_name then begin - let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in - BaseBuilt.fold - ~ctxt - BaseBuilt.BDoc - cs.cs_name - (fun () fn -> install_file ~ctxt fn (fun () -> tgt_dir)) - (); - install_data ~ctxt - 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 - fun ~ctxt pkg _ -> - install_libs ~ctxt pkg; - install_execs ~ctxt pkg; - install_docs ~ctxt pkg - - - (* Uninstall already installed data *) - let uninstall ~ctxt _ _ = - let uninstall_aux (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 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 (ocamlfind ()) ["remove"; data] - end else begin - failwithf (f_ "Unknown log event '%s'") ev; - end; - BaseLog.unregister ~ctxt ev data - in - (* We process event in reverse order *) - List.iter uninstall_aux - (List.rev - (BaseLog.filter ~ctxt [install_file_ev; install_dir_ev])); - List.iter uninstall_aux - (List.rev (BaseLog.filter ~ctxt [install_findlib_ev])) - -end - - -# 6465 "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"; - ] - else - []; - - if OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser (OASISVersion.version_of_string "3.11.1")) then - [ - "-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 ~ctxt extra_argv = - let extra_cli = - String.concat " " (Array.to_list extra_argv) - in - (* Run if never called with these args *) - if not (BaseLog.exists ~ctxt ocamlbuild_clean_ev extra_cli) then - begin - OASISExec.run ~ctxt (ocamlbuild ()) (fix_args ["-clean"] extra_argv); - BaseLog.register ~ctxt ocamlbuild_clean_ev extra_cli; - at_exit - (fun () -> - try - BaseLog.unregister ~ctxt ocamlbuild_clean_ev extra_cli - with _ -> ()) - end - - - (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild ~ctxt args extra_argv = - (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - OASISExec.run ~ctxt (ocamlbuild ()) (fix_args args extra_argv); - (* Remove any clean event, we must run it again *) - List.iter - (fun (e, d) -> BaseLog.unregister ~ctxt e d) - (BaseLog.filter ~ctxt [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 - - - let cond_targets_hook = ref (fun lst -> lst) - - - let build ~ctxt 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 ~what:".cmo" fn - || ends_with ~what:".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, _, _ = - 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, _ 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 ~ctxt bt bnm lst) - in - - (* Run the hook *) - let cond_targets = !cond_targets_hook cond_targets in - - (* Run a list of target... *) - run_ocamlbuild - ~ctxt - (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 ~ctxt pkg extra_args = - run_clean ~ctxt extra_args; - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister ~ctxt 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 OCamlbuildCommon - - - type run_t = - { - extra_args: string list; - run_path: unix_filename; - } - - - let doc_build ~ctxt run _ (cs, _) 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 ~ctxt (index_html :: run.extra_args) argv; - List.iter - (fun glb -> - match OASISFileUtil.glob ~ctxt (Filename.concat tgt_dir glb) with - | (_ :: _) as filenames -> - BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [filenames] - | [] -> ()) - ["*.html"; "*.css"] - - - let doc_clean ~ctxt _ _ (cs, _) argv = - run_clean ~ctxt argv; - BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name - - -end - - -# 6837 "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 ~ctxt:_ t _ extra_args = - let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in - run cmd args extra_args - - - let clean ~ctxt:_ t _ extra_args = - match var_choose t.cmd_clean with - | Some (cmd, args) -> run cmd args extra_args - | _ -> () - - - let distclean ~ctxt:_ t _ extra_args = - match var_choose t.cmd_distclean with - | Some (cmd, args) -> run cmd args extra_args - | _ -> () - - - module Build = - struct - let main ~ctxt t pkg extra_args = - main ~ctxt 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 ~ctxt bt bnm lst) - evs) - pkg.sections - - let clean ~ctxt t pkg extra_args = - clean ~ctxt 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 ~ctxt BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - let distclean ~ctxt t pkg extra_args = distclean ~ctxt t pkg extra_args - end - - - module Test = - struct - let main ~ctxt t pkg (cs, _) extra_args = - try - main ~ctxt t pkg extra_args; - 0.0 - with Failure s -> - BaseMessage.warning - (f_ "Test '%s' fails: %s") - cs.cs_name - s; - 1.0 - - let clean ~ctxt t pkg _ extra_args = clean ~ctxt t pkg extra_args - - let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args - end - - - module Doc = - struct - let main ~ctxt t pkg (cs, _) extra_args = - main ~ctxt t pkg extra_args; - BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [] - - let clean ~ctxt t pkg (cs, _) extra_args = - clean ~ctxt t pkg extra_args; - BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name - - let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args - end - - -end - - -# 6969 "setup.ml" -open OASISTypes;; - -let setup_t = - { - BaseSetup.configure = InternalConfigurePlugin.configure; - build = OCamlbuildPlugin.build ["-use-ocamlfind"; "-j 1"]; - test = - [ - ("all", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("./run_qtest.native", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - doc = - [ - ("containers", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = - [ - "-use-ocamlfind"; - "-docflags '-colorize-code -short-functors -charset utf-8'" - ]; - run_path = "." - }) - ]; - install = InternalInstallPlugin.install; - uninstall = InternalInstallPlugin.uninstall; - clean = [OCamlbuildPlugin.clean]; - clean_test = - [ - ("all", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("./run_qtest.native", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - clean_doc = - [ - ("containers", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = - [ - "-use-ocamlfind"; - "-docflags '-colorize-code -short-functors -charset utf-8'" - ]; - run_path = "." - }) - ]; - distclean = []; - distclean_test = - [ - ("all", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("./run_qtest.native", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - distclean_doc = []; - package = - { - oasis_version = "0.4"; - ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1"); - version = "1.5.2"; - license = - OASISLicense.DEP5License - (OASISLicense.DEP5Unit - { - OASISLicense.license = "BSD-2-clause"; - excption = None; - version = OASISLicense.NoVersion - }); - findlib_version = None; - alpha_features = ["ocamlbuild_more_args"]; - beta_features = []; - name = "containers"; - license_file = Some "LICENSE"; - copyrights = []; - maintainers = []; - authors = ["Simon Cruanes"]; - homepage = Some "https://github.com/c-cube/ocaml-containers"; - bugreports = None; - synopsis = "A modular standard library focused on data structures."; - description = - Some - [ - OASISText.Para - "Containers is a standard library (BSD license) focused on data structures, combinators and iterators, without dependencies on unix. Every module is independent and is prefixed with 'CC' in the global namespace. Some modules extend the stdlib (e.g. CCList provides safe map/fold_right/append, and additional functions on lists). It also features optional libraries for dealing with strings, and helpers for unix and threads." - ]; - tags = []; - categories = []; - files_ab = []; - sections = - [ - Flag - ({ - cs_name = "unix"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some - "Build the containers.unix library (depends on Unix)"; - flag_default = [(OASISExpr.EBool true, true)] - }); - Flag - ({ - cs_name = "thread"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some "Build modules that depend on threads"; - flag_default = [(OASISExpr.EBool true, true)] - }); - Flag - ({ - cs_name = "bench"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = Some "Build and run benchmarks"; - flag_default = [(OASISExpr.EBool true, true)] - }); - Library - ({ - cs_name = "containers"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/core"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("bytes", None); - FindlibPackage ("result", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_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 = - [ - "CCVector"; - "CCHeap"; - "CCList"; - "CCOpt"; - "CCPair"; - "CCFun"; - "CCHash"; - "CCInt"; - "CCBool"; - "CCFloat"; - "CCArray"; - "CCRef"; - "CCSet"; - "CCOrd"; - "CCRandom"; - "CCString"; - "CCHashtbl"; - "CCMap"; - "CCFormat"; - "CCIO"; - "CCInt64"; - "CCChar"; - "CCResult"; - "CCParse"; - "CCArray_slice"; - "CCListLabels"; - "CCArrayLabels"; - "CCEqual"; - "Containers" - ]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = None; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_unix"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/unix"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("bytes", None); - FindlibPackage ("result", None); - FindlibPackage ("unix", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_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 = ["CCUnix"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "unix"; - lib_findlib_directory = None; - 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); - FindlibPackage ("result", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_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"; "CCSexp_lex"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "sexp"; - lib_findlib_directory = None; - 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 = [FindlibPackage ("bytes", None)]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_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"; - "CCMixmap"; - "CCRingBuffer"; - "CCIntMap"; - "CCPersistentArray"; - "CCMixset"; - "CCGraph"; - "CCHashSet"; - "CCBitField"; - "CCHashTrie"; - "CCWBTree"; - "CCRAL"; - "CCSimple_queue"; - "CCImmutArray"; - "CCHet"; - "CCZipper" - ]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "data"; - lib_findlib_directory = None; - 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_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_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"; "CCLazy_list"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "iter"; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_thread"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "thread", true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "thread", true) - ]; - bs_path = "src/threads/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("threads", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_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 = - [ - "CCPool"; - "CCLock"; - "CCSemaphore"; - "CCThread"; - "CCBlockingQueue"; - "CCTimer" - ]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "thread"; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_top"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/top/"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("compiler-libs.common", None); - InternalLibrary "containers"; - InternalLibrary "containers_data"; - InternalLibrary "containers_unix"; - InternalLibrary "containers_sexp"; - InternalLibrary "containers_iter" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_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 = ["Containers_top"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "top"; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); - Doc - ({ - cs_name = "containers"; - 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", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EFlag "unix")), - 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_benchs"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "bench", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "benchs/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("qcheck", None); - InternalLibrary "containers_data"; - InternalLibrary "containers_iter"; - InternalLibrary "containers_thread"; - FindlibPackage ("sequence", None); - FindlibPackage ("gen", None); - FindlibPackage ("benchmark", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_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_benchs.ml"}); - Executable - ({ - cs_name = "run_bench_hash"; - 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 = "benchs/"; - bs_compiled_object = Best; - bs_build_depends = [InternalLibrary "containers"]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_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_bench_hash.ml"}); - Executable - ({ - cs_name = "run_qtest"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "unix"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "qtest/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_iter"; - InternalLibrary "containers_sexp"; - InternalLibrary "containers_unix"; - InternalLibrary "containers_thread"; - InternalLibrary "containers_data"; - FindlibPackage ("sequence", None); - FindlibPackage ("gen", None); - FindlibPackage ("unix", None); - FindlibPackage ("oUnit", None); - FindlibPackage ("qcheck", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_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, ("./run_qtest.native", []))]; - 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.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "unix")), - true) - ]; - test_tools = - [ - ExternalTool "ocamlbuild"; - InternalExecutable "run_qtest" - ] - }); - Executable - ({ - cs_name = "id_sexp"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "examples/"; - bs_compiled_object = Best; - bs_build_depends = [InternalLibrary "containers_sexp"]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_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_sexp.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/ocaml-containers"; - src_repo_browser = - Some - "https://github.com/c-cube/ocaml-containers/tree/master/src"; - src_repo_module = None; - src_repo_branch = None; - src_repo_tag = None; - src_repo_subdir = None - }) - ]; - disable_oasis_section = []; - 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)] - }; - plugins = - [(`Extra, "META", Some "0.3"); (`Extra, "DevFiles", Some "0.3")]; - schema_data = PropList.Data.create (); - plugin_data = [] - }; - oasis_fn = Some "_oasis"; - oasis_version = "0.4.10"; - oasis_digest = Some "/\027|\232W\235?\192\157\145^\200\176On^"; - oasis_exec = None; - oasis_setup_args = []; - setup_update = false - };; - -let setup () = BaseSetup.setup setup_t;; - -# 8912 "setup.ml" -let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t -open BaseCompat.Compat_0_4 -(* OASIS_STOP *) -let () = setup ();; diff --git a/src/core/CCArray.ml b/src/core/CCArray.ml index 3daf1e7e..4fa0a86f 100644 --- a/src/core/CCArray.ml +++ b/src/core/CCArray.ml @@ -176,8 +176,7 @@ let sort_indices cmp a = *) let sort_ranking cmp a = - let cmp_int : int -> int -> int = Pervasives.compare in - sort_indices cmp_int (sort_indices cmp a) + sort_indices compare (sort_indices cmp a) (*$= & ~cmp:(=) ~printer:Q.Print.(array int) [||] (sort_ranking Pervasives.compare [||]) @@ -297,24 +296,24 @@ let _lookup_exn ~cmp k a i j = | n when n<0 -> _lookup_rec ~cmp k a (i+1) (j-1) | _ -> raise Not_found (* too high *) -let lookup_exn ?(cmp=Pervasives.compare) k a = +let lookup_exn ~cmp k a = _lookup_exn ~cmp k a 0 (Array.length a-1) -let lookup ?(cmp=Pervasives.compare) k a = +let lookup ~cmp k a = try Some (_lookup_exn ~cmp k a 0 (Array.length a-1)) with Not_found -> None (*$T - lookup 2 [|0;1;2;3;4;5|] = Some 2 - lookup 4 [|0;1;2;3;4;5|] = Some 4 - lookup 0 [|1;2;3;4;5|] = None - lookup 6 [|1;2;3;4;5|] = None - lookup 3 [| |] = None - lookup 1 [| 1 |] = Some 0 - lookup 2 [| 1 |] = None + lookup ~cmp:CCInt.compare 2 [|0;1;2;3;4;5|] = Some 2 + lookup ~cmp:CCInt.compare 4 [|0;1;2;3;4;5|] = Some 4 + lookup ~cmp:CCInt.compare 0 [|1;2;3;4;5|] = None + lookup ~cmp:CCInt.compare 6 [|1;2;3;4;5|] = None + lookup ~cmp:CCInt.compare 3 [| |] = None + lookup ~cmp:CCInt.compare 1 [| 1 |] = Some 0 + lookup ~cmp:CCInt.compare 2 [| 1 |] = None *) -let bsearch ?(cmp=Pervasives.compare) k a = +let bsearch ~cmp k a = let rec aux i j = if i > j then `Just_after j @@ -333,13 +332,13 @@ let bsearch ?(cmp=Pervasives.compare) k a = | _ -> aux 0 (n-1) (*$T bsearch - bsearch 3 [|1; 2; 2; 3; 4; 10|] = `At 3 - bsearch 5 [|1; 2; 2; 3; 4; 10|] = `Just_after 4 - bsearch 1 [|1; 2; 5; 5; 11; 12|] = `At 0 - bsearch 12 [|1; 2; 5; 5; 11; 12|] = `At 5 - bsearch 10 [|1; 2; 2; 3; 4; 9|] = `All_lower - bsearch 0 [|1; 2; 2; 3; 4; 9|] = `All_bigger - bsearch 3 [| |] = `Empty + bsearch ~cmp:CCInt.compare 3 [|1; 2; 2; 3; 4; 10|] = `At 3 + bsearch ~cmp:CCInt.compare 5 [|1; 2; 2; 3; 4; 10|] = `Just_after 4 + bsearch ~cmp:CCInt.compare 1 [|1; 2; 5; 5; 11; 12|] = `At 0 + bsearch ~cmp:CCInt.compare 12 [|1; 2; 5; 5; 11; 12|] = `At 5 + bsearch ~cmp:CCInt.compare 10 [|1; 2; 2; 3; 4; 9|] = `All_lower + bsearch ~cmp:CCInt.compare 0 [|1; 2; 2; 3; 4; 9|] = `All_bigger + bsearch ~cmp:CCInt.compare 3 [| |] = `Empty *) let (>>=) a f = flat_map f a @@ -664,7 +663,7 @@ end let sort_generic (type arr)(type elt) (module A : MONO_ARRAY with type t = arr and type elt = elt) - ?(cmp=Pervasives.compare) a + ~cmp a = let module S = SortGeneric(A) in S.sort ~cmp a diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index d0b5e4f9..1acd7772 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -28,23 +28,39 @@ val swap : 'a t -> int -> int -> unit @since 1.4 *) val get : 'a t -> int -> 'a +(** [get a n] returns the element number [n] of array [a]. + The first element has number 0. + The last element has number [length a - 1]. + You can also write [a.(n)] instead of [get a n]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(length a - 1)]. *) val get_safe : 'a t -> int -> 'a option -(** [get_safe a i] returns [Some a.(i)] if [i] is a valid index +(** [get_safe a i] returns [Some a.(i)] if [i] is a valid index. @since 0.18 *) val set : 'a t -> int -> 'a -> unit +(** [set a n x] modifies array [a] in place, replacing + element number [n] with [x]. + You can also write [a.(n) <- x] instead of [set a n x]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [length a - 1]. *) val length : _ t -> int +(** Return the length (number of elements) of the given array. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a +(** [fold f x a] computes [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], + where [n] is the length of the array [a]. *) val foldi : ('a -> int -> 'b -> 'a) -> 'a -> 'b t -> 'a -(** Fold left on array, with index *) +(** Fold left on array, with index. *) val fold_while : ('a -> 'b -> 'a * [`Stop | `Continue]) -> 'a -> 'b t -> 'a (** Fold left on array until a stop condition via [('a, `Stop)] is - indicated by the accumulator + indicated by the accumulator. @since 0.8 *) val fold_map : ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a t -> 'acc * 'b t @@ -54,20 +70,32 @@ val fold_map : ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a t -> 'acc * 'b t val scan_left : ('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc t (** [scan_left f acc a] returns the array - [ [|acc; f acc x0; f (f acc a.(0)) a.(1); ā€¦|] ] + [ [|acc; f acc x0; f (f acc a.(0)) a.(1); ā€¦|] ]. @since 1.2 *) - val iter : ('a -> unit) -> 'a t -> unit +(** [iter f a] applies function [f] in turn to all + the elements of [a]. It is equivalent to + [f a.(0); f a.(1); ...; f a.(length a - 1); ()]. *) val iteri : (int -> 'a -> unit) -> 'a t -> unit +(** Same as {!Array.iter}, but the + function is applied with the index of the element as first argument, + and the element itself as second argument. *) val blit : 'a t -> int -> 'a t -> int -> int -> unit -(** [blit from i into j len] copies [len] elements from the first array - to the second. See {!Array.blit}. *) +(** [blit v1 o1 v2 o2 len] copies [len] elements + from array [v1], starting at element number [o1], to array [v2], + starting at element number [o2]. It works correctly even if + [v1] and [v2] are the same array, and the source and + destination chunks overlap. + + Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not + designate a valid subarray of [v1], or if [o2] and [len] do not + designate a valid subarray of [v2]. *) val reverse_in_place : 'a t -> unit -(** Reverse the array in place *) +(** Reverse the array in place. *) val sorted : ('a -> 'a -> int) -> 'a t -> 'a array (** [sorted cmp a] makes a copy of [a] and sorts it with [cmp]. @@ -80,7 +108,6 @@ val sort_indices : ('a -> 'a -> int) -> 'a t -> int array In other words, [map (fun i -> a.(i)) (sort_indices cmp a) = sorted cmp a]. [sort_indices] yields the inverse permutation of {!sort_ranking}. - @since 1.0 *) val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array @@ -92,17 +119,16 @@ val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array [sort_ranking] yields the inverse permutation of {!sort_indices}. In the absence of duplicate elements in [a], we also have - [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)] + [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)]. @since 1.0 *) val find_map : ('a -> 'b option) -> 'a t -> 'b option (** [find_map f a] returns [Some y] if there is an element [x] such - that [f x = Some y], else it returns [None] - @since 1.3 -*) + that [f x = Some y], else it returns [None]. + @since 1.3 *) val find : ('a -> 'b option) -> 'a t -> 'b option -(** Alias to {!find_map} +(** Alias to {!find_map}. @deprecated since 1.3 *) val find_map_i : (int -> 'a -> 'b option) -> 'a t -> 'b option @@ -110,31 +136,33 @@ val find_map_i : (int -> 'a -> 'b option) -> 'a t -> 'b option @since 1.3 *) val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option -(** Alias to {!find_map_i} +(** Alias to {!find_map_i}. @since 0.3.4 @deprecated since 1.3 *) val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option (** [find_idx p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], - and [p x] holds. Otherwise returns [None] + and [p x] holds. Otherwise returns [None]. @since 0.3.4 *) -val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option +val lookup : cmp:'a ord -> 'a -> 'a t -> int option (** Lookup the index of some value in a sorted array. + Undefined behavior if the array is not sorted wrt [cmp]. + Complexity: [O(log (n))] (dichotomic search). @return [None] if the key is not present, or - [Some i] ([i] the index of the key) otherwise *) + [Some i] ([i] the index of the key) otherwise. *) -val lookup_exn : ?cmp:'a ord -> 'a -> 'a t -> int +val lookup_exn : cmp:'a ord -> 'a -> 'a t -> int (** Same as {!lookup}, but - @raise Not_found if the key is not present *) + @raise Not_found if the key is not present. *) -val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t -> +val bsearch : cmp:('a -> 'a -> int) -> 'a -> 'a t -> [ `All_lower | `All_bigger | `Just_after of int | `Empty | `At of int ] (** [bsearch ?cmp x arr] finds the index of the object [x] in the array [arr], provided [arr] is {b sorted} using [cmp]. If the array is not sorted, the result is not specified (may raise Invalid_argument). - Complexity: O(log n) where n is the length of the array + Complexity: [O(log n)] where n is the length of the array (dichotomic search). @return @@ -142,44 +170,52 @@ val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t -> - [`All_lower] if all elements of [arr] are lower than [x] - [`All_bigger] if all elements of [arr] are bigger than [x] - [`Just_after i] if [arr.(i) < x < arr.(i+1)] - - [`Empty] if the array is empty + - [`Empty] if the array is empty. - @raise Invalid_argument if the array is found to be unsorted w.r.t [cmp] + @raise Invalid_argument if the array is found to be unsorted w.r.t [cmp]. @since 0.13 *) val for_all : ('a -> bool) -> 'a t -> bool +(** [for_all p [|a1; ...; an|]] checks if all elements of the array + satisfy the predicate [p]. That is, it returns + [(p a1) && (p a2) && ... && (p an)]. *) val for_all2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** Forall on pairs of arrays. @raise Invalid_argument if they have distinct lengths - allow different types @since 0.20 *) + allow different types. + @since 0.20 *) val exists : ('a -> bool) -> 'a t -> bool +(** [exists p [|a1; ...; an|]] checks if at least one element of + the array satisfies the predicate [p]. That is, it returns + [(p a1) || (p a2) || ... || (p an)]. *) val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** Exists on pairs of arrays. @raise Invalid_argument if they have distinct lengths - allow different types @since 0.20 *) + allow different types. + @since 0.20 *) val fold2 : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> 'a t -> 'b t -> 'acc (** Fold on two arrays stepwise. - @raise Invalid_argument if they have distinct lengths + @raise Invalid_argument if they have distinct lengths. @since 0.20 *) val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit (** Iterate on two arrays stepwise. - @raise Invalid_argument if they have distinct lengths + @raise Invalid_argument if they have distinct lengths. @since 0.20 *) val shuffle : 'a t -> unit -(** Shuffle randomly the array, in place *) +(** Shuffle randomly the array, in place. *) val shuffle_with : Random.State.t -> 'a t -> unit -(** Like shuffle but using a specialized random state *) +(** Like shuffle but using a specialized random state. *) val random_choose : 'a t -> 'a random_gen (** Choose an element randomly. - @raise Not_found if the array/slice is empty *) + @raise Not_found if the array/slice is empty. *) val to_seq : 'a t -> 'a sequence val to_gen : 'a t -> 'a gen @@ -188,20 +224,25 @@ val to_klist : 'a t -> 'a klist (** {2 IO} *) val pp: ?sep:string -> 'a printer -> 'a t printer -(** Print an array of items with printing function *) +(** Print an array of items with printing function. *) val pp_i: ?sep:string -> (int -> 'a printer) -> 'a t printer -(** Print an array, giving the printing function both index and item *) +(** Print an array, giving the printing function both index and item. *) val map : ('a -> 'b) -> 'a t -> 'b t +(** [map f a] applies function [f] to all the elements of [a], + and builds an array with the results returned by [f]: + [[| f a.(0); f a.(1); ...; f a.(length a - 1) |]]. *) val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t -(** Map on two arrays stepwise. - @raise Invalid_argument if they have distinct lengths +(** [map2 f a b] applies function [f] to all the elements of [a] and [b], + and builds an array with the results returned by [f]: + [[| f a.(0) b.(0); ...; f a.(length a - 1) b.(length b - 1)|]]. + @raise Invalid_argument if they have distinct lengths. @since 0.20 *) val rev : 'a t -> 'a t -(** Copy + reverse in place +(** Copy + reverse in place. @since 0.20 *) val filter : ('a -> bool) -> 'a t -> 'a t @@ -209,30 +250,30 @@ val filter : ('a -> bool) -> 'a t -> 'a t the given predicate will be kept. *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t -(** Map each element into another value, or discard it *) +(** Map each element into another value, or discard it. *) val flat_map : ('a -> 'b t) -> 'a t -> 'b array -(** Transform each element into an array, then flatten *) +(** Transform each element into an array, then flatten. *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -(** Infix version of {!flat_map} *) +(** Infix version of {!flat_map}. *) val (>>|) : 'a t -> ('a -> 'b) -> 'b t -(** Infix version of {!map} +(** Infix version of {!map}. @since 0.8 *) val (>|=) : 'a t -> ('a -> 'b) -> 'b t -(** Infix version of {!map} +(** Infix version of {!map}. @since 0.8 *) val except_idx : 'a t -> int -> 'a list -(** Remove given index, obtaining the list of the other elements *) +(** Remove given index, obtaining the list of the other elements. *) val (--) : int -> int -> int t -(** Range array *) +(** Range array. *) val (--^) : int -> int -> int t -(** Range array, excluding right bound +(** Range array, excluding right bound. @since 0.17 *) val random : 'a random_gen -> 'a t random_gen @@ -254,7 +295,7 @@ end val sort_generic : (module MONO_ARRAY with type t = 'arr and type elt = 'elt) -> - ?cmp:('elt -> 'elt -> int) -> 'arr -> unit + cmp:('elt -> 'elt -> int) -> 'arr -> unit (** Sort the array, without allocating (eats stack space though). Performance might be lower than {!Array.sort}. @since 0.14 *) diff --git a/src/core/CCArrayLabels.mli b/src/core/CCArrayLabels.mli index fdf3784b..4cf926d9 100644 --- a/src/core/CCArrayLabels.mli +++ b/src/core/CCArrayLabels.mli @@ -24,35 +24,64 @@ val equal : 'a equal -> 'a t equal val compare : 'a ord -> 'a t ord val get : 'a t -> int -> 'a +(** [get a n] returns the element number [n] of array [a]. + The first element has number 0. + The last element has number [length a - 1]. + You can also write [a.(n)] instead of [get a n]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(length a - 1)]. *) val get_safe : 'a t -> int -> 'a option -(** [get_safe a i] returns [Some a.(i)] if [i] is a valid index +(** [get_safe a i] returns [Some a.(i)] if [i] is a valid index. @since 0.18 *) val set : 'a t -> int -> 'a -> unit +(** [set a n x] modifies array [a] in place, replacing + element number [n] with [x]. + You can also write [a.(n) <- x] instead of [set a n x]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [length a - 1]. *) val length : _ t -> int +(** Return the length (number of elements) of the given array. *) val fold : f:('a -> 'b -> 'a) -> init:'a -> 'b t -> 'a +(** [fold f x a] computes [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], + where [n] is the length of the array [a]. *) val foldi : f:('a -> int -> 'b -> 'a) -> init:'a -> 'b t -> 'a -(** Fold left on array, with index *) +(** Fold left on array, with index. *) val fold_while : f:('a -> 'b -> 'a * [`Stop | `Continue]) -> init:'a -> 'b t -> 'a (** Fold left on array until a stop condition via [('a, `Stop)] is - indicated by the accumulator + indicated by the accumulator. @since 0.8 *) val iter : f:('a -> unit) -> 'a t -> unit +(** [iter f a] applies function [f] in turn to all + the elements of [a]. It is equivalent to + [f a.(0); f a.(1); ...; f a.(length a - 1); ()]. *) val iteri : f:(int -> 'a -> unit) -> 'a t -> unit +(** Same as {!Array.iter}, but the + function is applied with the index of the element as first argument, + and the element itself as second argument. *) val blit : 'a t -> int -> 'a t -> int -> int -> unit -(** [blit from i into j len] copies [len] elements from the first array - to the second. See {!Array.blit}. *) +(** [blit v1 o1 v2 o2 len] copies [len] elements + from array [v1], starting at element number [o1], to array [v2], + starting at element number [o2]. It works correctly even if + [v1] and [v2] are the same array, and the source and + destination chunks overlap. + + Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not + designate a valid subarray of [v1], or if [o2] and [len] do not + designate a valid subarray of [v2]. *) val reverse_in_place : 'a t -> unit -(** Reverse the array in place *) +(** Reverse the array in place. *) val sorted : f:('a -> 'a -> int) -> 'a t -> 'a array (** [sorted cmp a] makes a copy of [a] and sorts it with [cmp]. @@ -60,26 +89,28 @@ val sorted : f:('a -> 'a -> int) -> 'a t -> 'a array val sort_indices : f:('a -> 'a -> int) -> 'a t -> int array (** [sort_indices cmp a] returns a new array [b], with the same length as [a], - such that [b.(i)] is the index of the [i]-th element of [a] in [sort cmp a]. - In other words, [map (fun i -> a.(i)) (sort_indices a) = sorted cmp a]. - [a] is not modified. + such that [b.(i)] is the index at which the [i]-th element of [sorted cmp a] + appears in [a]. [a] is not modified. + + In other words, [map (fun i -> a.(i)) (sort_indices cmp a) = sorted cmp a]. + [sort_indices] yields the inverse permutation of {!sort_ranking}. @since 1.0 *) val sort_ranking : f:('a -> 'a -> int) -> 'a t -> int array (** [sort_ranking cmp a] returns a new array [b], with the same length as [a], - such that [b.(i)] is the position in [sorted cmp a] of the [i]-th - element of [a]. - [a] is not modified. + such that [b.(i)] is the index at which the [i]-the element of [a] appears + in [sorted cmp a]. [a] is not modified. In other words, [map (fun i -> (sorted cmp a).(i)) (sort_ranking cmp a) = a]. + [sort_ranking] yields the inverse permutation of {!sort_indices}. - Without duplicates, we also have - [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)] + In the absence of duplicate elements in [a], we also have + [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)]. @since 1.0 *) val find : f:('a -> 'b option) -> 'a t -> 'b option (** [find f a] returns [Some y] if there is an element [x] such - that [f x = Some y], else it returns [None] *) + that [f x = Some y], else it returns [None]. *) val findi : f:(int -> 'a -> 'b option) -> 'a t -> 'b option (** Like {!find}, but also pass the index to the predicate function. @@ -87,25 +118,27 @@ val findi : f:(int -> 'a -> 'b option) -> 'a t -> 'b option val find_idx : f:('a -> bool) -> 'a t -> (int * 'a) option (** [find_idx p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], - and [p x] holds. Otherwise returns [None] + and [p x] holds. Otherwise returns [None]. @since 0.3.4 *) -val lookup : ?cmp:'a ord -> key:'a -> 'a t -> int option +val lookup : cmp:'a ord -> key:'a -> 'a t -> int option (** Lookup the index of some value in a sorted array. + Undefined behavior if the array is not sorted wrt [cmp]. + Complexity: [O(log (n))] (dichotomic search). @return [None] if the key is not present, or - [Some i] ([i] the index of the key) otherwise *) + [Some i] ([i] the index of the key) otherwise. *) -val lookup_exn : ?cmp:'a ord -> key:'a -> 'a t -> int -(** Same as {!lookup_exn}, but - @raise Not_found if the key is not present *) +val lookup_exn : cmp:'a ord -> key:'a -> 'a t -> int +(** Same as {!lookup}, but + @raise Not_found if the key is not present. *) -val bsearch : ?cmp:('a -> 'a -> int) -> key:'a -> 'a t -> +val bsearch : cmp:('a -> 'a -> int) -> key:'a -> 'a t -> [ `All_lower | `All_bigger | `Just_after of int | `Empty | `At of int ] (** [bsearch ?cmp key arr] finds the index of the object [key] in the array [arr], provided [arr] is {b sorted} using [cmp]. If the array is not sorted, the result is not specified (may raise Invalid_argument). - Complexity: O(log n) where n is the length of the array + Complexity: [O(log n)] where n is the length of the array (dichotomic search). @return @@ -113,44 +146,52 @@ val bsearch : ?cmp:('a -> 'a -> int) -> key:'a -> 'a t -> - [`All_lower] if all elements of [arr] are lower than [key] - [`All_bigger] if all elements of [arr] are bigger than [key] - [`Just_after i] if [arr.(i) < key < arr.(i+1)] - - [`Empty] if the array is empty + - [`Empty] if the array is empty. - @raise Invalid_argument if the array is found to be unsorted w.r.t [cmp] + @raise Invalid_argument if the array is found to be unsorted w.r.t [cmp]. @since 0.13 *) val for_all : f:('a -> bool) -> 'a t -> bool +(** [for_all p [|a1; ...; an|]] checks if all elements of the array + satisfy the predicate [p]. That is, it returns + [(p a1) && (p a2) && ... && (p an)]. *) val for_all2 : f:('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** Forall on pairs of arrays. @raise Invalid_argument if they have distinct lengths - allow different types @since 0.20 *) + allow different types. + @since 0.20 *) val exists : f:('a -> bool) -> 'a t -> bool +(** [exists p [|a1; ...; an|]] checks if at least one element of + the array satisfies the predicate [p]. That is, it returns + [(p a1) || (p a2) || ... || (p an)]. *) val exists2 : f:('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** Exists on pairs of arrays. @raise Invalid_argument if they have distinct lengths - allow different types @since 0.20 *) + allow different types. + @since 0.20 *) val fold2 : f:('acc -> 'a -> 'b -> 'acc) -> init:'acc -> 'a t -> 'b t -> 'acc (** Fold on two arrays stepwise. - @raise Invalid_argument if they have distinct lengths + @raise Invalid_argument if they have distinct lengths. @since 0.20 *) val iter2 : f:('a -> 'b -> unit) -> 'a t -> 'b t -> unit (** Iterate on two arrays stepwise. - @raise Invalid_argument if they have distinct lengths + @raise Invalid_argument if they have distinct lengths. @since 0.20 *) val shuffle : 'a t -> unit -(** Shuffle randomly the array, in place *) +(** Shuffle randomly the array, in place. *) val shuffle_with : Random.State.t -> 'a t -> unit -(** Like shuffle but using a specialized random state *) +(** Like shuffle but using a specialized random state. *) val random_choose : 'a t -> 'a random_gen (** Choose an element randomly. - @raise Not_found if the array/slice is empty *) + @raise Not_found if the array/slice is empty. *) val to_seq : 'a t -> 'a sequence val to_gen : 'a t -> 'a gen @@ -159,20 +200,25 @@ val to_klist : 'a t -> 'a klist (** {2 IO} *) val pp: ?sep:string -> 'a printer -> 'a t printer -(** Print an array of items with printing function *) +(** Print an array of items with printing function. *) val pp_i: ?sep:string -> (int -> 'a printer) -> 'a t printer -(** Print an array, giving the printing function both index and item *) +(** Print an array, giving the printing function both index and item. *) val map : f:('a -> 'b) -> 'a t -> 'b t +(** [map f a] applies function [f] to all the elements of [a], + and builds an array with the results returned by [f]: + [[| f a.(0); f a.(1); ...; f a.(length a - 1) |]]. *) val map2 : f:('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t -(** Map on two arrays stepwise. - @raise Invalid_argument if they have distinct lengths +(** [map2 f a b] applies function [f] to all the elements of [a] and [b], + and builds an array with the results returned by [f]: + [[| f a.(0) b.(0); ...; f a.(length a - 1) b.(length b - 1)|]]. + @raise Invalid_argument if they have distinct lengths. @since 0.20 *) val rev : 'a t -> 'a t -(** Copy + reverse in place +(** Copy + reverse in place. @since 0.20 *) val filter : f:('a -> bool) -> 'a t -> 'a t @@ -180,30 +226,30 @@ val filter : f:('a -> bool) -> 'a t -> 'a t the given predicate will be kept. *) val filter_map : f:('a -> 'b option) -> 'a t -> 'b t -(** Map each element into another value, or discard it *) +(** Map each element into another value, or discard it. *) val flat_map : f:('a -> 'b t) -> 'a t -> 'b array -(** Transform each element into an array, then flatten *) +(** Transform each element into an array, then flatten. *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -(** Infix version of {!flat_map} *) +(** Infix version of {!flat_map}. *) val (>>|) : 'a t -> ('a -> 'b) -> 'b t -(** Infix version of {!map} +(** Infix version of {!map}. @since 0.8 *) val (>|=) : 'a t -> ('a -> 'b) -> 'b t -(** Infix version of {!map} +(** Infix version of {!map}. @since 0.8 *) val except_idx : 'a t -> int -> 'a list -(** Remove given index, obtaining the list of the other elements *) +(** Remove given index, obtaining the list of the other elements. *) val (--) : int -> int -> int t -(** Range array *) +(** Range array. *) val (--^) : int -> int -> int t -(** Range array, excluding right bound +(** Range array, excluding right bound. @since 0.17 *) val random : 'a random_gen -> 'a t random_gen @@ -225,7 +271,7 @@ end val sort_generic : (module MONO_ARRAY with type t = 'arr and type elt = 'elt) -> - ?cmp:('elt -> 'elt -> int) -> 'arr -> unit + cmp:('elt -> 'elt -> int) -> 'arr -> unit (** Sort the array, without allocating (eats stack space though). Performance might be lower than {!Array.sort}. @since 0.14 *) diff --git a/src/core/CCArray_slice.ml b/src/core/CCArray_slice.ml index fcbe1204..9e96841b 100644 --- a/src/core/CCArray_slice.ml +++ b/src/core/CCArray_slice.ml @@ -85,6 +85,7 @@ let rec _compare cmp a1 i1 j1 a2 i2 j2 = let equal eq a b = length a = length b && _equal eq a.arr a.i a.j b.arr b.i b.j +let compare_int (a : int) b = Pervasives.compare a b let compare cmp a b = _compare cmp a.arr a.i a.j b.arr b.i b.j @@ -292,9 +293,8 @@ let sorted cmp a = _sorted cmp a.arr a.i a.j let sort_ranking cmp a = let idx = _sort_indices cmp a.arr a.i a.j in - let cmp_int : int -> int -> int = Pervasives.compare in let sort_indices cmp a = _sort_indices cmp a 0 (Array.length a) in - sort_indices cmp_int idx + sort_indices compare_int idx (*$= & ~cmp:(=) ~printer:Q.Print.(array int) [||] \ @@ -345,18 +345,18 @@ let find_idx p a = (Some (1,"c")) (find_idx ((=) "c") (make [| "a"; "b"; "c" |] 1 2)) *) -let lookup_exn ?(cmp=Pervasives.compare) k a = +let lookup_exn ~cmp k a = _lookup_exn ~cmp k a.arr a.i (a.j-1) - a.i -let lookup ?(cmp=Pervasives.compare) k a = +let lookup ~cmp k a = try Some (_lookup_exn ~cmp k a.arr a.i (a.j-1) - a.i) with Not_found -> None (*$= - (Some 1) (lookup "c" (make [| "a"; "b"; "c" |] 1 2)) + (Some 1) (lookup ~cmp:CCString.compare "c" (make [| "a"; "b"; "c" |] 1 2)) *) -let bsearch ?(cmp=Pervasives.compare) k a = +let bsearch ~cmp k a = match bsearch_ ~cmp k a.arr a.i (a.j - 1) with | `At m -> `At (m - a.i) | `Just_after m -> `Just_after (m - a.i) diff --git a/src/core/CCArray_slice.mli b/src/core/CCArray_slice.mli index 1a5989bc..577a3abe 100644 --- a/src/core/CCArray_slice.mli +++ b/src/core/CCArray_slice.mli @@ -12,7 +12,7 @@ type 'a random_gen = Random.State.t -> 'a type 'a printer = Format.formatter -> 'a -> unit type 'a t -(** Array slice, containing elements of type ['a] *) +(** Array slice, containing elements of type ['a]. *) val empty : 'a t @@ -21,64 +21,93 @@ val equal : 'a equal -> 'a t equal val compare : 'a ord -> 'a t ord val get : 'a t -> int -> 'a +(** [get a n] returns the element number [n] of array [a]. + The first element has number 0. + The last element has number [length a - 1]. + You can also write [a.(n)] instead of [get a n]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(length a - 1)]. *) val get_safe : 'a t -> int -> 'a option -(** [get_safe a i] returns [Some a.(i)] if [i] is a valid index +(** [get_safe a i] returns [Some a.(i)] if [i] is a valid index. @since 0.18 *) val make : 'a array -> int -> len:int -> 'a t -(** Create a slice from given offset and length.. - @raise Invalid_argument if the slice isn't valid *) +(** Create a slice from given offset and length. + @raise Invalid_argument if the slice isn't valid. *) val of_slice : ('a array * int * int) -> 'a t (** Make a sub-array from a triple [(arr, i, len)] where [arr] is the array, [i] the offset in [arr], and [len] the number of elements of the slice. - @raise Invalid_argument if the slice isn't valid (See {!make}) *) + @raise Invalid_argument if the slice isn't valid (See {!make}). *) val to_slice : 'a t -> ('a array * int * int) (** Convert into a triple [(arr, i, len)] where [len] is the length of - the subarray of [arr] starting at offset [i] *) + the sub-array of [arr] starting at offset [i]. *) val to_list : 'a t -> 'a list -(** Convert directly to a list +(** Convert directly to a list. @since 1.0 *) val full : 'a array -> 'a t -(** Slice that covers the full array *) +(** Slice that covers the full array. *) val underlying : 'a t -> 'a array -(** Underlying array (shared). Modifying this array will modify the slice *) +(** Underlying array (shared). Modifying this array will modify the slice. *) val copy : 'a t -> 'a array -(** Copy into a new array *) +(** Copy into a new array. *) val sub : 'a t -> int -> int -> 'a t -(** Sub-slice *) +(** Sub-slice. *) val set : 'a t -> int -> 'a -> unit +(** [set a n x] modifies array [a] in place, replacing + element number [n] with [x]. + You can also write [a.(n) <- x] instead of [set a n x]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [length a - 1]. *) val length : _ t -> int +(** Return the length (number of elements) of the given array. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a +(** [fold f x a] computes [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], + where [n] is the length of the array [a]. *) val foldi : ('a -> int -> 'b -> 'a) -> 'a -> 'b t -> 'a -(** Fold left on array, with index *) +(** Fold left on array, with index. *) val fold_while : ('a -> 'b -> 'a * [`Stop | `Continue]) -> 'a -> 'b t -> 'a (** Fold left on array until a stop condition via [('a, `Stop)] is - indicated by the accumulator + indicated by the accumulator. @since 0.8 *) val iter : ('a -> unit) -> 'a t -> unit +(** [iter f a] applies function [f] in turn to all + the elements of [a]. It is equivalent to + [f a.(0); f a.(1); ...; f a.(length a - 1); ()]. *) val iteri : (int -> 'a -> unit) -> 'a t -> unit +(** Same as {!Array.iter}, but the + function is applied with the index of the element as first argument, + and the element itself as second argument. *) val blit : 'a t -> int -> 'a t -> int -> int -> unit -(** [blit from i into j len] copies [len] elements from the first array - to the second. See {!Array.blit}. *) +(** [blit v1 o1 v2 o2 len] copies [len] elements + from array [v1], starting at element number [o1], to array [v2], + starting at element number [o2]. It works correctly even if + [v1] and [v2] are the same array, and the source and + destination chunks overlap. + + Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not + designate a valid subarray of [v1], or if [o2] and [len] do not + designate a valid subarray of [v2]. *) val reverse_in_place : 'a t -> unit -(** Reverse the array in place *) +(** Reverse the array in place. *) val sorted : ('a -> 'a -> int) -> 'a t -> 'a array (** [sorted cmp a] makes a copy of [a] and sorts it with [cmp]. @@ -86,12 +115,11 @@ val sorted : ('a -> 'a -> int) -> 'a t -> 'a array val sort_indices : ('a -> 'a -> int) -> 'a t -> int array (** [sort_indices cmp a] returns a new array [b], with the same length as [a], - such that [b.(i)] is the index at which the [i]-th element of [sorted cmp a] + such that [b.(i)] is the index at which the [i]-th element of [sorted cmp a] appears in [a]. [a] is not modified. - In other words, [map (fun i -> a.(i)) (sort_indices cmp a) = sorted cmp a]. + In other words, [map (fun i -> a.(i)) (sort_indices cmp a) = sorted cmp a]. [sort_indices] yields the inverse permutation of {!sort_ranking}. - @since 1.0 *) val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array @@ -99,16 +127,16 @@ val sort_ranking : ('a -> 'a -> int) -> 'a t -> int array such that [b.(i)] is the index at which the [i]-the element of [a] appears in [sorted cmp a]. [a] is not modified. - In other words, [map (fun i -> (sorted cmp a).(i)) (sort_ranking cmp a) = a]. + In other words, [map (fun i -> (sorted cmp a).(i)) (sort_ranking cmp a) = a]. [sort_ranking] yields the inverse permutation of {!sort_indices}. In the absence of duplicate elements in [a], we also have - [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)] + [lookup_exn a.(i) (sorted a) = (sorted_ranking a).(i)]. @since 1.0 *) val find : ('a -> 'b option) -> 'a t -> 'b option (** [find f a] returns [Some y] if there is an element [x] such - that [f x = Some y], else it returns [None] *) + that [f x = Some y], else it returns [None]. *) val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option (** Like {!find}, but also pass the index to the predicate function. @@ -116,19 +144,19 @@ val findi : (int -> 'a -> 'b option) -> 'a t -> 'b option val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option (** [find_idx p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], - and [p x] holds. Otherwise returns [None] + and [p x] holds. Otherwise returns [None]. @since 0.3.4 *) -val lookup : ?cmp:'a ord -> 'a -> 'a t -> int option +val lookup : cmp:'a ord -> 'a -> 'a t -> int option (** Lookup the index of some value in a sorted array. @return [None] if the key is not present, or - [Some i] ([i] the index of the key) otherwise *) + [Some i] ([i] the index of the key) otherwise. *) -val lookup_exn : ?cmp:'a ord -> 'a -> 'a t -> int +val lookup_exn : cmp:'a ord -> 'a -> 'a t -> int (** Same as {!lookup}, but - @raise Not_found if the key is not present *) + @raise Not_found if the key is not present. *) -val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t -> +val bsearch : cmp:('a -> 'a -> int) -> 'a -> 'a t -> [ `All_lower | `All_bigger | `Just_after of int | `Empty | `At of int ] (** [bsearch ?cmp x arr] finds the index of the object [x] in the array [arr], provided [arr] is {b sorted} using [cmp]. If the array is not sorted, @@ -148,38 +176,46 @@ val bsearch : ?cmp:('a -> 'a -> int) -> 'a -> 'a t -> @since 0.13 *) val for_all : ('a -> bool) -> 'a t -> bool +(** [for_all p [|a1; ...; an|]] checks if all elements of the array + satisfy the predicate [p]. That is, it returns + [(p a1) && (p a2) && ... && (p an)]. *) val for_all2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** Forall on pairs of arrays. @raise Invalid_argument if they have distinct lengths - allow different types @since 0.20 *) + allow different types. + @since 0.20 *) val exists : ('a -> bool) -> 'a t -> bool +(** [exists p [|a1; ...; an|]] checks if at least one element of + the array satisfies the predicate [p]. That is, it returns + [(p a1) || (p a2) || ... || (p an)]. *) val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** Exists on pairs of arrays. @raise Invalid_argument if they have distinct lengths - allow different types @since 0.20 *) + allow different types. + @since 0.20 *) val fold2 : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> 'a t -> 'b t -> 'acc (** Fold on two arrays stepwise. - @raise Invalid_argument if they have distinct lengths + @raise Invalid_argument if they have distinct lengths. @since 0.20 *) val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit (** Iterate on two arrays stepwise. - @raise Invalid_argument if they have distinct lengths + @raise Invalid_argument if they have distinct lengths. @since 0.20 *) val shuffle : 'a t -> unit -(** Shuffle randomly the array, in place *) +(** Shuffle randomly the array, in place. *) val shuffle_with : Random.State.t -> 'a t -> unit -(** Like shuffle but using a specialized random state *) +(** Like shuffle but using a specialized random state. *) val random_choose : 'a t -> 'a random_gen (** Choose an element randomly. - @raise Not_found if the array/slice is empty *) + @raise Not_found if the array/slice is empty. *) val to_seq : 'a t -> 'a sequence val to_gen : 'a t -> 'a gen @@ -188,7 +224,7 @@ val to_klist : 'a t -> 'a klist (** {2 IO} *) val pp: ?sep:string -> 'a printer -> 'a t printer -(** Print an array of items with printing function *) +(** Print an array of items with printing function. *) val pp_i: ?sep:string -> (int -> 'a printer) -> 'a t printer -(** Print an array, giving the printing function both index and item *) +(** Print an array, giving the printing function both index and item. *) diff --git a/src/core/CCBool.ml b/src/core/CCBool.ml index 087d0101..89a6a9e5 100644 --- a/src/core/CCBool.ml +++ b/src/core/CCBool.ml @@ -3,7 +3,7 @@ type t = bool -let equal (a:bool) b = a=b +let equal (a:bool) b = Pervasives.(=) a b let compare (a:bool) b = Pervasives.compare a b diff --git a/src/core/CCChar.ml b/src/core/CCChar.ml index 55900bd6..68d45cad 100644 --- a/src/core/CCChar.ml +++ b/src/core/CCChar.ml @@ -6,7 +6,7 @@ include Char -let equal (a:char) b = a=b +let equal (a:char) b = Pervasives.(=) a b let pp = Buffer.add_char let print = Format.pp_print_char @@ -15,12 +15,10 @@ let of_int_exn = Char.chr let of_int c = try Some (of_int_exn c) with _ -> None let to_int = Char.code -let lowercase_ascii c = - if c >= 'A' && c <= 'Z' - then Char.unsafe_chr (Char. code c + 32) - else c +let lowercase_ascii = function + | 'A'..'Z' as c -> Char.unsafe_chr (Char.code c + 32) + | c -> c -let uppercase_ascii c = - if c >= 'a' && c <= 'z' - then Char.unsafe_chr (Char.code c - 32) - else c +let uppercase_ascii = function + | 'a'..'z' as c -> Char.unsafe_chr (Char.code c - 32) + | c -> c diff --git a/src/core/CCChar.mli b/src/core/CCChar.mli index 2100a900..b030d8bf 100644 --- a/src/core/CCChar.mli +++ b/src/core/CCChar.mli @@ -7,27 +7,37 @@ include module type of Char val equal : t -> t -> bool +(** The equal function for chars. *) + val compare : t -> t -> int +(** The comparison function for characters, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [Char] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) val lowercase_ascii : t -> t -(** See {!Char} +(** Convert the given character to its equivalent lowercase character, + using the US-ASCII character set. @since 0.20 *) val uppercase_ascii : t -> t -(** See {!Char} +(** Convert the given character to its equivalent uppercase character, + using the US-ASCII character set. @since 0.20 *) val of_int_exn : int -> t -(** Alias to {!Char.chr} - @raise Invalid_argument if the int is not within [0,...,255] +(** Alias to {!Char.chr}. + Return the character with the given ASCII code. + @raise Invalid_argument if the int is not within [0,...,255]. @since 1.0 *) val of_int : int -> t option -(** Safe version of {!of_int} +(** Safe version of {!of_int_exn}. @since 1.0 *) val to_int : t -> int -(** Alias to {!Char.code} +(** Alias to {!Char.code}. + Return the ASCII code of the argument. @since 1.0 *) val pp : Buffer.t -> t -> unit diff --git a/src/core/CCEqual.ml b/src/core/CCEqual.ml index f879bd05..13ee4d79 100644 --- a/src/core/CCEqual.ml +++ b/src/core/CCEqual.ml @@ -5,12 +5,13 @@ type 'a t = 'a -> 'a -> bool -let poly = (=) +let poly = Pervasives.(=) +let physical = Pervasives.(==) let int : int t = (=) -let string : string t = (=) -let bool : bool t = (=) -let float : float t = (=) +let string : string t = Pervasives.(=) +let bool : bool t = Pervasives.(=) +let float : float t = Pervasives.(=) let unit () () = true let rec list f l1 l2 = match l1, l2 with diff --git a/src/core/CCEqual.mli b/src/core/CCEqual.mli index 94230bfa..efcbc3ea 100644 --- a/src/core/CCEqual.mli +++ b/src/core/CCEqual.mli @@ -11,6 +11,10 @@ type 'a t = 'a -> 'a -> bool val poly : 'a t (** Standard polymorphic equality *) +val physical : 'a t +(** Standard physical equality + @since NEXT_RELEASE *) + val int : int t val string : string t val bool : bool t diff --git a/src/core/CCFloat.ml b/src/core/CCFloat.ml index 2e7fcc41..cb4062b9 100644 --- a/src/core/CCFloat.ml +++ b/src/core/CCFloat.ml @@ -9,6 +9,16 @@ type fpclass = Pervasives.fpclass = | FP_infinite | FP_nan +module Infix = struct + let (=) = Pervasives.(=) + let (<>) = Pervasives.(<>) + let (<) = Pervasives.(<) + let (>) = Pervasives.(>) + let (<=) = Pervasives.(<=) + let (>=) = Pervasives.(>=) +end +include Infix + let nan = Pervasives.nan let infinity = Pervasives.infinity @@ -84,13 +94,3 @@ let random_range i j st = i +. random (j-.i) st let equal_precision ~epsilon a b = abs_float (a-.b) < epsilon let classify = Pervasives.classify_float - -module Infix = struct - let (=) = Pervasives.(=) - let (<>) = Pervasives.(<>) - let (<) = Pervasives.(<) - let (>) = Pervasives.(>) - let (<=) = Pervasives.(<=) - let (>=) = Pervasives.(>=) -end -include Infix diff --git a/src/core/CCFormat.mli b/src/core/CCFormat.mli index 3af46e8d..d84c1719 100644 --- a/src/core/CCFormat.mli +++ b/src/core/CCFormat.mli @@ -7,11 +7,10 @@ type 'a sequence = ('a -> unit) -> unit -include module type of Format - with type formatter = Format.formatter - and type formatter_out_functions = Format.formatter_out_functions - and type formatter_tag_functions = Format.formatter_tag_functions - +(* include Format, and alias all its types. + see https://discuss.ocaml.org/t/extend-existing-module/1389/4 +*) +include module type of struct include Format end type t = Format.formatter type 'a printer = t -> 'a -> unit diff --git a/src/core/CCHashtbl.ml b/src/core/CCHashtbl.ml index 28634e43..00750e7b 100644 --- a/src/core/CCHashtbl.ml +++ b/src/core/CCHashtbl.ml @@ -124,7 +124,7 @@ module Poly = struct () *) - let print pp_k pp_v fmt m = + let pp pp_k pp_v fmt m = Format.fprintf fmt "@[tbl {@,"; let first = ref true in Hashtbl.iter @@ -232,9 +232,10 @@ module type S = sig to [tbl] and [v] is returned. @since 1.0 *) - val print : key printer -> 'a printer -> 'a t printer - (** Printer for tables - @since 0.13 *) + val pp : key printer -> 'a printer -> 'a t printer + (** Printer for table + @since 0.13 + Renamed from [print] @since NEXT_RELEASE *) end (*$inject @@ -344,7 +345,7 @@ module Make(X : Hashtbl.HashedType) List.iter (fun (k,v) -> add tbl k v) l; tbl - let print pp_k pp_v fmt m = + let pp pp_k pp_v fmt m = Format.fprintf fmt "@[tbl {@,"; let first = ref true in iter diff --git a/src/core/CCHashtbl.mli b/src/core/CCHashtbl.mli index 127893d8..223f8e28 100644 --- a/src/core/CCHashtbl.mli +++ b/src/core/CCHashtbl.mli @@ -102,9 +102,10 @@ module Poly : sig to [tbl] and [v] is returned. @since 1.0 *) - val print : 'a printer -> 'b printer -> ('a, 'b) Hashtbl.t printer + val pp : 'a printer -> 'b printer -> ('a, 'b) Hashtbl.t printer (** Printer for table - @since 0.13 *) + @since 0.13 + Renamed from [print] @since NEXT_RELEASE *) end include module type of Poly @@ -201,9 +202,10 @@ module type S = sig to [tbl] and [v] is returned. @since 1.0 *) - val print : key printer -> 'a printer -> 'a t printer + val pp : key printer -> 'a printer -> 'a t printer (** Printer for tables - @since 0.13 *) + @since 0.13 + Renamed from {!print} @since NEXT_RELEASE *) end module Make(X : Hashtbl.HashedType) : diff --git a/src/core/CCInt.ml b/src/core/CCInt.ml index eb37fccc..cc87f080 100644 --- a/src/core/CCInt.ml +++ b/src/core/CCInt.ml @@ -5,7 +5,7 @@ type t = int let equal (a:int) b = a=b -let compare (a:int) b = Pervasives.compare a b +let compare a b = compare a b let hash i = i land max_int @@ -75,9 +75,11 @@ let floor_div a n = (fun (n, m) -> floor_div n (-m) = int_of_float @@ floor (float n /. float (-m))) *) +let bool_neq (a : bool) b = Pervasives.(<>) a b + let rem a n = let y = a mod n in - if (y < 0) <> (n < 0) && y <> 0 then + if bool_neq (y < 0) (n < 0) && y <> 0 then y + n else y @@ -245,12 +247,12 @@ let range' i j yield = module Infix = struct - let (=) = Pervasives.(=) - let (<>) = Pervasives.(<>) - let (<) = Pervasives.(<) - let (>) = Pervasives.(>) - let (<=) = Pervasives.(<=) - let (>=) = Pervasives.(>=) + let (=) = (=) + let (<>) = (<>) + let (<) = (<) + let (>) = (>) + let (<=) = (<=) + let (>=) = (>=) let (--) = range let (--^) = range' end diff --git a/src/core/CCInt64.ml b/src/core/CCInt64.ml index f9ab3841..9ac33506 100644 --- a/src/core/CCInt64.ml +++ b/src/core/CCInt64.ml @@ -28,7 +28,7 @@ let (lsr) = shift_right_logical let (asr) = shift_right -let equal (x:t) y = x=y +let equal (x:t) y = Pervasives.(=) x y let hash x = Pervasives.abs (to_int x) diff --git a/src/core/CCInt64.mli b/src/core/CCInt64.mli index fbec7199..93e285b9 100644 --- a/src/core/CCInt64.mli +++ b/src/core/CCInt64.mli @@ -9,79 +9,159 @@ type t = int64 val (+) : t -> t -> t +(** Addition. *) val (-) : t -> t -> t +(** Subtraction. *) val (~-) : t -> t +(** Unary negation. *) val ( * ) : t -> t -> t +(** Multiplication. *) val (/) : t -> t -> t +(** Integer division. Raise [Division_by_zero] if the second + argument is zero. This division rounds the real quotient of + its arguments towards zero, as specified for {!Pervasives.(/)}. *) val (mod) : t -> t -> t +(** Integer remainder. + If [y = 0], [x mod y] raises [Division_by_zero]. *) val abs : t -> t +(** Return the absolute value of its argument. *) val max_int : t +(** The greatest representable 64-bit integer, 2{^63} - 1. *) val min_int : t +(** The smallest representable 64-bit integer, -2{^63}. *) val (land) : t -> t -> t +(** Bitwise logical and. *) val (lor) : t -> t -> t +(** Bitwise logical or. *) val (lxor) : t -> t -> t +(** Bitwise logical exclusive or. *) val lnot : t -> t +(** Bitwise logical negation. *) val (lsl) : t -> int -> t +(** [ x lsl y] shifts [x] to the left by [y] bits. + The result is unspecified if [y < 0] or [y >= 64]. *) val (lsr) : t -> int -> t +(** [x lsr y] shifts [x] to the right by [y] bits. + This is a logical shift: zeroes are inserted in the vacated bits + regardless of the sign of [x]. + The result is unspecified if [y < 0] or [y >= 64]. *) val (asr) : t -> int -> t +(** [x asr y] shifts [x] to the right by [y] bits. + This is an arithmetic shift: the sign bit of [x] is replicated + and inserted in the vacated bits. + The result is unspecified if [y < 0] or [y >= 64]. *) val equal : t -> t -> bool +(** The equal function for int64s. + Same as {!Pervasives.(=) x y)}. *) val compare : t -> t -> int +(** The comparison function for 64-bit integers, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [CCInt64] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) val hash : t -> int +(** Same as {!Pervasives.abs (to_int x)}. *) (** {2 Conversion} *) val to_int : t -> int +(** Convert the given 64-bit integer (type [int64]) to an + integer (type [int]). On 64-bit platforms, the 64-bit integer + is taken modulo 2{^63}, i.e. the high-order bit is lost + during the conversion. On 32-bit platforms, the 64-bit integer + is taken modulo 2{^31}, i.e. the top 33 bits are lost + during the conversion. *) val of_int : int -> t option +(** Safe version of {!of_int_exn}. *) val of_int_exn : int -> t -(** Alias to {!Int64.of_int} - @raise Failure in case of failure *) +(** Alias to {!Int64.of_int}. + Convert the given integer (type [int]) to a 64-bit integer + (type [int64]). + @raise Failure in case of failure. *) val to_int32 : t -> int32 +(** Convert the given 64-bit integer (type [int64]) to a + 32-bit integer (type [int32]). The 64-bit integer + is taken modulo 2{^32}, i.e. the top 32 bits are lost + during the conversion. *) val of_int32 : int32 -> t option +(** Safe version of {!of_int32_exn}. *) val of_int32_exn : int32 -> t (** Alias to {!Int64.of_int32} - @raise Failure in case of failure *) + Convert the given 32-bit integer (type [int32]) + to a 64-bit integer (type [int64]). + @raise Failure in case of failure. *) val to_nativeint : t -> nativeint +(** Convert the given 64-bit integer (type [int64]) to a + native integer. On 32-bit platforms, the 64-bit integer + is taken modulo 2{^32}. On 64-bit platforms, + the conversion is exact. *) val of_nativeint : nativeint -> t option +(** Safe version of {!of_nativeint_exn}. *) val of_nativeint_exn : nativeint -> t -(** Alias to {!Int64.of_nativeint} - @raise Failure in case of failure *) +(** Alias to {!Int64.of_nativeint}. + Convert the given native integer (type [nativeint]) + to a 64-bit integer (type [int64]). + @raise Failure in case of failure. *) val to_float : t -> float +(** Convert the given 64-bit integer to a floating-point number. *) val of_float : float -> t option +(** Safe version of {!of_float_exn}. *) val of_float_exn : float -> t -(** Alias to {!Int64.of_float} - @raise Failure in case of failure *) +(** Alias to {!Int64.of_float}. + Convert the given floating-point number to a 64-bit integer, + discarding the fractional part (truncate towards 0). + The result of the conversion is undefined if, after truncation, + the number is outside the range \[{!CCInt64.min_int}, {!CCInt64.max_int}\]. + @raise Failure in case of failure. *) val to_string : t -> string +(** Return the string representation of its argument, in decimal. *) val of_string : string -> t option +(** Safe version of {!of_string_exn}. *) val of_string_exn : string -> t +(** Alias to {!Int64.of_string}. + Convert the given string to a 64-bit integer. + The string is read in decimal (by default, or if the string + begins with [0u]) or in hexadecimal, octal or binary if the + string begins with [0x], [0o] or [0b] respectively. + + The [0u] prefix reads the input as an unsigned integer in the range + [[0, 2*CCInt64.max_int+1]]. If the input exceeds {!CCInt64.max_int} + it is converted to the signed integer + [CCInt64.min_int + input - CCInt64.max_int - 1]. + + The [_] (underscore) character can appear anywhere in the string + and is ignored. + Raise [Failure "Int64.of_string"] if the given string is not + a valid representation of an integer, or if the integer represented + exceeds the range of integers representable in type [int64]. *) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index 601fb06d..064070d8 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -1,7 +1,7 @@ (* This file is free software, part of containers. See file "license" for more details. *) -(** {1 complements to list} *) +(** {1 Complements to list} *) (*$inject let lsort l = List.sort Pervasives.compare l @@ -557,7 +557,7 @@ let map_product_l f l = cmp_lii_unord (cartesian_product l) (map_product_l CCFun.id l)) *) -let sorted_merge ?(cmp=Pervasives.compare) l1 l2 = +let sorted_merge ~cmp l1 l2 = let rec recurse cmp acc l1 l2 = match l1,l2 with | [], _ -> List.rev_append acc l2 | _, [] -> List.rev_append acc l1 @@ -570,17 +570,17 @@ let sorted_merge ?(cmp=Pervasives.compare) l1 l2 = recurse cmp [] l1 l2 (*$T - List.sort Pervasives.compare ([(( * )2); ((+)1)] <*> [10;100]) \ - = [11; 20; 101; 200] - sorted_merge [1;1;2] [1;2;3] = [1;1;1;2;2;3] + equal CCInt.equal (List.sort CCInt.compare ([(( * )2); ((+)1)] <*> [10;100])) \ + [11; 20; 101; 200] + equal CCInt.equal (sorted_merge ~cmp:CCInt.compare [1;1;2] [1;2;3]) [1;1;1;2;2;3] *) (*$Q Q.(pair (list int) (list int)) (fun (l1,l2) -> \ - List.length (sorted_merge l1 l2) = List.length l1 + List.length l2) + List.length (sorted_merge ~cmp:CCInt.compare l1 l2) = List.length l1 + List.length l2) *) -let sort_uniq (type elt) ?(cmp=Pervasives.compare) l = +let sort_uniq (type elt) ~cmp l = let module S = Set.Make(struct type t = elt let compare = cmp @@ -589,12 +589,12 @@ let sort_uniq (type elt) ?(cmp=Pervasives.compare) l = S.elements set (*$T - sort_uniq [1;2;5;3;6;1;4;2;3] = [1;2;3;4;5;6] - sort_uniq [] = [] - sort_uniq [10;10;10;10;1;10] = [1;10] + sort_uniq ~cmp:CCInt.compare [1;2;5;3;6;1;4;2;3] = [1;2;3;4;5;6] + sort_uniq ~cmp:CCInt.compare [] = [] + sort_uniq ~cmp:CCInt.compare [10;10;10;10;1;10] = [1;10] *) -let is_sorted ?(cmp=Pervasives.compare) l = +let is_sorted ~cmp l = let rec aux cmp = function | [] | [_] -> true | x :: ((y :: _) as tail) -> cmp x y <= 0 && aux cmp tail @@ -603,10 +603,10 @@ let is_sorted ?(cmp=Pervasives.compare) l = (*$Q Q.(list small_int) (fun l -> \ - is_sorted (List.sort Pervasives.compare l)) + is_sorted ~cmp:CCInt.compare (List.sort Pervasives.compare l)) *) -let sorted_insert ?(cmp=Pervasives.compare) ?(uniq=false) x l = +let sorted_insert ~cmp ?(uniq=false) x l = let rec aux cmp uniq x left l = match l with | [] -> List.rev_append left [x] | y :: tail -> @@ -622,20 +622,20 @@ let sorted_insert ?(cmp=Pervasives.compare) ?(uniq=false) x l = (*$Q Q.(pair small_int (list small_int)) (fun (x,l) -> \ let l = List.sort Pervasives.compare l in \ - is_sorted (sorted_insert ~uniq:true x l)) + is_sorted ~cmp:CCInt.compare (sorted_insert ~cmp:CCInt.compare ~uniq:true x l)) Q.(pair small_int (list small_int)) (fun (x,l) -> \ let l = List.sort Pervasives.compare l in \ - is_sorted (sorted_insert ~uniq:false x l)) + is_sorted ~cmp:CCInt.compare (sorted_insert ~cmp:CCInt.compare ~uniq:false x l)) Q.(pair small_int (list small_int)) (fun (x,l) -> \ let l = List.sort Pervasives.compare l in \ - let l' = sorted_insert ~uniq:false x l in \ + let l' = sorted_insert ~cmp:CCInt.compare ~uniq:false x l in \ List.length l' = List.length l + 1) Q.(pair small_int (list small_int)) (fun (x,l) -> \ let l = List.sort Pervasives.compare l in \ - List.mem x (sorted_insert x l)) + List.mem x (sorted_insert ~cmp:CCInt.compare x l)) *) -let uniq_succ ?(eq=(=)) l = +let uniq_succ ~eq l = let rec f acc l = match l with | [] -> List.rev acc | [x] -> List.rev (x::acc) @@ -645,10 +645,10 @@ let uniq_succ ?(eq=(=)) l = f [] l (*$T - uniq_succ [1;1;2;3;1;6;6;4;6;1] = [1;2;3;1;6;4;6;1] + uniq_succ ~eq:CCInt.equal [1;1;2;3;1;6;6;4;6;1] = [1;2;3;1;6;4;6;1] *) -let group_succ ?(eq=(=)) l = +let group_succ ~eq l = let rec f ~eq acc cur l = match cur, l with | [], [] -> List.rev acc | _::_, [] -> List.rev (List.rev cur :: acc) @@ -659,15 +659,15 @@ let group_succ ?(eq=(=)) l = f ~eq [] [] l (*$T - group_succ [1;2;3;1;1;2;4] = [[1]; [2]; [3]; [1;1]; [2]; [4]] - group_succ [] = [] - group_succ [1;1;1] = [[1;1;1]] - group_succ [1;2;2;2] = [[1]; [2;2;2]] + group_succ ~eq:CCInt.equal [1;2;3;1;1;2;4] = [[1]; [2]; [3]; [1;1]; [2]; [4]] + group_succ ~eq:CCInt.equal [] = [] + group_succ ~eq:CCInt.equal [1;1;1] = [[1;1;1]] + group_succ ~eq:CCInt.equal [1;2;2;2] = [[1]; [2;2;2]] group_succ ~eq:(fun (x,_)(y,_)-> x=y) [1, 1; 1, 2; 1, 3; 2, 0] \ = [[1, 1; 1, 2; 1, 3]; [2, 0]] *) -let sorted_merge_uniq ?(cmp=Pervasives.compare) l1 l2 = +let sorted_merge_uniq ~cmp l1 l2 = let push ~cmp acc x = match acc with | [] -> [x] | y :: _ when cmp x y > 0 -> x :: acc @@ -687,21 +687,21 @@ let sorted_merge_uniq ?(cmp=Pervasives.compare) l1 l2 = recurse ~cmp [] l1 l2 (*$T - sorted_merge_uniq [1; 1; 2; 3; 5; 8] [1; 2; 3; 4; 6; 8; 9; 9] = [1;2;3;4;5;6;8;9] + sorted_merge_uniq ~cmp:CCInt.compare [1; 1; 2; 3; 5; 8] [1; 2; 3; 4; 6; 8; 9; 9] = [1;2;3;4;5;6;8;9] *) (*$Q Q.(list int) (fun l -> \ let l = List.sort Pervasives.compare l in \ - sorted_merge_uniq l [] = uniq_succ l) + sorted_merge_uniq ~cmp:CCInt.compare l [] = uniq_succ ~eq:CCInt.equal l) Q.(list int) (fun l -> \ let l = List.sort Pervasives.compare l in \ - sorted_merge_uniq [] l = uniq_succ l) + sorted_merge_uniq ~cmp:CCInt.compare [] l = uniq_succ ~eq:CCInt.equal l) Q.(pair (list int) (list int)) (fun (l1, l2) -> \ let l1 = List.sort Pervasives.compare l1 \ and l2 = List.sort Pervasives.compare l2 in \ - let l3 = sorted_merge_uniq l1 l2 in \ - uniq_succ l3 = l3) + let l3 = sorted_merge_uniq ~cmp:CCInt.compare l1 l2 in \ + uniq_succ ~eq:CCInt.equal l3 = l3) *) let take n l = @@ -766,7 +766,7 @@ let sublists_of_len ?(last=fun _ -> None) ?offset n l = (* add sub-lists of [l] to [acc] *) let rec aux acc l = let group = take n l in - if group=[] then acc (* this was the last group, we are done *) + if is_empty group then acc (* this was the last group, we are done *) else if List.length group < n (* last group, with missing elements *) then match last group with | None -> acc @@ -900,7 +900,7 @@ let find_idx p l = find_mapi (fun i x -> if p x then Some (i, x) else None) l find_map (fun x -> if x=3 then Some "a" else None) [1;2;4;5] = None *) -let remove ?(eq=(=)) ~x l = +let remove ~eq ~x l = let rec remove' eq x acc l = match l with | [] -> List.rev acc | y :: tail when eq x y -> remove' eq x acc tail @@ -909,8 +909,8 @@ let remove ?(eq=(=)) ~x l = remove' eq x [] l (*$T - remove ~x:1 [2;1;3;3;2;1] = [2;3;3;2] - remove ~x:10 [1;2;3] = [1;2;3] + remove ~eq:CCInt.equal ~x:1 [2;1;3;3;2;1] = [2;3;3;2] + remove ~eq:CCInt.equal ~x:10 [1;2;3] = [1;2;3] *) let filter_map f l = @@ -972,16 +972,16 @@ let all_ok l = (Error "e2") (all_ok [Ok 1; Error "e2"; Error "e3"; Ok 4]) *) -let mem ?(eq=(=)) x l = +let mem ~eq x l = let rec search eq x l = match l with | [] -> false | y::l' -> eq x y || search eq x l' in search eq x l -let add_nodup ?(eq=(=)) x l = +let add_nodup ~eq x l = if mem ~eq x l then l else x::l -let remove_one ?(eq=(=)) x l = +let remove_one ~eq x l = let rec remove_one ~eq x acc l = match l with | [] -> assert false | y :: tl when eq x y -> List.rev_append acc tl @@ -991,19 +991,19 @@ let remove_one ?(eq=(=)) x l = (*$Q Q.(pair int (list int)) (fun (x,l) -> \ - remove_one x (add_nodup x l) = l) + remove_one ~eq:CCInt.equal x (add_nodup ~eq:CCInt.equal x l) = l) Q.(pair int (list int)) (fun (x,l) -> \ - mem x l || List.length (add_nodup x l) = List.length l + 1) + mem ~eq:CCInt.equal x l || List.length (add_nodup ~eq:CCInt.equal x l) = List.length l + 1) Q.(pair int (list int)) (fun (x,l) -> \ - not (mem x l) || List.length (remove_one x l) = List.length l - 1) + not (mem ~eq:CCInt.equal x l) || List.length (remove_one ~eq:CCInt.equal x l) = List.length l - 1) *) -let subset ?(eq=(=)) l1 l2 = +let subset ~eq l1 l2 = List.for_all (fun t -> mem ~eq t l2) l1 -let uniq ?(eq=(=)) l = +let uniq ~eq l = let rec uniq eq acc l = match l with | [] -> List.rev acc | x::xs when List.exists (eq x) xs -> uniq eq acc xs @@ -1011,15 +1011,15 @@ let uniq ?(eq=(=)) l = in uniq eq [] l (*$T - uniq [1;1;2;2;3;4;4;2;4;1;5] |> List.sort Pervasives.compare = [1;2;3;4;5] + uniq ~eq:CCInt.equal [1;1;2;2;3;4;4;2;4;1;5] |> List.sort Pervasives.compare = [1;2;3;4;5] *) (*$Q Q.(small_list small_int) (fun l -> \ - sort_uniq l = (uniq l |> sort Pervasives.compare)) - *) + sort_uniq ~cmp:CCInt.compare l = (uniq ~eq:CCInt.equal l |> sort Pervasives.compare)) +*) -let union ?(eq=(=)) l1 l2 = +let union ~eq l1 l2 = let rec union eq acc l1 l2 = match l1 with | [] -> List.rev_append acc l2 | x::xs when mem ~eq x l2 -> union eq acc xs l2 @@ -1027,10 +1027,10 @@ let union ?(eq=(=)) l1 l2 = in union eq [] l1 l2 (*$T - union [1;2;4] [2;3;4;5] = [1;2;3;4;5] + union ~eq:CCInt.equal [1;2;4] [2;3;4;5] = [1;2;3;4;5] *) -let inter ?(eq=(=)) l1 l2 = +let inter ~eq l1 l2 = let rec inter eq acc l1 l2 = match l1 with | [] -> List.rev acc | x::xs when mem ~eq x l2 -> inter eq (x::acc) xs l2 @@ -1038,7 +1038,7 @@ let inter ?(eq=(=)) l1 l2 = in inter eq [] l1 l2 (*$T - inter [1;2;4] [2;3;4;5] = [2;4] + inter ~eq:CCInt.equal [1;2;4] [2;3;4;5] = [2;4] *) let mapi f l = @@ -1059,6 +1059,16 @@ let iteri f l = | x::l' -> f i x; aux f (i+1) l' in aux f 0 l +let iteri2 f l1 l2 = + let rec aux f i l1 l2 = match l1, l2 with + | [], [] -> () + | [], _ + | _, [] -> invalid_arg "iteri2" + | x1::l1', x2::l2' -> + f i x1 x2; + aux f (i+1) l1' l2' + in aux f 0 l1 l2 + let foldi f acc l = let rec foldi f acc i l = match l with | [] -> acc @@ -1068,6 +1078,17 @@ let foldi f acc l = in foldi f acc 0 l +let foldi2 f acc l1 l2 = + let rec foldi f acc i l1 l2 = match l1, l2 with + | [], [] -> acc + | [], _ + | _, [] -> invalid_arg "foldi2" + | x1::l1', x2::l2' -> + let acc = f acc i x1 x2 in + foldi f acc (i+1) l1' l2' + in + foldi f acc 0 l1 l2 + let rec get_at_idx_rec i l = match l with | [] -> raise Not_found | x::_ when i=0 -> x @@ -1236,17 +1257,17 @@ module Assoc = struct | (y,z)::l' -> if eq x y then z else search_exn eq l' x - let get_exn ?(eq=(=)) x l = search_exn eq l x + let get_exn ~eq x l = search_exn eq l x - let get ?(eq=(=)) x l = + let get ~eq x l = try Some (search_exn eq l x) with Not_found -> None (*$T - Assoc.get 1 [1, "1"; 2, "2"] = Some "1" - Assoc.get 2 [1, "1"; 2, "2"] = Some "2" - Assoc.get 3 [1, "1"; 2, "2"] = None - Assoc.get 42 [] = None + Assoc.get ~eq:CCInt.equal 1 [1, "1"; 2, "2"] = Some "1" + Assoc.get ~eq:CCInt.equal 2 [1, "1"; 2, "2"] = Some "2" + Assoc.get ~eq:CCInt.equal 3 [1, "1"; 2, "2"] = None + Assoc.get ~eq:CCInt.equal 42 [] = None *) (* search for a binding for [x] in [l], and calls [f x (Some v) rest] @@ -1259,27 +1280,27 @@ module Assoc = struct then f x (Some y') (List.rev_append acc l') else search_set eq ((x',y')::acc) l' x ~f - let set ?(eq=(=)) x y l = + let set ~eq x y l = search_set eq [] l x ~f:(fun x _ l -> (x,y)::l) (*$T - Assoc.set 2 "two" [1,"1"; 2, "2"] |> List.sort Pervasives.compare \ + Assoc.set ~eq:CCInt.equal 2 "two" [1,"1"; 2, "2"] |> List.sort Pervasives.compare \ = [1, "1"; 2, "two"] - Assoc.set 3 "3" [1,"1"; 2, "2"] |> List.sort Pervasives.compare \ + Assoc.set ~eq:CCInt.equal 3 "3" [1,"1"; 2, "2"] |> List.sort Pervasives.compare \ = [1, "1"; 2, "2"; 3, "3"] *) - let mem ?(eq=(=)) x l = + let mem ~eq x l = try ignore (search_exn eq l x); true with Not_found -> false (*$T - Assoc.mem 1 [1,"1"; 2,"2"; 3, "3"] - not (Assoc.mem 4 [1,"1"; 2,"2"; 3, "3"]) + Assoc.mem ~eq:CCInt.equal 1 [1,"1"; 2,"2"; 3, "3"] + not (Assoc.mem ~eq:CCInt.equal 4 [1,"1"; 2,"2"; 3, "3"]) *) - let update ?(eq=(=)) ~f x l = + let update ~eq ~f x l = search_set eq [] l x ~f:(fun x opt_y rest -> match f opt_y with @@ -1287,17 +1308,17 @@ module Assoc = struct | Some y' -> (x,y') :: rest) (*$= [1,"1"; 2,"22"] \ - (Assoc.update 2 [1,"1"; 2,"2"] \ + (Assoc.update ~eq:CCInt.equal 2 [1,"1"; 2,"2"] \ ~f:(function Some "2" -> Some "22" | _ -> assert false) |> lsort) [1,"1"; 3,"3"] \ - (Assoc.update 2 [1,"1"; 2,"2"; 3,"3"] \ + (Assoc.update ~eq:CCInt.equal 2 [1,"1"; 2,"2"; 3,"3"] \ ~f:(function Some "2" -> None | _ -> assert false) |> lsort) [1,"1"; 2,"2"; 3,"3"] \ - (Assoc.update 3 [1,"1"; 2,"2"] \ + (Assoc.update ~eq:CCInt.equal 3 [1,"1"; 2,"2"] \ ~f:(function None -> Some "3" | _ -> assert false) |> lsort) *) - let remove ?(eq=(=)) x l = + let remove ~eq x l = search_set eq [] l x ~f:(fun _ opt_y rest -> match opt_y with | None -> l (* keep as is *) @@ -1305,14 +1326,19 @@ module Assoc = struct (*$= [1,"1"] \ - (Assoc.remove 2 [1,"1"; 2,"2"] |> lsort) + (Assoc.remove ~eq:CCInt.equal 2 [1,"1"; 2,"2"] |> lsort) [1,"1"; 3,"3"] \ - (Assoc.remove 2 [1,"1"; 2,"2"; 3,"3"] |> lsort) + (Assoc.remove ~eq:CCInt.equal 2 [1,"1"; 2,"2"; 3,"3"] |> lsort) [1,"1"; 2,"2"] \ - (Assoc.remove 3 [1,"1"; 2,"2"] |> lsort) + (Assoc.remove ~eq:CCInt.equal 3 [1,"1"; 2,"2"] |> lsort) *) end +let assoc = Assoc.get_exn +let assoc_opt = Assoc.get +let mem_assoc = Assoc.mem +let remove_assoc = Assoc.remove + (** {2 References on Lists} *) module Ref = struct diff --git a/src/core/CCList.mli b/src/core/CCList.mli index c6fe1af1..d0a85896 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -1,7 +1,7 @@ (* This file is free software, part of containers. See file "license" for more details. *) -(** {1 complements to list} *) +(** {1 Complements to list} *) type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option @@ -16,39 +16,47 @@ type 'a t = 'a list val empty : 'a t val is_empty : _ t -> bool -(** [is_empty l] returns [true] iff [l = []] +(** [is_empty l] returns [true] iff [l = []]. @since 0.11 *) val map : ('a -> 'b) -> 'a t -> 'b t -(** Safe version of map *) +(** Safe version of {!List.map}. *) val (>|=) : 'a t -> ('a -> 'b) -> 'b t -(** Infix version of [map] with reversed arguments +(** Infix version of [map] with reversed arguments. @since 0.5 *) val cons : 'a -> 'a t -> 'a t -(** [cons x l] is [x::l] +(** [cons x l] is [x::l]. @since 0.12 *) val append : 'a t -> 'a t -> 'a t -(** Safe version of append *) +(** Safe version of {!List.append}. + Concatenate two lists. *) val cons_maybe : 'a option -> 'a t -> 'a t -(** [cons_maybe (Some x) l] is [x :: l] - [cons_maybe None l] is [l] +(** [cons_maybe (Some x) l] is [x :: l]. + [cons_maybe None l] is [l]. @since 0.13 *) val (@) : 'a t -> 'a t -> 'a t +(** Same as [append]. + Concatenate two lists. *) val filter : ('a -> bool) -> 'a t -> 'a t -(** Safe version of {!List.filter} *) +(** Safe version of {!List.filter}. + [filter p l] returns all the elements of the list [l] + that satisfy the predicate [p]. The order of the elements + in the input list is preserved. *) val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b -(** Safe version of [fold_right] *) +(** Safe version of [fold_right]. + [fold_right f [a1; ...; an] b] is + [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *) val fold_while : ('a -> 'b -> 'a * [`Stop | `Continue]) -> 'a -> 'b t -> 'a (** Fold until a stop condition via [('a, `Stop)] is - indicated by the accumulator + indicated by the accumulator. @since 0.8 *) val fold_map : ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list @@ -57,35 +65,39 @@ val fold_map : ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list @since 0.14 *) val scan_left : ('acc -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc list -(** [scan_left f acc l] returns the list [[acc; f acc x0; f (f acc x0) x1; ā€¦]] - where [x0], [x1], etc. are the elements of [l] +(** [scan_left f acc l] returns the list [[acc; f acc x0; f (f acc x0) x1; ...]] + where [x0], [x1], etc. are the elements of [l]. @since 1.2 *) val fold_map2 : ('acc -> 'a -> 'b -> 'acc * 'c) -> 'acc -> 'a list -> 'b list -> 'acc * 'c list (** [fold_map2] is to [fold_map] what [List.map2] is to [List.map]. - @raise Invalid_argument if the lists do not have the same length + @raise Invalid_argument if the lists do not have the same length. @since 0.16 *) val fold_filter_map : ('acc -> 'a -> 'acc * 'b option) -> 'acc -> 'a list -> 'acc * 'b list (** [fold_filter_map f acc l] is a [fold_left]-like function, but also - generates a list of output in a way similar to {!filter_map} + generates a list of output in a way similar to {!filter_map}. @since 0.17 *) val fold_flat_map : ('acc -> 'a -> 'acc * 'b list) -> 'acc -> 'a list -> 'acc * 'b list (** [fold_flat_map f acc l] is a [fold_left]-like function, but it also maps the - list to a list of lists that is then [flatten]'d.. + list to a list of lists that is then [flatten]'d. @since 0.14 *) val count : ('a -> bool) -> 'a list -> int -(** [count f l] counts how much element of [l] comply with the function [f]. +(** [count f l] counts how much elements of [l] comply with the function [f]. @since 1.5 *) val init : int -> (int -> 'a) -> 'a t -(** Similar to {!Array.init} +(** [init len f] is [f 0; f 1; ...; f (len-1)]. + @raise Invalid_argument if len < 0. @since 0.6 *) val combine : 'a list -> 'b list -> ('a * 'b) list (** Similar to {!List.combine} but tail-recursive. + Transform a pair of lists into a list of pairs: + [combine [a1; ...; an] [b1; ...; bn]] is + [[(a1,b1); ...; (an,bn)]]. @raise Invalid_argument if the lists have distinct lengths. @since 1.2 *) @@ -97,16 +109,20 @@ val combine_gen : 'a list -> 'b list -> ('a * 'b) gen @since 1.2 *) val split : ('a * 'b) t -> 'a t * 'b t -(** A tail-recursive version of {!List.split}. *) +(** A tail-recursive version of {!List.split}. + Transform a list of pairs into a pair of lists: + [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. *) val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int val compare_lengths : 'a t -> 'b t -> int -(** equivalent to [compare (length l1) (length l2)] but more efficient. +(** Equivalent to [compare (length l1) (length l2)] but more efficient. + Compare the lengths of two lists. @since 1.5 *) val compare_length_with : 'a t -> int -> int -(** equivalent to [compare (length l) x] but more efficient. +(** Equivalent to [compare (length l) x] but more efficient. + Compare the length of a list to an integer. @since 1.5 *) val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool @@ -115,33 +131,33 @@ val flat_map : ('a -> 'b t) -> 'a t -> 'b t (** Map and flatten at the same time (safe). Evaluation order is not guaranteed. *) val flatten : 'a t t -> 'a t -(** Safe flatten *) +(** Safe flatten. Concatenate a list of lists. *) val product : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t -(** Cartesian product of the two lists, with the given combinator *) +(** Cartesian product of the two lists, with the given combinator. *) val fold_product : ('c -> 'a -> 'b -> 'c) -> 'c -> 'a t -> 'b t -> 'c -(** Fold on the cartesian product *) +(** Fold on the cartesian product. *) val cartesian_product : 'a t t -> 'a t t (** Produce the cartesian product of this list of lists, by returning all the ways of picking one element per sublist. {b NOTE} the order of the returned list is unspecified. For example: - {[ - # cartesian_product [[1;2];[3];[4;5;6]] |> sort = - [[1;3;4];[1;3;5];[1;3;6];[2;3;4];[2;3;5];[2;3;6]];; - # cartesian_product [[1;2];[];[4;5;6]] = [];; - # cartesian_product [[1;2];[3];[4];[5];[6]] |> sort = - [[1;3;4;5;6];[2;3;4;5;6]];; - ]} + {[ + # cartesian_product [[1;2];[3];[4;5;6]] |> sort = + [[1;3;4];[1;3;5];[1;3;6];[2;3;4];[2;3;5];[2;3;6]];; + # cartesian_product [[1;2];[];[4;5;6]] = [];; + # cartesian_product [[1;2];[3];[4];[5];[6]] |> sort = + [[1;3;4;5;6];[2;3;4;5;6]];; + ]} invariant: [cartesian_product l = map_product id l]. @since 1.2 *) val map_product_l : ('a -> 'b list) -> 'a list -> 'b list list (** [map_product_l f l] maps each element of [l] to a list of objects of type ['b] using [f]. - We obtain [[l1;l2;ā€¦;ln]] where [length l=n] and [li : 'b list]. + We obtain [[l1;l2;...;ln]] where [length l=n] and [li : 'b list]. Then, it returns all the ways of picking exactly one element per [li]. @since 1.2 *) @@ -152,9 +168,9 @@ val diagonal : 'a t -> ('a * 'a) t val partition_map : ('a -> [<`Left of 'b | `Right of 'c | `Drop]) -> 'a list -> 'b list * 'c list (** [partition_map f l] maps [f] on [l] and gather results in lists: - - if [f x = `Left y], adds [y] to the first list - - if [f x = `Right z], adds [z] to the second list - - if [f x = `Drop], ignores [x] + - if [f x = `Left y], adds [y] to the first list. + - if [f x = `Right z], adds [z] to the second list. + - if [f x = `Drop], ignores [x]. @since 0.11 *) val sublists_of_len : @@ -165,14 +181,14 @@ val sublists_of_len : 'a list list (** [sublists_of_len n l] returns sub-lists of [l] that have length [n]. By default, these sub-lists are non overlapping: - [sublists_of_len 2 [1;2;3;4;5;6]] returns [[1;2]; [3;4]; [5;6]] + [sublists_of_len 2 [1;2;3;4;5;6]] returns [[1;2]; [3;4]; [5;6]]. Examples: - - [sublists_of_len 2 [1;2;3;4;5;6] = [[1;2]; [3;4]; [5;6]]] - - [sublists_of_len 2 ~offset:3 [1;2;3;4;5;6] = [1;2];[4;5]] - - [sublists_of_len 3 ~last:CCOpt.return [1;2;3;4] = [1;2;3];[4]] - - [sublists_of_len 2 [1;2;3;4;5] = [[1;2]; [3;4]]] + - [sublists_of_len 2 [1;2;3;4;5;6] = [[1;2]; [3;4]; [5;6]]]. + - [sublists_of_len 2 ~offset:3 [1;2;3;4;5;6] = [1;2];[4;5]]. + - [sublists_of_len 3 ~last:CCOpt.return [1;2;3;4] = [1;2;3];[4]]. + - [sublists_of_len 2 [1;2;3;4;5] = [[1;2]; [3;4]]]. @param offset the number of elements skipped between two consecutive sub-lists. By default it is [n]. If [offset < n], the sub-lists @@ -182,33 +198,38 @@ val sublists_of_len : [g'] is appended; otherwise [g] is dropped. If [last = CCOpt.return], it will simply keep the last group. By default, [last = fun _ -> None], i.e. the last group is dropped if shorter than [n]. - @raise Invalid_argument if [offset <= 0] or [n <= 0] + @raise Invalid_argument if [offset <= 0] or [n <= 0]. @since 1.0 *) val pure : 'a -> 'a t +(** [pure] = [return]. *) val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +(** [funs <*> l] = [product (fun f x -> f x) funs l]. *) val (<$>) : ('a -> 'b) -> 'a t -> 'b t +(** [(<$>)] = [map]. *) val return : 'a -> 'a t +(** [return x] = [x]. *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +(** [l >>= f] = [flat_map f l]. *) val take : int -> 'a t -> 'a t -(** Take the [n] first elements, drop the rest *) +(** Take the [n] first elements, drop the rest. *) val drop : int -> 'a t -> 'a t -(** Drop the [n] first elements, keep the rest *) +(** Drop the [n] first elements, keep the rest. *) val hd_tl : 'a t -> 'a * 'a t (** [hd_tl (x :: l)] returns [hd, l]. - @raise Failure if the list is empty + @raise Failure if the list is empty. @since 0.16 *) val take_drop : int -> 'a t -> 'a t * 'a t (** [take_drop n l] returns [l1, l2] such that [l1 @ l2 = l] and - [length l1 = min (length l) n] *) + [length l1 = min (length l) n]. *) val take_while : ('a -> bool) -> 'a t -> 'a t (** @since 0.13 *) @@ -217,12 +238,12 @@ val drop_while : ('a -> bool) -> 'a t -> 'a t (** @since 0.13 *) val take_drop_while : ('a -> bool) -> 'a t -> 'a t * 'a t -(** [take_drop_while p l = take_while p l, drop_while p l] +(** [take_drop_while p l = take_while p l, drop_while p l]. @since 1.2 *) val last : int -> 'a t -> 'a t (** [last n l] takes the last [n] elements of [l] (or less if - [l] doesn't have that many elements *) + [l] doesn't have that many elements. *) val head_opt : 'a t -> 'a option (** First element. @@ -234,22 +255,22 @@ val last_opt : 'a t -> 'a option val find_pred : ('a -> bool) -> 'a t -> 'a option (** [find_pred p l] finds the first element of [l] that satisfies [p], - or returns [None] if no element satisfies [p] + or returns [None] if no element satisfies [p]. @since 0.11 *) val find_opt : ('a -> bool) -> 'a t -> 'a option -(** Safe version of {!find} +(** Safe version of {!find}. @since 1.5 *) val find_pred_exn : ('a -> bool) -> 'a t -> 'a -(** Unsafe version of {!find_pred} - @raise Not_found if no such element is found +(** Unsafe version of {!find_pred}. + @raise Not_found if no such element is found. @since 0.11 *) val find_map : ('a -> 'b option) -> 'a t -> 'b option (** [find_map f l] traverses [l], applying [f] to each element. If for some element [x], [f x = Some y], then [Some y] is returned. Otherwise - the call returns [None] + the call returns [None]. @since 0.11 *) val find_mapi : (int -> 'a -> 'b option) -> 'a t -> 'b option @@ -258,24 +279,23 @@ val find_mapi : (int -> 'a -> 'b option) -> 'a t -> 'b option val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option (** [find_idx p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], - and [p x] holds. Otherwise returns [None] *) + and [p x] holds. Otherwise returns [None]. *) -val remove : ?eq:('a -> 'a -> bool) -> x:'a -> 'a t -> 'a t +val remove : eq:('a -> 'a -> bool) -> x:'a -> 'a t -> 'a t (** [remove ~x l] removes every instance of [x] from [l]. Tailrec. - @param eq equality function + @param eq equality function. @since 0.11 *) val filter_map : ('a -> 'b option) -> 'a t -> 'b t -(** Map and remove elements at the same time *) +(** Map and remove elements at the same time. *) val keep_some : 'a option t -> 'a t (** [filter_some l] retains only elements of the form [Some x]. - Same as [filter_map CCFun.id] + Same as [filter_map CCFun.id]. @since 1.3 *) val keep_ok : ('a, _) Result.result t -> 'a t -(** [filter_some l] retains only elements of the form [Some x]. - Same as [filter_map CCFun.id] +(** [keep_ok l] retains only elements of the form [Ok x]. @since 1.3 *) val all_some : 'a option t -> 'a t option @@ -288,23 +308,23 @@ val all_ok : ('a, 'err) Result.result t -> ('a t, 'err) Result.result or [Error e] otherwise (with the first error met). @since 1.3 *) -val sorted_merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list -(** Merges elements from both sorted list *) +val sorted_merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list +(** Merges elements from both sorted list. *) -val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -(** Sort the list and remove duplicate elements *) +val sort_uniq : cmp:('a -> 'a -> int) -> 'a list -> 'a list +(** Sort the list and remove duplicate elements. *) -val sorted_merge_uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list +val sorted_merge_uniq : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** [sorted_merge_uniq l1 l2] merges the sorted lists [l1] and [l2] and - removes duplicates + removes duplicates. @since 0.10 *) -val is_sorted : ?cmp:('a -> 'a -> int) -> 'a list -> bool -(** [is_sorted l] returns [true] iff [l] is sorted (according to given order) - @param cmp the comparison function (default [Pervasives.compare]) +val is_sorted : cmp:('a -> 'a -> int) -> 'a list -> bool +(** [is_sorted l] returns [true] iff [l] is sorted (according to given order). + @param cmp the comparison function (default [Pervasives.compare]). @since 0.17 *) -val sorted_insert : ?cmp:('a -> 'a -> int) -> ?uniq:bool -> 'a -> 'a list -> 'a list +val sorted_insert : cmp:('a -> 'a -> int) -> ?uniq:bool -> 'a -> 'a list -> 'a list (** [sorted_insert x l] inserts [x] into [l] such that, if [l] was sorted, then [sorted_insert x l] is sorted too. @param uniq if true and [x] is already in sorted position in [l], then @@ -314,29 +334,44 @@ val sorted_insert : ?cmp:('a -> 'a -> int) -> ?uniq:bool -> 'a -> 'a list -> 'a (*$Q Q.(pair small_int (list small_int)) (fun (x,l) -> \ let l = List.sort Pervasives.compare l in \ - is_sorted (sorted_insert x l)) + is_sorted ~cmp:CCInt.compare (sorted_insert ~cmp:CCInt.compare x l)) *) -val uniq_succ : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list +val uniq_succ : eq:('a -> 'a -> bool) -> 'a list -> 'a list (** [uniq_succ l] removes duplicate elements that occur one next to the other. Examples: - [uniq_succ [1;2;1] = [1;2;1]] - [uniq_succ [1;1;2] = [1;2]] + [uniq_succ [1;2;1] = [1;2;1]]. + [uniq_succ [1;1;2] = [1;2]]. @since 0.10 *) -val group_succ : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list list +val group_succ : eq:('a -> 'a -> bool) -> 'a list -> 'a list list (** [group_succ ~eq l] groups together consecutive elements that are equal - according to [eq] + according to [eq]. @since 0.11 *) (** {2 Indices} *) val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t +(** Same as {!map}, but the function is applied to the index of + the element as first argument (counting from 0), and the element + itself as second argument. *) val iteri : (int -> 'a -> unit) -> 'a t -> unit +(** Same as {!iter}, but the function is applied to the index of + the element as first argument (counting from 0), and the element + itself as second argument. *) + +val iteri2 : (int -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit +(** @raise Invalid_argument when lists do not have the same length. + @since NEXT_RELEASE *) val foldi : ('b -> int -> 'a -> 'b) -> 'b -> 'a t -> 'b -(** Fold on list, with index *) +(** Fold on list, with index. *) + +val foldi2 : ('c -> int -> 'a -> 'b -> 'c) -> 'c -> 'a t -> 'b t -> 'c +(** Fold on two lists, with index. + @raise Invalid_argument when lists do not have the same length. + @since NEXT_RELEASE *) val get_at_idx : int -> 'a t -> 'a option (** Get by index in the list. @@ -350,7 +385,7 @@ val nth_opt : 'a t -> int -> 'a option val get_at_idx_exn : int -> 'a t -> 'a (** Get the i-th element, or - @raise Not_found if the index is invalid + @raise Not_found if the index is invalid. If the index is negative, it will get element starting from the end of the list. *) @@ -375,32 +410,32 @@ val remove_at_idx : int -> 'a t -> 'a t (** {2 Set Operators} Those operations maintain the invariant that the list does not - contain duplicates (if it already satisfies it) *) + contain duplicates (if it already satisfies it). *) -val add_nodup : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t +val add_nodup : eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t (** [add_nodup x set] adds [x] to [set] if it was not already present. Linear time. @since 0.11 *) -val remove_one : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t +val remove_one : eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t (** [remove_one x set] removes one occurrence of [x] from [set]. Linear time. @since 0.11 *) -val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool -(** Membership to the list. Linear time *) +val mem : eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool +(** Membership to the list. Linear time. *) -val subset : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool -(** Test for inclusion *) +val subset : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool +(** Test for inclusion. *) -val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t +val uniq : eq:('a -> 'a -> bool) -> 'a t -> 'a t (** Remove duplicates w.r.t the equality predicate. Complexity is quadratic in the length of the list, but the order of elements is preserved. If you wish for a faster de-duplication - but do not care about the order, use {!sort_uniq}*) + but do not care about the order, use {!sort_uniq}. *) -val union : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t +val union : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t (** List union. Complexity is product of length of inputs. *) -val inter : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t +val inter : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t (** List intersection. Complexity is product of length of inputs. *) (** {2 Other Constructors} *) @@ -409,69 +444,81 @@ val range_by : step:int -> int -> int -> int t (** [range_by ~step i j] iterates on integers from [i] to [j] included, where the difference between successive elements is [step]. use a negative [step] for a decreasing list. - @raise Invalid_argument if [step=0] + @raise Invalid_argument if [step=0]. @since 0.18 *) val range : int -> int -> int t -(** [range i j] iterates on integers from [i] to [j] included . It works - both for decreasing and increasing ranges *) +(** [range i j] iterates on integers from [i] to [j] included. It works + both for decreasing and increasing ranges. *) val range' : int -> int -> int t (** Same as {!range} but the second bound is excluded. - For instance [range' 0 5 = [0;1;2;3;4]] *) + For instance [range' 0 5 = [0;1;2;3;4]]. *) val (--) : int -> int -> int t -(** Infix alias for [range] *) +(** Infix alias for [range]. *) val (--^) : int -> int -> int t -(** Infix alias for [range'] +(** Infix alias for [range']. @since 0.17 *) val replicate : int -> 'a -> 'a t -(** Replicate the given element [n] times *) +(** Replicate the given element [n] times. *) val repeat : int -> 'a t -> 'a t -(** Concatenate the list with itself [n] times *) +(** Concatenate the list with itself [n] times. *) (** {2 Association Lists} *) module Assoc : sig type ('a, 'b) t = ('a*'b) list - val get : ?eq:('a->'a->bool) -> 'a -> ('a,'b) t -> 'b option - (** Find the element *) + val get : eq:('a->'a->bool) -> 'a -> ('a,'b) t -> 'b option + (** Find the element. *) - val get_exn : ?eq:('a->'a->bool) -> 'a -> ('a,'b) t -> 'b - (** Same as [get], but unsafe - @raise Not_found if the element is not present *) + val get_exn : eq:('a->'a->bool) -> 'a -> ('a,'b) t -> 'b + (** Same as [get], but unsafe. + @raise Not_found if the element is not present. *) - val set : ?eq:('a->'a->bool) -> 'a -> 'b -> ('a,'b) t -> ('a,'b) t - (** Add the binding into the list (erase it if already present) *) + val set : eq:('a->'a->bool) -> 'a -> 'b -> ('a,'b) t -> ('a,'b) t + (** Add the binding into the list (erase it if already present). *) - val mem : ?eq:('a->'a->bool) -> 'a -> ('a,_) t -> bool - (** [mem x l] returns [true] iff [x] is a key in [l] + val mem : eq:('a->'a->bool) -> 'a -> ('a,_) t -> bool + (** [mem x l] returns [true] iff [x] is a key in [l]. @since 0.16 *) val update : - ?eq:('a->'a->bool) -> f:('b option -> 'b option) -> 'a -> ('a,'b) t -> ('a,'b) t + eq:('a->'a->bool) -> f:('b option -> 'b option) -> 'a -> ('a,'b) t -> ('a,'b) t (** [update k ~f l] updates [l] on the key [k], by calling [f (get l k)] and removing [k] if it returns [None], mapping [k] to [v'] if it - returns [Some v'] + returns [Some v']. @since 0.16 *) - val remove : ?eq:('a->'a->bool) -> 'a -> ('a,'b) t -> ('a,'b) t + val remove : eq:('a->'a->bool) -> 'a -> ('a,'b) t -> ('a,'b) t (** [remove x l] removes the first occurrence of [k] from [l]. @since 0.17 *) end -val assoc_opt : 'a -> ('a * 'b) t -> 'b option -(** Safe version of {!assoc} +val assoc : eq:('a -> 'a -> bool) -> 'a -> ('a * 'b) t -> 'b +(** Same as [Assoc.get_exn]. + @since NEXT_RELEASE *) + +val assoc_opt : eq:('a -> 'a -> bool) -> 'a -> ('a * 'b) t -> 'b option +(** Same as [Assoc.get]. @since 1.5 *) val assq_opt : 'a -> ('a * 'b) t -> 'b option -(** Safe version of {!assq} +(** Safe version of {!assq}. @since 1.5 *) +val mem_assoc : eq:('a -> 'a -> bool) -> 'a -> ('a * _) t -> bool +(** Same as [Assoc.mem]. + @since NEXT_RELEASE *) + +val remove_assoc : eq:('a -> 'a -> bool) -> 'a -> ('a * 'b) t -> ('a * 'b) t +(** Same as [Assoc.remove]. + @since NEXT_RELEASE *) + (** {2 References on Lists} @since 0.3.3 *) @@ -484,20 +531,20 @@ module Ref : sig val pop_exn : 'a t -> 'a (** Unsafe version of {!pop}. - @raise Failure if the list is empty *) + @raise Failure if the list is empty. *) val create : unit -> 'a t - (** Create a new list reference *) + (** Create a new list reference. *) val clear : _ t -> unit - (** Remove all elements *) + (** Remove all elements. *) val lift : ('a list -> 'b) -> 'a t -> 'b - (** Apply a list function to the content *) + (** Apply a list function to the content. *) val push_list : 'a t -> 'a list -> unit (** Add elements of the list at the beginning of the list ref. Elements - at the end of the list will be at the beginning of the list ref *) + at the end of the list will be at the beginning of the list ref. *) end (** {2 Monadic Operations} *) @@ -528,7 +575,7 @@ val random_len : int -> 'a random_gen -> 'a t random_gen val random_choose : 'a t -> 'a random_gen (** Randomly choose an element in the list. - @raise Not_found if the list is empty *) + @raise Not_found if the list is empty. *) val random_sequence : 'a random_gen t -> 'a t random_gen @@ -543,7 +590,7 @@ val of_klist : 'a klist -> 'a t (** {2 Infix Operators} It is convenient to {!open CCList.Infix} to access the infix operators - without cluttering the scope too much. + without cluttering the scope too much. @since 0.16 *) diff --git a/src/core/CCListLabels.mli b/src/core/CCListLabels.mli index 4bc67737..60435e1c 100644 --- a/src/core/CCListLabels.mli +++ b/src/core/CCListLabels.mli @@ -1,7 +1,7 @@ (* This file is free software, part of containers. See file "license" for more details. *) -(** {1 complements to list} *) +(** {1 Complements to list} *) include module type of ListLabels @@ -10,39 +10,42 @@ type 'a t = 'a list val empty : 'a t val is_empty : _ t -> bool -(** [is_empty l] returns [true] iff [l = []] +(** [is_empty l] returns [true] iff [l = []]. @since 0.11 *) val map : f:('a -> 'b) -> 'a t -> 'b t -(** Safe version of map *) +(** Safe version of {!List.map}. *) val (>|=) : 'a t -> ('a -> 'b) -> 'b t -(** Infix version of [map] with reversed arguments +(** Infix version of [map] with reversed arguments. @since 0.5 *) val cons : 'a -> 'a t -> 'a t -(** [cons x l] is [x::l] +(** [cons x l] is [x::l]. @since 0.12 *) val append : 'a t -> 'a t -> 'a t -(** Safe version of append *) +(** Safe version of {!List.append}. + Concatenate two lists. *) val cons_maybe : 'a option -> 'a t -> 'a t -(** [cons_maybe (Some x) l] is [x :: l] - [cons_maybe None l] is [l] +(** [cons_maybe (Some x) l] is [x :: l]. + [cons_maybe None l] is [l]. @since 0.13 *) val (@) : 'a t -> 'a t -> 'a t +(** Same as [append]. + Concatenate two lists. *) val filter : f:('a -> bool) -> 'a t -> 'a t -(** Safe version of {!List.filter} *) +(** Safe version of {!List.filter}. *) val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b -(** Safe version of [fold_right] *) +(** Safe version of [fold_right]. *) val fold_while : f:('a -> 'b -> 'a * [`Stop | `Continue]) -> init:'a -> 'b t -> 'a (** Fold until a stop condition via [('a, `Stop)] is - indicated by the accumulator + indicated by the accumulator. @since 0.8 *) val fold_map : f:('acc -> 'a -> 'acc * 'b) -> init:'acc -> 'a list -> 'acc * 'b list @@ -52,21 +55,22 @@ val fold_map : f:('acc -> 'a -> 'acc * 'b) -> init:'acc -> 'a list -> 'acc * 'b val fold_map2 : f:('acc -> 'a -> 'b -> 'acc * 'c) -> init:'acc -> 'a list -> 'b list -> 'acc * 'c list (** [fold_map2] is to [fold_map] what [List.map2] is to [List.map]. - @raise Invalid_argument if the lists do not have the same length + @raise Invalid_argument if the lists do not have the same length. @since 0.16 *) val fold_filter_map : f:('acc -> 'a -> 'acc * 'b option) -> init:'acc -> 'a list -> 'acc * 'b list (** [fold_filter_map f acc l] is a [fold_left]-like function, but also - generates a list of output in a way similar to {!filter_map} + generates a list of output in a way similar to {!filter_map}. @since 0.17 *) val fold_flat_map : f:('acc -> 'a -> 'acc * 'b list) -> init:'acc -> 'a list -> 'acc * 'b list (** [fold_flat_map f acc l] is a [fold_left]-like function, but it also maps the - list to a list of lists that is then [flatten]'d.. + list to a list of lists that is then [flatten]'d. @since 0.14 *) val init : int -> f:(int -> 'a) -> 'a t -(** Similar to {!Array.init} +(** [init len f] is [f 0; f 1; ...; f (len-1)]. + @raise Invalid_argument if len < 0. @since 0.6 *) val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int @@ -77,13 +81,13 @@ val flat_map : f:('a -> 'b t) -> 'a t -> 'b t (** Map and flatten at the same time (safe). Evaluation order is not guaranteed. *) val flatten : 'a t t -> 'a t -(** Safe flatten *) +(** Safe flatten. Concatenate a list of lists. *) val product : f:('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t -(** Cartesian product of the two lists, with the given combinator *) +(** Cartesian product of the two lists, with the given combinator. *) val fold_product : f:('c -> 'a -> 'b -> 'c) -> init:'c -> 'a t -> 'b t -> 'c -(** Fold on the cartesian product *) +(** Fold on the cartesian product. *) val diagonal : 'a t -> ('a * 'a) t (** All pairs of distinct positions of the list. [list_diagonal l] will @@ -92,9 +96,9 @@ val diagonal : 'a t -> ('a * 'a) t val partition_map : f:('a -> [<`Left of 'b | `Right of 'c | `Drop]) -> 'a list -> 'b list * 'c list (** [partition_map f l] maps [f] on [l] and gather results in lists: - - if [f x = `Left y], adds [y] to the first list - - if [f x = `Right z], adds [z] to the second list - - if [f x = `Drop], ignores [x] + - if [f x = `Left y], adds [y] to the first list. + - if [f x = `Right z], adds [z] to the second list. + - if [f x = `Drop], ignores [x]. @since 0.11 *) val sublists_of_len : @@ -112,29 +116,34 @@ val sublists_of_len : @since 1.5 *) val pure : 'a -> 'a t +(** [pure] = [return]. *) val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +(** [funs <*> l] = [product fun f x -> f x) funs l]. *) val (<$>) : ('a -> 'b) -> 'a t -> 'b t +(** [(<$>)] = [map]. *) val return : 'a -> 'a t +(** [return x] = [x]. *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +(** [l >>= f] = [flat_map f l]. *) val take : int -> 'a t -> 'a t -(** Take the [n] first elements, drop the rest *) +(** Take the [n] first elements, drop the rest. *) val drop : int -> 'a t -> 'a t -(** Drop the [n] first elements, keep the rest *) +(** Drop the [n] first elements, keep the rest. *) val hd_tl : 'a t -> 'a * 'a t (** [hd_tl (x :: l)] returns [hd, l]. - @raise Failure if the list is empty + @raise Failure if the list is empty. @since 0.16 *) val take_drop : int -> 'a t -> 'a t * 'a t (** [take_drop n l] returns [l1, l2] such that [l1 @ l2 = l] and - [length l1 = min (length l) n] *) + [length l1 = min (length l) n]. *) val take_while : f:('a -> bool) -> 'a t -> 'a t (** @since 0.13 *) @@ -144,7 +153,7 @@ val drop_while : f:('a -> bool) -> 'a t -> 'a t val last : int -> 'a t -> 'a t (** [last n l] takes the last [n] elements of [l] (or less if - [l] doesn't have that many elements *) + [l] doesn't have that many elements. *) val head_opt : 'a t -> 'a option (** First element. @@ -156,18 +165,18 @@ val last_opt : 'a t -> 'a option val find_pred : f:('a -> bool) -> 'a t -> 'a option (** [find_pred p l] finds the first element of [l] that satisfies [p], - or returns [None] if no element satisfies [p] + or returns [None] if no element satisfies [p]. @since 0.11 *) val find_pred_exn : f:('a -> bool) -> 'a t -> 'a -(** Unsafe version of {!find_pred} - @raise Not_found if no such element is found +(** Unsafe version of {!find_pred}. + @raise Not_found if no such element is found. @since 0.11 *) val find_map : f:('a -> 'b option) -> 'a t -> 'b option (** [find_map f l] traverses [l], applying [f] to each element. If for some element [x], [f x = Some y], then [Some y] is returned. Otherwise - the call returns [None] + the call returns [None]. @since 0.11 *) val find_mapi : f:(int -> 'a -> 'b option) -> 'a t -> 'b option @@ -176,33 +185,33 @@ val find_mapi : f:(int -> 'a -> 'b option) -> 'a t -> 'b option val find_idx : f:('a -> bool) -> 'a t -> (int * 'a) option (** [find_idx p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], - and [p x] holds. Otherwise returns [None] *) + and [p x] holds. Otherwise returns [None]. *) -val remove : ?eq:('a -> 'a -> bool) -> key:'a -> 'a t -> 'a t +val remove : eq:('a -> 'a -> bool) -> key:'a -> 'a t -> 'a t (** [remove ~key l] removes every instance of [key] from [l]. Tailrec. - @param eq equality function + @param eq equality function. @since 0.11 *) val filter_map : f:('a -> 'b option) -> 'a t -> 'b t -(** Map and remove elements at the same time *) +(** Map and remove elements at the same time. *) -val sorted_merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list -(** Merges elements from both sorted list *) +val sorted_merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list +(** Merges elements from both sorted list. *) -val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -(** Sort the list and remove duplicate elements *) +val sort_uniq : cmp:('a -> 'a -> int) -> 'a list -> 'a list +(** Sort the list and remove duplicate elements. *) -val sorted_merge_uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list +val sorted_merge_uniq : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** [sorted_merge_uniq l1 l2] merges the sorted lists [l1] and [l2] and - removes duplicates + removes duplicates. @since 0.10 *) -val is_sorted : ?cmp:('a -> 'a -> int) -> 'a list -> bool -(** [is_sorted l] returns [true] iff [l] is sorted (according to given order) - @param cmp the comparison function (default [Pervasives.compare]) +val is_sorted : cmp:('a -> 'a -> int) -> 'a list -> bool +(** [is_sorted l] returns [true] iff [l] is sorted (according to given order). + @param cmp the comparison function (default [Pervasives.compare]). @since 0.17 *) -val sorted_insert : ?cmp:('a -> 'a -> int) -> ?uniq:bool -> 'a -> 'a list -> 'a list +val sorted_insert : cmp:('a -> 'a -> int) -> ?uniq:bool -> 'a -> 'a list -> 'a list (** [sorted_insert x l] inserts [x] into [l] such that, if [l] was sorted, then [sorted_insert x l] is sorted too. @param uniq if true and [x] is already in sorted position in [l], then @@ -215,74 +224,91 @@ val sorted_insert : ?cmp:('a -> 'a -> int) -> ?uniq:bool -> 'a -> 'a list -> 'a is_sorted (sorted_insert x l)) *) -val uniq_succ : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list +val uniq_succ : eq:('a -> 'a -> bool) -> 'a list -> 'a list (** [uniq_succ l] removes duplicate elements that occur one next to the other. Examples: - [uniq_succ [1;2;1] = [1;2;1]] - [uniq_succ [1;1;2] = [1;2]] + [uniq_succ [1;2;1] = [1;2;1]]. + [uniq_succ [1;1;2] = [1;2]]. @since 0.10 *) -val group_succ : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list list +val group_succ : eq:('a -> 'a -> bool) -> 'a list -> 'a list list (** [group_succ ~eq l] groups together consecutive elements that are equal - according to [eq] + according to [eq]. @since 0.11 *) (** {2 Indices} *) val mapi : f:(int -> 'a -> 'b) -> 'a t -> 'b t +(** Same as {!map}, but the function is applied to the index of + the element as first argument (counting from 0), and the element + itself as second argument. *) val iteri : f:(int -> 'a -> unit) -> 'a t -> unit +(** Same as {!iter}, but the function is applied to the index of + the element as first argument (counting from 0), and the element + itself as second argument. *) val foldi : f:('b -> int -> 'a -> 'b) -> init:'b -> 'a t -> 'b -(** Fold on list, with index *) +(** Fold on list, with index. *) val get_at_idx : int -> 'a t -> 'a option +(** Get by index in the list. + If the index is negative, it will get element starting from the end + of the list. *) val get_at_idx_exn : int -> 'a t -> 'a (** Get the i-th element, or - @raise Not_found if the index is invalid *) + @raise Not_found if the index is invalid. + If the index is negative, it will get element starting from the end + of the list. *) val set_at_idx : int -> 'a -> 'a t -> 'a t (** Set i-th element (removes the old one), or does nothing if - index is too high *) + index is too high. + If the index is negative, it will set element starting from the end + of the list. *) val insert_at_idx : int -> 'a -> 'a t -> 'a t (** Insert at i-th position, between the two existing elements. If the - index is too high, append at the end of the list *) + index is too high, append at the end of the list. + If the index is negative, it will insert element starting from the end + of the list. *) val remove_at_idx : int -> 'a t -> 'a t (** Remove element at given index. Does nothing if the index is - too high. *) + too high. + If the index is negative, it will remove element starting from the end + of the list. *) (** {2 Set Operators} Those operations maintain the invariant that the list does not - contain duplicates (if it already satisfies it) *) + contain duplicates (if it already satisfies it). *) -val add_nodup : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t +val add_nodup : eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t (** [add_nodup x set] adds [x] to [set] if it was not already present. Linear time. @since 0.11 *) -val remove_one : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t +val remove_one : eq:('a -> 'a -> bool) -> 'a -> 'a t -> 'a t (** [remove_one x set] removes one occurrence of [x] from [set]. Linear time. @since 0.11 *) -val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool -(** Membership to the list. Linear time *) +val mem : eq:('a -> 'a -> bool) -> 'a -> 'a t -> bool +(** Membership to the list. Linear time. *) -val subset : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool -(** Test for inclusion *) +val subset : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool +(** Test for inclusion. *) -val uniq : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t +val uniq : eq:('a -> 'a -> bool) -> 'a t -> 'a t (** Remove duplicates w.r.t the equality predicate. Complexity is quadratic in the length of the list, but the order of elements is preserved. If you wish for a faster de-duplication - but do not care about the order, use {!sort_uniq}*) + but do not care about the order, use {!sort_uniq}. *) -val union : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t +val union : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t (** List union. Complexity is product of length of inputs. *) -val inter : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t +val inter : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> 'a t (** List intersection. Complexity is product of length of inputs. *) (** {2 Other Constructors} *) @@ -291,61 +317,81 @@ val range_by : step:int -> int -> int -> int t (** [range_by ~step i j] iterates on integers from [i] to [j] included, where the difference between successive elements is [step]. use a negative [step] for a decreasing list. - @raise Invalid_argument if [step=0] + @raise Invalid_argument if [step=0]. @since 0.18 *) val range : int -> int -> int t -(** [range i j] iterates on integers from [i] to [j] included . It works - both for decreasing and increasing ranges *) +(** [range i j] iterates on integers from [i] to [j] included. It works + both for decreasing and increasing ranges. *) val range' : int -> int -> int t (** Same as {!range} but the second bound is excluded. - For instance [range' 0 5 = [0;1;2;3;4]] *) + For instance [range' 0 5 = [0;1;2;3;4]]. *) val (--) : int -> int -> int t -(** Infix alias for [range] *) +(** Infix alias for [range]. *) val (--^) : int -> int -> int t -(** Infix alias for [range'] +(** Infix alias for [range']. @since 0.17 *) val replicate : int -> 'a -> 'a t -(** Replicate the given element [n] times *) +(** Replicate the given element [n] times. *) val repeat : int -> 'a t -> 'a t -(** Concatenate the list with itself [n] times *) +(** Concatenate the list with itself [n] times. *) (** {2 Association Lists} *) module Assoc : sig type ('a, 'b) t = ('a*'b) list - val get : ?eq:('a->'a->bool) -> 'a -> ('a,'b) t -> 'b option - (** Find the element *) + val get : eq:('a->'a->bool) -> 'a -> ('a,'b) t -> 'b option + (** Find the element. *) - val get_exn : ?eq:('a->'a->bool) -> 'a -> ('a,'b) t -> 'b - (** Same as [get], but unsafe - @raise Not_found if the element is not present *) + val get_exn : eq:('a->'a->bool) -> 'a -> ('a,'b) t -> 'b + (** Same as [get], but unsafe. + @raise Not_found if the element is not present. *) - val set : ?eq:('a->'a->bool) -> 'a -> 'b -> ('a,'b) t -> ('a,'b) t - (** Add the binding into the list (erase it if already present) *) + val set : eq:('a->'a->bool) -> 'a -> 'b -> ('a,'b) t -> ('a,'b) t + (** Add the binding into the list (erase it if already present). *) - val mem : ?eq:('a->'a->bool) -> 'a -> ('a,_) t -> bool - (** [mem x l] returns [true] iff [x] is a key in [l] + val mem : eq:('a->'a->bool) -> 'a -> ('a,_) t -> bool + (** [mem x l] returns [true] iff [x] is a key in [l]. @since 0.16 *) val update : - ?eq:('a->'a->bool) -> f:('b option -> 'b option) -> 'a -> ('a,'b) t -> ('a,'b) t + eq:('a->'a->bool) -> f:('b option -> 'b option) -> 'a -> ('a,'b) t -> ('a,'b) t (** [update k ~f l] updates [l] on the key [k], by calling [f (get l k)] and removing [k] if it returns [None], mapping [k] to [v'] if it - returns [Some v'] + returns [Some v']. @since 0.16 *) - val remove : ?eq:('a->'a->bool) -> 'a -> ('a,'b) t -> ('a,'b) t + val remove : eq:('a->'a->bool) -> 'a -> ('a,'b) t -> ('a,'b) t (** [remove x l] removes the first occurrence of [k] from [l]. @since 0.17 *) end +val assoc : eq:('a -> 'a -> bool) -> 'a -> ('a * 'b) t -> 'b +(** Same as [Assoc.get_exn]. + @since NEXT_RELEASE *) + +val assoc_opt : eq:('a -> 'a -> bool) -> 'a -> ('a * 'b) t -> 'b option +(** Same as [Assoc.get]. + @since NEXT_RELEASE *) + +val assq_opt : 'a -> ('a * 'b) t -> 'b option +(** Safe version of {!assq}. + @since NEXT_RELEASE *) + +val mem_assoc : eq:('a -> 'a -> bool) -> 'a -> ('a * _) t -> bool +(** Same as [Assoc.mem]. + @since NEXT_RELEASE *) + +val remove_assoc : eq:('a -> 'a -> bool) -> 'a -> ('a * 'b) t -> ('a * 'b) t +(** Same as [Assoc.remove]. + @since NEXT_RELEASE *) + (** {2 References on Lists} @since 0.3.3 *) @@ -358,20 +404,20 @@ module Ref : sig val pop_exn : 'a t -> 'a (** Unsafe version of {!pop}. - @raise Failure if the list is empty *) + @raise Failure if the list is empty. *) val create : unit -> 'a t - (** Create a new list reference *) + (** Create a new list reference. *) val clear : _ t -> unit - (** Remove all elements *) + (** Remove all elements. *) val lift : ('a list -> 'b) -> 'a t -> 'b - (** Apply a list function to the content *) + (** Apply a list function to the content. *) val push_list : 'a t -> 'a list -> unit (** Add elements of the list at the beginning of the list ref. Elements - at the end of the list will be at the beginning of the list ref *) + at the end of the list will be at the beginning of the list ref. *) end (** {2 Monadic Operations} *) @@ -408,7 +454,7 @@ val random_len : int -> 'a random_gen -> 'a t random_gen val random_choose : 'a t -> 'a random_gen (** Randomly choose an element in the list. - @raise Not_found if the list is empty *) + @raise Not_found if the list is empty. *) val random_sequence : 'a random_gen t -> 'a t random_gen @@ -423,7 +469,7 @@ val of_klist : 'a klist -> 'a t (** {2 Infix Operators} It is convenient to {!open CCList.Infix} to access the infix operators - without cluttering the scope too much. + without cluttering the scope too much. @since 0.16 *) diff --git a/src/core/CCMap.mli b/src/core/CCMap.mli index 14b689e7..ae1cf57f 100644 --- a/src/core/CCMap.mli +++ b/src/core/CCMap.mli @@ -16,11 +16,11 @@ module type S = sig include Map.S val get : key -> 'a t -> 'a option - (** Safe version of {!find} *) + (** Safe version of {!find}. *) val get_or : key -> 'a t -> default:'a -> 'a (** [get_or k m ~default] returns the value associated to [k] if present, - and returns [default] otherwise (if [k] doesn't belong in [m]) + and returns [default] otherwise (if [k] doesn't belong in [m]). @since 0.16 *) val update : key -> ('a option -> 'a option) -> 'a t -> 'a t @@ -30,19 +30,19 @@ module type S = sig [add k v' m] is returned. *) val choose_opt : 'a t -> (key * 'a) option - (** Safe version of {!choose} + (** Safe version of {!choose}. @since 1.5 *) val min_binding_opt : 'a t -> (key * 'a) option - (** Safe version of {!min_binding} + (** Safe version of {!min_binding}. @since 1.5 *) val max_binding_opt : 'a t -> (key * 'a) option - (** Safe version of {!max_binding} + (** Safe version of {!max_binding}. @since 1.5 *) val find_opt : key -> 'a t -> 'a option - (** Safe version of {!find} + (** Safe version of {!find}. @since 1.5 *) val find_first : (key -> bool) -> 'a t -> key * 'a @@ -51,7 +51,7 @@ module type S = sig @since 1.5 *) val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option - (** Safe version of {!find_first} + (** Safe version of {!find_first}. @since 1.5 *) val merge_safe : @@ -62,11 +62,11 @@ module type S = sig val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t (** Union of both maps, using the function to combine bindings - that belong to both inputs + that belong to both inputs. @since 1.4 *) val of_seq : (key * 'a) sequence -> 'a t - (** Same as {!of_list} *) + (** Same as {!of_list}. *) val add_seq : 'a t -> (key * 'a) sequence -> 'a t (** @since 0.14 *) @@ -83,11 +83,11 @@ module type S = sig (** @since 0.14 *) val keys : _ t -> key sequence - (** Iterate on keys only + (** Iterate on keys only. @since 0.15 *) val values : 'a t -> 'a sequence - (** Iterate on values only + (** Iterate on values only. @since 0.15 *) val to_list : 'a t -> (key * 'a) list diff --git a/src/core/CCParse.ml b/src/core/CCParse.ml index f581784a..b66d0e6a 100644 --- a/src/core/CCParse.ml +++ b/src/core/CCParse.ml @@ -43,6 +43,9 @@ type state = { exception ParseError of parse_branch * (unit -> string) +let char_equal (a : char) b = Pervasives.(=) a b +let string_equal (a : string) b = Pervasives.(=) a b + let rec string_of_branch l = let pp_s () = function | None -> "" @@ -83,11 +86,11 @@ let fail_ ~err st msg = let next st ~ok ~err = if st.i = String.length st.str - then fail_ st ~err (const_ "unexpected end of input") + then fail_ ~err st (const_ "unexpected end of input") else ( let c = st.str.[st.i] in st.i <- st.i + 1; - if c='\n' + if char_equal c '\n' then (st.lnum <- st.lnum + 1; st.cnum <- 1) else st.cnum <- st.cnum + 1; ok c @@ -107,24 +110,24 @@ type 'a t = state -> ok:('a -> unit) -> err:(exn -> unit) -> unit let return : 'a -> 'a t = fun x _st ~ok ~err:_ -> ok x let pure = return let (>|=) : 'a t -> ('a -> 'b) -> 'b t - = fun p f st ~ok ~err -> p st ~err ~ok:(fun x -> ok (f x)) + = fun p f st ~ok ~err -> p st ~ok:(fun x -> ok (f x)) ~err let (>>=) : 'a t -> ('a -> 'b t) -> 'b t - = fun p f st ~ok ~err -> p st ~err ~ok:(fun x -> f x st ~err ~ok) + = fun p f st ~ok ~err -> p st ~ok:(fun x -> f x st ~ok ~err) ~err let (<*>) : ('a -> 'b) t -> 'a t -> 'b t = fun f x st ~ok ~err -> - f st ~err ~ok:(fun f' -> x st ~err ~ok:(fun x' -> ok (f' x'))) + f st ~ok:(fun f' -> x st ~ok:(fun x' -> ok (f' x')) ~err) ~err let (<* ) : 'a t -> _ t -> 'a t = fun x y st ~ok ~err -> - x st ~err ~ok:(fun res -> y st ~err ~ok:(fun _ -> ok res)) + x st ~ok:(fun res -> y st ~ok:(fun _ -> ok res) ~err) ~err let ( *>) : _ t -> 'a t -> 'a t = fun x y st ~ok ~err -> - x st ~err ~ok:(fun _ -> y st ~err ~ok) + x st ~ok:(fun _ -> y st ~ok ~err) ~err let map f x = x >|= f let map2 f x y = pure f <*> x <*> y let map3 f x y z = pure f <*> x <*> y <*> z -let junk_ st = next st ~err:(fun _ -> assert false) ~ok:ignore +let junk_ st = next st ~ok:ignore ~err:(fun _ -> assert false) let eoi st ~ok ~err = if is_done st @@ -145,15 +148,15 @@ let nop _ ~ok ~err:_ = ok() let char c = let msg = Printf.sprintf "expected '%c'" c in fun st ~ok ~err -> - next st ~err - ~ok:(fun c' -> if c=c' then ok c else fail_ ~err st (const_ msg)) + next st + ~ok:(fun c' -> if char_equal c c' then ok c else fail_ ~err st (const_ msg)) ~err let char_if p st ~ok ~err = - next st ~err + next st ~ok:(fun c -> if p c then ok c else fail_ ~err st (fun () -> Printf.sprintf "unexpected char '%c'" c) - ) + ) ~err let chars_if p st ~ok ~err:_ = let i = st.i in @@ -162,11 +165,12 @@ let chars_if p st ~ok ~err:_ = ok (String.sub st.str i !len) let chars1_if p st ~ok ~err = - chars_if p st ~err + chars_if p st ~ok:(fun s -> - if s = "" + if string_equal s "" then fail_ ~err st (const_ "unexpected sequence of chars") else ok s) + ~err let rec skip_chars p st ~ok ~err = if not (is_done st) && p (cur st) then ( @@ -188,10 +192,11 @@ let space = char_if is_space let white = char_if is_white let endline st ~ok ~err = - next st ~err + next st ~ok:(function | '\n' as c -> ok c | _ -> fail_ ~err st (const_ "expected end-of-line")) + ~err let skip_space = skip_chars is_space let skip_white = skip_chars is_white @@ -229,32 +234,33 @@ let string s st ~ok ~err = let rec check i = if i = String.length s then ok s else - next st ~err + next st ~ok:(fun c -> - if c = s.[i] + if char_equal c s.[i] then check (i+1) else fail_ ~err st (fun () -> Printf.sprintf "expected \"%s\"" s)) + ~err in check 0 let rec many_rec : 'a t -> 'a list -> 'a list t = fun p acc st ~ok ~err -> if is_done st then ok(List.rev acc) else - p st ~err + p st ~ok:(fun x -> let i = pos st in many_rec p (x :: acc) st ~ok ~err:(fun _ -> backtrack st i; ok(List.rev acc)) - ) + ) ~err let many : 'a t -> 'a list t = fun p st ~ok ~err -> many_rec p [] st ~ok ~err let many1 : 'a t -> 'a list t = fun p st ~ok ~err -> - p st ~err ~ok:(fun x -> many_rec p [x] st ~err ~ok) + p st ~ok:(fun x -> many_rec p [x] st ~ok ~err) ~err let rec skip p st ~ok ~err = let i = pos st in @@ -303,12 +309,12 @@ let memo (type a) (p:a t):a t = with Not_found -> (* parse, and save *) p st - ~err:(fun e -> - MemoTbl.H.replace tbl (i,id) (fun () -> r := Some (MemoTbl.Fail e)); - err e) ~ok:(fun x -> MemoTbl.H.replace tbl (i,id) (fun () -> r := Some (MemoTbl.Ok x)); ok x) + ~err:(fun e -> + MemoTbl.H.replace tbl (i,id) (fun () -> r := Some (MemoTbl.Fail e)); + err e) let fix_memo f = let rec p = @@ -386,7 +392,7 @@ module U = struct skip_white <* string stop let int = - chars1_if (fun c -> is_num c || c='-') + chars1_if (fun c -> is_num c || char_equal c '-') >>= fun s -> try return (int_of_string s) with Failure _ -> fail "expected an int" diff --git a/src/core/CCRandom.ml b/src/core/CCRandom.ml index bcc83111..2879540e 100644 --- a/src/core/CCRandom.ml +++ b/src/core/CCRandom.ml @@ -77,7 +77,7 @@ let replicate n g st = in aux [] n (* Sample without replacement using rejection sampling. *) -let sample_without_replacement (type elt) ?(compare=compare) k (rng:elt t) st= +let sample_without_replacement (type elt) ~compare k (rng:elt t) st= let module S = Set.Make(struct type t=elt let compare = compare end) in let rec aux s k = if k <= 0 then @@ -117,10 +117,10 @@ let _diff_list ~last l = āˆ‘_k y_k = āˆ‘_k (x_{k+1} - x_k ) = x_{len} - x_0 = i. *) let split_list i ~len st = if len <= 1 then invalid_arg "Random.split_list"; - if i >= len then - let xs = sample_without_replacement (len-1) (int_range 1 (i-1)) st in - _diff_list ( 0::xs ) ~last:i - else + if i >= len then ( + let xs = sample_without_replacement ~compare (len-1) (int_range 1 (i-1)) st in + _diff_list ~last:i (0::xs) + ) else None (*$Q @@ -221,6 +221,7 @@ let uniformity_test ?(size_hint=10) k rng st = let confidence = 4. in let std = confidence *. (sqrt (kf *. variance)) in let predicate _key n acc = + let (<) (a : float) b = Pervasives.(<) a b in acc && abs_float (average -. float_of_int n) < std in Hashtbl.fold predicate histogram true diff --git a/src/core/CCRandom.mli b/src/core/CCRandom.mli index ffb32cfb..c445de65 100644 --- a/src/core/CCRandom.mli +++ b/src/core/CCRandom.mli @@ -8,19 +8,21 @@ include module type of Random type state = Random.State.t type 'a t = state -> 'a -(** Random generator for values of type ['a] *) +(** Random generator for values of type ['a]. *) type 'a random_gen = 'a t val return : 'a -> 'a t (** [return x] is the generator that always returns [x]. - Example: [let random_int = return 4 (* fair dice roll *)] *) + Example: [let random_int = return 4 (* fair dice roll *)]. *) val flat_map : ('a -> 'b t) -> 'a t -> 'b t +(** [flat_map f g st] = [f (g st) st]. *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val map : ('a -> 'b) -> 'a t -> 'b t +(** [map f g st] = [f (g st)]. *) val (>|=) : 'a t -> ('a -> 'b) -> 'b t @@ -43,41 +45,41 @@ val choose : 'a t list -> 'a option t val choose_exn : 'a t list -> 'a t (** Same as {!choose} but without option. - @raise Invalid_argument if the list is empty *) + @raise Invalid_argument if the list is empty. *) val choose_array : 'a t array -> 'a option t val choose_return : 'a list -> 'a t -(** Choose among the list +(** Choose among the list. @raise Invalid_argument if the list is empty *) val replicate : int -> 'a t -> 'a list t (** [replicate n g] makes a list of [n] elements which are all generated - randomly using [g] *) + randomly using [g]. *) val sample_without_replacement: - ?compare:('a -> 'a -> int) -> int -> 'a t -> 'a list t + compare:('a -> 'a -> int) -> int -> 'a t -> 'a list t (** [sample_without_replacement n g] makes a list of [n] elements which are all generated randomly using [g] with the added constraint that none of the generated - random values are equal - @raise Invalid_argument if [n <= 0] + random values are equal. + @raise Invalid_argument if [n <= 0]. @since 0.15 *) val list_seq : 'a t list -> 'a list t -(** Build random lists from lists of random generators +(** Build random lists from lists of random generators. @since 0.4 *) exception Pick_from_empty (** @since 0.16 *) val pick_list : 'a list -> 'a t -(** Pick an element at random from the list - @raise Pick_from_empty if the list is empty +(** Pick an element at random from the list. + @raise Pick_from_empty if the list is empty. @since 0.16 *) val pick_array : 'a array -> 'a t -(** Pick an element at random from the array - @raise Pick_from_empty if the array is empty +(** Pick an element at random from the array. + @raise Pick_from_empty if the array is empty. @since 0.16 *) val small_int : int t @@ -85,14 +87,14 @@ val small_int : int t val int : int -> int t val int_range : int -> int -> int t -(** Inclusive range *) +(** Inclusive range. *) val small_float : float t (** A reasonably small float. @since 0.6.1 *) val float : float -> float t -(** Random float within the given range +(** Random float within the given range. @since 0.6.1 *) val float_range : float -> float -> float t @@ -101,25 +103,25 @@ val float_range : float -> float -> float t val split : int -> (int * int) option t (** Split a positive value [n] into [n1,n2] where [n = n1 + n2]. - @return [None] if the value is too small *) + @return [None] if the value is too small. *) val split_list : int -> len:int -> int list option t (** Split a value [n] into a list of values whose sum is [n] and whose length is [length]. The list is never empty and does not contain [0]. - @raise Invalid_argument if [len <= 1] - @return [None] if the value is too small *) + @raise Invalid_argument if [len <= 1]. + @return [None] if the value is too small. *) val retry : ?max:int -> 'a option t -> 'a option t (** [retry g] calls [g] until it returns some value, or until the maximum number of retries was reached. If [g] fails, then it counts for one iteration, and the generator retries. - @param max: maximum number of retries. Default [10] *) + @param max: maximum number of retries. Default [10]. *) val try_successively : 'a option t list -> 'a option t (** [try_successively l] tries each generator of [l], one after the other. If some generator succeeds its result is returned, else the - next generator is tried *) + next generator is tried. *) val () : 'a option t -> 'a option t -> 'a option t (** [a b] is a choice operator. It first tries [a], and returns its @@ -133,9 +135,9 @@ val fix : (** Recursion combinators, for building recursive values. The integer generator is used to provide fuel. The [sub_] generators should use their arguments only once! - @param sub1 cases that recurse on one value - @param sub2 cases that use the recursive gen twice - @param subn cases that use a list of recursive cases *) + @param sub1 cases that recurse on one value. + @param sub2 cases that use the recursive gen twice. + @param subn cases that use a list of recursive cases. *) (** {6 Applicative} *) @@ -146,7 +148,7 @@ val (<*>) : ('a -> 'b) t -> 'a t -> 'b t (** {6 Run a generator} *) val run : ?st:state -> 'a t -> 'a -(** Using a random state (possibly the one in argument) run a generator *) +(** Using a random state (possibly the one in argument) run a generator. *) (**/**) diff --git a/src/core/CCResult.ml b/src/core/CCResult.ml index 271c4823..362d7b4d 100644 --- a/src/core/CCResult.ml +++ b/src/core/CCResult.ml @@ -109,12 +109,12 @@ let (>|=) e f = map f e let (>>=) e f = flat_map f e -let equal ?(err=Pervasives.(=)) eq a b = match a, b with +let equal ~err eq a b = match a, b with | Ok x, Ok y -> eq x y | Error s, Error s' -> err s s' | _ -> false -let compare ?(err=Pervasives.compare) cmp a b = match a, b with +let compare ~err cmp a b = match a, b with | Ok x, Ok y -> cmp x y | Ok _, _ -> 1 | _, Ok _ -> -1 diff --git a/src/core/CCResult.mli b/src/core/CCResult.mli index a494081a..15e4d53a 100644 --- a/src/core/CCResult.mli +++ b/src/core/CCResult.mli @@ -96,9 +96,9 @@ val (>|=) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t val (>>=) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t -val equal : ?err:'err equal -> 'a equal -> ('a, 'err) t equal +val equal : err:'err equal -> 'a equal -> ('a, 'err) t equal -val compare : ?err:'err ord -> 'a ord -> ('a, 'err) t ord +val compare : err:'err ord -> 'a ord -> ('a, 'err) t ord val fold : ok:('a -> 'b) -> error:('err -> 'b) -> ('a, 'err) t -> 'b (** [fold ~ok ~error e] opens [e] and, if [e = Ok x], returns diff --git a/src/core/CCSet.mli b/src/core/CCSet.mli index 6eebbb93..4d577528 100644 --- a/src/core/CCSet.mli +++ b/src/core/CCSet.mli @@ -15,35 +15,35 @@ module type S = sig include Set.S val min_elt_opt : t -> elt option - (** Safe version of {!min_elt} + (** Safe version of {!min_elt}. @since 1.5 *) val max_elt_opt : t -> elt option - (** Safe version of {!max_elt} + (** Safe version of {!max_elt}. @since 1.5 *) val choose_opt : t -> elt option - (** Safe version of {!choose} + (** Safe version of {!choose}. @since 1.5 *) val find_opt : elt -> t -> elt option - (** Safe version of {!find} + (** Safe version of {!find}. @since 1.5 *) val find_first : (elt -> bool) -> t -> elt - (** Find minimum element satisfying predicate + (** Find minimum element satisfying predicate. @since 1.5 *) val find_first_opt : (elt -> bool) -> t -> elt option - (** Safe version of {!find_first} + (** Safe version of {!find_first}. @since 1.5 *) val find_last : (elt -> bool) -> t -> elt - (** Find maximum element satisfying predicate + (** Find maximum element satisfying predicate. @since 1.5 *) val find_last_opt : (elt -> bool) -> t -> elt option - (** Safe version of {!find_last} + (** Safe version of {!find_last}. @since 1.5 *) val of_seq : elt sequence -> t diff --git a/src/core/CCString.ml b/src/core/CCString.ml index 9654760d..219cd554 100644 --- a/src/core/CCString.ml +++ b/src/core/CCString.ml @@ -52,12 +52,13 @@ module type S = sig val to_klist : t -> char klist val to_list : t -> char list - val pp : Buffer.t -> t -> unit - val print : Format.formatter -> t -> unit + val pp_buf : Buffer.t -> t -> unit + val pp : Format.formatter -> t -> unit end -let equal (a:string) b = a=b +let equal (a:string) b = Pervasives.(=) a b +let compare_int (a : int) b = Pervasives.compare a b let compare = String.compare let hash s = Hashtbl.hash s @@ -78,7 +79,7 @@ let _is_sub ~sub i s j ~len = let rec check k = if k = len then true - else sub.[i+k] = s.[j+k] && check (k+1) + else CCChar.equal sub.[i+k] s.[j+k] && check (k+1) in j+len <= String.length s && check 0 @@ -126,7 +127,7 @@ module Find = struct let j = ref 0 in while !i < len do match !j with - | _ when get str (!i-1) = get str !j -> + | _ when CCChar.equal (get str (!i-1)) (get str !j) -> (* substring starting at !j continues matching current char *) incr j; failure.(!i) <- !j; @@ -158,7 +159,7 @@ module Find = struct while !j < pat_len && !i + !j < len do let c = String.get s (!i + !j) in let expected = String.get pattern.str !j in - if c = expected + if CCChar.equal c expected then ( (* char matches *) incr j; @@ -193,7 +194,7 @@ module Find = struct while !j < pat_len && !i + !j < len do let c = String.get s (len - !i - !j - 1) in let expected = String.get pattern.str (String.length pattern.str - !j - 1) in - if c = expected + if CCChar.equal c expected then ( (* char matches *) incr j; @@ -256,14 +257,14 @@ end let find ?(start=0) ~sub = let pattern = Find.compile sub in - fun s -> Find.find ~pattern s ~start + fun s -> Find.find ~start ~pattern s let find_all ?(start=0) ~sub = let pattern = Find.compile sub in fun s -> let i = ref start in fun () -> - let res = Find.find ~pattern s ~start:!i in + let res = Find.find ~start:!i ~pattern s in if res = ~-1 then None else ( i := res + 1; (* possible overlap *) @@ -281,7 +282,7 @@ let mem ?start ~sub s = find ?start ~sub s >= 0 let rfind ~sub = let pattern = Find.rcompile sub in - fun s -> Find.rfind ~pattern s ~start:(String.length s-1) + fun s -> Find.rfind ~start:(String.length s-1) ~pattern s (* Replace substring [s.[pos]....s.[pos+len-1]] by [by] in [s] *) let replace_at_ ~pos ~len ~by s = @@ -292,10 +293,10 @@ let replace_at_ ~pos ~len ~by s = Buffer.contents b let replace ?(which=`All) ~sub ~by s = - if sub="" then invalid_arg "CCString.replace"; + if is_empty sub then invalid_arg "CCString.replace"; match which with | `Left -> - let i = find ~sub s ~start:0 in + let i = find ~start:0 ~sub s in if i>=0 then replace_at_ ~pos:i ~len:(String.length sub) ~by s else s | `Right -> let i = rfind ~sub s in @@ -306,7 +307,7 @@ let replace ?(which=`All) ~sub ~by s = let b = Buffer.create (String.length s) in let start = ref 0 in while !start < String.length s do - let i = Find.find ~pattern s ~start:!start in + let i = Find.find ~start:!start ~pattern s in if i>=0 then ( (* between last and cur occurrences *) Buffer.add_substring b s !start (i- !start); @@ -338,7 +339,7 @@ module Split = struct | SplitAt prev -> _split_search ~by s prev and _split_search ~by s prev = - let j = Find.find ~pattern:by s ~start:prev in + let j = Find.find ~start:prev ~pattern:by s in if j < 0 then Some (SplitStop, prev, String.length s - prev) else Some (SplitAt (j+Find.pattern_length by), prev, j-prev) @@ -442,7 +443,7 @@ let compare_versions a b = | Some _, None -> 1 | None, Some _ -> -1 | Some x, Some y -> - let c = Pervasives.compare x y in + let c = compare_int x y in if c<>0 then c else cmp_rec a b in cmp_rec (Split.gen_cpy ~by:"." a) (Split.gen_cpy ~by:"." b) @@ -480,7 +481,7 @@ let compare_natural a b = | NC_int _, NC_char _ -> 1 | NC_char _, NC_int _ -> -1 | NC_int x, NC_int y -> - let c = Pervasives.compare x y in + let c = compare_int x y in if c<>0 then c else cmp_rec a b in cmp_rec (chunks a) (chunks b) @@ -490,7 +491,7 @@ let edit_distance s1 s2 = then length s2 else if length s2 = 0 then length s1 - else if s1 = s2 + else if equal s1 s2 then 0 else begin (* distance vectors (v0=previous, v1=current) *) @@ -774,25 +775,20 @@ let exists2 p s1 s2 = try iter2 (fun c1 c2 -> if p c1 c2 then raise MyExit) s1 s2; false with MyExit -> true - (** {2 Ascii functions} *) +(** {2 Ascii functions} *) let equal_caseless s1 s2: bool = - let char_lower c = - if c >= 'A' && c <= 'Z' - then Char.unsafe_chr (Char. code c + 32) - else c - in String.length s1 = String.length s2 && for_all2 - (fun c1 c2 -> char_lower c1 = char_lower c2) + (fun c1 c2 -> CCChar.equal (CCChar.lowercase_ascii c1) (CCChar.lowercase_ascii c2)) s1 s2 -let pp buf s = +let pp_buf buf s = Buffer.add_char buf '"'; Buffer.add_string buf s; Buffer.add_char buf '"' -let print fmt s = +let pp fmt s = Format.fprintf fmt "\"%s\"" s module Sub = struct @@ -834,11 +830,11 @@ module Sub = struct let to_klist (s,i,len) = _to_klist s i len let to_list (s,i,len) = _to_list s [] i len - let pp buf (s,i,len) = + let pp_buf buf (s,i,len) = Buffer.add_char buf '"'; Buffer.add_substring buf s i len; Buffer.add_char buf '"' - let print fmt s = + let pp fmt s = Format.fprintf fmt "\"%s\"" (copy s) end diff --git a/src/core/CCString.mli b/src/core/CCString.mli index 5852b3ae..d52b030a 100644 --- a/src/core/CCString.mli +++ b/src/core/CCString.mli @@ -20,14 +20,14 @@ module type S = sig val blit : t -> int -> Bytes.t -> int -> int -> unit (** Similar to {!String.blit}. Compatible with the [-safe-string] option. - @raise Invalid_argument if indices are not valid *) + @raise Invalid_argument if indices are not valid. *) (* val blit_immut : t -> int -> t -> int -> int -> string (** Immutable version of {!blit}, returning a new string. [blit a i b j len] is the same as [b], but in which the range [j, ..., j+len] is replaced by [a.[i], ..., a.[i + len]]. - @raise Invalid_argument if indices are not valid *) + @raise Invalid_argument if indices are not valid. *) *) val fold : ('a -> char -> 'a) -> 'a -> t -> 'a @@ -41,9 +41,14 @@ module type S = sig val to_klist : t -> char klist val to_list : t -> char list - val pp : Buffer.t -> t -> unit - val print : Format.formatter -> t -> unit - (** Print the string within quotes *) + val pp_buf : Buffer.t -> t -> unit + (** Renamed from [pp]. + @since NEXT_RELEASE *) + + val pp : Format.formatter -> t -> unit + (** Print the string within quotes. + Renamed from [print]. + @since NEXT_RELEASE *) end (** {2 Strings} *) @@ -69,7 +74,7 @@ val init : int -> (int -> char) -> string *) val rev : string -> string -(** [rev s] returns the reverse of [s] +(** [rev s] returns the reverse of [s]. @since 0.17 *) (*$Q @@ -86,8 +91,8 @@ val rev : string -> string val pad : ?side:[`Left|`Right] -> ?c:char -> int -> string -> string (** [pad n str] ensures that [str] is at least [n] bytes long, and pads it on the [side] with [c] if it's not the case. - @param side determines where padding occurs (default: [`Left]) - @param c the char used to pad (default: ' ') + @param side determines where padding occurs (default: [`Left]). + @param c the char used to pad (default: ' '). @since 0.17 *) (*$= & ~printer:Q.Print.string @@ -100,7 +105,7 @@ val pad : ?side:[`Left|`Right] -> ?c:char -> int -> string -> string *) val of_char : char -> string -(** [of_char 'a' = "a"] +(** [of_char 'a' = "a"]. @since 0.19 *) val of_gen : char gen -> string @@ -135,13 +140,13 @@ val find : ?start:int -> sub:string -> string -> int val find_all : ?start:int -> sub:string -> string -> int gen (** [find_all ~sub s] finds all occurrences of [sub] in [s], even overlapping instances. - @param start starting position in [s] + @param start starting position in [s]. @since 0.17 *) val find_all_l : ?start:int -> sub:string -> string -> int list (** [find_all ~sub s] finds all occurrences of [sub] in [s] and returns - them in a list - @param start starting position in [s] + them in a list. + @param start starting position in [s]. @since 0.17 *) (*$= & ~printer:Q.Print.(list int) @@ -152,7 +157,7 @@ val find_all_l : ?start:int -> sub:string -> string -> int list *) val mem : ?start:int -> sub:string -> string -> bool -(** [mem ~sub s] is true iff [sub] is a substring of [s] +(** [mem ~sub s] is true iff [sub] is a substring of [s]. @since 0.12 *) (*$T @@ -162,7 +167,7 @@ val mem : ?start:int -> sub:string -> string -> bool val rfind : sub:string -> string -> int (** Find [sub] in string from the right, returns its first index or [-1]. - Should only be used with very small [sub] + Should only be used with very small [sub]. @since 0.12 *) (*$= & ~printer:string_of_int @@ -180,14 +185,14 @@ val rfind : sub:string -> string -> int *) val replace : ?which:[`Left|`Right|`All] -> sub:string -> by:string -> string -> string -(** [replace ~sub ~by s] replaces some occurrences of [sub] by [by] in [s] +(** [replace ~sub ~by s] replaces some occurrences of [sub] by [by] in [s]. @param which decides whether the occurrences to replace are: {ul {- [`Left] first occurrence from the left (beginning)} {- [`Right] first occurrence from the right (end)} {- [`All] all occurrences (default)} } - @raise Invalid_argument if [sub = ""] + @raise Invalid_argument if [sub = ""]. @since 0.14 *) (*$= & ~printer:CCFun.id @@ -203,13 +208,13 @@ val replace : ?which:[`Left|`Right|`All] -> sub:string -> by:string -> string -> val is_sub : sub:string -> int -> string -> int -> len:int -> bool (** [is_sub ~sub i s j ~len] returns [true] iff the substring of [sub] starting at position [i] and of length [len] is a substring - of [s] starting at position [j] *) + of [s] starting at position [j]. *) val repeat : string -> int -> string -(** The same string, repeated n times *) +(** The same string, repeated n times. *) val prefix : pre:string -> string -> bool -(** [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" @@ -222,7 +227,7 @@ val prefix : pre:string -> string -> bool *) val suffix : suf:string -> string -> bool -(** [suffix ~suf s] returns [true] iff [suf] is a suffix of [s] +(** [suffix ~suf s] returns [true] iff [suf] is a suffix of [s]. @since 0.7 *) (*$T @@ -234,8 +239,8 @@ val suffix : suf:string -> string -> bool *) val chop_prefix : pre:string -> string -> string option -(** [chop_pref ~pre s] removes [pre] from [s] if [pre] really is a prefix - of [s], returns [None] otherwise +(** [chop_prefix ~pre s] removes [pre] from [s] if [pre] really is a prefix + of [s], returns [None] otherwise. @since 0.17 *) (*$= & ~printer:Q.Print.(option string) @@ -246,7 +251,7 @@ val chop_prefix : pre:string -> string -> string option val chop_suffix : suf:string -> string -> string option (** [chop_suffix ~suf s] removes [suf] from [s] if [suf] really is a suffix - of [s], returns [None] otherwise + of [s], returns [None] otherwise. @since 0.17 *) (*$= & ~printer:Q.Print.(option string) @@ -256,15 +261,15 @@ val chop_suffix : suf:string -> string -> string option *) val take : int -> string -> string -(** [take n s] keeps only the [n] first chars of [s] +(** [take n s] keeps only the [n] first chars of [s]. @since 0.17 *) val drop : int -> string -> string -(** [drop n s] removes the [n] first chars of [s] +(** [drop n s] removes the [n] first chars of [s]. @since 0.17 *) val take_drop : int -> string -> string * string -(** [take_drop n s = take n s, drop n s] +(** [take_drop n s = take n s, drop n s]. @since 0.17 *) (*$= @@ -274,11 +279,11 @@ val take_drop : int -> string -> string * string *) val lines : string -> string list -(** [lines s] returns a list of the lines of [s] (splits along '\n') +(** [lines s] returns a list of the lines of [s] (splits along '\n'). @since 0.10 *) val lines_gen : string -> string gen -(** [lines_gen s] returns a generator of the lines of [s] (splits along '\n') +(** [lines_gen s] returns a generator of the lines of [s] (splits along '\n'). @since 0.10 *) (*$= & ~printer:Q.Print.(list @@ Printf.sprintf "%S") @@ -294,11 +299,11 @@ val concat_gen : sep:string -> string gen -> string @since 0.10 *) val unlines : string list -> string -(** [unlines l] concatenates all strings of [l], separated with '\n' +(** [unlines l] concatenates all strings of [l], separated with '\n'. @since 0.10 *) val unlines_gen : string gen -> string -(** [unlines_gen g] concatenates all strings of [g], separated with '\n' +(** [unlines_gen g] concatenates all strings of [g], separated with '\n'. @since 0.10 *) (*$= & ~printer:CCFun.id @@ -320,7 +325,7 @@ val unlines_gen : string gen -> string val set : string -> int -> char -> string (** [set s i c] creates a new string which is a copy of [s], except for index [i], which becomes [c]. - @raise Invalid_argument if [i] is an invalid index + @raise Invalid_argument if [i] is an invalid index. @since 0.12 *) (*$T @@ -330,19 +335,19 @@ val set : string -> int -> char -> string *) val iter : (char -> unit) -> string -> unit -(** Alias to {!String.iter} +(** Alias to {!String.iter}. @since 0.12 *) val iteri : (int -> char -> unit) -> string -> unit -(** Iter on chars with their index +(** Iter on chars with their index. @since 0.12 *) val map : (char -> char) -> string -> string -(** Map chars +(** Map chars. @since 0.12 *) val mapi : (int -> char -> char) -> string -> string -(** Map chars with their index +(** Map chars with their index. @since 0.12 *) val filter_map : (char -> char option) -> string -> string @@ -365,8 +370,8 @@ val filter : (char -> bool) -> string -> string *) val flat_map : ?sep:string -> (char -> string) -> string -> string -(** Map each chars to a string, then concatenates them all - @param sep optional separator between each generated string +(** Map each chars to a string, then concatenates them all. + @param sep optional separator between each generated string. @since 0.12 *) val for_all : (char -> bool) -> string -> bool @@ -380,11 +385,11 @@ val exists : (char -> bool) -> string -> bool include S with type t := string val ltrim : t -> t -(** trim space on the left (see {!String.trim} for more details) +(** Trim space on the left (see {!String.trim} for more details). @since 1.2 *) val rtrim : t -> t -(** trim space on the right (see {!String.trim} for more details) +(** Trim space on the right (see {!String.trim} for more details). @since 1.2 *) (*$= & ~printer:id @@ -408,39 +413,39 @@ val rtrim : t -> t (** {2 Operations on 2 strings} *) val map2 : (char -> char -> char) -> string -> string -> string -(** Map pairs of chars - @raise Invalid_argument if the strings have not the same length +(** Map pairs of chars. + @raise Invalid_argument if the strings have not the same length. @since 0.12 *) val iter2: (char -> char -> unit) -> string -> string -> unit -(** Iterate on pairs of chars - @raise Invalid_argument if the strings have not the same length +(** Iterate on pairs of chars. + @raise Invalid_argument if the strings have not the same length. @since 0.12 *) val iteri2: (int -> char -> char -> unit) -> string -> string -> unit -(** Iterate on pairs of chars with their index - @raise Invalid_argument if the strings have not the same length +(** Iterate on pairs of chars with their index. + @raise Invalid_argument if the strings have not the same length. @since 0.12 *) val fold2: ('a -> char -> char -> 'a) -> 'a -> string -> string -> 'a -(** Fold on pairs of chars - @raise Invalid_argument if the strings have not the same length +(** Fold on pairs of chars. + @raise Invalid_argument if the strings have not the same length. @since 0.12 *) val for_all2 : (char -> char -> bool) -> string -> string -> bool (** All pairs of chars respect the predicate? - @raise Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length. @since 0.12 *) val exists2 : (char -> char -> bool) -> string -> string -> bool (** Exists a pair of chars? - @raise Invalid_argument if the strings have not the same length + @raise Invalid_argument if the strings have not the same length. @since 0.12 *) (** {2 Ascii functions} Those functions are deprecated in {!String} since 4.03, so we provide - a stable alias for them even in older versions *) + a stable alias for them even in older versions. *) val capitalize_ascii : string -> string (** See {!String}. @since 0.18 *) @@ -472,7 +477,7 @@ val equal_caseless : string -> string -> bool (** {2 Finding} - A relatively efficient algorithm for finding sub-strings + A relatively efficient algorithm for finding sub-strings. @since 1.0 *) module Find : sig @@ -483,14 +488,14 @@ module Find : sig val rcompile : string -> [ `Reverse ] pattern val find : ?start:int -> pattern:[`Direct] pattern -> string -> int - (** Search for [pattern] in the string, left-to-right - @return the offset of the first match, -1 otherwise - @param start offset in string at which we start *) + (** Search for [pattern] in the string, left-to-right. + @return the offset of the first match, -1 otherwise. + @param start offset in string at which we start. *) val rfind : ?start:int -> pattern:[`Reverse] pattern -> string -> int - (** Search for [pattern] in the string, right-to-left - @return the offset of the start of the first match from the right, -1 otherwise - @param start right-offset in string at which we start *) + (** Search for [pattern] in the string, right-to-left. + @return the offset of the start of the first match from the right, -1 otherwise. + @param start right-offset in string at which we start. *) end (** {2 Splitting} *) @@ -498,10 +503,10 @@ end module Split : sig (** Specification of what to do with empty blocks, as in [split ~by:"-" "-a-b-"]. - - [{first=false; last=false}] will return [""; "a"; "b"; ""] - - [{first=true; last=false}] will return ["a"; "b" ""] - - [{first=false; last=true}] will return [""; "a"; "b"] - - [{first=true; last=true}] will return ["a"; "b"] + - [{first=false; last=false}] will return [""; "a"; "b"; ""]. + - [{first=true; last=false}] will return ["a"; "b" ""]. + - [{first=false; last=true}] will return [""; "a"; "b"]. + - [{first=true; last=true}] will return ["a"; "b"]. The default value of all remaining functions is [Drop_none]. @since 1.5 @@ -512,17 +517,17 @@ module Split : sig } val no_drop : drop_if_empty - (** Do not drop any group, even empty and on borders + (** Do not drop any group, even empty and on borders. @since 1.5 *) val list_ : ?drop:drop_if_empty -> by:string -> string -> (string*int*int) list - (** Eplit the given string along the given separator [by]. Should only + (** Split the given string along the given separator [by]. Should only be used with very small separators, otherwise use {!Containers_string.KMP}. @return a list of slices [(s,index,length)] that are separated by [by]. {!String.sub} can then be used to actually extract a string from the slice. - @raise Failure if [by = ""] *) + @raise Failure if [by = ""]. *) val gen : ?drop:drop_if_empty -> by:string -> string -> (string*int*int) gen @@ -533,7 +538,7 @@ module Split : sig (** {6 Copying functions} Those split functions actually copy the substrings, which can be - more convenient but less efficient in general *) + more convenient but less efficient in general. *) val list_cpy : ?drop:drop_if_empty -> by:string -> string -> string list @@ -551,12 +556,12 @@ module Split : sig val left : by:string -> string -> (string * string) option (** Split on the first occurrence of [by] from the leftmost part of - the string + the string. @since 0.12 *) val left_exn : by:string -> string -> string * string - (** Split on the first occurrence of [by] from the leftmost part of the string - @raise Not_found if [by] is not part of the string + (** Split on the first occurrence of [by] from the leftmost part of the string. + @raise Not_found if [by] is not part of the string. @since 0.16 *) (*$T @@ -569,12 +574,12 @@ module Split : sig val right : by:string -> string -> (string * string) option (** Split on the first occurrence of [by] from the rightmost part of - the string + the string. @since 0.12 *) val right_exn : by:string -> string -> string * string - (** Split on the first occurrence of [by] from the rightmost part of the string - @raise Not_found if [by] is not part of the string + (** Split on the first occurrence of [by] from the rightmost part of the string. + @raise Not_found if [by] is not part of the string. @since 0.16 *) (*$T @@ -586,7 +591,7 @@ module Split : sig end val split_on_char : char -> string -> string list -(** Split the string along the given char +(** Split the string along the given char. @since 1.2 *) (*$= & ~printer:Q.Print.(list string) @@ -601,7 +606,7 @@ val split_on_char : char -> string -> string list *) val split : by:string -> string -> string list -(** Alias to {!Split.list_cpy} +(** Alias to {!Split.list_cpy}. @since 1.2 *) (** {2 Utils} *) @@ -652,7 +657,7 @@ val compare_natural : string -> string -> int val edit_distance : string -> string -> int (** Edition distance between two strings. This satisfies the classical distance axioms: it is always positive, symmetric, and satisfies - the formula [distance a b + distance b c >= distance a c] *) + the formula [distance a b + distance b c >= distance a c]. *) (*$Q Q.(string_of_size Gen.(0 -- 30)) (fun s -> \ @@ -663,7 +668,7 @@ val edit_distance : string -> string -> int a string s' that is accepted by a. --> generate triples (s, i, c) where c is a char, s a non empty string - and i a valid index in s + and i a valid index in s. *) (*$QR @@ -687,24 +692,24 @@ val edit_distance : string -> string -> int module Sub : sig type t = string * int * int - (** A string, an offset, and the length of the slice *) + (** A string, an offset, and the length of the slice. *) val make : string -> int -> len:int -> t val full : string -> t - (** Full string *) + (** Full string. *) val copy : t -> string - (** Make a copy of the substring *) + (** Make a copy of the substring. *) val underlying : t -> string val sub : t -> int -> int -> t - (** Sub-slice *) + (** Sub-slice. *) val get : t -> int -> char - (** [get s i] gets the [i]-th element, or fails - @raise Invalid_argument if the index is not within [0... length -1] + (** [get s i] gets the [i]-th element, or fails. + @raise Invalid_argument if the index is not within [0 ... length - 1]. @since 1.2 *) include S with type t := t @@ -718,7 +723,7 @@ module Sub : sig (*$T let sub = Sub.make " abc " 1 ~len:3 in \ - "\"abc\"" = (CCFormat.to_string Sub.print sub) + "\"abc\"" = (CCFormat.to_string Sub.pp sub) *) (*$= & ~printer:(String.make 1) diff --git a/src/core/CCVector.ml b/src/core/CCVector.ml index 13586ae7..32d4bb33 100644 --- a/src/core/CCVector.ml +++ b/src/core/CCVector.ml @@ -297,7 +297,7 @@ let compare cmp v1 v2 = let n = min v1.size v2.size in let rec check i = if i = n - then Pervasives.compare v1.size v2.size + then compare v1.size v2.size else let c = cmp (get v1 i) (get v2 i) in if c = 0 then check (i+1) else c @@ -513,7 +513,7 @@ let for_all p v = else p v.vec.(i) && check (i+1) in check 0 -let member ?(eq=(=)) x v = +let member ~eq x v = exists (eq x) v let find_exn p v = diff --git a/src/core/CCVector.mli b/src/core/CCVector.mli index edb60897..b570905e 100644 --- a/src/core/CCVector.mli +++ b/src/core/CCVector.mli @@ -118,7 +118,7 @@ val shrink : ('a, rw) t -> int -> unit (** Shrink to the given size (remove elements above this size). Does nothing if the parameter is bigger than the current size. *) -val member : ?eq:('a -> 'a -> bool) -> 'a -> ('a, _) t -> bool +val member : eq:('a -> 'a -> bool) -> 'a -> ('a, _) t -> bool (** Is the element a member of the vector? *) val sort : ('a -> 'a -> int) -> ('a, _) t -> ('a, 'mut) t diff --git a/src/core/containers.ml b/src/core/containers.ml index cb3f4814..6db033eb 100644 --- a/src/core/containers.ml +++ b/src/core/containers.ml @@ -42,3 +42,6 @@ module Result = CCResult module Set = CCSet module String = CCString module Vector = CCVector +module Monomorphic = CCMonomorphic + +include Monomorphic diff --git a/src/core/jbuild b/src/core/jbuild new file mode 100644 index 00000000..172c8daf --- /dev/null +++ b/src/core/jbuild @@ -0,0 +1,9 @@ + +(library + ((name containers) + (public_name containers) + (wrapped false) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string -nolabels -open CCMonomorphic)) + (ocamlopt_flags (:standard (:include ../flambda.flags))) + (libraries (bytes result containers.monomorphic)) + )) diff --git a/src/data/CCBV.ml b/src/data/CCBV.ml index 2fb734de..793eb456 100644 --- a/src/data/CCBV.ml +++ b/src/data/CCBV.ml @@ -257,17 +257,21 @@ let iter bv f = [30; 100; 255; 256;10_000] *) +(*$inject + let seq_zip s k = s (fun x y -> k(x,y)) +*) + (*$= & ~printer:Q.Print.(list (pair int bool)) - [] (iter (create ~size:0 false) |> Sequence.zip |> Sequence.to_list) + [] (iter (create ~size:0 false) |> seq_zip |> Sequence.to_list) [0, false; 1, true; 2, false] \ - (iter (let bv = create ~size:3 false in set bv 1; bv) |> Sequence.zip |> Sequence.to_list) + (iter (let bv = create ~size:3 false in set bv 1; bv) |> seq_zip |> Sequence.to_list) *) (*$Q Q.(small_int) (fun n -> \ assert (n >= 0); \ let bv = create ~size:n true in \ - let l = iter bv |> Sequence.zip |> Sequence.to_list in \ + let l = iter bv |> seq_zip |> Sequence.to_list in \ List.length l = n && List.for_all (fun (_,b) -> b) l) *) @@ -549,7 +553,7 @@ let of_seq seq = |> CCList.of_seq |> List.sort CCOrd.compare = CCList.range 0 10 *) -let print out bv = +let pp out bv = Format.pp_print_string out "bv {"; iter bv (fun _i b -> diff --git a/src/data/CCBV.mli b/src/data/CCBV.mli index a67d28e5..be0b3053 100644 --- a/src/data/CCBV.mli +++ b/src/data/CCBV.mli @@ -16,13 +16,13 @@ type t (** A resizable bitvector *) val empty : unit -> t -(** Empty bitvector *) +(** Empty bitvector. *) val create : size:int -> bool -> t -(** Create a bitvector of given size, with given default value *) +(** Create a bitvector of given size, with given default value. *) val copy : t -> t -(** Copy of bitvector *) +(** Copy of bitvector. *) val cardinal : t -> int (** Number of bits set to one, seen as a set of bits. *) @@ -51,7 +51,7 @@ val set : t -> int -> unit (** Set i-th bit, extending the bitvector if needed. *) val get : t -> int -> bool -(** Is the i-th bit true? Returns false if the index is too high*) +(** Is the i-th bit true? Returns false if the index is too high. *) val reset : t -> int -> unit (** Set i-th bit to 0, extending the bitvector if needed. *) @@ -60,20 +60,20 @@ val flip : t -> int -> unit (** Flip i-th bit, extending the bitvector if needed. *) val clear : t -> unit -(** Set every bit to 0 *) +(** Set every bit to 0. *) val iter : t -> (int -> bool -> unit) -> unit -(** Iterate on all bits *) +(** Iterate on all bits. *) val iter_true : t -> (int -> unit) -> unit -(** Iterate on bits set to 1 *) +(** Iterate on bits set to 1. *) val to_list : t -> int list -(** List of indexes that are true *) +(** List of indexes that are true. *) val to_sorted_list : t -> int list (** Same as {!to_list}, but also guarantees the list is sorted in - increasing order *) + increasing order. *) val of_list : int list -> t (** From a list of true bits. @@ -87,12 +87,12 @@ val first : t -> int option val first_exn : t -> int (** First set bit, or - @raise Not_found if all bits are 0 + @raise Not_found if all bits are 0. @since 1.2 *) val filter : t -> (int -> bool) -> unit (** [filter bv p] only keeps the true bits of [bv] whose [index] - satisfies [p index] *) + satisfies [p index]. *) val negate_self : t -> unit (** [negate_self t] flips all of the bits in [t]. @@ -103,28 +103,26 @@ val negate : t -> t (** [negate t] returns a copy of [t] with all of the bits flipped. *) val union_into : into:t -> t -> unit -(** [union ~into bv] sets [into] to the union of itself and [bv]. - +(** [union_into ~into bv] sets [into] to the union of itself and [bv]. Also updates the length of [into] to be at least [length bv]. *) val inter_into : into:t -> t -> unit -(** [inter ~into bv] sets [into] to the intersection of itself and [bv] - +(** [inter_into ~into bv] sets [into] to the intersection of itself and [bv]. Also updates the length of [into] to be at most [length bv]. *) val union : t -> t -> t -(** [union bv1 bv2] returns the union of the two sets *) +(** [union bv1 bv2] returns the union of the two sets. *) val inter : t -> t -> t -(** [inter bv1 bv2] returns the intersection of the two sets *) +(** [inter bv1 bv2] returns the intersection of the two sets. *) val diff_into : into:t -> t -> unit -(** [diff ~into t] Modify [into] with only the bits set but not in [t]. +(** [diff_into ~into t] modifies [into] with only the bits set but not in [t]. @since 1.2 *) val diff : t -> t -> t -(** [diff t1 t2] Return those bits found [t1] but not in [t2]. +(** [diff t1 t2] returns those bits found in [t1] but not in [t2]. @since 1.2 *) @@ -135,13 +133,13 @@ val select : t -> 'a array -> 'a list selected. *) val selecti : t -> 'a array -> ('a * int) list -(** Same as {!select}, but selected elements are paired with their index *) +(** Same as {!select}, but selected elements are paired with their indexes. *) type 'a sequence = ('a -> unit) -> unit val to_seq : t -> int sequence val of_seq : int sequence -> t -val print : Format.formatter -> t -> unit -(** Print the bitvector as a string of bits +val pp : Format.formatter -> t -> unit +(** Print the bitvector as a string of bits. @since 0.13 *) diff --git a/src/data/CCBitField.mli b/src/data/CCBitField.mli index 6821855e..9607e6f4 100644 --- a/src/data/CCBitField.mli +++ b/src/data/CCBitField.mli @@ -25,13 +25,13 @@ *) exception TooManyFields -(** Raised when too many fields are packed into one bitfield *) +(** Raised when too many fields are packed into one bitfield. *) exception Frozen -(** Raised when a frozen bitfield is modified *) +(** Raised when a frozen bitfield is modified. *) val max_width : int -(** System-dependent maximum width for a bitfield, typically 30 or 62 *) +(** System-dependent maximum width for a bitfield, typically 30 or 62. *) (** {2 Bitfield Signature} *) module type S = sig @@ -40,25 +40,25 @@ module type S = sig should create a new, incompatible type *) val empty : t - (** Empty bitfields (all bits 0) *) + (** Empty bitfields (all bits 0). *) type field val get : field -> t -> bool - (** Get the value of this field *) + (** Get the value of this field. *) val set : field -> bool -> t -> t - (** Set the value of this field *) + (** Set the value of this field. *) val mk_field : unit -> field - (** Make a new field *) + (** Make a new field. *) val freeze : unit -> unit (** Prevent new fields from being added. From now on, creating - a field will raise Frozen *) + a field will raise Frozen. *) val total_width : unit -> int - (** Current width of the bitfield *) + (** Current width of the bitfield. *) end (** Create a new bitfield type *) diff --git a/src/data/CCCache.ml b/src/data/CCCache.ml index ec956458..e8cf3426 100644 --- a/src/data/CCCache.ml +++ b/src/data/CCCache.ml @@ -6,7 +6,6 @@ type 'a equal = 'a -> 'a -> bool type 'a hash = 'a -> int -let default_eq_ = Pervasives.(=) let default_hash_ = Hashtbl.hash (** {2 Value interface} *) @@ -57,7 +56,7 @@ let with_cache_rec ?(cb=default_callback_) c f = f' (*$R - let c = unbounded 256 in + let c = unbounded ~eq:CCInt.equal 256 in let fib = with_cache_rec c (fun self n -> match n with | 1 | 2 -> 1 @@ -124,7 +123,7 @@ module Linear = struct !r end -let linear ?(eq=default_eq_) size = +let linear ~eq size = let size = max size 1 in let arr = Linear.make eq size in { get=(fun x -> Linear.get arr x); @@ -161,9 +160,13 @@ module Replacing = struct | Pair _ | Empty -> raise Not_found + let is_empty = function + | Empty -> true + | Pair _ -> false + let set c x y = let i = c.hash x mod Array.length c.arr in - if c.arr.(i) = Empty then c.c_size <- c.c_size + 1; + if is_empty c.arr.(i) then c.c_size <- c.c_size + 1; c.arr.(i) <- Pair (x,y) let iter c f = @@ -172,7 +175,7 @@ module Replacing = struct let size c () = c.c_size end -let replacing ?(eq=default_eq_) ?(hash=default_hash_) size = +let replacing ~eq ?(hash=default_hash_) size = let c = Replacing.make eq hash size in { get=(fun x -> Replacing.get c x); set=(fun x y -> Replacing.set c x y); @@ -219,7 +222,7 @@ module LRU(X:HASH) = struct (* take first from queue *) let take_ c = match c.first with - | Some n when n.next == n -> + | Some n when Pervasives.(==) n.next n -> (* last element *) c.first <- None; n @@ -238,7 +241,7 @@ module LRU(X:HASH) = struct n.next <- n; n.prev <- n; c.first <- Some n - | Some n1 when n1==n -> () + | Some n1 when Pervasives.(==) n1 n -> () | Some n1 -> n.prev <- n1.prev; n.next <- n1; @@ -294,7 +297,7 @@ module LRU(X:HASH) = struct H.iter (fun x node -> f x node.value) c.table end -let lru (type a) ?(eq=default_eq_) ?(hash=default_hash_) size = +let lru (type a) ~eq ?(hash=default_hash_) size = let module L = LRU(struct type t = a let equal = eq @@ -318,7 +321,7 @@ let lru (type a) ?(eq=default_eq_) ?(hash=default_hash_) size = (*$T let f = (let r = ref 0 in fun _ -> incr r; !r) in \ - let c = lru 2 in \ + let c = lru ~eq:CCInt.equal 2 in \ let res1 = with_cache c f 1 in \ let res2 = with_cache c f 2 in \ let res3 = with_cache c f 3 in \ @@ -328,7 +331,7 @@ let lru (type a) ?(eq=default_eq_) ?(hash=default_hash_) size = (*$R let f = (let r = ref 0 in fun _ -> incr r; !r) in - let c = lru 2 in + let c = lru ~eq:CCEqual.unit 2 in let x = with_cache c f () in assert_equal 1 x; assert_equal 1 (size c); @@ -356,7 +359,7 @@ module UNBOUNDED(X:HASH) = struct let iter c f = H.iter f c end -let unbounded (type a) ?(eq=default_eq_) ?(hash=default_hash_) size = +let unbounded (type a) ~eq ?(hash=default_hash_) size = let module C = UNBOUNDED(struct type t = a let equal = eq diff --git a/src/data/CCCache.mli b/src/data/CCCache.mli index 28c287b2..b2e7b590 100644 --- a/src/data/CCCache.mli +++ b/src/data/CCCache.mli @@ -29,7 +29,7 @@ type 'a hash = 'a -> int type ('a, 'b) t val clear : (_,_) t -> unit -(** Clear the content of the cache *) +(** Clear the content of the cache. *) type ('a, 'b) callback = in_cache:bool -> 'a -> 'b -> unit (** Type of the callback that is called once a cached value is found @@ -44,7 +44,7 @@ val with_cache : ?cb:('a, 'b) callback -> ('a, 'b) t -> ('a -> 'b) -> 'a -> 'b cache [c]. It always returns the same value as [f x], if [f x] returns, or raise the same exception. However, [f] may not be called if [x] is in the cache. - @param cb called after the value is generated or retrieved *) + @param cb called after the value is generated or retrieved. *) val with_cache_rec : ?cb:('a, 'b) callback -> ('a,'b) t -> (('a -> 'b) -> 'a -> 'b) -> 'a -> 'b (** [with_cache_rec c f] is a function that first, applies [f] to @@ -61,7 +61,7 @@ val with_cache_rec : ?cb:('a, 'b) callback -> ('a,'b) t -> (('a -> 'b) -> 'a -> fib 70;; ]} - @param cb called after the value is generated or retrieved + @param cb called after the value is generated or retrieved. *) val size : (_,_) t -> int @@ -72,20 +72,20 @@ val iter : ('a,'b) t -> ('a -> 'b -> unit) -> unit (** Iterate on cached values. Should yield [size cache] pairs. *) val add : ('a, 'b) t -> 'a -> 'b -> bool -(** Manually add a cached value. Returns [true] if the value has succesfully +(** Manually add a cached value. Returns [true] if the value has successfully been added, and [false] if the value was already bound. @since 1.5 *) val dummy : ('a,'b) t -(** Dummy cache, never stores any value *) +(** Dummy cache, never stores any value. *) -val linear : ?eq:'a equal -> int -> ('a, 'b) t +val linear : eq:'a equal -> int -> ('a, 'b) t (** Linear cache with the given size. It stores key/value pairs in an array and does linear search at every call, so it should only be used with small size. - @param eq optional equality predicate for keys *) + @param eq optional equality predicate for keys. *) -val replacing : ?eq:'a equal -> ?hash:'a hash -> +val replacing : eq:'a equal -> ?hash:'a hash -> int -> ('a,'b) t (** Replacing cache of the given size. Equality and hash functions can be parametrized. It's a hash table that handles collisions by replacing @@ -93,12 +93,12 @@ val replacing : ?eq:'a equal -> ?hash:'a hash -> entry with the same hash (modulo size) is added). Never grows wider than the given size. *) -val lru : ?eq:'a equal -> ?hash:'a hash -> +val lru : eq:'a equal -> ?hash:'a hash -> int -> ('a,'b) t (** LRU cache of the given size ("Least Recently Used": keys that have not been used recently are deleted first). Never grows wider than the given size. *) -val unbounded : ?eq:'a equal -> ?hash:'a hash -> +val unbounded : eq:'a equal -> ?hash:'a hash -> int -> ('a,'b) t (** Unbounded cache, backed by a Hash table. Will grow forever unless {!clear} is called manually. *) diff --git a/src/data/CCDeque.ml b/src/data/CCDeque.ml index 9453e464..ca4e038d 100644 --- a/src/data/CCDeque.ml +++ b/src/data/CCDeque.ml @@ -74,9 +74,11 @@ let is_zero_ n = match n.cell with | Two _ | Three _ -> false +let bool_eq (a : bool) b = Pervasives.(=) a b + let is_empty d = let res = d.size = 0 in - assert (res = is_zero_ d.cur); + assert (bool_eq res (is_zero_ d.cur)); res let push_front d x = @@ -161,7 +163,7 @@ let take_back_node_ n = match n.cell with let take_back d = if is_empty d then raise Empty - else if d.cur == d.cur.prev + else if Pervasives.(==) d.cur d.cur.prev then ( (* only one cell *) decr_size_ d; @@ -194,7 +196,7 @@ let take_front_node_ n = match n.cell with let take_front d = if is_empty d then raise Empty - else if d.cur.prev == d.cur + else if Pervasives.(==) d.cur.prev d.cur then ( (* only one cell *) decr_size_ d; @@ -253,7 +255,7 @@ let fold f acc d = | Two (x,y) -> f (f acc x) y | Three (x,y,z) -> f (f (f acc x) y) z in - if n.next == first then acc else aux ~first f acc n.next + if Pervasives.(==) n.next first then acc else aux ~first f acc n.next in aux ~first:d.cur f acc d.cur @@ -335,7 +337,7 @@ let to_gen q = let cell = ref q.cur.cell in let cur = ref q.cur in let rec next () = match !cell with - | Zero when (!cur).next == first -> None + | Zero when Pervasives.(==) (!cur).next first -> None | Zero -> (* go to next node *) let n = !cur in @@ -367,7 +369,7 @@ let copy d = let q = of_list [1;2;3;4] in assert_equal 4 (length q); let q' = copy q in - let cmp = equal ?eq:None in + let cmp = equal ~eq:CCInt.equal in assert_equal 4 (length q'); assert_equal ~cmp q q'; push_front q 0; @@ -377,7 +379,7 @@ let copy d = assert_equal ~cmp q q' *) -let equal ?(eq=(=)) a b = +let equal ~eq a b = let rec aux eq a b = match a() , b() with | None, None -> true | None, Some _ @@ -385,7 +387,7 @@ let equal ?(eq=(=)) a b = | Some x, Some y -> eq x y && aux eq a b in aux eq (to_gen a) (to_gen b) -let compare ?(cmp=Pervasives.compare) a b = +let compare ~cmp a b = let rec aux cmp a b = match a() , b() with | None, None -> 0 | None, Some _ -> -1 @@ -397,13 +399,13 @@ let compare ?(cmp=Pervasives.compare) a b = (*$Q Q.(pair (list int) (list int)) (fun (l1,l2) -> \ - CCOrd.equiv (compare (of_list l1) (of_list l2)) \ + CCOrd.equiv (compare ~cmp:Pervasives.compare (of_list l1) (of_list l2)) \ (CCList.compare Pervasives.compare l1 l2)) *) type 'a printer = Format.formatter -> 'a -> unit -let print pp_x out d = +let pp pp_x out d = let first = ref true in Format.fprintf out "@[deque {"; iter @@ -412,4 +414,3 @@ let print pp_x out d = pp_x out x ) d; Format.fprintf out "}@]" - diff --git a/src/data/CCDeque.mli b/src/data/CCDeque.mli index c0bde886..c0b6b8c3 100644 --- a/src/data/CCDeque.mli +++ b/src/data/CCDeque.mli @@ -4,7 +4,7 @@ (** {1 Imperative deque} This structure provides fast access to its front and back elements, - with O(1) operations*) + with O(1) operations *) type 'a t (** Contains 'a elements, queue in both ways *) @@ -12,64 +12,64 @@ type 'a t exception Empty val create : unit -> 'a t -(** New deque *) +(** New deque. *) val clear : _ t -> unit -(** Remove all elements +(** Remove all elements. @since 0.13 *) val is_empty : 'a t -> bool (** Is the deque empty? *) -val equal : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool +val equal : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal a b] checks whether [a] and [b] contain the same sequence of elements. - @param eq comparison function for elements + @param eq comparison function for elements. @since 0.13 *) -val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int +val compare : cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int (** [compare a b] compares lexicographically [a] and [b] - @param cmp comparison function for elements + @param cmp comparison function for elements. @since 0.13 *) val length : 'a t -> int -(** Number of elements - used to be linear time, now constant time *) +(** Number of elements. + Used to be linear time, now constant time. *) val push_front : 'a t -> 'a -> unit -(** Push value at the front *) +(** Push value at the front. *) val push_back : 'a t -> 'a -> unit -(** Push value at the back *) +(** Push value at the back. *) val peek_front : 'a t -> 'a -(** First value, or @raise Empty if empty *) +(** First value, or @raise Empty if empty. *) val peek_back : 'a t -> 'a -(** Last value, or @raise Empty if empty *) +(** Last value, or @raise Empty if empty. *) val take_back : 'a t -> 'a -(** Take last value, or @raise Empty if empty *) +(** Take last value, or @raise Empty if empty. *) val take_front : 'a t -> 'a -(** Take first value, or @raise Empty if empty *) +(** Take first value, or @raise Empty if empty. *) val append_front : into:'a t -> 'a t -> unit (** [append_front ~into q] adds all elements of [q] at the front - of [into] - O(length q) in time + of [into]. + [O(length q)] in time. @since 0.13 *) val append_back : into:'a t -> 'a t -> unit (** [append_back ~into q] adds all elements of [q] at the back of [into]. - O(length q) in time + [O(length q)] in time. @since 0.13 *) val iter : ('a -> unit) -> 'a t -> unit -(** Iterate on elements *) +(** Iterate on elements. *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b -(** Fold on elements +(** Fold on elements. @since 0.13 *) (** {2 Conversions} *) @@ -80,36 +80,36 @@ type 'a sequence = ('a -> unit) -> unit val of_seq : 'a sequence -> 'a t (** Create a deque from the sequence. @since 0.13 optional argument [deque] disappears, use - {!add_seq_back} instead *) + {!add_seq_back} instead. *) val to_seq : 'a t -> 'a sequence -(** iterate on the elements *) +(** Iterate on the elements. *) val of_gen : 'a gen -> 'a t -(** [of_gen g] makes a deque containing the elements of [g] +(** [of_gen g] makes a deque containing the elements of [g]. @since 0.13 *) val to_gen : 'a t -> 'a gen -(** Iterates on elements of the deque +(** Iterate on elements of the deque. @since 0.13 *) val add_seq_front : 'a t -> 'a sequence -> unit (** [add_seq_front q seq] adds elements of [seq] into the front of [q], in reverse order. - O(n) in time, where [n] is the number of elements to add. + [O(n)] in time, where [n] is the number of elements to add. @since 0.13 *) val add_seq_back : 'a t -> 'a sequence -> unit (** [add_seq_back q seq] adds elements of [seq] into the back of [q], in order. - O(n) in time, where [n] is the number of elements to add. + [O(n)] in time, where [n] is the number of elements to add. @since 0.13 *) val copy : 'a t -> 'a t -(** Fresh copy, O(n) in time *) +(** Fresh copy, [O(n)] in time. *) val of_list : 'a list -> 'a t -(** Conversion from list, in order +(** Conversion from list, in order. @since 0.13 *) val to_list : 'a t -> 'a list @@ -117,13 +117,13 @@ val to_list : 'a t -> 'a list @since 0.13 *) val to_rev_list : 'a t -> 'a list -(** Efficient conversion to list, in reverse order +(** Efficient conversion to list, in reverse order. @since 0.13 *) (** {2 print} *) type 'a printer = Format.formatter -> 'a -> unit -val print : 'a printer -> 'a t printer -(** Print the elements +val pp : 'a printer -> 'a t printer +(** Print the elements. @since 0.13 *) diff --git a/src/data/CCFQueue.ml b/src/data/CCFQueue.ml index de6848f1..fd1f99e8 100644 --- a/src/data/CCFQueue.ml +++ b/src/data/CCFQueue.ml @@ -34,10 +34,14 @@ let empty = Shallow Zero exception Empty +let is_not_zero = function + | Zero -> false + | One _ | Two _ | Three _ -> true + let _single x = Shallow (One x) let _double x y = Shallow (Two (x,y)) let _deep n hd middle tl = - assert (hd<>Zero && tl<>Zero); + assert (is_not_zero hd && is_not_zero tl); Deep (n, hd, middle, tl) let is_empty = function @@ -511,7 +515,7 @@ let (--^) a b = 0 --^ 0 |> to_list = [] *) -let print pp_x out d = +let pp pp_x out d = let first = ref true in Format.fprintf out "@[queue {"; iter diff --git a/src/data/CCFQueue.mli b/src/data/CCFQueue.mli index fddb78ac..4fce8b7d 100644 --- a/src/data/CCFQueue.mli +++ b/src/data/CCFQueue.mli @@ -24,67 +24,67 @@ val doubleton : 'a -> 'a -> 'a t exception Empty val cons : 'a -> 'a t -> 'a t -(** Push element at the front of the queue *) +(** Push element at the front of the queue. *) val snoc : 'a t -> 'a -> 'a t -(** Push element at the end of the queue *) +(** Push element at the end of the queue. *) val take_front : 'a t -> ('a * 'a t) option -(** Get and remove the first element *) +(** Get and remove the first element. *) val take_front_exn : 'a t -> ('a * 'a t) (** Same as {!take_front}, but fails on empty queues. - @raise Empty if the queue is empty *) + @raise Empty if the queue is empty. *) val take_front_l : int -> 'a t -> 'a list * 'a t (** [take_front_l n q] takes at most [n] elements from the front - of [q], and returns them wrapped in a list - @raise Invalid_argument if n<0 *) + of [q], and returns them wrapped in a list. + @raise Invalid_argument if n<0. *) val take_front_while : ('a -> bool) -> 'a t -> 'a list * 'a t val take_back : 'a t -> ('a t * 'a) option -(** Take last element *) +(** Take last element. *) val take_back_exn : 'a t -> ('a t * 'a) (** Same as {!take_back}, but fails on empty queues. - @raise Empty if the queue is empty *) + @raise Empty if the queue is empty. *) val take_back_l : int -> 'a t -> 'a t * 'a list (** [take_back_l n q] removes and returns the last [n] elements of [q]. The elements are in the order of the queue, that is, the head of the returned list is the first element to appear via {!take_front}. - [take_back_l 2 (of_list [1;2;3;4]) = of_list [1;2], [3;4]] - @raise Invalid_argument if n<0 *) + [take_back_l 2 (of_list [1;2;3;4]) = of_list [1;2], [3;4]]. + @raise Invalid_argument if n<0. *) val take_back_while : ('a -> bool) -> 'a t -> 'a t * 'a list (** {2 Individual extraction} *) val first : 'a t -> 'a option -(** First element of the queue *) +(** First element of the queue. *) val last : 'a t -> 'a option -(** Last element of the queue *) +(** Last element of the queue. *) val first_exn : 'a t -> 'a (** Same as {!first} but - @raise Empty if the queue is empty *) + @raise Empty if the queue is empty. *) val last_exn : 'a t -> 'a val nth : int -> 'a t -> 'a option -(** Return the [i]-th element of the queue in logarithmic time *) +(** Return the [i]-th element of the queue in logarithmic time. *) val nth_exn : int -> 'a t -> 'a -(** Unsafe version of {!nth} - @raise Not_found if the index is wrong *) +(** Unsafe version of {!nth}. + @raise Not_found if the index is wrong. *) val tail : 'a t -> 'a t -(** Queue deprived of its first element. Does nothing on empty queues *) +(** Queue deprived of its first element. Does nothing on empty queues. *) val init : 'a t -> 'a t -(** Queue deprived of its last element. Does nothing on empty queues *) +(** Queue deprived of its last element. Does nothing on empty queues. *) (** {2 Global Operations} *) @@ -94,17 +94,17 @@ val append : 'a t -> 'a t -> 'a t Linear in the size of the second queue. *) val rev : 'a t -> 'a t -(** Reverse the queue, O(n) complexity +(** Reverse the queue, [O(n)] complexity. @since 0.10 *) val map : ('a -> 'b) -> 'a t -> 'b t -(** Map values *) +(** Map values. *) val (>|=) : 'a t -> ('a -> 'b) -> 'b t -(** Synonym to {!map} *) +(** Synonym to {!map}. *) val size : 'a t -> int -(** Number of elements in the queue (constant time) *) +(** Number of elements in the queue (constant time). *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b @@ -135,5 +135,5 @@ val (--^) : int -> int -> int t (** [a -- b] is the integer range from [a] to [b], where [b] is excluded. @since 0.17 *) -val print : 'a printer -> 'a t printer +val pp : 'a printer -> 'a t printer (** @since 0.13 *) diff --git a/src/data/CCFlatHashtbl.ml b/src/data/CCFlatHashtbl.ml deleted file mode 100644 index 3be31ae9..00000000 --- a/src/data/CCFlatHashtbl.ml +++ /dev/null @@ -1,388 +0,0 @@ -(* -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 Open-Addressing Hash-table} - - We use Robin-Hood hashing as described in - http://codecapsule.com/2013/11/17/robin-hood-hashing-backward-shift-deletion/ - with backward shift. *) - -type 'a sequence = ('a -> unit) -> unit - -module type S = sig - type key - type 'a t - - val create : int -> 'a t - (** Create a new table of the given initial capacity *) - - val mem : 'a t -> key -> bool - (** [mem tbl k] returns [true] iff [k] is mapped to some value - in [tbl] *) - - val find : 'a t -> key -> 'a option - - val find_exn : 'a t -> key -> 'a - - val get : key -> 'a t -> 'a option - (** [get k tbl] recovers the value for [k] in [tbl], or - returns [None] if [k] doesn't belong *) - - val get_exn : key -> 'a t -> 'a - - val add : 'a t -> key -> 'a -> unit - (** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old - value associated with [k]. *) - - val remove : 'a t -> key -> unit - (** Remove binding *) - - val size : _ t -> int - (** Number of bindings *) - - val of_list : (key * 'a) list -> 'a t - val to_list : 'a t -> (key * 'a) list - - val of_seq : (key * 'a) sequence -> 'a t - val to_seq : 'a t -> (key * 'a) sequence - - val keys : _ t -> key sequence - val values : 'a t -> 'a sequence -end - -module type HASHABLE = sig - type t - val equal : t -> t -> bool - val hash : t -> int -end - -module Make(X : HASHABLE) = struct - type key = X.t - - type 'a bucket = - | Empty - | Key of key * 'a * int (* store the hash too *) - - type 'a t = { - mutable arr : 'a bucket array; - mutable size : int; - } - - let size tbl = tbl.size - - let _reached_max_load tbl = - let n = Array.length tbl.arr in - (n - tbl.size) < n/10 (* full at 9/10 *) - - let create i = - let i = min Sys.max_array_length (max i 8) in - { arr=Array.make i Empty; size=0; } - - (* TODO: enforce that [tbl.arr] has a power of 2 as length, then - initial_index is just a mask with (length-1)? *) - - (* initial index for a value with hash [h] *) - let _initial_idx tbl h = - h mod Array.length tbl.arr - - let _succ tbl i = - let i' = i+1 in - if i' = Array.length tbl.arr then 0 else i' - - (* distance to initial bucket, at index [i] with hash [h] *) - let _dib tbl h ~i = - let i0 = _initial_idx tbl h in - if i>=i0 - then i - i0 - else i + (Array.length tbl.arr - i0) - - (* insert k->v in [tbl], currently at index [i] and distance [dib] *) - let rec _linear_probe tbl k v h_k i dib = - match tbl.arr.(i) with - | Empty -> - (* add binding *) - tbl.size <- 1 + tbl.size; - tbl.arr.(i) <- Key (k, v, h_k) - | Key (k', _, h_k') when X.equal k k' -> - (* replace *) - assert (h_k = h_k'); - tbl.arr.(i) <- Key (k, v, h_k) - | Key (k', v', h_k') -> - let dib' = _dib tbl h_k' ~i in - if dib > dib' - then ( - (* replace *) - tbl.arr.(i) <- Key (k, v, h_k); - _linear_probe tbl k' v' h_k' (_succ tbl i) (dib'+1) - ) else ( - (* go further *) - _linear_probe tbl k v h_k (_succ tbl i) (dib+1) - ) - - (* resize table: put a bigger array in it, then insert values - from the old array *) - let _resize tbl = - let size' = min Sys.max_array_length (2 * Array.length tbl.arr) in - let arr' = Array.make size' Empty in - let old_arr = tbl.arr in - (* replace with new table *) - tbl.size <- 0; - tbl.arr <- arr'; - Array.iter - (function - | Empty -> () - | Key (k, v, h_k) -> - _linear_probe tbl k v h_k (_initial_idx tbl h_k) 0) - old_arr - - let add tbl k v = - if _reached_max_load tbl then _resize tbl; - (* insert value *) - let h_k = X.hash k in - _linear_probe tbl k v h_k (_initial_idx tbl h_k) 0 - - (* shift back elements that have a DIB > 0 until an empty bucket - or a bucket that doesn't need shifting is met *) - let rec _backward_shift tbl ~prev:prev_i i = - match tbl.arr.(i) with - | Empty -> - tbl.arr.(prev_i) <- Empty; - | Key (_, _, h_k) as bucket -> - let d = _dib tbl h_k ~i in - assert (d >= 0); - if d > 0 then ( - (* shift backward *) - tbl.arr.(prev_i) <- bucket; - _backward_shift tbl ~prev:i (_succ tbl i) - ) else ( - tbl.arr.(prev_i) <- Empty; - ) - - (* linear probing for removal of [k]: find the bucket containing [k], - if any, and perform backward shift from there *) - let rec _linear_probe_remove tbl k h_k i dib = - match tbl.arr.(i) with - | Empty -> () - | Key (k', _, _) when X.equal k k' -> - tbl.size <- tbl.size - 1; - (* shift all elements that follow and have a DIB > 0; - it will also erase the last shifted bucket, and erase [i] in - any case *) - _backward_shift tbl ~prev:i (_succ tbl i) - | Key (_, _, h_k') -> - if dib > _dib tbl h_k' ~i - then () (* [k] not present, would be here otherwise *) - else _linear_probe_remove tbl k h_k (_succ tbl i) (dib+1) - - let remove tbl k = - let h_k = X.hash k in - _linear_probe_remove tbl k h_k (_initial_idx tbl h_k) 0 - - let rec get_exn_rec tbl k h_k i dib = - match tbl.arr.(i) with - | Empty -> raise Not_found - | Key (k', v', _) when X.equal k k' -> v' - | Key (_, _, h_k') -> - if dib > _dib tbl h_k' ~i - then raise Not_found (* [k] would be here otherwise *) - else get_exn_rec tbl k h_k (_succ tbl i) (dib+1) - - let get_exn k tbl = - let h_k = X.hash k in - let i0 = _initial_idx tbl h_k in - (* unroll a few steps *) - match tbl.arr.(i0) with - | Empty -> raise Not_found - | Key (k', v, _) -> - if X.equal k k' then v - else - let i1 = _succ tbl i0 in - match tbl.arr.(i1) with - | Empty -> raise Not_found - | Key (k', v, _) -> - if X.equal k k' then v - else - let i2 = _succ tbl i1 in - match tbl.arr.(i2) with - | Empty -> raise Not_found - | Key (k', v, _) -> - if X.equal k k' then v - else get_exn_rec tbl k h_k (_succ tbl i2) 3 - - let get k tbl = - try Some (get_exn k tbl) - with Not_found -> None - - let find_exn tbl k = get_exn k tbl - - let find tbl k = - try Some (get_exn k tbl) - with Not_found -> None - - let mem tbl k = - try ignore (get_exn k tbl); true - with Not_found -> false - - let of_list l = - let tbl = create 16 in - List.iter (fun (k,v) -> add tbl k v) l; - tbl - - let to_list tbl = - Array.fold_left - (fun acc bucket -> match bucket with - | Empty -> acc - | Key (k,v,_) -> (k,v)::acc) - [] tbl.arr - - let of_seq seq = - let tbl = create 16 in - seq (fun (k,v) -> add tbl k v); - tbl - - let to_seq tbl yield = - Array.iter - (function Empty -> () | Key (k, v, _) -> yield (k,v)) - tbl.arr - - let keys tbl yield = - Array.iter - (function Empty -> () | Key (k, _, _) -> yield k) - tbl.arr - - let values tbl yield = - Array.iter - (function Empty -> () | Key (_, v, _) -> yield v) - tbl.arr - - (* - let pp_debug_ out t = - let open T in - let pp_buck out (i,b) = match b with - | Empty -> Format.fprintf out "_" - | Key (k,v,h_k) -> - let dib = _dib t h_k ~i in - Format.fprintf out "[%d]{%d -> %d (dib=%d)}@," i (Obj.magic k) (Obj.magic v) dib - in - Format.fprintf out "@["; - Array.iteri - (fun i b -> pp_buck out (i,b)) - t.arr; - Format.fprintf out "@]"; - () - *) -end - -(*$inject - module T = Make(CCInt) - - let gen_l = - let g = Q.(list (pair small_int small_int)) in - Q.map_same_type - (CCList.sort_uniq ~cmp:(fun x y -> compare (fst x) (fst y))) - g - - - type op = - | Add of int*int - | Remove of int - - let op_add x y = Add (x,y) - let op_remove x = Remove x - - let op_exec t = function - | Add (x,y) -> T.add t x y - | Remove x -> T.remove t x - - let op_pp = function - | Add (x,y) -> Printf.sprintf "add(%d,%d)" x y - | Remove x -> Printf.sprintf "remove(%d)" x - - let gen_ops n = - let open Q.Gen in - let gen_op = - frequency - [ 2, return op_add <*> small_int <*> small_int - ; 1, return op_remove <*> small_int - ] - in - list_size (0--n) gen_op - - let arb_ops n : op list Q.arbitrary = - let shrink_op o = - let open Q.Iter in - match o with - | Add (x,y) -> - (return op_add <*> Q.Shrink.int x <*> return y) - <+> - (return op_add <*> return x <*> Q.Shrink.int y) - | Remove x -> map op_remove (Q.Shrink.int x) - in - let shrink = - Q.Shrink.list ~shrink:shrink_op in - let print = Q.Print.list op_pp in - Q.make ~shrink ~print (gen_ops n) - - module TRef = CCHashtbl.Make(CCInt) - - let op_exec_ref t = function - | Add (x,y) -> TRef.replace t x y - | Remove x -> TRef.remove t x -*) - -(*$T - let t = T.create 32 in \ - T.add t 0 "0"; T.find t 0 = Some "0" -*) - -(*$Q - gen_l (fun l -> \ - (T.of_list l |> T.to_list |> List.sort CCOrd.compare) = l) -*) - -(* test that the table behaves the same as a normal hashtable *) - -(*$inject - let test_ops l = - let t = T.create 16 in - let t' = TRef.create 16 in - List.iter (op_exec t) l; - List.iter (op_exec_ref t') l; - (T.to_list t |> List.sort CCOrd.compare) = - (TRef.to_list t' |> List.sort CCOrd.compare) -*) - -(*$Q & ~count:500 - (arb_ops 300) test_ops -*) - -(*$Q & ~count:10 - (arb_ops 3000) test_ops -*) - -(*$Q & ~count:5 - (arb_ops 30000) test_ops -*) diff --git a/src/data/CCFlatHashtbl.mli b/src/data/CCFlatHashtbl.mli deleted file mode 100644 index c9692bd5..00000000 --- a/src/data/CCFlatHashtbl.mli +++ /dev/null @@ -1,83 +0,0 @@ -(* -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 Open-Addressing Hash-table} - - This module was previously named [CCHashtbl], but the name is now used for - an extension of the standard library's hashtables. - - @since 0.4 *) - -type 'a sequence = ('a -> unit) -> unit - -module type S = sig - type key - type 'a t - - val create : int -> 'a t - (** Create a new table of the given initial capacity *) - - val mem : 'a t -> key -> bool - (** [mem tbl k] returns [true] iff [k] is mapped to some value - in [tbl] *) - - val find : 'a t -> key -> 'a option - - val find_exn : 'a t -> key -> 'a - - val get : key -> 'a t -> 'a option - (** [get k tbl] recovers the value for [k] in [tbl], or - returns [None] if [k] doesn't belong *) - - val get_exn : key -> 'a t -> 'a - - val add : 'a t -> key -> 'a -> unit - (** [add tbl k v] adds [k -> v] to [tbl], possibly replacing the old - value associated with [k]. *) - - val remove : 'a t -> key -> unit - (** Remove binding *) - - val size : _ t -> int - (** Number of bindings *) - - val of_list : (key * 'a) list -> 'a t - val to_list : 'a t -> (key * 'a) list - - val of_seq : (key * 'a) sequence -> 'a t - val to_seq : 'a t -> (key * 'a) sequence - - val keys : _ t -> key sequence - val values : 'a t -> 'a sequence -end - -module type HASHABLE = sig - type t - val equal : t -> t -> bool - val hash : t -> int -end - -module Make(X : HASHABLE) : S with type key = X.t diff --git a/src/data/CCGraph.ml b/src/data/CCGraph.ml index 067f9c3d..63c889fb 100644 --- a/src/data/CCGraph.ml +++ b/src/data/CCGraph.ml @@ -56,7 +56,7 @@ type ('k, 'a) table = { (** Mutable set *) type 'a set = ('a, unit) table -let mk_table (type k) ?(eq=(=)) ?(hash=Hashtbl.hash) size = +let mk_table (type k) ~eq ?(hash=Hashtbl.hash) size = let module H = Hashtbl.Make(struct type t = k let equal = eq @@ -68,7 +68,7 @@ let mk_table (type k) ?(eq=(=)) ?(hash=Hashtbl.hash) size = ; add=(fun k v -> H.replace tbl k v) } -let mk_map (type k) ?(cmp=Pervasives.compare) () = +let mk_map (type k) ~cmp () = let module M = Map.Make(struct type t = k let compare = cmp @@ -160,15 +160,15 @@ module Traverse = struct ) done - let generic ?(tbl=mk_table 128) ~bag ~graph seq = + let generic ~tbl ~bag ~graph seq = let tags = { get_tag=tbl.mem; set_tag=(fun v -> tbl.add v ()); } in generic_tag ~tags ~bag ~graph seq - let bfs ?tbl ~graph seq = - generic ?tbl ~bag:(mk_queue ()) ~graph seq + let bfs ~tbl ~graph seq = + generic ~tbl ~bag:(mk_queue ()) ~graph seq let bfs_tag ~tags ~graph seq = generic_tag ~tags ~bag:(mk_queue()) ~graph seq @@ -186,15 +186,15 @@ module Traverse = struct let bag = mk_heap ~leq:(fun (_,d1,_) (_,d2,_) -> d1 <= d2) in generic_tag ~tags:tags' ~bag ~graph:graph' seq' - let dijkstra ?(tbl=mk_table 128) ?dist ~graph seq = + let dijkstra ~tbl ?dist ~graph seq = let tags = { get_tag=tbl.mem; set_tag=(fun v -> tbl.add v ()); } in dijkstra_tag ~tags ?dist ~graph seq - let dfs ?tbl ~graph seq = - generic ?tbl ~bag:(mk_stack ()) ~graph seq + let dfs ~tbl ~graph seq = + generic ~tbl ~bag:(mk_stack ()) ~graph seq let dfs_tag ~tags ~graph seq = generic_tag ~tags ~bag:(mk_stack()) ~graph seq @@ -240,7 +240,7 @@ module Traverse = struct | (v1,_,_) :: path' -> eq v v1 || list_mem_ ~eq ~graph v path' - let dfs_tag ?(eq=(=)) ~tags ~graph seq = + let dfs_tag ~eq ~tags ~graph seq = let first = ref true in fun k -> if !first then first := false else raise Sequence_once; @@ -279,17 +279,18 @@ module Traverse = struct done ) seq - let dfs ?(tbl=mk_table 128) ?eq ~graph seq = + let dfs ~tbl ~eq ~graph seq = let tags = { set_tag=(fun v -> tbl.add v ()); get_tag=tbl.mem; } in - dfs_tag ?eq ~tags ~graph seq + dfs_tag ~eq ~tags ~graph seq end (*$R let l = - Traverse.Event.dfs ~graph:divisors_graph (Sequence.return 345614) + let tbl = mk_table ~eq:CCInt.equal 128 in + Traverse.Event.dfs ~tbl ~eq:CCInt.equal ~graph:divisors_graph (Sequence.return 345614) |> Sequence.to_list in let expected = [`Enter (345614, 0, []); `Edge (345614, (), 172807, `Forward); @@ -305,8 +306,8 @@ end (** {2 Cycles} *) -let is_dag ?(tbl=mk_table 128) ~graph vs = - Traverse.Event.dfs ~tbl ~graph vs +let is_dag ~tbl ~eq ~graph vs = + Traverse.Event.dfs ~tbl ~eq ~graph vs |> Seq.exists_ (function | `Edge (_, _, _, `Back) -> true @@ -316,7 +317,7 @@ let is_dag ?(tbl=mk_table 128) ~graph vs = exception Has_cycle -let topo_sort_tag ?(eq=(=)) ?(rev=false) ~tags ~graph seq = +let topo_sort_tag ~eq ?(rev=false) ~tags ~graph seq = (* use DFS *) let l = Traverse.Event.dfs_tag ~eq ~tags ~graph seq @@ -331,21 +332,23 @@ let topo_sort_tag ?(eq=(=)) ?(rev=false) ~tags ~graph seq = in if rev then List.rev l else l -let topo_sort ?eq ?rev ?(tbl=mk_table 128) ~graph seq = +let topo_sort ~eq ?rev ~tbl ~graph seq = let tags = { get_tag=tbl.mem; set_tag=(fun v -> tbl.add v ()); } in - topo_sort_tag ?eq ?rev ~tags ~graph seq + topo_sort_tag ~eq ?rev ~tags ~graph seq (*$T - let l = topo_sort ~graph:divisors_graph (Seq.return 42) in \ + let tbl = mk_table ~eq:CCInt.equal 128 in \ + let l = topo_sort ~tbl ~eq:CCInt.equal ~graph:divisors_graph (Seq.return 42) in \ List.for_all (fun (i,j) -> \ let idx_i = CCList.find_idx ((=)i) l |> CCOpt.get_exn |> fst in \ let idx_j = CCList.find_idx ((=)j) l |> CCOpt.get_exn |> fst in \ idx_i < idx_j) \ [ 42, 21; 14, 2; 3, 1; 21, 7; 42, 3] - let l = topo_sort ~rev:true ~graph:divisors_graph (Seq.return 42) in \ + let tbl = mk_table ~eq:CCInt.equal 128 in \ + let l = topo_sort ~tbl ~eq:CCInt.equal ~rev:true ~graph:divisors_graph (Seq.return 42) in \ List.for_all (fun (i,j) -> \ let idx_i = CCList.find_idx ((=)i) l |> CCOpt.get_exn |> fst in \ let idx_j = CCList.find_idx ((=)j) l |> CCOpt.get_exn |> fst in \ @@ -393,7 +396,7 @@ let spanning_tree_tag ~tags ~graph v = in mk_node v -let spanning_tree ?(tbl=mk_table 128) ~graph v = +let spanning_tree ~tbl ~graph v = let tags = { get_tag=tbl.mem; set_tag=(fun v -> tbl.add v ()); @@ -482,12 +485,12 @@ end type 'v scc_state = 'v SCC.state -let scc ?(tbl=mk_table 128) ~graph seq = SCC.explore ~tbl ~graph seq +let scc ~tbl ~graph seq = SCC.explore ~tbl ~graph seq (* example from https://en.wikipedia.org/wiki/Strongly_connected_component *) (*$R let set_eq ?(eq=(=)) l1 l2 = CCList.subset ~eq l1 l2 && CCList.subset ~eq l2 l1 in - let graph = of_list + let graph = of_list ~eq:CCString.equal [ "a", "b" ; "b", "e" ; "e", "a" @@ -503,7 +506,8 @@ let scc ?(tbl=mk_table 128) ~graph seq = SCC.explore ~tbl ~graph seq ; "h", "d" ; "h", "g" ] in - let res = scc ~graph (Seq.return "a") |> Seq.to_list in + let tbl = mk_table ~eq:CCString.equal 128 in + let res = scc ~tbl ~graph (Seq.return "a") |> Seq.to_list in assert_bool "scc" (set_eq ~eq:(set_eq ?eq:None) res [ [ "a"; "b"; "e" ] @@ -541,8 +545,8 @@ module Dot = struct (** Print an enum of Full.traverse_event *) let pp_seq - ?(tbl=mk_table 128) - ?(eq=(=)) + ~tbl + ~eq ?(attrs_v=fun _ -> []) ?(attrs_e=fun _ -> []) ?(name="graph") @@ -598,8 +602,8 @@ module Dot = struct Format.fprintf out "}@]@;@?"; () - let pp ?tbl ?eq ?attrs_v ?attrs_e ?name ~graph fmt v = - pp_seq ?tbl ?eq ?attrs_v ?attrs_e ?name ~graph fmt (Seq.return v) + let pp ~tbl ~eq ?attrs_v ?attrs_e ?name ~graph fmt v = + pp_seq ~tbl ~eq ?attrs_v ?attrs_e ?name ~graph fmt (Seq.return v) let with_out filename f = let oc = open_out filename in @@ -622,7 +626,7 @@ type ('v, 'e) mut_graph = { remove : 'v -> unit; } -let mk_mut_tbl (type k) ?(eq=(=)) ?(hash=Hashtbl.hash) size = +let mk_mut_tbl (type k) ~eq ?(hash=Hashtbl.hash) size = let module Tbl = Hashtbl.Make(struct type t = k let hash = hash @@ -757,7 +761,7 @@ end (** {2 Misc} *) -let of_list ?(eq=(=)) l = +let of_list ~eq l = (fun v yield -> List.iter (fun (a,b) -> if eq a v then yield ((),b)) l) let of_fun f = diff --git a/src/data/CCGraph.mli b/src/data/CCGraph.mli index 9daa6223..95f6a9d6 100644 --- a/src/data/CCGraph.mli +++ b/src/data/CCGraph.mli @@ -32,7 +32,7 @@ type 'a sequence_once = 'a sequence (** Sequence that should be used only once *) exception Sequence_once -(** Raised when a sequence meant to be used once is used several times *) +(** Raised when a sequence meant to be used once is used several times. *) module Seq : sig type 'a t = 'a sequence @@ -55,7 +55,7 @@ type ('v, 'e) t = ('v -> ('e * 'v) sequence) type ('v, 'e) graph = ('v, 'e) t val make : ('v -> ('e * 'v) sequence) -> ('v, 'e) t -(** Make a graph by providing the children function *) +(** Make a graph by providing the children function. *) (** {2 Tags} @@ -77,11 +77,11 @@ type ('k, 'a) table = { (** Mutable set *) type 'a set = ('a, unit) table -val mk_table: ?eq:('k -> 'k -> bool) -> ?hash:('k -> int) -> int -> ('k, 'a) table -(** Default implementation for {!table}: a {!Hashtbl.t} *) +val mk_table: eq:('k -> 'k -> bool) -> ?hash:('k -> int) -> int -> ('k, 'a) table +(** Default implementation for {!table}: a {!Hashtbl.t}. *) -val mk_map: ?cmp:('k -> 'k -> int) -> unit -> ('k, 'a) table -(** Use a {!Map.S} underneath *) +val mk_map: cmp:('k -> 'k -> int) -> unit -> ('k, 'a) table +(** Use a {!Map.S} underneath. *) (** {2 Bags of vertices} *) @@ -97,14 +97,14 @@ val mk_stack: unit -> 'a bag val mk_heap: leq:('a -> 'a -> bool) -> 'a bag (** [mk_heap ~leq] makes a priority queue where [leq x y = true] means that - [x] is smaller than [y] and should be prioritary *) + [x] is smaller than [y] and should be prioritary. *) (** {2 Traversals} *) module Traverse : sig type ('v, 'e) path = ('v * 'e * 'v) list - val generic: ?tbl:'v set -> + val generic: tbl:'v set -> bag:'v bag -> graph:('v, 'e) t -> 'v sequence -> @@ -120,7 +120,7 @@ module Traverse : sig 'v sequence_once (** One-shot traversal of the graph using a tag set and the given bag *) - val dfs: ?tbl:'v set -> + val dfs: tbl:'v set -> graph:('v, 'e) t -> 'v sequence -> 'v sequence_once @@ -130,7 +130,7 @@ module Traverse : sig 'v sequence -> 'v sequence_once - val bfs: ?tbl:'v set -> + val bfs: tbl:'v set -> graph:('v, 'e) t -> 'v sequence -> 'v sequence_once @@ -140,7 +140,7 @@ module Traverse : sig 'v sequence -> 'v sequence_once - val dijkstra : ?tbl:'v set -> + val dijkstra : tbl:'v set -> ?dist:('e -> int) -> graph:('v, 'e) t -> 'v sequence -> @@ -149,7 +149,7 @@ module Traverse : sig Yields each vertex paired with its distance to the set of initial vertices (the smallest distance needed to reach the node from the initial vertices) @param dist distance from origin of the edge to destination, - must be strictly positive. Default is 1 for every edge *) + must be strictly positive. Default is 1 for every edge. *) val dijkstra_tag : ?dist:('e -> int) -> tags:'v tag_set -> @@ -174,28 +174,29 @@ module Traverse : sig val get_edge : ('v, 'e) t -> ('v * 'e * 'v) option val get_edge_kind : ('v, 'e) t -> ('v * 'e * 'v * edge_kind) option - val dfs: ?tbl:'v set -> - ?eq:('v -> 'v -> bool) -> + val dfs: tbl:'v set -> + eq:('v -> 'v -> bool) -> graph:('v, 'e) graph -> 'v sequence -> ('v,'e) t sequence_once (** Full version of DFS. - @param eq equality predicate on vertices *) + @param eq equality predicate on vertices. *) - val dfs_tag: ?eq:('v -> 'v -> bool) -> + val dfs_tag: eq:('v -> 'v -> bool) -> tags:'v tag_set -> graph:('v, 'e) graph -> 'v sequence -> ('v,'e) t sequence_once - (** Full version of DFS using integer tags - @param eq equality predicate on vertices *) + (** Full version of DFS using integer tags. + @param eq equality predicate on vertices. *) end end (** {2 Cycles} *) val is_dag : - ?tbl:'v set -> + tbl:'v set -> + eq:('v -> 'v -> bool) -> graph:('v, _) t -> 'v sequence -> bool @@ -207,9 +208,9 @@ val is_dag : exception Has_cycle -val topo_sort : ?eq:('v -> 'v -> bool) -> +val topo_sort : eq:('v -> 'v -> bool) -> ?rev:bool -> - ?tbl:'v set -> + tbl:'v set -> graph:('v, 'e) t -> 'v sequence -> 'v list @@ -217,20 +218,20 @@ val topo_sort : ?eq:('v -> 'v -> bool) -> element of [l] is reachable from [seq]. The list is sorted in a way such that if [v -> v'] in the graph, then [v] comes before [v'] in the list (i.e. has a smaller index). - Basically [v -> v'] means that [v] is smaller than [v'] - see {{: https://en.wikipedia.org/wiki/Topological_sorting} wikipedia} - @param eq equality predicate on vertices (default [(=)]) + Basically [v -> v'] means that [v] is smaller than [v']. + See {{: https://en.wikipedia.org/wiki/Topological_sorting} wikipedia}. + @param eq equality predicate on vertices (default [(=)]). @param rev if true, the dependency relation is inverted ([v -> v'] means - [v'] occurs before [v]) - @raise Has_cycle if the graph is not a DAG *) + [v'] occurs before [v]). + @raise Has_cycle if the graph is not a DAG. *) -val topo_sort_tag : ?eq:('v -> 'v -> bool) -> +val topo_sort_tag : eq:('v -> 'v -> bool) -> ?rev:bool -> tags:'v tag_set -> graph:('v, 'e) t -> 'v sequence -> 'v list -(** Same as {!topo_sort} but uses an explicit tag set *) +(** Same as {!topo_sort} but uses an explicit tag set. *) (** {2 Lazy Spanning Tree} *) @@ -245,12 +246,12 @@ module Lazy_tree : sig val fold_v : ('acc -> 'v -> 'acc) -> 'acc -> ('v, _) t -> 'acc end -val spanning_tree : ?tbl:'v set -> +val spanning_tree : tbl:'v set -> graph:('v, 'e) t -> 'v -> ('v, 'e) Lazy_tree.t (** [spanning_tree ~graph v] computes a lazy spanning tree that has [v] - as a root. The table [tbl] is used for the memoization part *) + as a root. The table [tbl] is used for the memoization part. *) val spanning_tree_tag : tags:'v tag_set -> graph:('v, 'e) t -> @@ -260,9 +261,9 @@ val spanning_tree_tag : tags:'v tag_set -> (** {2 Strongly Connected Components} *) type 'v scc_state -(** Hidden state for {!scc} *) +(** Hidden state for {!scc}. *) -val scc : ?tbl:('v, 'v scc_state) table -> +val scc : tbl:('v, 'v scc_state) table -> graph:('v, 'e) t -> 'v sequence -> 'v list sequence_once @@ -271,8 +272,8 @@ val scc : ?tbl:('v, 'v scc_state) table -> in the graph. The components are explored in a topological order (if C1 and C2 are components, and C1 points to C2, then C2 will be yielded before C1). - Uses {{: https://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm} Tarjan's algorithm} - @param tbl table used to map nodes to some hidden state + Uses {{: https://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm} Tarjan's algorithm}. + @param tbl table used to map nodes to some hidden state. @raise Sequence_once if the result is iterated on more than once. *) @@ -304,8 +305,8 @@ module Dot : sig type vertex_state (** Hidden state associated to a vertex *) - val pp : ?tbl:('v,vertex_state) table -> - ?eq:('v -> 'v -> bool) -> + val pp : tbl:('v,vertex_state) table -> + eq:('v -> 'v -> bool) -> ?attrs_v:('v -> attribute list) -> ?attrs_e:('e -> attribute list) -> ?name:string -> @@ -313,13 +314,13 @@ module Dot : sig Format.formatter -> 'v -> unit - (** Print the graph, starting from given vertex, on the formatter - @param attrs_v attributes for vertices - @param attrs_e attributes for edges - @param name name of the graph *) + (** Print the graph, starting from given vertex, on the formatter. + @param attrs_v attributes for vertices. + @param attrs_e attributes for edges. + @param name name of the graph. *) - val pp_seq : ?tbl:('v,vertex_state) table -> - ?eq:('v -> 'v -> bool) -> + val pp_seq : tbl:('v,vertex_state) table -> + eq:('v -> 'v -> bool) -> ?attrs_v:('v -> attribute list) -> ?attrs_e:('e -> attribute list) -> ?name:string -> @@ -329,7 +330,7 @@ module Dot : sig unit val with_out : string -> (Format.formatter -> 'a) -> 'a - (** Shortcut to open a file and write to it *) + (** Shortcut to open a file and write to it. *) end (** {2 Mutable Graph} *) @@ -340,11 +341,11 @@ type ('v, 'e) mut_graph = { remove : 'v -> unit; } -val mk_mut_tbl : ?eq:('v -> 'v -> bool) -> +val mk_mut_tbl : eq:('v -> 'v -> bool) -> ?hash:('v -> int) -> int -> ('v, 'a) mut_graph -(** Make a new mutable graph from a Hashtbl. Edges are labelled with type ['a] *) +(** Make a new mutable graph from a Hashtbl. Edges are labelled with type ['a]. *) (** {2 Immutable Graph} @@ -358,7 +359,7 @@ module type MAP = sig type 'a t val as_graph : 'a t -> (vertex, 'a) graph - (** Graph view of the map *) + (** Graph view of the map. *) val empty : 'a t @@ -367,12 +368,12 @@ module type MAP = sig val remove_edge : vertex -> vertex -> 'a t -> 'a t val add : vertex -> 'a t -> 'a t - (** Add a vertex, possibly with no outgoing edge *) + (** Add a vertex, possibly with no outgoing edge. *) val remove : vertex -> 'a t -> 'a t (** Remove the vertex and all its outgoing edges. Edges that point to the vertex are {b NOT} removed, they must be - manually removed with {!remove_edge} *) + manually removed with {!remove_edge}. *) val union : 'a t -> 'a t -> 'a t @@ -397,18 +398,18 @@ module Map(O : Map.OrderedType) : MAP with type vertex = O.t (** {2 Misc} *) -val of_list : ?eq:('v -> 'v -> bool) -> ('v * 'v) list -> ('v, unit) t +val of_list : eq:('v -> 'v -> bool) -> ('v * 'v) list -> ('v, unit) t (** [of_list l] makes a graph from a list of pairs of vertices. Each pair [(a,b)] is an edge from [a] to [b]. - @param eq equality used to compare vertices *) + @param eq equality used to compare vertices. *) val of_hashtbl : ('v, 'v list) Hashtbl.t -> ('v, unit) t (** [of_hashtbl tbl] makes a graph from a hashtable that maps vertices - to lists of children *) + to lists of children. *) val of_fun : ('v -> 'v list) -> ('v, unit) t (** [of_fun f] makes a graph out of a function that maps a vertex to the list of its children. The function is assumed to be deterministic. *) val divisors_graph : (int, unit) t -(** [n] points to all its strict divisors *) +(** [n] points to all its strict divisors. *) diff --git a/src/data/CCHashSet.mli b/src/data/CCHashSet.mli index c689c7bd..d009ea04 100644 --- a/src/data/CCHashSet.mli +++ b/src/data/CCHashSet.mli @@ -14,72 +14,72 @@ module type S = sig type elt val create : int -> t - (** [create n] makes a new set with the given capacity [n] *) + (** [create n] makes a new set with the given capacity [n]. *) val singleton : elt -> t - (** [singleton x] is the singleton [{x}] *) + (** [singleton x] is the singleton [{x}]. *) val clear : t -> unit - (** [clear s] removes all elements from [s] *) + (** [clear s] removes all elements from [s]. *) val copy : t -> t - (** Fresh copy *) + (** Fresh copy. *) val copy_into : into:t -> t -> unit - (** [copy_into ~into s] copies all elements of [s] into [into] *) + (** [copy_into ~into s] copies all elements of [s] into [into]. *) val insert : t -> elt -> unit - (** [insert s x] adds [x] into [s] *) + (** [insert s x] adds [x] into [s]. *) val remove : t -> elt -> unit - (** Remove the element, if it were in there *) + (** Remove the element, if it were in there. *) val cardinal : t -> int - (** [cardinal s] returns the number of elements in [s] *) + (** [cardinal s] returns the number of elements in [s]. *) val mem : t -> elt -> bool - (** [mem s x] returns [true] iff [x] is in [s] *) + (** [mem s x] returns [true] iff [x] is in [s]. *) val find_exn : t -> elt -> elt (** [find_exn s x] returns [y] if [x] and [y] are equal, and [mem s y]. - @raise Not_found if [x] not in [s] *) + @raise Not_found if [x] not in [s]. *) val find : t -> elt -> elt option - (** Safe version of {!find_exn} *) + (** Safe version of {!find_exn}. *) val inter : t -> t -> t - (** [inter a b] returns [a āˆ© b] *) + (** [inter a b] returns [a āˆ© b]. *) val inter_mut : into:t -> t -> unit - (** [inter_mut ~into a] changes [into] into [a āˆ© into] *) + (** [inter_mut ~into a] changes [into] into [a āˆ© into]. *) val union : t -> t -> t - (** [union a b] returns [a āˆŖ b] *) + (** [union a b] returns [a āˆŖ b]. *) val union_mut : into:t -> t -> unit - (** [union_mut ~into a] changes [into] into [a āˆŖ into] *) + (** [union_mut ~into a] changes [into] into [a āˆŖ into]. *) val diff : t -> t -> t - (** [diff a b] returns [a - b] *) + (** [diff a b] returns [a - b]. *) val subset : t -> t -> bool - (** [subset a b] returns [true] if all elements of [a] are in [b] *) + (** [subset a b] returns [true] if all elements of [a] are in [b]. *) val equal : t -> t -> bool - (** [equal a b] is extensional equality ([a] and [b] have the same elements) *) + (** [equal a b] is extensional equality ([a] and [b] have the same elements). *) val for_all : (elt -> bool) -> t -> bool val exists : (elt -> bool) -> t -> bool val iter : (elt -> unit) -> t -> unit - (** Iterate on values *) + (** Iterate on values. *) val fold : ('a -> elt -> 'a) -> 'a -> t -> 'a - (** Fold on values *) + (** Fold on values. *) val elements : t -> elt list - (** List of elements *) + (** List of elements. *) val of_list : elt list -> t @@ -91,7 +91,7 @@ module type S = sig val pp : ?sep:string -> elt printer -> t printer (** [pp pp_elt] returns a set printer, given a printer for - individual elements *) + individual elements. *) end module type ELEMENT = sig diff --git a/src/data/CCHashTrie.ml b/src/data/CCHashTrie.ml index 926d13c8..76d005c4 100644 --- a/src/data/CCHashTrie.ml +++ b/src/data/CCHashTrie.ml @@ -24,7 +24,7 @@ module Transient = struct type state = { mutable frozen: bool } type t = Nil | St of state let empty = Nil - let equal a b = a==b + let equal a b = Pervasives.(==) a b let create () = St {frozen=false} let active = function Nil -> false | St st -> not st.frozen let frozen = function Nil -> true | St st -> st.frozen @@ -126,7 +126,7 @@ module type S = sig (** {6 IO} *) - val print : key printer -> 'a printer -> 'a t printer + val pp : key printer -> 'a printer -> 'a t printer val as_tree : 'a t -> [`L of int * (key * 'a) list | `N ] ktree (** For debugging purpose: explore the structure of the tree, @@ -292,13 +292,15 @@ module Make(Key : KEY) val make : Key.t -> t val zero : t (* special "hash" *) val is_0 : t -> bool + val equal : t -> t -> bool val rem : t -> int (* [A.length_log] last bits *) val quotient : t -> t (* remove [A.length_log] last bits *) end = struct type t = int let make = Key.hash let zero = 0 - let is_0 h = h==0 + let is_0 h = h = 0 + let equal (a : int) b = Pervasives.(=) a b let rem h = h land (A.length - 1) let quotient h = h lsr A.length_log end @@ -407,14 +409,14 @@ module Make(Key : KEY) let rec add_ ~id k v ~h m = match m with | E -> S (h, k, v) | S (h', k', v') -> - if h=h' + if Hash.equal h h' then if Key.equal k k' then S (h, k, v) (* replace *) else L (h, Cons (k, v, Cons (k', v', Nil))) else make_array_ ~id ~leaf:(Cons (k', v', Nil)) ~h_leaf:h' k v ~h | L (h', l) -> - if h=h' + if Hash.equal h h' then L (h, add_list_ k v l) else (* split into N *) make_array_ ~id ~leaf:l ~h_leaf:h' k v ~h @@ -696,7 +698,7 @@ module Make(Key : KEY) | None -> raise Not_found | Some (k,v) -> k, v - let print ppk ppv out m = + let pp ppk ppv out m = let first = ref true in iter m ~f:(fun k v -> diff --git a/src/data/CCHashTrie.mli b/src/data/CCHashTrie.mli index dcfbbf8b..662af8ec 100644 --- a/src/data/CCHashTrie.mli +++ b/src/data/CCHashTrie.mli @@ -28,28 +28,28 @@ module Transient : sig is called, [r] cannot be used to modify the structure again. *) val create : unit -> t - (** Create a new, active ID *) + (** Create a new, active ID. *) val equal : t -> t -> bool - (** Equality between IDs *) + (** Equality between IDs. *) val frozen : t -> bool (** [frozen i] returns [true] if [freeze i] was called before. In this case, the ID cannot be used for modifications again. *) val active : t -> bool - (** [active i] is [not (frozen i)] *) + (** [active i] is [not (frozen i)]. *) val freeze : t -> unit (** [freeze i] makes [i] unusable for new modifications. The values created with [i] will now be immutable. *) val with_ : (t -> 'a) -> 'a - (** [Transient.with_ f] creates a transient ID [i], calls [f i], + (** [with_ f] creates a transient ID [i], calls [f i], freezes the ID [i] and returns the result of [f i]. *) exception Frozen - (** Raised when a frozen ID is used *) + (** Raised when a frozen ID is used. *) end (** {2 Signature} *) @@ -71,7 +71,7 @@ module type S = sig val get : key -> 'a t -> 'a option val get_exn : key -> 'a t -> 'a - (** @raise Not_found if key not present *) + (** @raise Not_found if key not present. *) val remove : key -> 'a t -> 'a t (** Remove the key, if present. *) @@ -79,29 +79,29 @@ module type S = sig val update : key -> f:('a option -> 'a option) -> 'a t -> 'a t (** [update k ~f m] calls [f (Some v)] if [get k m = Some v], [f None] otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], - if [f] returns [None] it removes [k] *) + if [f] returns [None] it removes [k]. *) val add_mut : id:Transient.t -> key -> 'a -> 'a t -> 'a t (** [add_mut ~id k v m] behaves like [add k v m], except it will mutate in place whenever possible. Changes done with an [id] might affect all versions of the structure obtained with the same [id] (but not other versions). - @raise Transient.Frozen if [id] is frozen *) + @raise Transient.Frozen if [id] is frozen. *) val remove_mut : id:Transient.t -> key -> 'a t -> 'a t - (** Same as {!remove}, but modifies in place whenever possible - @raise Transient.Frozen if [id] is frozen *) + (** Same as {!remove}, but modifies in place whenever possible. + @raise Transient.Frozen if [id] is frozen. *) val update_mut : id:Transient.t -> key -> f:('a option -> 'a option) -> 'a t -> 'a t - (** Same as {!update} but with mutability - @raise Transient.Frozen if [id] is frozen *) + (** Same as {!update} but with mutability. + @raise Transient.Frozen if [id] is frozen. *) val cardinal : _ t -> int val choose : 'a t -> (key * 'a) option val choose_exn : 'a t -> key * 'a - (** @raise Not_found if not pair was found *) + (** @raise Not_found if not pair was found. *) val iter : f:(key -> 'a -> unit) -> 'a t -> unit @@ -114,14 +114,14 @@ module type S = sig val add_list : 'a t -> (key * 'a) list -> 'a t val add_list_mut : id:Transient.t -> 'a t -> (key * 'a) list -> 'a t - (** @raise Frozen if the ID is frozen *) + (** @raise Frozen if the ID is frozen. *) val of_list : (key * 'a) list -> 'a t val add_seq : 'a t -> (key * 'a) sequence -> 'a t val add_seq_mut : id:Transient.t -> 'a t -> (key * 'a) sequence -> 'a t - (** @raise Frozen if the ID is frozen *) + (** @raise Frozen if the ID is frozen. *) val of_seq : (key * 'a) sequence -> 'a t @@ -130,7 +130,7 @@ module type S = sig val add_gen : 'a t -> (key * 'a) gen -> 'a t val add_gen_mut : id:Transient.t -> 'a t -> (key * 'a) gen -> 'a t - (** @raise Frozen if the ID is frozen *) + (** @raise Frozen if the ID is frozen. *) val of_gen : (key * 'a) gen -> 'a t @@ -138,12 +138,14 @@ module type S = sig (** {6 IO} *) - val print : key printer -> 'a printer -> 'a t printer + val pp : key printer -> 'a printer -> 'a t printer + (** Renamed from [val print]. + @since NEXT_RELEASE *) val as_tree : 'a t -> [`L of int * (key * 'a) list | `N ] ktree (** For debugging purpose: explore the structure of the tree, with [`L (h,l)] being a leaf (with shared hash [h]) - and [`N] an inner node *) + and [`N] an inner node. *) end (** {2 Type for keys} *) diff --git a/src/data/CCHet.mli b/src/data/CCHet.mli index 51ea0fe9..2bb400c1 100644 --- a/src/data/CCHet.mli +++ b/src/data/CCHet.mli @@ -17,7 +17,7 @@ module Key : sig val create : unit -> 'a t val equal : 'a t -> 'a t -> bool - (** Compare two keys that have compatible types *) + (** Compare two keys that have compatible types. *) end type pair = @@ -38,7 +38,7 @@ module Tbl : sig val find : t -> 'a Key.t -> 'a option val find_exn : t -> 'a Key.t -> 'a - (** @raise Not_found if the key is not in the table *) + (** @raise Not_found if the key is not in the table. *) val iter : (pair -> unit) -> t -> unit @@ -72,7 +72,7 @@ module Map : sig val find : 'a Key.t -> t -> 'a option val find_exn : 'a Key.t -> t -> 'a - (** @raise Not_found if the key is not in the table *) + (** @raise Not_found if the key is not in the table. *) val iter : (pair -> unit) -> t -> unit diff --git a/src/data/CCImmutArray.ml b/src/data/CCImmutArray.ml index 1165b6af..970e944b 100644 --- a/src/data/CCImmutArray.ml +++ b/src/data/CCImmutArray.ml @@ -118,7 +118,7 @@ let to_gen a = type 'a printer = Format.formatter -> 'a -> unit -let print ?(start="") ?(stop="") ?(sep=", ") pp_item out a = +let pp ?(start="") ?(stop="") ?(sep=", ") pp_item out a = Format.pp_print_string out start; for k = 0 to Array.length a - 1 do if k > 0 then ( diff --git a/src/data/CCImmutArray.mli b/src/data/CCImmutArray.mli index a58dc35c..0383cfa0 100644 --- a/src/data/CCImmutArray.mli +++ b/src/data/CCImmutArray.mli @@ -24,17 +24,17 @@ val singleton : 'a -> 'a t val doubleton : 'a -> 'a -> 'a t val make : int -> 'a -> 'a t -(** [make n x] makes an array of [n] times [x] *) +(** [make n x] makes an array of [n] times [x]. *) val init : int -> (int -> 'a) -> 'a t (** [init n f] makes the array [[| f 0; f 1; ... ; f (n-1) |]]. - @raise Invalid_argument if [n < 0] *) + @raise Invalid_argument if [n < 0]. *) val get : 'a t -> int -> 'a -(** Access the element *) +(** Access the element. *) val set : 'a t -> int -> 'a -> 'a t -(** Copy the array and modify its copy *) +(** Copy the array and modify its copy. *) val sub : 'a t -> int -> int -> 'a t (** [sub a start len] returns a fresh array of length len, containing the elements @@ -88,7 +88,7 @@ val to_gen : 'a t -> 'a gen type 'a printer = Format.formatter -> 'a -> unit -val print : +val pp : ?start:string -> ?stop:string -> ?sep:string -> 'a printer -> 'a t printer diff --git a/src/data/CCIntMap.ml b/src/data/CCIntMap.ml index cf2e6f82..af62e8a4 100644 --- a/src/data/CCIntMap.ml +++ b/src/data/CCIntMap.ml @@ -11,6 +11,7 @@ module Bit : sig type t = private int val highest : int -> t val min_int : t + val equal : t -> t -> bool val is_0 : bit:t -> int -> bool val is_1 : bit:t -> int -> bool val mask : mask:t -> int -> int (* zeroes the bit, puts all lower bits to 1 *) @@ -21,6 +22,8 @@ end = struct let min_int = min_int + let equal = (=) + let rec highest_bit_naive x m = if x=m then m else highest_bit_naive (x land (lnot m)) (2*m) @@ -237,11 +240,11 @@ let update k f t = let doubleton k1 v1 k2 v2 = add k1 v1 (singleton k2 v2) -let rec equal ~eq a b = a==b || match a, b with +let rec equal ~eq a b = Pervasives.(==) a b || match a, b with | E, E -> true | L (ka, va), L (kb, vb) -> ka = kb && eq va vb | N (pa, sa, la, ra), N (pb, sb, lb, rb) -> - pa=pb && sa=sb && equal ~eq la lb && equal ~eq ra rb + pa=pb && Bit.equal sa sb && equal ~eq la lb && equal ~eq ra rb | E, _ | N _, _ | L _, _ -> false @@ -287,7 +290,7 @@ let choose t = with Not_found -> None let rec union f t1 t2 = - if t1==t2 then t1 + if Pervasives.(==) t1 t2 then t1 else match t1, t2 with | E, o | o, E -> o | L (k, v), o @@ -295,7 +298,7 @@ let rec union f t1 t2 = (* insert k, v into o *) insert_ (fun ~old v -> f k old v) k v o | N (p1, m1, l1, r1), N (p2, m2, l2, r2) -> - if p1 = p2 && m1 = m2 + if p1 = p2 && Bit.equal m1 m2 then mk_node_ p1 m1 (union f l1 l2) (union f r1 r2) else if Bit.gt m1 m2 && is_prefix_ ~prefix:p1 p2 ~bit:m1 then if Bit.is_0 p2 ~bit:m1 @@ -323,14 +326,14 @@ let rec union f t1 t2 = *) (*$R - assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (print CCString.print)) + assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (pp CCString.pp)) (of_list [1, "1"; 2, "2"; 3, "3"; 4, "4"]) (union (fun _ a b -> a) (of_list [1, "1"; 3, "3"]) (of_list [2, "2"; 4, "4"])); *) (*$R - assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (print CCString.print)) + assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (pp CCString.pp)) (of_list [1, "1"; 2, "2"; 3, "3"; 4, "4"]) (union (fun _ a b -> a) (of_list [1, "1"; 2, "2"; 3, "3"]) (of_list [2, "2"; 4, "4"])) @@ -342,7 +345,7 @@ let rec union f t1 t2 = *) let rec inter f a b = - if a==b then a + if Pervasives.(==) a b then a else match a, b with | E, _ | _, E -> E | L (k, v), o @@ -353,7 +356,7 @@ let rec inter f a b = with Not_found -> E end | N (p1, m1, l1, r1), N (p2, m2, l2, r2) -> - if p1 = p2 && m1 = m2 + if p1 = p2 && Bit.equal m1 m2 then mk_node_ p1 m1 (inter f l1 l2) (inter f r1 r2) else if Bit.gt m1 m2 && is_prefix_ ~prefix:p1 p2 ~bit:m1 then if Bit.is_0 p2 ~bit:m1 @@ -366,7 +369,7 @@ let rec inter f a b = else E (*$R - assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (print CCString.print)) + assert_equal ~cmp:(equal ~eq:(=)) ~printer:(CCFormat.to_string (pp CCString.pp)) (singleton 2 "2") (inter (fun _ a b -> a) (of_list [1, "1"; 2, "2"; 3, "3"]) (of_list [2, "2"; 4, "4"])) @@ -466,7 +469,7 @@ let compare ~cmp a b = then let c = cmp va vb in if c=0 then cmp_gen cmp a b else c - else Pervasives.compare ka kb + else compare ka kb in cmp_gen cmp (to_gen a) (to_gen b) @@ -530,7 +533,7 @@ let rec as_tree t () = match t with type 'a printer = Format.formatter -> 'a -> unit -let print pp_x out m = +let pp pp_x out m = Format.fprintf out "@[intmap {@,"; let first = ref true in iter diff --git a/src/data/CCIntMap.mli b/src/data/CCIntMap.mli index ab7445ea..2036ddb9 100644 --- a/src/data/CCIntMap.mli +++ b/src/data/CCIntMap.mli @@ -19,8 +19,8 @@ val mem : int -> _ t -> bool val find : int -> 'a t -> 'a option val find_exn : int -> 'a t -> 'a -(** Same as {!find} but unsafe - @raise Not_found if key not present *) +(** Same as {!find} but unsafe. + @raise Not_found if key is not present. *) val add : int -> 'a -> 'a t -> 'a t @@ -28,17 +28,17 @@ val remove : int -> 'a t -> 'a t val equal : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool (** [equal ~eq a b] checks whether [a] and [b] have the same set of pairs - (key, value), comparing values with [eq] + (key, value), comparing values with [eq]. @since 0.13 *) val compare : cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int -(** Total order between maps; the precise order is unspecified . +(** Total order between maps; the precise order is unspecified. @since 0.13 *) val update : int -> ('a option -> 'a option) -> 'a t -> 'a t val cardinal : _ t -> int -(** Number of bindings in the map. Linear time *) +(** Number of bindings in the map. Linear time. *) val iter : (int -> 'a -> unit) -> 'a t -> unit @@ -53,7 +53,7 @@ val map : ('a -> 'b) -> 'a t -> 'b t val choose : 'a t -> (int * 'a) option val choose_exn : 'a t -> int * 'a -(** @raise Not_found if not pair was found *) +(** @raise Not_found if not pair was found. *) val union : (int -> 'a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t @@ -107,7 +107,7 @@ val as_tree : 'a t -> [`Node of int * int | `Leaf of int * 'a ] tree type 'a printer = Format.formatter -> 'a -> unit -val print : 'a printer -> 'a t printer +val pp : 'a printer -> 'a t printer (** @since 0.13 *) (** Helpers *) diff --git a/src/data/CCMixmap.ml b/src/data/CCMixmap.ml index 8c162a36..616aca2b 100644 --- a/src/data/CCMixmap.ml +++ b/src/data/CCMixmap.ml @@ -123,9 +123,13 @@ module Make(X : ORD) : S with type key = X.t = struct let remove = M.remove + let is_some = function + | None -> false + | Some _ -> true + let mem ~inj x map = try - inj.get (M.find x map) <> None + is_some (inj.get (M.find x map)) with Not_found -> false let iter_keys ~f map = diff --git a/src/data/CCMixmap.mli b/src/data/CCMixmap.mli index dbb0a44c..829330f9 100644 --- a/src/data/CCMixmap.mli +++ b/src/data/CCMixmap.mli @@ -37,9 +37,9 @@ type 'a injection val create_inj : unit -> 'a injection (** Return a value that works for a given type of values. This function is - normally called once for each type of value. Several keys may be + normally called once for each type of value. Several keys may be created for the same type, but a value set with a given setter can only be - retrieved with the matching getter. The same key can be reused + retrieved with the matching getter. The same key can be reused across multiple maps (although not in a thread-safe way). *) module type S = sig @@ -49,50 +49,50 @@ module type S = sig (** A map containing values of different types, indexed by {!key}. *) val empty : t - (** Empty map *) + (** Empty map. *) val get : inj:'a injection -> key -> t -> 'a option (** Get the value corresponding to this key, if it exists and - belongs to the same key *) + belongs to the same key. *) val add : inj:'a injection -> key -> 'a -> t -> t - (** Bind the key to the value, using [inj] *) + (** Bind the key to the value, using [inj]. *) val find : inj:'a injection -> key -> t -> 'a (** Find the value for the given key, which must be of the right type. @raise Not_found if either the key is not found, or if its value - doesn't belong to the right type *) + doesn't belong to the right type. *) val cardinal : t -> int - (** Number of bindings *) + (** Number of bindings. *) val remove : key -> t -> t - (** Remove the binding for this key *) + (** Remove the binding for this key. *) val mem : inj:_ injection-> key -> t -> bool (** Is the given key in the map, with the right type? *) val iter_keys : f:(key -> unit) -> t -> unit - (** Iterate on the keys of this map *) + (** Iterate on the keys of this map. *) val fold_keys : f:('a -> key -> 'a) -> x:'a -> t -> 'a - (** Fold over the keys *) + (** Fold over the keys. *) (** {2 Iterators} *) type 'a sequence = ('a -> unit) -> unit val keys_seq : t -> key sequence - (** All the keys *) + (** All the keys. *) val bindings_of : inj:'a injection -> t -> (key * 'a) sequence - (** All the bindings that come from the corresponding injection *) + (** All the bindings that come from the corresponding injection. *) type value = | Value : ('a injection -> 'a option) -> value val bindings : t -> (key * value) sequence - (** Iterate on all bindings *) + (** Iterate on all bindings. *) end module type ORD = sig diff --git a/src/data/CCMixset.mli b/src/data/CCMixset.mli index 7f7f2619..e51eee5c 100644 --- a/src/data/CCMixset.mli +++ b/src/data/CCMixset.mli @@ -45,8 +45,8 @@ val get : key:'a key -> t -> 'a option (** [get ~key set] obtains the value for [key] in [set], if any. *) val get_exn : key:'a key -> t -> 'a -(** Same as {!get}, but can fail - @raise Not_found if the key is not present *) +(** Same as {!get}, but can fail. + @raise Not_found if the key is not present. *) val cardinal : t -> int -(** Number of mappings *) +(** Number of mappings. *) diff --git a/src/data/CCMixtbl.ml b/src/data/CCMixtbl.ml index 8d1d9f73..e697a72e 100644 --- a/src/data/CCMixtbl.ml +++ b/src/data/CCMixtbl.ml @@ -84,9 +84,13 @@ let remove tbl x = Hashtbl.remove tbl x let copy tbl = Hashtbl.copy tbl +let is_some = function + | None -> false + | Some _ -> true + let mem ~inj tbl x = try - inj.get (Hashtbl.find tbl x) <> None + is_some (inj.get (Hashtbl.find tbl x)) with Not_found -> false (*$R diff --git a/src/data/CCMixtbl.mli b/src/data/CCMixtbl.mli index c35fa810..099d3090 100644 --- a/src/data/CCMixtbl.mli +++ b/src/data/CCMixtbl.mli @@ -53,49 +53,49 @@ val create_inj : unit -> 'b injection val get : inj:'b injection -> 'a t -> 'a -> 'b option (** Get the value corresponding to this key, if it exists and - belongs to the same key *) + belongs to the same key. *) val set : inj:'b injection -> 'a t -> 'a -> 'b -> unit -(** Bind the key to the value, using [inj] *) +(** Bind the key to the value, using [inj]. *) val find : inj:'b injection -> 'a t -> 'a -> 'b (** Find the value for the given key, which must be of the right type. @raise Not_found if either the key is not found, or if its value - doesn't belong to the right type *) + doesn't belong to the right type. *) val length : 'a t -> int -(** Number of bindings *) +(** Number of bindings. *) val clear : 'a t -> unit -(** Clear content of the hashtable *) +(** Clear content of the hashtable. *) val remove : 'a t -> 'a -> unit -(** Remove the binding for this key *) +(** Remove the binding for this key. *) val copy : 'a t -> 'a t -(** Copy of the table *) +(** Copy of the table. *) val mem : inj:_ injection-> 'a t -> 'a -> bool (** Is the given key in the table, with the right type? *) val iter_keys : 'a t -> ('a -> unit) -> unit -(** Iterate on the keys of this table *) +(** Iterate on the keys of this table. *) val fold_keys : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b -(** Fold over the keys *) +(** Fold over the keys. *) (** {2 Iterators} *) type 'a sequence = ('a -> unit) -> unit val keys_seq : 'a t -> 'a sequence -(** All the keys *) +(** All the keys. *) val bindings_of : inj:'b injection -> 'a t -> ('a * 'b) sequence -(** All the bindings that come from the corresponding injection *) +(** All the bindings that come from the corresponding injection. *) type value = | Value : ('b injection -> 'b option) -> value val bindings : 'a t -> ('a * value) sequence -(** Iterate on all bindings *) +(** Iterate on all bindings. *) diff --git a/src/data/CCMultiMap.ml b/src/data/CCMultiMap.ml index de83764b..8c6ab6f0 100644 --- a/src/data/CCMultiMap.ml +++ b/src/data/CCMultiMap.ml @@ -1,27 +1,4 @@ -(* -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. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Multimap} *) diff --git a/src/data/CCMultiMap.mli b/src/data/CCMultiMap.mli index be602417..86ea1788 100644 --- a/src/data/CCMultiMap.mli +++ b/src/data/CCMultiMap.mli @@ -1,27 +1,4 @@ -(* -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. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Multimap} *) @@ -33,59 +10,59 @@ module type S = sig type t val empty : t - (** Empty multimap *) + (** Empty multimap. *) val is_empty : t -> bool (** Empty multimap? *) val add : t -> key -> value -> t - (** Add a key/value binding *) + (** Add a key/value binding. *) val remove : t -> key -> value -> t - (** Remove the binding *) + (** Remove the binding. *) val remove_all : t -> key -> t - (** Remove the key from the map *) + (** Remove the key from the map. *) val mem : t -> key -> bool (** Is there a binding for this key? *) val find : t -> key -> value list - (** List of values for this key *) + (** List of values for this key. *) val find_iter : t -> key -> (value -> unit) -> unit - (** Iterate on bindings for this key *) + (** Iterate on bindings for this key. *) val count : t -> key -> int - (** Number of bindings for this key *) + (** Number of bindings for this key. *) val iter : t -> (key -> value -> unit) -> unit - (** Iterate on all key/value *) + (** Iterate on all key/value. *) val fold : t -> 'a -> ('a -> key -> value -> 'a) -> 'a - (** Fold on all key/value *) + (** Fold on all key/value. *) val size : t -> int - (** Number of keys *) + (** Number of keys. *) val union : t -> t -> t - (** Union of multimaps *) + (** Union of multimaps. *) val inter : t -> t -> t - (** Intersection of multimaps *) + (** Intersection of multimaps. *) val diff : t -> t -> t (** Difference of maps, ie bindings of the first that are not - in the second *) + in the second. *) val equal : t -> t -> bool - (** Same multimap *) + (** Same multimap. *) val compare : t -> t -> int - (** Total order on multimaps *) + (** Total order on multimaps. *) val submap : t -> t -> bool - (** [submap m1 m2] is true iff all bindings of [m1] are also in [m2] *) + (** [submap m1 m2] is true iff all bindings of [m1] are also in [m2]. *) val to_seq : t -> (key * value) sequence @@ -94,7 +71,7 @@ module type S = sig val keys : t -> key sequence val values : t -> value sequence - (** Some values may occur several times *) + (** Some values may occur several times. *) end module type OrderedType = sig @@ -120,22 +97,22 @@ module type BIDIR = sig val is_empty : t -> bool val add : t -> left -> right -> t - (** Add a binding (left,right) *) + (** Add a binding (left,right). *) val remove : t -> left -> right -> t - (** Remove a specific binding *) + (** Remove a specific binding. *) val cardinal_left : t -> int - (** Number of distinct left keys *) + (** Number of distinct left keys. *) val cardinal_right : t -> int - (** Number of distinct right keys *) + (** Number of distinct right keys. *) val remove_left : t -> left -> t - (** Remove all bindings for the left key *) + (** Remove all bindings for the left key. *) val remove_right : t -> right -> t - (** Remove all bindings for the right key *) + (** Remove all bindings for the right key. *) val mem_left : t -> left -> bool (** Is the left key present in at least one pair? *) @@ -144,25 +121,25 @@ module type BIDIR = sig (** Is the right key present in at least one pair? *) val find_left : t -> left -> right sequence - (** Find all bindings for this given left-key *) + (** Find all bindings for this given left-key. *) val find_right : t -> right -> left sequence - (** Find all bindings for this given right-key *) + (** Find all bindings for this given right-key. *) val find1_left : t -> left -> right option - (** like {!find_left} but returns at most one value *) + (** Like {!find_left} but returns at most one value. *) val find1_right : t -> right -> left option - (** like {!find_right} but returns at most one value *) + (** Like {!find_right} but returns at most one value. *) val fold : ('a -> left -> right -> 'a) -> 'a -> t -> 'a - (** Fold on pairs *) + (** Fold on pairs. *) val pairs : t -> (left * right) sequence - (** Iterate on pairs *) + (** Iterate on pairs. *) val add_pairs : t -> (left * right) sequence -> t - (** Add pairs *) + (** Add pairs. *) val seq_left : t -> left sequence val seq_right : t -> right sequence diff --git a/src/data/CCMultiSet.ml b/src/data/CCMultiSet.ml index 39d13019..9e9a01cb 100644 --- a/src/data/CCMultiSet.ml +++ b/src/data/CCMultiSet.ml @@ -5,6 +5,9 @@ type 'a sequence = ('a -> unit) -> unit +let max_int = max +let min_int = min + module type S = sig type elt type t @@ -172,7 +175,7 @@ module Make(O : Set.OrderedType) = struct (fun _ n1 n2 -> match n1, n2 with | None, None -> assert false | Some n, None | None, Some n -> Some n - | Some n1, Some n2 -> Some (Pervasives.max n1 n2)) + | Some n1, Some n2 -> Some (max_int n1 n2)) m1 m2 let intersection m1 m2 = @@ -181,7 +184,7 @@ module Make(O : Set.OrderedType) = struct | None, None -> assert false | Some _, None | None, Some _ -> None - | Some n1, Some n2 -> Some (Pervasives.min n1 n2)) + | Some n1, Some n2 -> Some (min_int n1 n2)) m1 m2 let diff m1 m2 = diff --git a/src/data/CCMultiSet.mli b/src/data/CCMultiSet.mli index 2f060dc2..053607e7 100644 --- a/src/data/CCMultiSet.mli +++ b/src/data/CCMultiSet.mli @@ -24,31 +24,31 @@ module type S = sig val remove : t -> elt -> t val add_mult : t -> elt -> int -> t - (** [add_mult set x n] adds [n] occurrences of [x] to [set] - @raise Invalid_argument if [n < 0] + (** [add_mult set x n] adds [n] occurrences of [x] to [set]. + @raise Invalid_argument if [n < 0]. @since 0.6 *) val remove_mult : t -> elt -> int -> t - (** [remove_mult set x n] removes at most [n] occurrences of [x] from [set] - @raise Invalid_argument if [n < 0] + (** [remove_mult set x n] removes at most [n] occurrences of [x] from [set]. + @raise Invalid_argument if [n < 0]. @since 0.6 *) val remove_all : t -> elt -> t - (** [remove_all set x] removes all occurrences of [x] from [set] + (** [remove_all set x] removes all occurrences of [x] from [set]. @since 0.22 *) val update : t -> elt -> (int -> int) -> t (** [update set x f] calls [f n] where [n] is the current multiplicity of [x] in [set] ([0] to indicate its absence); the result of [f n] is the new multiplicity of [x]. - @raise Invalid_argument if [f n < 0] + @raise Invalid_argument if [f n < 0]. @since 0.6 *) val min : t -> elt - (** Minimal element w.r.t the total ordering on elements *) + (** Minimal element w.r.t the total ordering on elements. *) val max : t -> elt - (** Maximal element w.r.t the total ordering on elements *) + (** Maximal element w.r.t the total ordering on elements. *) val union : t -> t -> t (** [union a b] contains as many occurrences of an element [x] @@ -56,25 +56,25 @@ module type S = sig val meet : t -> t -> t (** [meet a b] is a multiset such that - [count (meet a b) x = max (count a x) (count b x)] *) + [count (meet a b) x = max (count a x) (count b x)]. *) val intersection : t -> t -> t (** [intersection a b] is a multiset such that - [count (intersection a b) x = min (count a x) (count b x)] *) + [count (intersection a b) x = min (count a x) (count b x)]. *) val diff : t -> t -> t (** MultiSet difference. - [count (diff a b) x = max (count a x - count b x) 0] *) + [count (diff a b) x = max (count a x - count b x) 0]. *) val contains : t -> t -> bool - (** [contains a x = (count m x > 0)] *) + (** [contains a x = (count m x > 0)]. *) val compare : t -> t -> int val equal : t -> t -> bool val cardinal : t -> int - (** Number of distinct elements *) + (** Number of distinct elements. *) val iter : t -> (int -> elt -> unit) -> unit diff --git a/src/data/CCPersistentArray.ml b/src/data/CCPersistentArray.ml index 663617db..749e3340 100644 --- a/src/data/CCPersistentArray.ml +++ b/src/data/CCPersistentArray.ml @@ -163,7 +163,7 @@ let to_gen a = type 'a printer = Format.formatter -> 'a -> unit -let print pp_item out v = +let pp pp_item out v = Format.fprintf out "[|"; iteri (fun i x -> diff --git a/src/data/CCPersistentArray.mli b/src/data/CCPersistentArray.mli index 413600dd..7ed20503 100644 --- a/src/data/CCPersistentArray.mli +++ b/src/data/CCPersistentArray.mli @@ -43,24 +43,24 @@ val make : int -> 'a -> 'a t array entries will modify all other entries at the same time. @raise Invalid_argument if [n < 0] or [n > Sys.max_array_length]. If the value of x is a floating-point number, then the maximum size is - only [Sys.max_array_length / 2].*) + only [Sys.max_array_length / 2]. *) val init : int -> (int -> 'a) -> 'a t -(** [make n f] returns a persistent array of length n, with element +(** [init n f] returns a persistent array of length n, with element [i] initialized to the result of [f i]. @raise Invalid_argument if [n < 0] or [n > Sys.max_array_length]. If the value of x is a floating-point number, then the maximum size is - only [Sys.max_array_length / 2].*) + only [Sys.max_array_length / 2]. *) val get : 'a t -> int -> 'a (** [get a i] returns the element with index [i] from the array [a]. @raise Invalid_argument "index out of bounds" if [n] is outside the - range [0] to [Array.length a - 1].*) + range [0] to [Array.length a - 1]. *) val set : 'a t -> int -> 'a -> 'a t (** [set a i v] sets the element index [i] from the array [a] to [v]. @raise Invalid_argument "index out of bounds" if [n] is outside the - range [0] to [Array.length a - 1].*) + range [0] to [Array.length a - 1]. *) val length : 'a t -> int (** Returns the length of the persistent array. *) @@ -76,31 +76,31 @@ val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t It is equivalent to [fun f t -> init (fun i -> f (get t i))]. *) val iter : ('a -> unit) -> 'a t -> unit -val iteri : (int -> 'a -> unit) -> 'a t -> unit (** [iter f t] applies function [f] to all elements of the persistent array, in order from element [0] to element [length t - 1]. *) +val iteri : (int -> 'a -> unit) -> 'a t -> unit val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b (** Fold on the elements of the array. *) val append : 'a t -> 'a t -> 'a t -(** Append the two arrays +(** Append the two arrays. @since 0.13 *) val flatten : 'a t t -> 'a t -(** Concatenates all the sub-arrays +(** Concatenates all the sub-arrays. @since 0.13 *) val flat_map : ('a -> 'b t) -> 'a t -> 'b t -(** Flat map (map + concatenation) +(** Flat map (map + concatenation). @since 0.13 *) val to_array : 'a t -> 'a array (** [to_array t] returns a mutable copy of [t]. *) val of_array : 'a array -> 'a t -(** [from_array a] returns an immutable copy of [a]. *) +(** [of_array a] returns an immutable copy of [a]. *) val to_list : 'a t -> 'a list (** [to_list t] returns the list of elements in [t]. *) @@ -109,7 +109,7 @@ val of_list : 'a list -> 'a t (** [of_list l] returns a fresh persistent array containing the elements of [l]. *) val of_rev_list : 'a list -> 'a t -(** [of_rev_list l] is the same as [of_list (List.rev l)] but more efficient +(** [of_rev_list l] is the same as [of_list (List.rev l)] but more efficient. @since 0.13 *) (** {2 Conversions} *) @@ -131,5 +131,5 @@ val to_gen : 'a t -> 'a gen type 'a printer = Format.formatter -> 'a -> unit -val print : 'a printer -> 'a t printer +val pp : 'a printer -> 'a t printer (** @since 0.13 *) diff --git a/src/data/CCPersistentHashtbl.mli b/src/data/CCPersistentHashtbl.mli index 8c51f19c..93672157 100644 --- a/src/data/CCPersistentHashtbl.mli +++ b/src/data/CCPersistentHashtbl.mli @@ -27,29 +27,29 @@ module type S = sig type 'a t val empty : unit -> 'a t - (** Empty table. The table will be allocated at the first binding *) + (** Empty table. The table will be allocated at the first binding. *) val create : int -> 'a t - (** Create a new hashtable, with the given initial capacity *) + (** Create a new hashtable, with the given initial capacity. *) val is_empty : 'a t -> bool (** Is the table empty? *) val find : 'a t -> key -> 'a - (** Find the value for this key, or fails - @raise Not_found if the key is not present in the table *) + (** Find the value for this key, or fails. + @raise Not_found if the key is not present in the table. *) val get_exn : key -> 'a t -> 'a - (** Synonym to {!find} with flipped arguments *) + (** Synonym to {!find} with flipped arguments. *) val get : key -> 'a t -> 'a option - (** Safe version of !{get_exn} *) + (** Safe version of !{get_exn}. *) val mem : 'a t -> key -> bool (** Is the key bound? *) val length : _ t -> int - (** Number of bindings *) + (** Number of bindings. *) val add : 'a t -> key -> 'a -> 'a t (** Add the binding to the table, returning a new table. The old binding @@ -67,11 +67,11 @@ module type S = sig [key] is removed, else it returns [Some v'] and [key -> v'] is added. *) val remove : 'a t -> key -> 'a t - (** Remove the key *) + (** Remove the key. *) val copy : 'a t -> 'a t (** Fresh copy of the table; the underlying structure is not shared - anymore, so using both tables alternatively will be efficient *) + anymore, so using both tables alternatively will be efficient. *) val merge : f:(key -> [`Left of 'a | `Right of 'b | `Both of 'a * 'b] -> 'c option) -> @@ -81,13 +81,13 @@ module type S = sig function returns [None] the key will not appear in the result. *) val iter : 'a t -> (key -> 'a -> unit) -> unit - (** Iterate over bindings *) + (** Iterate over bindings. *) val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold over bindings *) + (** Fold over bindings. *) val map : (key -> 'a -> 'b) -> 'a t -> 'b t - (** Map all values *) + (** Map all values. *) val filter : (key -> 'a -> bool) -> 'a t -> 'a t @@ -100,7 +100,7 @@ module type S = sig (** {3 Conversions} *) val of_seq : (key * 'a) sequence -> 'a t - (** Add (replace) bindings from the sequence to the table *) + (** Add (replace) bindings from the sequence to the table. *) val of_list : (key * 'a) list -> 'a t @@ -109,7 +109,7 @@ module type S = sig val add_list : 'a t -> (key * 'a) list -> 'a t val to_seq : 'a t -> (key * 'a) sequence - (** Sequence of the bindings of the table *) + (** Sequence of the bindings of the table. *) val to_list : 'a t -> (key * 'a) list diff --git a/src/data/CCRAL.ml b/src/data/CCRAL.ml index 5d9aa245..f025bf53 100644 --- a/src/data/CCRAL.ml +++ b/src/data/CCRAL.ml @@ -96,7 +96,7 @@ let tl l = match l with (*$Q Q.(list_of_size Gen.(1--100) int) (fun l -> \ let l' = of_list l in \ - (not (is_empty l')) ==> (equal l' (cons (hd l') (tl l'))) ) + (not (is_empty l')) ==> (equal ~eq:CCInt.equal l' (cons (hd l') (tl l'))) ) *) let front l = match l with @@ -371,7 +371,7 @@ let drop_while ~f l = let take_drop n l = take n l, drop n l -let equal ?(eq=(=)) l1 l2 = +let equal ~eq l1 l2 = let rec aux ~eq l1 l2 = match l1, l2 with | Nil, Nil -> true | Cons (size1, t1, l1'), Cons (size2, t2, l2') -> @@ -389,7 +389,7 @@ let equal ?(eq=(=)) l1 l2 = (*$Q Q.(pair (list int)(list int)) (fun (l1,l2) -> \ - equal (of_list l1) (of_list l2) = (l1=l2)) + equal ~eq:CCInt.equal (of_list l1) (of_list l2) = (l1=l2)) *) (** {2 Utils} *) @@ -543,7 +543,7 @@ let rec of_list_map ~f l = match l with let y = f x in cons y (of_list_map ~f l') -let compare ?(cmp=Pervasives.compare) l1 l2 = +let compare ~cmp l1 l2 = let rec cmp_gen ~cmp g1 g2 = match g1(), g2() with | None, None -> 0 | Some _, None -> 1 @@ -556,7 +556,7 @@ let compare ?(cmp=Pervasives.compare) l1 l2 = (*$Q Q.(pair (list int)(list int)) (fun (l1,l2) -> \ - compare (of_list l1) (of_list l2) = (Pervasives.compare l1 l2)) + compare ~cmp:CCInt.compare (of_list l1) (of_list l2) = (Pervasives.compare l1 l2)) *) (** {2 Infix} *) @@ -576,7 +576,7 @@ include Infix type 'a printer = Format.formatter -> 'a -> unit -let print ?(sep=", ") pp_item fmt l = +let pp ?(sep=", ") pp_item fmt l = let first = ref true in iter l ~f:(fun x -> diff --git a/src/data/CCRAL.mli b/src/data/CCRAL.mli index 0e76eca3..36c48fdc 100644 --- a/src/data/CCRAL.mli +++ b/src/data/CCRAL.mli @@ -18,50 +18,50 @@ type +'a t (** List containing elements of type 'a *) val empty : 'a t -(** Empty list *) +(** Empty list. *) val is_empty : _ t -> bool -(** Check whether the list is empty *) +(** Check whether the list is empty. *) val cons : 'a -> 'a t -> 'a t -(** Add an element at the front of the list *) +(** Add an element at the front of the list. *) val return : 'a -> 'a t -(** Singleton *) +(** Singleton. *) val map : f:('a -> 'b) -> 'a t -> 'b t -(** Map on elements *) +(** Map on elements. *) val mapi : f:(int -> 'a -> 'b) -> 'a t -> 'b t -(** Map with index *) +(** Map with index. *) val hd : 'a t -> 'a (** First element of the list, or - @raise Invalid_argument if the list is empty *) + @raise Invalid_argument if the list is empty. *) val tl : 'a t -> 'a t (** Remove the first element from the list, or - @raise Invalid_argument if the list is empty *) + @raise Invalid_argument if the list is empty. *) val front : 'a t -> ('a * 'a t) option -(** Remove and return the first element of the list *) +(** Remove and return the first element of the list. *) val front_exn : 'a t -> 'a * 'a t (** Unsafe version of {!front}. - @raise Invalid_argument if the list is empty *) + @raise Invalid_argument if the list is empty. *) val length : 'a t -> int -(** Number of elements. Complexity O(ln n) where n=number of elements *) +(** Number of elements. Complexity [O(ln n)] where n=number of elements. *) val get : 'a t -> int -> 'a option -(** [get l i] accesses the [i]-th element of the list. O(log(n)). *) +(** [get l i] accesses the [i]-th element of the list. [O(log(n))]. *) val get_exn : 'a t -> int -> 'a -(** Unsafe version of {!get} +(** Unsafe version of {!get}. @raise Invalid_argument if the list has less than [i+1] elements. *) val set : 'a t -> int -> 'a -> 'a t -(** [set l i v] sets the [i]-th element of the list to [v]. O(log(n)). +(** [set l i v] sets the [i]-th element of the list to [v]. [O(log(n))]. @raise Invalid_argument if the list has less than [i+1] elements. *) val remove : 'a t -> int -> 'a t @@ -90,39 +90,39 @@ val drop_while : f:('a -> bool) -> 'a t -> 'a t val take_drop : int -> 'a t -> 'a t * 'a t (** [take_drop n l] splits [l] into [a, b] such that [length a = n] - if [length l >= n], and such that [append a b = l] *) + if [length l >= n], and such that [append a b = l]. *) val iter : f:('a -> unit) -> 'a t -> unit -(** Iterate on the list's elements *) +(** Iterate on the list's elements. *) val iteri : f:(int -> 'a -> unit) -> 'a t -> unit val fold : f:('b -> 'a -> 'b) -> x:'b -> 'a t -> 'b -(** Fold on the list's elements *) +(** Fold on the list's elements. *) val fold_rev : f:('b -> 'a -> 'b) -> x:'b -> 'a t -> 'b -(** Fold on the list's elements, in reverse order (starting from the tail) *) +(** Fold on the list's elements, in reverse order (starting from the tail). *) val rev_map : f:('a -> 'b) -> 'a t -> 'b t -(** [rev_map f l] is the same as [map f (rev l)] *) +(** [rev_map f l] is the same as [map f (rev l)]. *) val rev : 'a t -> 'a t -(** Reverse the list *) +(** Reverse the list. *) -val equal : ?eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool +val equal : eq:('a -> 'a -> bool) -> 'a t -> 'a t -> bool -val compare : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int -(** Lexicographic comparison *) +val compare : cmp:('a -> 'a -> int) -> 'a t -> 'a t -> int +(** Lexicographic comparison. *) (** {2 Utils} *) val make : int -> 'a -> 'a t val repeat : int -> 'a t -> 'a t -(** [repeat n l] is [append l (append l ... l)] [n] times *) +(** [repeat n l] is [append l (append l ... l)] [n] times. *) val range : int -> int -> int t -(** [range i j] is [i; i+1; ... ; j] or [j; j-1; ...; i] *) +(** [range i j] is [i; i+1; ... ; j] or [j; j-1; ...; i]. *) (** {2 Conversions} *) @@ -132,19 +132,19 @@ type 'a gen = unit -> 'a option val add_list : 'a t -> 'a list -> 'a t val of_list : 'a list -> 'a t -(** Convert a list to a RAL. {b Caution}: non tail-rec *) +(** Convert a list to a RAL. {b Caution}: non tail-rec. *) val to_list : 'a t -> 'a list val of_list_map : f:('a -> 'b) -> 'a list -> 'b t -(** Combination of {!of_list} and {!map} *) +(** Combination of {!of_list} and {!map}. *) val of_array : 'a array -> 'a t val add_array : 'a t -> 'a array -> 'a t val to_array : 'a t -> 'a array -(** More efficient than on usual lists *) +(** More efficient than on usual lists. *) val add_seq : 'a t -> 'a sequence -> 'a t @@ -162,22 +162,22 @@ val to_gen : 'a t -> 'a gen module Infix : sig val (@+) : 'a -> 'a t -> 'a t - (** Cons (alias to {!cons}) *) + (** Cons (alias to {!cons}). *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - (** Alias to {!flat_map} *) + (** Alias to {!flat_map}. *) val (>|=) : 'a t -> ('a -> 'b) -> 'b t - (** Alias to {!map} *) + (** Alias to {!map}. *) val (<*>) : ('a -> 'b) t -> 'a t -> 'b t (** Alias to {!app} *) val (--) : int -> int -> int t - (** Alias to {!range} *) + (** Alias to {!range}. *) val (--^) : int -> int -> int t - (** [a -- b] is the integer range from [a] to [b], where [b] is excluded. + (** [a --^ b] is the integer range from [a] to [b], where [b] is excluded. @since 0.17 *) end @@ -187,4 +187,4 @@ include module type of Infix type 'a printer = Format.formatter -> 'a -> unit -val print : ?sep:string -> 'a printer -> 'a t printer +val pp : ?sep:string -> 'a printer -> 'a t printer diff --git a/src/data/CCRingBuffer.mli b/src/data/CCRingBuffer.mli index 5e24ea5b..ffec50fd 100644 --- a/src/data/CCRingBuffer.mli +++ b/src/data/CCRingBuffer.mli @@ -28,31 +28,31 @@ module Array : sig type t val create : int -> t - (** Make an array of the given size, filled with dummy elements *) + (** Make an array of the given size, filled with dummy elements. *) val length: t -> int - (** [length t] gets the total number of elements currently in [t] *) + (** [length t] gets the total number of elements currently in [t]. *) val get: t -> int -> elt - (** [get t i] gets the element at position [i] *) + (** [get t i] gets the element at position [i]. *) val set: t -> int -> elt -> unit - (** [set t i e] sets the element at position [i] to [e] *) + (** [set t i e] sets the element at position [i] to [e]. *) val sub: t -> int -> int -> t - (** [sub t i len] gets the subarray of [t] from - position [i] to [i + len] *) + (** [sub t i len] gets the sub-array of [t] from + position [i] to [i + len]. *) val copy : t -> t - (** [copy t] makes a fresh copy of the array [t] *) + (** [copy t] makes a fresh copy of the array [t]. *) val blit : t -> int -> t -> int -> int -> unit (** [blit t s arr i len] copies [len] elements from [arr] starting at [i] - to position [s] from [t] *) + to position [s] from [t]. *) val iter : (elt -> unit) -> t -> unit (** [iter f t] iterates over the array [t] invoking [f] with - the current element, in array order *) + the current element, in array order. *) end (** Efficient array version for the [char] type *) @@ -82,7 +82,7 @@ module type S = sig (** [create size] creates a new bounded buffer with given size. The underlying array is allocated immediately and no further (large) allocation will happen from now on. - @raise Invalid_argument if the arguments is [< 1] *) + @raise Invalid_argument if the arguments is [< 1]. *) val copy : t -> t (** Make a fresh copy of the buffer. *) @@ -102,7 +102,7 @@ module type S = sig a input buffer [from_buf] to the end of the buffer. If the slice is too large for the buffer, only the last part of the array will be copied. - @raise Invalid_argument if [o,len] is not a valid slice of [s] *) + @raise Invalid_argument if [o,len] is not a valid slice of [s]. *) val blit_into : t -> Array.t -> int -> int -> int (** [blit_into buf to_buf o len] copies at most [len] elements from [buf] @@ -115,7 +115,7 @@ module type S = sig end of [into]. Erases data of [into] if there is not enough room. *) val to_list : t -> Array.elt list - (** Extract the current content into a list *) + (** Extract the current content into a list. *) val clear : t -> unit (** Clear the content of the buffer. Doesn't actually destroy the content. *) @@ -136,7 +136,7 @@ module type S = sig @raise Invalid_argument if [len > length b]. *) val iter : t -> f:(Array.elt -> unit) -> unit - (** [iter b ~f] calls [f i t] for each element [t] in [buf] *) + (** [iter b ~f] calls [f i t] for each element [t] in [buf]. *) val iteri : t -> f:(int -> Array.elt -> unit) -> unit (** [iteri b ~f] calls [f i t] for each element [t] in [buf], with [i] @@ -145,12 +145,12 @@ module type S = sig val get_front : t -> int -> Array.elt (** [get_front buf i] returns the [i]-th element of [buf] from the front, ie the one returned by [take_front buf] after [i-1] calls to [junk_front buf]. - @raise Invalid_argument if the index is invalid (> [length buf]) *) + @raise Invalid_argument if the index is invalid (> [length buf]). *) val get_back : t -> int -> Array.elt (** [get_back buf i] returns the [i]-th element of [buf] from the back, ie the one returned by [take_back buf] after [i-1] calls to [junk_back buf]. - @raise Invalid_argument if the index is invalid (> [length buf]) *) + @raise Invalid_argument if the index is invalid (> [length buf]). *) val push_back : t -> Array.elt -> unit (** Push value at the back of [t]. @@ -174,14 +174,14 @@ module type S = sig @since 1.3 *) val take_back : t -> Array.elt option - (** Take and remove the last value from back of [t], if any *) + (** Take and remove the last value from back of [t], if any. *) val take_back_exn : t -> Array.elt (** Take and remove the last value from back of [t]. @raise Empty if buffer is already empty. *) val take_front : t -> Array.elt option - (** Take and remove the first value from front of [t], if any *) + (** Take and remove the first value from front of [t], if any. *) val take_front_exn : t -> Array.elt (** Take and remove the first value from front of [t]. @@ -189,7 +189,7 @@ module type S = sig val of_array : Array.t -> t (** Create a buffer from an initial array, but doesn't take ownership - of it (stills allocates a new internal array) + of it (still allocates a new internal array). @since 0.11 *) val to_array : t -> Array.t diff --git a/src/data/CCSimple_queue.ml b/src/data/CCSimple_queue.ml index ed9b639c..1eea0162 100644 --- a/src/data/CCSimple_queue.ml +++ b/src/data/CCSimple_queue.ml @@ -23,7 +23,11 @@ let make_ hd tl = match hd with | [] -> {hd=List.rev tl; tl=[] } | _::_ -> {hd; tl; } -let is_empty q = q.hd = [] +let list_is_empty = function + | [] -> true + | _::_ -> false + +let is_empty q = list_is_empty q.hd let push x q = make_ q.hd (x :: q.tl) @@ -31,7 +35,7 @@ let snoc q x = push x q let peek_exn q = match q.hd with - | [] -> assert (q.tl = []); invalid_arg "Queue.peek" + | [] -> assert (list_is_empty q.tl); invalid_arg "Queue.peek" | x::_ -> x let peek q = match q.hd with @@ -40,7 +44,7 @@ let peek q = match q.hd with let pop_exn q = match q.hd with - | [] -> assert (q.tl = []); invalid_arg "Queue.peek" + | [] -> assert (list_is_empty q.tl); invalid_arg "Queue.peek" | x::hd' -> let q' = make_ hd' q.tl in x, q' diff --git a/src/data/CCSimple_queue.mli b/src/data/CCSimple_queue.mli index 5b2bbcf1..33dd8d73 100644 --- a/src/data/CCSimple_queue.mli +++ b/src/data/CCSimple_queue.mli @@ -19,24 +19,24 @@ val empty : 'a t val is_empty : 'a t -> bool val push : 'a -> 'a t -> 'a t -(** Push element at the end of the queue *) +(** Push element at the end of the queue. *) val snoc : 'a t -> 'a -> 'a t -(** Flip version of {!push} *) +(** Flip version of {!push}. *) val peek : 'a t -> 'a option -(** First element of the queue *) +(** First element of the queue. *) val peek_exn : 'a t -> 'a (** Same as {!peek} but - @raise Invalid_argument if the queue is empty *) + @raise Invalid_argument if the queue is empty. *) val pop : 'a t -> ('a * 'a t) option -(** Get and remove the first element *) +(** Get and remove the first element. *) val pop_exn : 'a t -> ('a * 'a t) (** Same as {!pop}, but fails on empty queues. - @raise Invalid_argument if the queue is empty *) + @raise Invalid_argument if the queue is empty. *) val junk : 'a t -> 'a t (** Remove first element. If the queue is empty, do nothing. *) @@ -47,7 +47,7 @@ val append : 'a t -> 'a t -> 'a t Linear in the size of the second queue. *) val map : ('a -> 'b) -> 'a t -> 'b t -(** Map values *) +(** Map values. *) val rev : 'a t -> 'a t (** Reverse the queue. Constant time. *) @@ -55,15 +55,15 @@ val rev : 'a t -> 'a t val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool module Infix : sig - val (>|=) : 'a t -> ('a -> 'b) -> 'b t (** Alias to {!map} *) - val (@) : 'a t -> 'a t -> 'a t (** Alias to {!append} *) - val (<::) : 'a t -> 'a -> 'a t (** Alias to {!snoc} *) + val (>|=) : 'a t -> ('a -> 'b) -> 'b t (** Alias to {!map}. *) + val (@) : 'a t -> 'a t -> 'a t (** Alias to {!append}. *) + val (<::) : 'a t -> 'a -> 'a t (** Alias to {!snoc}. *) end include module type of Infix val length : 'a t -> int -(** Number of elements in the queue (linear in time) *) +(** Number of elements in the queue (linear in time). *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b diff --git a/src/data/CCTrie.ml b/src/data/CCTrie.ml index d7f8b9f7..c5beeae7 100644 --- a/src/data/CCTrie.ml +++ b/src/data/CCTrie.ml @@ -527,7 +527,7 @@ module Make(W : WORD) | Empty -> 0 | Cons (_, t') -> size t' | Node (v, map) -> - let s = if v=None then 0 else 1 in + let s = match v with None -> 0 | Some _ -> 1 in M.fold (fun _ t' acc -> size t' + acc) map s diff --git a/src/data/CCTrie.mli b/src/data/CCTrie.mli index 0cb34515..5592bd02 100644 --- a/src/data/CCTrie.mli +++ b/src/data/CCTrie.mli @@ -32,17 +32,17 @@ module type S = sig val is_empty : _ t -> bool val add : key -> 'a -> 'a t -> 'a t - (** Add a binding to the trie (possibly erasing the previous one) *) + (** Add a binding to the trie (possibly erasing the previous one). *) val remove : key -> 'a t -> 'a t - (** Remove the key, if present *) + (** Remove the key, if present. *) val find : key -> 'a t -> 'a option - (** Find the value associated with the key, if any *) + (** Find the value associated with the key, if any. *) val find_exn : key -> 'a t -> 'a (** Same as {!find} but can fail. - @raise Not_found if the key is not present *) + @raise Not_found if the key is not present. *) val longest_prefix : key -> 'a t -> key (** [longest_prefix k m] finds the longest prefix of [k] that leads to @@ -50,7 +50,7 @@ module type S = sig a value. Example: if [m] has keys "abc0" and "abcd", then [longest_prefix "abc2" m] - will return "abc" + will return "abc". @since 0.17 *) @@ -58,7 +58,7 @@ module type S = sig (** Update the binding for the given key. The function is given [None] if the key is absent, or [Some v] if [key] is bound to [v]; if it returns [None] the key is removed, otherwise it - returns [Some y] and [key] becomes bound to [y] *) + returns [Some y] and [key] becomes bound to [y]. *) val fold : ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b (** Fold on key/value bindings. Will use {!WORD.of_list} to rebuild keys. *) @@ -72,19 +72,19 @@ module type S = sig @since 0.17 *) val iter : (key -> 'a -> unit) -> 'a t -> unit - (** Same as {!fold}, but for effectful functions *) + (** Same as {!fold}, but for effectful functions. *) val fold_values : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** More efficient version of {!fold}, that doesn't keep keys *) + (** More efficient version of {!fold}, that doesn't keep keys. *) val iter_values : ('a -> unit) -> 'a t -> unit val merge : ('a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t (** Merge two tries together. The function is used in - case of conflicts, when a key belongs to both tries *) + case of conflicts, when a key belongs to both tries. *) val size : _ t -> int - (** Number of bindings *) + (** Number of bindings. *) (** {6 Conversions} *) @@ -104,11 +104,11 @@ module type S = sig val above : key -> 'a t -> (key * 'a) sequence (** All bindings whose key is bigger or equal to the given key, in - ascending order *) + ascending order. *) val below : key -> 'a t -> (key * 'a) sequence (** All bindings whose key is smaller or equal to the given key, - in decreasing order *) + in decreasing order. *) (**/**) val check_invariants: _ t -> bool diff --git a/src/data/CCWBTree.ml b/src/data/CCWBTree.ml index f3ac3336..2979b362 100644 --- a/src/data/CCWBTree.ml +++ b/src/data/CCWBTree.ml @@ -161,7 +161,7 @@ module type S = sig val to_gen : 'a t -> (key * 'a) gen - val print : key printer -> 'a printer -> 'a t printer + val pp : key printer -> 'a printer -> 'a t printer (**/**) val node_ : key -> 'a -> 'a t -> 'a t -> 'a t @@ -588,7 +588,7 @@ module MakeFull(K : KEY) : S with type key = K.t = struct Some (k,v) in next - let print pp_k pp_v fmt m = + let pp pp_k pp_v fmt m = let start = "[" and stop = "]" and arrow = "->" and sep = ","in Format.pp_print_string fmt start; let first = ref true in diff --git a/src/data/CCWBTree.mli b/src/data/CCWBTree.mli index 767735db..c6f13f98 100644 --- a/src/data/CCWBTree.mli +++ b/src/data/CCWBTree.mli @@ -38,14 +38,14 @@ module type S = sig val get : key -> 'a t -> 'a option val get_exn : key -> 'a t -> 'a - (** @raise Not_found if the key is not present *) + (** @raise Not_found if the key is not present. *) val nth : int -> 'a t -> (key * 'a) option (** [nth i m] returns the [i]-th [key, value] in the ascending - order. Complexity is [O(log (cardinal m))] *) + order. Complexity is [O(log (cardinal m))]. *) val nth_exn : int -> 'a t -> key * 'a - (** @raise Not_found if the index is invalid *) + (** @raise Not_found if the index is invalid. *) val get_rank : key -> 'a t -> [`At of int | `After of int | `First] (** [get_rank k m] looks for the rank of [k] in [m], i.e. the index @@ -60,7 +60,7 @@ module type S = sig val update : key -> ('a option -> 'a option) -> 'a t -> 'a t (** [update k f m] calls [f (Some v)] if [get k m = Some v], [f None] otherwise. Then, if [f] returns [Some v'] it binds [k] to [v'], - if [f] returns [None] it removes [k] *) + if [f] returns [None] it removes [k]. *) val cardinal : _ t -> int @@ -83,30 +83,30 @@ module type S = sig val split : key -> 'a t -> 'a t * 'a option * 'a t (** [split k t] returns [l, o, r] where [l] is the part of the map with keys smaller than [k], [r] has keys bigger than [k], - and [o = Some v] if [k, v] belonged to the map *) + and [o = Some v] if [k, v] belonged to the map. *) val merge : f:(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t - (** Similar to {!Map.S.merge} *) + (** Similar to {!Map.S.merge}. *) val extract_min : 'a t -> key * 'a * 'a t (** [extract_min m] returns [k, v, m'] where [k,v] is the pair with the smallest key in [m], and [m'] does not contain [k]. - @raise Not_found if the map is empty *) + @raise Not_found if the map is empty. *) val extract_max : 'a t -> key * 'a * 'a t (** [extract_max m] returns [k, v, m'] where [k,v] is the pair with the highest key in [m], and [m'] does not contain [k]. - @raise Not_found if the map is empty *) + @raise Not_found if the map is empty. *) val choose : 'a t -> (key * 'a) option val choose_exn : 'a t -> key * 'a - (** @raise Not_found if the tree is empty *) + (** @raise Not_found if the tree is empty. *) val random_choose : Random.State.t -> 'a t -> key * 'a (** Randomly choose a (key,value) pair within the tree, using weights - as probability weights - @raise Not_found if the tree is empty *) + as probability weights. + @raise Not_found if the tree is empty. *) val add_list : 'a t -> (key * 'a) list -> 'a t @@ -126,7 +126,9 @@ module type S = sig val to_gen : 'a t -> (key * 'a) gen - val print : key printer -> 'a printer -> 'a t printer + val pp : key printer -> 'a printer -> 'a t printer + (** Renamed from [val print]. + @since NEXT_RELEASE *) (**/**) val node_ : key -> 'a -> 'a t -> 'a t -> 'a t diff --git a/src/data/CCZipper.mli b/src/data/CCZipper.mli index 0ccc2acb..763074ec 100644 --- a/src/data/CCZipper.mli +++ b/src/data/CCZipper.mli @@ -10,7 +10,7 @@ type 'a t = 'a list * 'a list with the focus on [r]. *) val empty : 'a t -(** Empty zipper *) +(** Empty zipper. *) val is_empty : _ t -> bool (** Empty zipper? Returns true iff the two lists are empty. *) @@ -22,36 +22,36 @@ val is_empty : _ t -> bool val to_list : 'a t -> 'a list (** Convert the zipper back to a list. - [to_list (l,r)] is [List.rev_append l r] *) + [to_list (l,r)] is [List.rev_append l r]. *) val to_rev_list : 'a t -> 'a list (** Convert the zipper back to a {i reversed} list. - In other words, [to_list (l,r)] is [List.rev_append r l] *) + In other words, [to_list (l,r)] is [List.rev_append r l]. *) val make : 'a list -> 'a t -(** Create a zipper pointing at the first element of the list *) +(** Create a zipper pointing at the first element of the list. *) val left : 'a t -> 'a t -(** Go to the left, or do nothing if the zipper is already at leftmost pos *) +(** Go to the left, or do nothing if the zipper is already at leftmost pos. *) val left_exn : 'a t -> 'a t (** Go to the left, or - @raise Invalid_argument if the zipper is already at leftmost pos *) + @raise Invalid_argument if the zipper is already at leftmost pos. *) val right : 'a t -> 'a t -(** Go to the right, or do nothing if the zipper is already at rightmost pos *) +(** Go to the right, or do nothing if the zipper is already at rightmost pos. *) val right_exn : 'a t -> 'a t (** Go to the right, or - @raise Invalid_argument if the zipper is already at rightmost pos *) + @raise Invalid_argument if the zipper is already at rightmost pos. *) val modify : ('a option -> 'a option) -> 'a t -> 'a t (** Modify the current element, if any, by returning a new element, or - returning [None] if the element is to be deleted *) + returning [None] if the element is to be deleted. *) val insert : 'a -> 'a t -> 'a t (** Insert an element at the current position. If an element was focused, - [insert x l] adds [x] just before it, and focuses on [x] *) + [insert x l] adds [x] just before it, and focuses on [x]. *) val remove : 'a t -> 'a t (** [remove l] removes the current element, if any. *) @@ -61,12 +61,12 @@ val is_focused : _ t -> bool return a [Some v]? *) val focused : 'a t -> 'a option -(** Returns the focused element, if any. [focused zip = Some _] iff - [empty zip = false] *) +(** Return the focused element, if any. [focused zip = Some _] iff + [empty zip = false]. *) val focused_exn : 'a t -> 'a -(** Returns the focused element, or - @raise Not_found if the zipper is at an end *) +(** Return the focused element, or + @raise Not_found if the zipper is at an end. *) val drop_before : 'a t -> 'a t (** Drop every element on the "left" (calling {!left} then will do nothing). *) diff --git a/src/data/jbuild b/src/data/jbuild new file mode 100644 index 00000000..9fcf9861 --- /dev/null +++ b/src/data/jbuild @@ -0,0 +1,9 @@ + +(library + ((name containers_data) + (public_name containers.data) + (wrapped false) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string)) + (ocamlopt_flags (:standard (:include ../flambda.flags))) + (libraries (bytes result)) + )) diff --git a/src/iter/CCKList.ml b/src/iter/CCKList.ml index 13b0ae44..28be96a6 100644 --- a/src/iter/CCKList.ml +++ b/src/iter/CCKList.ml @@ -422,11 +422,11 @@ let of_gen g = assert_equal [11;12] (drop 10 l |> take 2 |> to_list); *) -let sort ?(cmp=Pervasives.compare) l = +let sort ~cmp l = let l = to_list l in of_list (List.sort cmp l) -let sort_uniq ?(cmp=Pervasives.compare) l = +let sort_uniq ~cmp l = let l = to_list l in uniq (fun x y -> cmp x y = 0) (of_list (List.sort cmp l)) diff --git a/src/iter/CCKList.mli b/src/iter/CCKList.mli index e304138d..a7061d86 100644 --- a/src/iter/CCKList.mli +++ b/src/iter/CCKList.mli @@ -35,28 +35,28 @@ val cycle : 'a t -> 'a t val unfold : ('b -> ('a * 'b) option) -> 'b -> 'a t (** [unfold f acc] calls [f acc] and: - - if [f acc = Some (x, acc')], yield [x], continue with [unfold f acc'] - - if [f acc = None], stops + - if [f acc = Some (x, acc')], yield [x], continue with [unfold f acc']. + - if [f acc = None], stops. @since 0.13 *) val is_empty : 'a t -> bool val head : 'a t -> 'a option -(** Head of the list +(** Head of the list. @since 0.13 *) val head_exn : 'a t -> 'a -(** Unsafe version of {!head} - @raise Not_found if the list is empty +(** Unsafe version of {!head}. + @raise Not_found if the list is empty. @since 0.13 *) val tail : 'a t -> 'a t option -(** Tail of the list +(** Tail of the list. @since 0.13 *) val tail_exn : 'a t -> 'a t -(** Unsafe version of {!tail} - @raise Not_found if the list is empty +(** Unsafe version of {!tail}. + @raise Not_found if the list is empty. @since 0.13 *) val equal : 'a equal -> 'a t equal @@ -66,12 +66,12 @@ val compare : 'a ord -> 'a t ord (** Lexicographic comparison. Eager. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a -(** Fold on values *) +(** Fold on values. *) val iter : ('a -> unit) -> 'a t -> unit val iteri : (int -> 'a -> unit) -> 'a t -> unit -(** Iterate with index (starts at 0) +(** Iterate with index (starts at 0). @since 0.13 *) val length : _ t -> int @@ -90,7 +90,7 @@ val drop_while : ('a -> bool) -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t -(** Map with index (starts at 0) +(** Map with index (starts at 0). @since 0.13 *) val fmap : ('a -> 'b option) -> 'a t -> 'b t @@ -101,17 +101,17 @@ val append : 'a t -> 'a t -> 'a t val product_with : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** Fair product of two (possibly infinite) lists into a new list. Lazy. - The first parameter is used to combine each pair of elements + The first parameter is used to combine each pair of elements. @since 0.3.3 *) val product : 'a t -> 'b t -> ('a * 'b) t -(** Specialization of {!product_with} producing tuples +(** Specialization of {!product_with} producing tuples. @since 0.3.3 *) val group : 'a equal -> 'a t -> 'a t t (** [group eq l] groups together consecutive elements that satisfy [eq]. Lazy. For instance [group (=) [1;1;1;2;2;3;3;1]] yields - [[1;1;1]; [2;2]; [3;3]; [1]] + [[1;1;1]; [2;2]; [3;3]; [1]]. @since 0.3.3 *) val uniq : 'a equal -> 'a t -> 'a t @@ -130,7 +130,7 @@ val range : int -> int -> int t val (--) : int -> int -> int t (** [a -- b] is the range of integers containing - [a] and [b] (therefore, never empty) *) + [a] and [b] (therefore, never empty). *) val (--^) : int -> int -> int t (** [a -- b] is the integer range from [a] to [b], where [b] is excluded. @@ -139,43 +139,43 @@ val (--^) : int -> int -> int t (** {2 Operations on two Collections} *) val fold2 : ('acc -> 'a -> 'b -> 'acc) -> 'acc -> 'a t -> 'b t -> 'acc -(** Fold on two collections at once. Stop at soon as one of them ends *) +(** Fold on two collections at once. Stop at soon as one of them ends. *) val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** Map on two collections at once. Stop as soon as one of the - arguments is exhausted *) + arguments is exhausted. *) val iter2 : ('a -> 'b -> unit) -> 'a t -> 'b t -> unit -(** Iterate on two collections at once. Stop as soon as one of them ends *) +(** Iterate on two collections at once. Stop as soon as one of them ends. *) val for_all2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool val merge : 'a ord -> 'a t -> 'a t -> 'a t -(** Merge two sorted iterators into a sorted iterator *) +(** Merge two sorted iterators into a sorted iterator. *) val zip : 'a t -> 'b t -> ('a * 'b) t (** Combine elements pairwise. Stops as soon as one of the lists stops. @since 0.13 *) val unzip : ('a * 'b) t -> 'a t * 'b t -(** Splits each tuple in the list +(** Splits each tuple in the list. @since 0.13 *) (** {2 Misc} *) -val sort : ?cmp:'a ord -> 'a t -> 'a t -(** Eager sort. Requires the iterator to be finite. O(n ln(n)) time +val sort : cmp:'a ord -> 'a t -> 'a t +(** Eager sort. Requires the iterator to be finite. [O(n ln(n))] time and space. @since 0.3.3 *) -val sort_uniq : ?cmp:'a ord -> 'a t -> 'a t +val sort_uniq : cmp:'a ord -> 'a t -> 'a t (** Eager sort that removes duplicate values. Requires the iterator to be - finite. O(n ln(n)) time and space. + finite. [O(n ln(n))] time and space. @since 0.3.3 *) val memoize : 'a t -> 'a t -(** Avoid recomputations by caching intermediate results +(** Avoid recomputations by caching intermediate results. @since 0.14 *) (** {2 Fair Combinations} *) @@ -189,7 +189,7 @@ val fair_flat_map : ('a -> 'b t) -> 'a t -> 'b t @since 0.13 *) val fair_app : ('a -> 'b) t -> 'a t -> 'b t -(** Fair version of {!(<*>)} +(** Fair version of {!(<*>)}. @since 0.13 *) (** {2 Implementations} @@ -202,11 +202,11 @@ val (>|=) : 'a t -> ('a -> 'b) -> 'b t val (<*>) : ('a -> 'b) t -> 'a t -> 'b t val (>>-) : 'a t -> ('a -> 'b t) -> 'b t -(** Infix version of {! fair_flat_map} +(** Infix version of {! fair_flat_map}. @since 0.13 *) val (<.>) : ('a -> 'b) t -> 'a t -> 'b t -(** Infix version of {!fair_app} +(** Infix version of {!fair_app}. @since 0.13 *) (** {2 Infix operators} @@ -246,7 +246,7 @@ val to_list : 'a t -> 'a list (** Gather all values into a list *) val of_array : 'a array -> 'a t -(** Iterate on the array +(** Iterate on the array. @since 0.13 *) val to_array : 'a t -> 'a array @@ -254,18 +254,18 @@ val to_array : 'a t -> 'a array @since 0.13 *) val to_rev_list : 'a t -> 'a list -(** Convert to a list, in reverse order. More efficient than {!to_list} *) +(** Convert to a list, in reverse order. More efficient than {!to_list}. *) val to_seq : 'a t -> 'a sequence val to_gen : 'a t -> 'a gen val of_gen : 'a gen -> 'a t -(** [of_gen g] consumes the generator and caches intermediate results +(** [of_gen g] consumes the generator and caches intermediate results. @since 0.13 *) (** {2 IO} *) val pp : ?sep:string -> 'a printer -> 'a t printer (** Print the list with the given separator (default ","). - Does not print opening/closing delimiters *) + Does not print opening/closing delimiters. *) diff --git a/src/iter/CCKTree.ml b/src/iter/CCKTree.ml index eae5a29c..ede20047 100644 --- a/src/iter/CCKTree.ml +++ b/src/iter/CCKTree.ml @@ -1,27 +1,4 @@ -(* -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. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Lazy Tree Structure} This structure can be used to represent trees and directed @@ -91,7 +68,7 @@ class type ['a] pset = object method mem : 'a -> bool end -let set_of_cmp (type elt) ?(cmp=Pervasives.compare) () = +let set_of_cmp (type elt) ~cmp () = let module S = Set.Make(struct type t = elt let compare = cmp @@ -105,7 +82,7 @@ let set_of_cmp (type elt) ?(cmp=Pervasives.compare) () = let _nil () = `Nil let _cons x l = `Cons (x, l) -let dfs ?(pset=set_of_cmp ()) t = +let dfs ~pset t = let rec dfs pset stack () = match stack with | [] -> `Nil | `Explore t :: stack' -> @@ -141,19 +118,23 @@ module FQ = struct let empty = _make [] [] - let is_empty q = q.hd = [] + let list_is_empty = function + | [] -> true + | _::_ -> false + + let is_empty q = list_is_empty q.hd let push q x = _make q.hd (x::q.tl) let pop_exn q = match q.hd with - | [] -> assert (q.tl = []); raise Empty + | [] -> assert (list_is_empty q.tl); raise Empty | x::hd' -> let q' = _make hd' q.tl in x, q' end -let bfs ?(pset=set_of_cmp ()) t = +let bfs ~pset t = let rec bfs pset q () = if FQ.is_empty q then `Nil else @@ -173,7 +154,7 @@ let rec force t : ([`Nil | `Node of 'a * 'b list] as 'b) = match t() with | `Nil -> `Nil | `Node (x, l) -> `Node (x, List.map force l) -let find ?pset f t = +let find ~pset f t = let rec _find_kl f l = match l() with | `Nil -> None | `Cons (x, l') -> @@ -181,7 +162,7 @@ let find ?pset f t = | None -> _find_kl f l' | Some _ as res -> res in - _find_kl f (bfs ?pset t) + _find_kl f (bfs ~pset t) (** {2 Pretty-printing} *) diff --git a/src/iter/CCKTree.mli b/src/iter/CCKTree.mli index fadf711c..c732f6a0 100644 --- a/src/iter/CCKTree.mli +++ b/src/iter/CCKTree.mli @@ -1,27 +1,4 @@ -(* -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. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Lazy Tree Structure} This structure can be used to represent trees and directed @@ -42,16 +19,16 @@ val empty : 'a t val is_empty : _ t -> bool val singleton : 'a -> 'a t -(** Tree with only one label *) +(** Tree with only one label. *) val node : 'a -> 'a t list -> 'a t -(** Build a node from a label and a list of children *) +(** Build a node from a label and a list of children. *) val node1 : 'a -> 'a t -> 'a t -(** Node with one child *) +(** Node with one child. *) val node2 : 'a -> 'a t -> 'a t -> 'a t -(** Node with two children *) +(** Node with two children. *) val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** Fold on values in no specified order. May not terminate if the @@ -60,10 +37,10 @@ val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val iter : ('a -> unit) -> 'a t -> unit val size : _ t -> int -(** Number of elements *) +(** Number of elements. *) val height : _ t -> int -(** Length of the longest path to empty leaves *) +(** Length of the longest path to empty leaves. *) val map : ('a -> 'b) -> 'a t -> 'b t @@ -80,22 +57,22 @@ class type ['a] pset = object method mem : 'a -> bool end -val set_of_cmp : ?cmp:('a -> 'a -> int) -> unit -> 'a pset -(** Build a set structure given a total ordering *) +val set_of_cmp : cmp:('a -> 'a -> int) -> unit -> 'a pset +(** Build a set structure given a total ordering. *) -val dfs : ?pset:'a pset -> 'a t -> [ `Enter of 'a | `Exit of 'a ] klist -(** Depth-first traversal of the tree *) +val dfs : pset:'a pset -> 'a t -> [ `Enter of 'a | `Exit of 'a ] klist +(** Depth-first traversal of the tree. *) -val bfs : ?pset:'a pset -> 'a t -> 'a klist -(** Breadth-first traversal of the tree *) +val bfs : pset:'a pset -> 'a t -> 'a klist +(** Breadth-first traversal of the tree. *) val force : 'a t -> ([ `Nil | `Node of 'a * 'b list ] as 'b) (** [force t] evaluates [t] completely and returns a regular tree - structure + structure. @since 0.13 *) -val find : ?pset:'a pset -> ('a -> 'b option) -> 'a t -> 'b option -(** Look for an element that maps to [Some _] *) +val find : pset:'a pset -> ('a -> 'b option) -> 'a t -> 'b option +(** Look for an element that maps to [Some _]. *) (** {2 Pretty-printing} @@ -137,13 +114,13 @@ module Dot : sig ] (** Dot attributes for nodes *) type graph = (string * attribute list t list) - (** A dot graph is a name, plus a list of trees labelled with attributes *) + (** A dot graph is a name, plus a list of trees labelled with attributes. *) val mk_id : ('a, Buffer.t, unit, attribute) format4 -> 'a - (** Using a formatter string, build an ID *) + (** Using a formatter string, build an ID. *) val mk_label : ('a, Buffer.t, unit, attribute) format4 -> 'a - (** Using a formatter string, build a label *) + (** Using a formatter string, build a label. *) val make : name:string -> attribute list t list -> graph @@ -163,6 +140,6 @@ module Dot : sig val to_file : ?name:string -> string -> attribute list t list -> unit (** [to_file filename trees] makes a graph out of the trees, opens the file [filename] and prints the graph into the file. - @param name name of the graph + @param name name of the graph. @since 0.6.1 *) end diff --git a/src/iter/CCLazy_list.mli b/src/iter/CCLazy_list.mli index 3f046fb2..b6111661 100644 --- a/src/iter/CCLazy_list.mli +++ b/src/iter/CCLazy_list.mli @@ -11,25 +11,25 @@ and +'a node = | Cons of 'a * 'a t val empty : 'a t -(** Empty list *) +(** Empty list. *) val return : 'a -> 'a t -(** Return a computed value *) +(** Return a computed value. *) val is_empty : _ t -> bool -(** Evaluates the head *) +(** Evaluates the head. *) val length : _ t -> int (** [length l] returns the number of elements in [l], eagerly (linear time). - Caution, will not terminate if [l] is infinite *) + Caution, will not terminate if [l] is infinite. *) val cons : 'a -> 'a t -> 'a t val head : 'a t -> ('a * 'a t) option -(** Evaluate head, return it, or [None] if the list is empty *) +(** Evaluate head, return it, or [None] if the list is empty. *) val map : f:('a -> 'b) -> 'a t -> 'b t -(** Lazy map *) +(** Lazy map. *) val filter : f:('a -> bool) -> 'a t -> 'a t (** Filter values. @@ -40,10 +40,10 @@ val take : int -> 'a t -> 'a t @since 0.18 *) val append : 'a t -> 'a t -> 'a t -(** Lazy concatenation *) +(** Lazy concatenation. *) val flat_map : f:('a -> 'b t) -> 'a t -> 'b t -(** Monadic flatten + map *) +(** Monadic flatten + map. *) module Infix : sig val (>|=) : 'a t -> ('a -> 'b) -> 'b t diff --git a/src/iter/jbuild b/src/iter/jbuild new file mode 100644 index 00000000..bade997f --- /dev/null +++ b/src/iter/jbuild @@ -0,0 +1,9 @@ + +(library + ((name containers_iter) + (public_name containers.iter) + (wrapped false) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string)) + (ocamlopt_flags (:standard (:include ../flambda.flags))) + (libraries (bytes result)) + )) diff --git a/src/jbuild b/src/jbuild new file mode 100644 index 00000000..8373c9ad --- /dev/null +++ b/src/jbuild @@ -0,0 +1,10 @@ + + +(rule + ((targets (flambda.flags)) + (deps ((file mkflags.ml))) + (fallback) + (action + (run ocaml ./mkflags.ml)) + )) + diff --git a/src/mkflags.ml b/src/mkflags.ml new file mode 100644 index 00000000..d781110e --- /dev/null +++ b/src/mkflags.ml @@ -0,0 +1,13 @@ +let () = + let major, minor = + Scanf.sscanf Sys.ocaml_version "%u.%u" + (fun major minor -> major, minor) + in + let after_4_3 = (major, minor) >= (4, 3) in + let flags_file = open_out "flambda.flags" in + if after_4_3 then ( + output_string flags_file "(-O3 -unbox-closures -unbox-closures-factor 20 -color always)\n"; + ) else ( + output_string flags_file "()\n"; + ); + close_out flags_file diff --git a/src/monomorphic/CCMonomorphic.ml b/src/monomorphic/CCMonomorphic.ml new file mode 100644 index 00000000..3817b80a --- /dev/null +++ b/src/monomorphic/CCMonomorphic.ml @@ -0,0 +1,6 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +include Pervasives + +let (==) = `Consider_using_CCEqual_physical diff --git a/src/monomorphic/CCMonomorphic.mli b/src/monomorphic/CCMonomorphic.mli new file mode 100644 index 00000000..d11e1514 --- /dev/null +++ b/src/monomorphic/CCMonomorphic.mli @@ -0,0 +1,19 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Shadow unsafe functions and operators from Pervasives} *) +(** @since NEXT_RELEASE *) + +val (=) : int -> int -> bool +val (<>) : int -> int -> bool +val (<) : int -> int -> bool +val (>) : int -> int -> bool +val (<=) : int -> int -> bool +val (>=) : int -> int -> bool + +val compare : int -> int -> int +val min : int -> int -> int +val max : int -> int -> int + +val (==) : [`Consider_using_CCEqual_physical] +[@@ocaml.deprecated "Please use CCEqual.physical or Pervasives.(==) instead."] diff --git a/src/monomorphic/jbuild b/src/monomorphic/jbuild new file mode 100644 index 00000000..4eeaac49 --- /dev/null +++ b/src/monomorphic/jbuild @@ -0,0 +1,9 @@ + +(library + ((name containers_monomorphic) + (public_name containers.monomorphic) + (wrapped false) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string)) + (ocamlopt_flags (:standard (:include ../flambda.flags))) + (libraries ()) + )) diff --git a/src/sexp/CCSexp.ml b/src/sexp/CCSexp.ml index 6e5d96a0..25857c31 100644 --- a/src/sexp/CCSexp.ml +++ b/src/sexp/CCSexp.ml @@ -13,9 +13,32 @@ type t = [ ] type sexp = t -let equal a b = a = b +let equal_string (a : string) b = Pervasives.(=) a b -let compare a b = Pervasives.compare a b +let rec equal a b = match a, b with + | `Atom s1, `Atom s2 -> + equal_string s1 s2 + | `List l1, `List l2 -> + begin try List.for_all2 equal l1 l2 with Invalid_argument _ -> false end + | `Atom _, _ | `List _, _ -> false + +let compare_string (a : string) b = Pervasives.compare a b + +let rec compare_list a b = match a, b with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | x::xs, y::ys -> + begin match compare x y with + | 0 -> compare_list xs ys + | c -> c + end + +and compare a b = match a, b with + | `Atom s1, `Atom s2 -> compare_string s1 s2 + | `List l1, `List l2 -> compare_list l1 l2 + | `Atom _, _ -> -1 + | `List _, _ -> 1 let hash a = Hashtbl.hash a diff --git a/src/sexp/CCSexp.mli b/src/sexp/CCSexp.mli index 4dd3aced..b1cd713e 100644 --- a/src/sexp/CCSexp.mli +++ b/src/sexp/CCSexp.mli @@ -19,12 +19,14 @@ 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 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_rev_list : t list -> t +(** Reverse the list. *) val of_float : float -> t val of_unit : t val of_pair : t * t -> t @@ -34,13 +36,13 @@ 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] *) + represents the value [Some 1]. *) val of_field : string -> t -> t -(** Used to represent one record field *) +(** Used to represent one record field. *) val of_record : (string * t) list -> t -(** Represent a record by its named fields *) +(** Represent a record by its named fields. *) (** {2 Printing} *) @@ -51,21 +53,21 @@ 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 *) +(** Print the given sequence of expressions to a file. *) val to_chan : out_channel -> t -> unit val pp : Format.formatter -> t -> unit -(** Pretty-printer nice on human eyes (including indentation) *) +(** Pretty-printer nice on human eyes (including indentation). *) val pp_noindent : Format.formatter -> t -> unit -(** Raw, direct printing as compact as possible *) +(** Raw, direct printing as compact as possible. *) (** {2 Parsing} *) (** A parser of ['a] can return [Yield x] when it parsed a value, or [Fail e] when a parse error was encountered, or - [End] if the input was empty *) + [End] if the input was empty. *) type 'a parse_result = | Yield of 'a | Fail of string @@ -79,24 +81,24 @@ module Decoder : sig val next : t -> sexp parse_result (** Parse the next S-expression or return an error if the input isn't - long enough or isn't a proper S-expression *) + long enough or isn't a proper S-expression. *) end val parse_string : string -> t or_error -(** Parse a string *) +(** Parse a string. *) val parse_chan : 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) *) + to read something else {b after} the S-exp). *) val parse_chan_gen : in_channel -> t or_error gen -(** Parse a channel into a generator of S-expressions *) +(** Parse a channel into a generator of S-expressions. *) val parse_chan_list : in_channel -> t list or_error val parse_file : string -> t or_error -(** Open the file and read a S-exp from it *) +(** 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 *) +(** Open the file and read a S-exp from it. *) diff --git a/src/sexp/CCSexp_lex.mll b/src/sexp/CCSexp_lex.mll index c67e66eb..024d0a6b 100644 --- a/src/sexp/CCSexp_lex.mll +++ b/src/sexp/CCSexp_lex.mll @@ -20,9 +20,11 @@ | Escaped_int_1 of int | Escaped_int_2 of int + let char_equal (a : char) b = Pervasives.(=) a b + (* remove quotes + unescape *) let remove_quotes lexbuf s = - assert (s.[0] = '"' && s.[String.length s - 1] = '"'); + assert (char_equal s.[0] '"' && char_equal s.[String.length s - 1] '"'); let buf = Buffer.create (String.length s) in let st = ref Not_escaped in for i = 1 to String.length s-2 do @@ -72,4 +74,3 @@ rule token = parse | string { ATOM (remove_quotes lexbuf (Lexing.lexeme lexbuf)) } | _ as c { error lexbuf (Printf.sprintf "lexing failed on char `%c`" c) } - diff --git a/src/sexp/jbuild b/src/sexp/jbuild new file mode 100644 index 00000000..b3c35302 --- /dev/null +++ b/src/sexp/jbuild @@ -0,0 +1,11 @@ + +(library + ((name containers_sexp) + (public_name containers.sexp) + (wrapped false) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string)) + (ocamlopt_flags (:standard (:include ../flambda.flags))) + (libraries (bytes result)) + )) + +(ocamllex (CCSexp_lex)) diff --git a/src/threads/CCBlockingQueue.mli b/src/threads/CCBlockingQueue.mli index 003110b1..1912bdc1 100644 --- a/src/threads/CCBlockingQueue.mli +++ b/src/threads/CCBlockingQueue.mli @@ -15,36 +15,36 @@ val create : int -> 'a t (** Create a new queue of size [n]. Using [n=max_int] amounts to using an infinite queue (2^61 items is a lot to fit in memory); using [n=1] amounts to using a box with 0 or 1 elements inside. - @raise Invalid_argument if [n < 1] *) + @raise Invalid_argument if [n < 1]. *) val push : 'a t -> 'a -> unit -(** [push q x] pushes [x] into [q], blocking if the queue is full *) +(** [push q x] pushes [x] into [q], blocking if the queue is full. *) val take : 'a t -> 'a -(** Take the first element, blocking if needed *) +(** Take the first element, blocking if needed. *) val push_list : 'a t -> 'a list -> unit -(** Push items of the list, one by one *) +(** Push items of the list, one by one. *) val take_list : 'a t -> int -> 'a list -(** [take_list n q] takes [n] elements out of [q] *) +(** [take_list n q] takes [n] elements out of [q]. *) val try_take : 'a t -> 'a option (** Take the first element if the queue is not empty, return [None] - otherwise *) + otherwise. *) val try_push : 'a t -> 'a -> bool (** [try_push q x] pushes [x] into [q] if [q] is not full, in which case it returns [true]. - If it fails because [q] is full, it returns [false] *) + If it fails because [q] is full, it returns [false]. *) val peek : 'a t -> 'a option (** [peek q] returns [Some x] if [x] is the first element of [q], - otherwise it returns [None] *) + otherwise it returns [None]. *) val size : _ t -> int -(** Number of elements currently in the queue *) +(** Number of elements currently in the queue. *) val capacity : _ t -> int -(** Number of values the queue can hold *) +(** Number of values the queue can hold. *) diff --git a/src/threads/CCLock.mli b/src/threads/CCLock.mli index 354e47c0..f06ec7c1 100644 --- a/src/threads/CCLock.mli +++ b/src/threads/CCLock.mli @@ -11,17 +11,17 @@ type 'a t (** A value surrounded with a lock *) val create : 'a -> 'a t -(** Create a new protected value *) +(** Create a new protected value. *) val with_lock : 'a t -> ('a -> 'b) -> 'b (** [with_lock l f] runs [f x] where [x] is the value protected with the lock [l], in a critical section. If [f x] fails, [with_lock l f] - fails too but the lock is released *) + fails too but the lock is released. *) val try_with_lock : 'a t -> ('a -> 'b) -> 'b option (** [try_with_lock l f] runs [f x] in a critical section if [l] is not locked. [x] is the value protected by the lock [l]. If [f x] - fails, [try_with_lock l f] fails too but the lock is released + fails, [try_with_lock l f] fails too but the lock is released. @since 0.22 *) (** Type allowing to manipulate the lock as a reference @@ -39,56 +39,56 @@ end val with_lock_as_ref : 'a t -> f:('a LockRef.t -> 'b) -> 'b (** [with_lock_as_ref l f] calls [f] with a reference-like object that allows to manipulate the value of [l] safely. - The object passed to [f] must not escape the function call + The object passed to [f] must not escape the function call. @since 0.13 *) val update : 'a t -> ('a -> 'a) -> unit -(** [update l f] replaces the content [x] of [l] with [f x], atomically *) +(** [update l f] replaces the content [x] of [l] with [f x], atomically. *) val update_map : 'a t -> ('a -> 'a * 'b) -> 'b (** [update_map l f] computes [x', y = f (get l)], then puts [x'] in [l] - and returns [y] + and returns [y]. @since 0.16 *) val mutex : _ t -> Mutex.t -(** Underlying mutex *) +(** Underlying mutex. *) val get : 'a t -> 'a (** Atomically get the value in the lock. The value that is returned isn't protected! *) val set : 'a t -> 'a -> unit -(** Atomically set the value +(** Atomically set the value. @since 0.13 *) val incr : int t -> unit -(** Atomically increment the value +(** Atomically increment the value. @since 0.13 *) val decr : int t -> unit -(** Atomically decrement the value +(** Atomically decrement the value. @since 0.13 *) val incr_then_get : int t -> int -(** [incr_then_get x] increments [x], and return its new value +(** [incr_then_get x] increments [x], and returns its new value. @since 0.16 *) val get_then_incr : int t -> int -(** [get_then_incr x] increments [x], and return its previous value +(** [get_then_incr x] increments [x], and returns its previous value. @since 0.16 *) val decr_then_get : int t -> int -(** [decr_then_get x] decrements [x], and return its new value +(** [decr_then_get x] decrements [x], and returns its new value. @since 0.16 *) val get_then_decr : int t -> int -(** [get_then_decr x] decrements [x], and return its previous value +(** [get_then_decr x] decrements [x], and returns its previous value. @since 0.16 *) val get_then_set : bool t -> bool -(** [get_then_set b] sets [b] to [true], and return the old value +(** [get_then_set b] sets [b] to [true], and returns the old value. @since 0.16 *) val get_then_clear : bool t -> bool -(** [get_then_clear b] sets [b] to [false], and return the old value +(** [get_then_clear b] sets [b] to [false], and returns the old value. @since 0.16 *) diff --git a/src/threads/CCPool.ml b/src/threads/CCPool.ml index 914461cc..fd9c21a1 100644 --- a/src/threads/CCPool.ml +++ b/src/threads/CCPool.ml @@ -9,9 +9,6 @@ type +'a state = | Failed of exn module type PARAM = sig - val min_size : int - (** Minimum number of threads in the pool *) - val max_size : int (** Maximum number of threads in the pool *) end @@ -19,9 +16,10 @@ end exception Stopped (*$inject - module P = Make(struct let min_size = 0 let max_size = 30 end) + module P = Make(struct let max_size = 30 end) + module P2 = Make(struct let max_size = 15 end) module Fut = P.Fut - open Fut.Infix + module Fut2 = P2.Fut *) (** {2 Thread pool} *) @@ -81,14 +79,15 @@ module Make(P : PARAM) = struct (* thread: seek what to do next (including dying). Assumes the pool is locked. *) let get_next_ pool = - if pool.stop - || (Queue.is_empty pool.jobs && pool.cur_size > P.min_size) then ( + (*Printf.printf "get_next (cur=%d, idle=%d, stop=%B)\n%!" pool.cur_size pool.cur_idle pool.stop;*) + if pool.stop || (Queue.is_empty pool.jobs && pool.cur_size > 0) then ( (* die: the thread would be idle otherwise *) - assert (pool.cur_size > 0); + (*Printf.printf "timeā€¦ to die (cur=%d, idle=%d, stop=%B)\n%!" pool.cur_size pool.cur_idle pool.stop;*) decr_size_ pool; Die - ) else if Queue.is_empty pool.jobs then Wait - else ( + ) else if Queue.is_empty pool.jobs then ( + Wait + ) else ( let job = Queue.pop pool.jobs in Process job ) @@ -120,13 +119,11 @@ module Make(P : PARAM) = struct begin try ignore (f x y z w) with e -> pool.exn_handler e end; serve pool (* create a new worker thread *) - let launch_worker_ pool = ignore (Thread.create serve pool) - - (* launch the minimum required number of threads *) - let () = - if P.min_size < 0 then invalid_arg "CCPool: min_size must be >= 0"; - if P.min_size > P.max_size then invalid_arg "CCPool: min_size must be <= max_size"; - for _i = 1 to P.min_size do launch_worker_ pool done + let launch_worker_ pool = + with_lock_ pool + (fun pool -> + incr_size_ pool; + ignore (Thread.create serve pool)) (* heuristic criterion for starting a new thread. *) let can_start_thread_ p = p.cur_size < P.max_size @@ -137,8 +134,7 @@ module Make(P : PARAM) = struct with_lock_ pool (fun pool -> if pool.stop then raise Stopped; - if Queue.is_empty pool.jobs && can_start_thread_ pool && pool.cur_idle = 0 - then ( + if Queue.is_empty pool.jobs && can_start_thread_ pool && pool.cur_idle = 0 then ( (* create the thread now, on [job], as it will not break order of jobs. We do not want to wait for the busy threads to do our task if we are allowed to spawn a new thread. *) @@ -147,10 +143,11 @@ module Make(P : PARAM) = struct ) else ( (* cannot start thread, push and wait for some worker to pick it up *) Queue.push job pool.jobs; - Condition.signal pool.cond; (* wake up some worker, if any *) + Condition.broadcast pool.cond; (* wake up some worker, if any *) (* might want to process in the background, if all threads are busy *) - if pool.cur_idle = 0 && can_start_thread_ pool then ( - incr_size_ pool; + if not (Queue.is_empty pool.jobs) + && pool.cur_idle = 0 + && can_start_thread_ pool then ( launch_worker_ pool; ) )) @@ -283,6 +280,23 @@ module Make(P : PARAM) = struct [ 10; 300; ] *) + (*$R + List.iter + (fun n -> + let l = Sequence.(1 -- n) |> Sequence.to_list in + let l = List.rev_map (fun i -> + Fut2.make + (fun () -> + Thread.delay 0.01; + 1 + )) l in + let l' = List.map Fut2.get l in + OUnit.assert_equal n (List.fold_left (+) 0 l'); + ) + [ 10; 300; ] + *) + + let make2 f x y = let cell = create_cell() in run4 run_and_set2 cell f x y; @@ -314,11 +328,15 @@ module Make(P : PARAM) = struct | Run cell -> with_lock_ cell (fun cell -> cell.state) + let is_not_waiting = function + | Waiting -> false + | Failed _ | Done _ -> true + let is_done = function | Return _ | FailNow _ -> true | Run cell -> - with_lock_ cell (fun c -> c.state <> Waiting) + with_lock_ cell (fun c -> is_not_waiting c.state) (** {2 Combinators *) @@ -375,6 +393,13 @@ module Make(P : PARAM) = struct OUnit.assert_equal 1 (Fut.get c) *) + (*$R + let a = Fut2.make (fun () -> 1) in + let b = Fut2.map (fun x -> x+1) a in + let c = Fut2.map (fun x -> x-1) b in + OUnit.assert_equal 1 (Fut2.get c) + *) + let app_ ~async f x = match f, x with | Return f, Return x -> if async @@ -521,6 +546,43 @@ module Make(P : PARAM) = struct OUnit.assert_equal 10_000 (List.length l'); *) + (*$R + let l = CCList.(1 -- 50) in + let l' = l + |> List.map + (fun x -> Fut2.make (fun () -> Thread.delay 0.1; x*10)) + |> Fut2.sequence_l + |> Fut2.map (List.fold_left (+) 0) + in + let expected = List.fold_left (fun acc x -> acc + 10 * x) 0 l in + OUnit.assert_equal expected (Fut2.get l') + *) + + (*$R + let l = CCList.(1 -- 50) in + let l' = l + |> List.map + (fun x -> Fut2.make (fun () -> Thread.delay 0.1; if x = 5 then raise Exit; x)) + |> Fut2.sequence_l + |> Fut2.map (List.fold_left (+) 0) + in + OUnit.assert_raises Exit (fun () -> Fut2.get l') + *) + + (*$R + let rec fib x = if x<2 then 1 else fib (x-1)+fib(x-2) in + let l = + CCList.(1--10_000) + |> List.rev_map + (fun x-> Fut2.make (fun () -> Thread.yield(); fib (x mod 20))) + |> Fut2.(map_l (fun x->x>|= fun x->x+1)) + in + OUnit.assert_bool "not done" (Fut2.state l = Waiting); + let l' = Fut2.get l in + OUnit.assert_equal 10_000 (List.length l'); + *) + + let choose_ : type a. a t array_or_list -> a t = fun aol -> @@ -556,6 +618,17 @@ module Make(P : PARAM) = struct OUnit.assert_bool "some_parallelism" (stop -. start < float_of_int n *. pause); *) + (*$R + let start = Unix.gettimeofday () in + let pause = 0.2 and n = 10 in + let l = CCList.(1 -- n) + |> List.map (fun _ -> Fut2.make (fun () -> Thread.delay pause)) + in + List.iter Fut2.get l; + let stop = Unix.gettimeofday () in + OUnit.assert_bool "some_parallelism" (stop -. start < float_of_int n *. pause); + *) + module Infix = struct let (>>=) x f = flat_map f x let (>>) a f = and_then a f diff --git a/src/threads/CCPool.mli b/src/threads/CCPool.mli index 9697c6d1..f915c7d6 100644 --- a/src/threads/CCPool.mli +++ b/src/threads/CCPool.mli @@ -12,11 +12,8 @@ type +'a state = | Failed of exn module type PARAM = sig - val min_size : int - (** Minimum number of threads in the pool *) - val max_size : int - (** Maximum number of threads in the pool *) + (** Maximum number of threads in the pool. *) end exception Stopped @@ -24,10 +21,10 @@ exception Stopped (** {2 Create a new Pool} *) module Make(P : PARAM) : sig val run : (unit -> _) -> unit - (** [run f] schedules [f] for being executed in the thread pool *) + (** [run f] schedules [f] for being executed in the thread pool. *) val run1 : ('a -> _) -> 'a -> unit - (** [run1 f x] is similar to [run (fun () -> f x)] *) + (** [run1 f x] is similar to [run (fun () -> f x)]. *) val run2 : ('a -> 'b -> _) -> 'a -> 'b -> unit @@ -36,7 +33,7 @@ module Make(P : PARAM) : sig val set_exn_handler : (exn -> unit) -> unit val active : unit -> bool - (** [active ()] is true as long as [stop()] has not been called yet *) + (** [active ()] is true as long as [stop()] has not been called yet. *) val stop : unit -> unit (** After calling [stop ()], Most functions will raise Stopped. @@ -55,10 +52,10 @@ module Make(P : PARAM) : sig (** {2 Constructors} *) val return : 'a -> 'a t - (** Future that is already computed *) + (** Future that is already computed. *) val fail : exn -> 'a t - (** Future that fails immediately *) + (** Future that fails immediately. *) val make : (unit -> 'a) -> 'a t (** Create a future, representing a value that will be computed by @@ -73,10 +70,10 @@ module Make(P : PARAM) : sig val get : 'a t -> 'a (** Blocking get: wait for the future to be evaluated, and get the value, or the exception that failed the future is returned. - raise e if the future failed with e *) + raise e if the future failed with e. *) val state : 'a t -> 'a state - (** State of the future *) + (** State of the future. *) val is_done : 'a t -> bool (** Is the future evaluated (success/failure)? *) @@ -99,10 +96,10 @@ module Make(P : PARAM) : sig Might be evaluated now if the future is already done. *) val flat_map : ('a -> 'b t) -> 'a t -> 'b t - (** Monadic combination of futures *) + (** Monadic combination of futures. *) val and_then : 'a t -> (unit -> 'b t) -> 'b t - (** Wait for the first future to succeed, then launch the second *) + (** Wait for the first future to succeed, then launch the second. *) val sequence_a : 'a t array -> 'a array t (** Future that waits for all previous futures to terminate. If any future @@ -122,25 +119,25 @@ module Make(P : PARAM) : sig val choose_a : 'a t array -> 'a t (** Choose among those futures (the first to terminate). Behaves like - the first future that terminates, by failing if the future fails *) + the first future that terminates, by failing if the future fails. *) val choose_l : 'a t list -> 'a t (** Choose among those futures (the first to terminate). Behaves like - the first future that terminates, by failing if the future fails *) + the first future that terminates, by failing if the future fails. *) val map : ('a -> 'b) -> 'a t -> 'b t - (** Maps the value inside the future. The function doesn't run in its - own task; if it can take time, use {!flat_map} or {!map_async} *) + (** Map the value inside the future. The function doesn't run in its + own task; if it can take time, use {!flat_map} or {!map_async}. *) val map_async : ('a -> 'b) -> 'a t -> 'b t - (** Maps the value inside the future, to be computed in a separated job. *) + (** Map the value inside the future, to be computed in a separated job. *) val app : ('a -> 'b) t -> 'a t -> 'b t - (** [app f x] applies the result of [f] to the result of [x] *) + (** [app f x] applies the result of [f] to the result of [x]. *) val app_async : ('a -> 'b) t -> 'a t -> 'b t - (** [app f x] applies the result of [f] to the result of [x], in - a separated job scheduled in the pool *) + (** [app_async f x] applies the result of [f] to the result of [x], in + a separated job scheduled in the pool. *) val sleep : float -> unit t (** Future that returns with success in the given amount of seconds. Blocks @@ -159,9 +156,9 @@ module Make(P : PARAM) : sig val (>>) : 'a t -> (unit -> 'b t) -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t - (** Alias to {!map} *) + (** Alias to {!map}. *) val (<*>): ('a -> 'b) t -> 'a t -> 'b t - (** Alias to {!app} *) + (** Alias to {!app}. *) end end diff --git a/src/threads/CCSemaphore.mli b/src/threads/CCSemaphore.mli index 5734d31c..dcf66e29 100644 --- a/src/threads/CCSemaphore.mli +++ b/src/threads/CCSemaphore.mli @@ -8,23 +8,23 @@ type t (** A semaphore *) val create : int -> t -(** [create n] creates a semaphore with initial value [n] - @raise Invalid_argument if [n <= 0] *) +(** [create n] creates a semaphore with initial value [n]. + @raise Invalid_argument if [n <= 0]. *) val get : t -> int -(** Current value *) +(** Current value. *) val acquire : int -> t -> unit (** [acquire n s] blocks until [get s >= n], then atomically - sets [s := !s - n] *) + sets [s := !s - n]. *) val release : int -> t -> unit -(** [release n s] atomically sets [s := !s + n] *) +(** [release n s] atomically sets [s := !s + n]. *) val with_acquire : n:int -> t -> f:(unit -> 'a) -> 'a (** [with_acquire ~n s ~f] first acquires [s] with [n] units, - calls [f ()], and then release [s] with [n] units. - Safely release the semaphore even if [f ()] fails *) + calls [f ()], and then releases [s] with [n] units. + Safely release the semaphore even if [f ()] fails. *) val wait_until_at_least : n:int -> t -> f:(unit -> 'a) -> 'a (** [wait_until_at_least ~n s ~f] waits until [get s >= n], then calls [f ()] diff --git a/src/threads/CCThread.mli b/src/threads/CCThread.mli index fe54e6f8..a8240fed 100644 --- a/src/threads/CCThread.mli +++ b/src/threads/CCThread.mli @@ -8,7 +8,7 @@ type t = Thread.t val spawn : (unit -> _) -> t -(** [spawn f] creates a new thread that runs [f ()] *) +(** [spawn f] creates a new thread that runs [f ()]. *) val spawn1 : ('a -> _) -> 'a -> t (** [spawn1 f x] is like [spawn (fun () -> f x)]. @@ -19,16 +19,16 @@ val spawn2 : ('a -> 'b -> _) -> 'a -> 'b -> t @since 0.16 *) val detach : (unit -> 'a) -> unit -(** [detach f] is the same as [ignore (spawn f)] *) +(** [detach f] is the same as [ignore (spawn f)]. *) (** {2 Array of threads} *) module Arr : sig val spawn : int -> (int -> 'a) -> t array - (** [A.spawn n f] creates an array [res] of length [n], such that - [res.(i) = spawn (fun () -> f i)] *) + (** [Arr.spawn n f] creates an array [res] of length [n], such that + [res.(i) = spawn (fun () -> f i)]. *) val join : t array -> unit - (** [A.join a] joins every thread in [a] *) + (** [Arr.join a] joins every thread in [a]. *) end (** {2 Single-Use Barrier} *) @@ -38,18 +38,18 @@ module Barrier : sig (** Barrier, used to synchronize threads *) val create : unit -> t - (** Create a barrier *) + (** Create a barrier. *) val reset : t -> unit - (** Reset to initial (non-triggered) state *) + (** Reset to initial (non-triggered) state. *) val wait : t -> unit (** [wait b] waits for barrier [b] to be activated by [activate b]. All threads calling this wait until [activate b] is called. - If [b] is already activated, [wait b] does nothing *) + If [b] is already activated, [wait b] does nothing. *) val activate : t -> unit - (** [activate b] unblocks all threads that were waiting on [b] *) + (** [activate b] unblocks all threads that were waiting on [b]. *) val activated : t -> bool (** [activated b] returns [true] iff [activate b] was called, and [reset b] diff --git a/src/threads/CCTimer.ml b/src/threads/CCTimer.ml index f2c37cb8..9ad6e2c4 100644 --- a/src/threads/CCTimer.ml +++ b/src/threads/CCTimer.ml @@ -6,6 +6,11 @@ type job = | Job : float * (unit -> 'a) -> job +let (<=) (a : float) b = Pervasives.(<=) a b +let (>=) (a : float) b = Pervasives.(>=) a b +let (<) (a : float) b = Pervasives.(<) a b +let (>) (a : float) b = Pervasives.(>) a b + module TaskHeap = CCHeap.Make(struct type t = job let leq (Job(f1,_)) (Job (f2,_)) = f1 <= f2 diff --git a/src/threads/CCTimer.mli b/src/threads/CCTimer.mli index f0068cf8..6a2db7e5 100644 --- a/src/threads/CCTimer.mli +++ b/src/threads/CCTimer.mli @@ -14,17 +14,17 @@ val create : unit -> t val set_exn_handler : t -> (exn -> unit) -> unit (** [set_exn_handler timer f] registers [f] so that any exception - raised by a task scheduled in [timer] is given to [f] *) + raised by a task scheduled in [timer] is given to [f]. *) exception Stopped val after : t -> float -> f:(unit -> _) -> unit (** Call the callback [f] after the given number of seconds. - @raise Stopped if the timer was stopped *) + @raise Stopped if the timer was stopped. *) val at : t -> float -> f:(unit -> _) -> unit -(** Create a future that evaluates to [()] at the given Unix timestamp - @raise Stopped if the timer was stopped *) +(** Create a future that evaluates to [()] at the given Unix timestamp. + @raise Stopped if the timer was stopped. *) exception ExitEvery @@ -33,11 +33,11 @@ val every : ?delay:float -> t -> float -> f:(unit -> _) -> unit [f()] can raise ExitEvery to stop the cycle. @param delay if provided, the first call to [f ()] is delayed by that many seconds. - @raise Stopped if the timer was stopped *) + @raise Stopped if the timer was stopped. *) val stop : t -> unit (** Stop the given timer, cancelling pending tasks. Idempotent. From now on, calling most other operations on the timer will raise Stopped. *) val active : t -> bool -(** Returns [true] until [stop t] has been called. *) +(** Return [true] until [stop t] has been called. *) diff --git a/src/threads/jbuild b/src/threads/jbuild new file mode 100644 index 00000000..7af8cbef --- /dev/null +++ b/src/threads/jbuild @@ -0,0 +1,11 @@ + +(library + ((name containers_thread) + (public_name containers.thread) + (wrapped false) + (optional) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string)) + (ocamlopt_flags (:standard (:include ../flambda.flags))) + (libraries (containers threads)) + )) + diff --git a/src/top/jbuild b/src/top/jbuild new file mode 100644 index 00000000..3bd8a254 --- /dev/null +++ b/src/top/jbuild @@ -0,0 +1,11 @@ + + +(library + ((name containers_top) + (public_name containers.top) + (wrapped false) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string)) + (ocamlopt_flags (:standard (:include ../flambda.flags))) + (libraries (compiler-libs.common containers containers.data + containers.unix containers.sexp containers.iter)) + )) diff --git a/src/unix/.merlin b/src/unix/.merlin deleted file mode 100644 index 9ed5b46a..00000000 --- a/src/unix/.merlin +++ /dev/null @@ -1,2 +0,0 @@ -PKG unix -REC diff --git a/src/unix/CCUnix.mli b/src/unix/CCUnix.mli index 3515f0de..93836339 100644 --- a/src/unix/CCUnix.mli +++ b/src/unix/CCUnix.mli @@ -40,8 +40,8 @@ val call_full : returning. @param stdin if provided, the generator or string is consumed and fed to the subprocess input channel, which is then closed. - @param bufsize buffer size used to read stdout and stderr - @param env environment to run the command in + @param bufsize buffer size used to read stdout and stderr. + @param env environment to run the command in. *) (*$T @@ -94,7 +94,7 @@ val async_call : ?env:string array -> 'a (** Spawns a subprocess, like {!call}, but the subprocess's channels are line generators and line sinks (for stdin). - if [p] is [async_call "cmd"], then [p#wait] waits for the subprocess + If [p] is [async_call "cmd"], then [p#wait] waits for the subprocess to die. Channels can be closed independently. @since 0.11 *) @@ -114,25 +114,25 @@ val with_in : ?mode:int -> ?flags:Unix.open_flag list -> (** Open an input file with the given optional flag list, calls the function on the input channel. When the function raises or returns, the channel is closed. - @param flags opening flags. [Unix.O_RDONLY] is used in any cases + @param flags opening flags. [Unix.O_RDONLY] is used in any cases. @since 0.16 *) val with_out : ?mode:int -> ?flags:Unix.open_flag list -> string -> f:(out_channel -> 'a) -> 'a -(** Same as {!with_in} but for an output channel +(** Same as {!with_in} but for an output channel. @param flags opening flags (default [[Unix.O_CREAT; Unix.O_TRUNC]]) [Unix.O_WRONLY] is used in any cases. @since 0.16 *) val with_process_in : string -> f:(in_channel -> 'a) -> 'a -(** Open a subprocess and obtain a handle to its stdout +(** Open a subprocess and obtain a handle to its stdout. {[ CCUnix.with_process_in "ls /tmp" ~f:CCIO.read_lines_l;; ]} @since 0.16 *) val with_process_out : string -> f:(out_channel -> 'a) -> 'a -(** Open a subprocess and obtain a handle to its stdin +(** Open a subprocess and obtain a handle to its stdin. @since 0.16 *) (** Handle to a subprocess. @@ -150,7 +150,7 @@ val with_process_full : ?env:string array -> string -> f:(process_full -> 'a) -> @since 0.16 *) val with_connection : Unix.sockaddr -> f:(in_channel -> out_channel -> 'a) -> 'a -(** Wrap {!Unix.open_connection} with a handler +(** Wrap {!Unix.open_connection} with a handler. @since 0.16 *) exception ExitServer @@ -174,11 +174,11 @@ val with_file_lock : kind:[`Read|`Write] -> string -> (unit -> 'a) -> 'a module Infix : sig val (?|) : ('a, Buffer.t, unit, call_result) format4 -> 'a - (** Infix version of {!call} + (** Infix version of {!call}. @since 0.11 *) val (?|&) : ('a, Buffer.t, unit, async_call_result) format4 -> 'a - (** Infix version of {!async_call} + (** Infix version of {!async_call}. @since 0.11 *) end diff --git a/src/unix/jbuild b/src/unix/jbuild new file mode 100644 index 00000000..6502a9d3 --- /dev/null +++ b/src/unix/jbuild @@ -0,0 +1,10 @@ + +(library + ((name containers_unix) + (public_name containers.unix) + (wrapped false) + (optional) + (flags (:standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string)) + (ocamlopt_flags (:standard (:include ../flambda.flags))) + (libraries (bytes result unix)) + ))