From 5378f9843e406def0344691d1208711dc0125285 Mon Sep 17 00:00:00 2001 From: Jacques-Pascal Deplaix Date: Sat, 9 Aug 2014 10:45:34 +0200 Subject: [PATCH 01/28] OASIS: Use the compiled_setup_ml AlphaFeature --- Makefile | 31 ++++++++++++++++++------------- _oasis | 1 + configure | 4 ++-- setup.ml | 11 ++--------- 4 files changed, 23 insertions(+), 24 deletions(-) diff --git a/Makefile b/Makefile index 250b2b1a..15342953 100644 --- a/Makefile +++ b/Makefile @@ -1,41 +1,46 @@ # OASIS_START -# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) +# DO NOT EDIT (digest: 9a60866e2fa295c5e33a3fe33b8f3a32) -SETUP = ocaml setup.ml +SETUP = ./setup.exe -build: setup.data +build: setup.data $(SETUP) $(SETUP) -build $(BUILDFLAGS) -doc: setup.data build +doc: setup.data $(SETUP) build $(SETUP) -doc $(DOCFLAGS) -test: setup.data build +test: setup.data $(SETUP) build $(SETUP) -test $(TESTFLAGS) -all: +all: $(SETUP) $(SETUP) -all $(ALLFLAGS) -install: setup.data +install: setup.data $(SETUP) $(SETUP) -install $(INSTALLFLAGS) -uninstall: setup.data +uninstall: setup.data $(SETUP) $(SETUP) -uninstall $(UNINSTALLFLAGS) -reinstall: setup.data +reinstall: setup.data $(SETUP) $(SETUP) -reinstall $(REINSTALLFLAGS) -clean: +clean: $(SETUP) $(SETUP) -clean $(CLEANFLAGS) -distclean: +distclean: $(SETUP) $(SETUP) -distclean $(DISTCLEANFLAGS) + $(RM) $(SETUP) -setup.data: +setup.data: $(SETUP) $(SETUP) -configure $(CONFIGUREFLAGS) -configure: +configure: $(SETUP) $(SETUP) -configure $(CONFIGUREFLAGS) +setup.exe: setup.ml + ocamlfind ocamlopt -o $@ -linkpkg -package oasis.dynrun $< || ocamlfind ocamlc -o $@ -linkpkg -package oasis.dynrun $< || true + $(RM) setup.cmi setup.cmo setup.cmx setup.o + .PHONY: build doc test all install uninstall reinstall clean distclean configure # OASIS_STOP diff --git a/_oasis b/_oasis index 67e1812b..f9204fb4 100644 --- a/_oasis +++ b/_oasis @@ -8,6 +8,7 @@ LicenseFile: LICENSE Plugins: META (0.3), DevFiles (0.3) OCamlVersion: >= 4.00.1 BuildTools: ocamlbuild +AlphaFeatures: compiled_setup_ml Synopsis: A modular standard library focused on data structures. Description: diff --git a/configure b/configure index 6acfaeb9..d2a26d17 100755 --- a/configure +++ b/configure @@ -1,7 +1,7 @@ #!/bin/sh # OASIS_START -# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) +# DO NOT EDIT (digest: 6f7b8221311e800a7093dc3b793f67ca) set -e FST=true @@ -23,5 +23,5 @@ for i in "$@"; do esac done -ocaml setup.ml -configure "$@" +make configure CONFIGUREFLAGS="$*" # OASIS_STOP diff --git a/setup.ml b/setup.ml index fe8169fe..e4c486de 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 9852805d5c19ca1cb6abefde2dcea323) *) +(* DO NOT EDIT (digest: 172e37fc4b327922311f6cf9389bc560) *) (******************************************************************************) (* OASIS: architecture for building OCaml libraries and applications *) (* *) @@ -24,14 +24,7 @@ (* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) (******************************************************************************) -let () = - try - Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") - with Not_found -> () -;; -#use "topfind";; -#require "oasis.dynrun";; -open OASISDynRun;; +open OASISDynRun (* OASIS_STOP *) let () = setup ();; From dda1dda27d2b85490a0f2a73842f477950b66661 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 2 Sep 2014 23:44:51 +0200 Subject: [PATCH 02/28] removed type alias CCString.t (duplicate of String.t which already exists) --- core/CCString.ml | 2 -- core/CCString.mli | 56 +++++++++++++++++++++++------------------------ 2 files changed, 27 insertions(+), 31 deletions(-) diff --git a/core/CCString.ml b/core/CCString.ml index 96023ea0..6d926f43 100644 --- a/core/CCString.ml +++ b/core/CCString.ml @@ -48,8 +48,6 @@ module type S = sig val pp : Buffer.t -> t -> unit end -type t = string - let equal (a:string) b = a=b let compare = String.compare diff --git a/core/CCString.mli b/core/CCString.mli index f003b908..db14e264 100644 --- a/core/CCString.mli +++ b/core/CCString.mli @@ -54,47 +54,45 @@ end (** {2 Strings} *) -type t = string +val equal : string -> string -> bool -val equal : t -> t -> bool +val compare : string -> string -> int -val compare : t -> t -> int +val hash : string -> int -val hash : t -> int - -val init : int -> (int -> char) -> t -(** Analog to [Array.init]. +val init : int -> (int -> char) -> string +(** Analog stringo [Array.init]. @since 0.3.3 *) -val of_gen : char gen -> t -val of_seq : char sequence -> t -val of_klist : char klist -> t -val of_list : char list -> t -val of_array : char array -> t +val of_gen : char gen -> string +val of_seq : char sequence -> string +val of_klist : char klist -> string +val of_list : char list -> string +val of_array : char array -> string -val to_array : t -> char array +val to_array : string -> char array -val find : ?start:int -> sub:t -> t -> int -(** Find [sub] in the string, returns its first index or -1. +val find : ?start:int -> sub:string -> string -> int +(** Find [sub] in stringhe string, returns its first index or -1. Should only be used with very small [sub] *) -val is_sub : sub:t -> int -> t -> int -> len:int -> bool -(** [is_sub ~sub i s j ~len] returns [true] iff the substring of +val is_sub : sub:string -> int -> string -> int -> len:int -> bool +(** [is_sub ~sub i s j ~len] returns [true] iff stringhe substring of [sub] starting at position [i] and of length [len], is a substring of [s] starting at position [j] *) -val repeat : t -> int -> t -(** The same string, repeated n times *) +val repeat : string -> int -> string +(** The same string, repeated n stringimes *) -val prefix : pre:t -> t -> bool +val prefix : pre:string -> string -> bool (** [str_prefix ~pre s] returns [true] iff [pre] is a prefix of [s] *) -include S with type t := t +include S with type t := string (** {2 Splitting} *) module Split : sig - val list_ : by:t -> t -> (t*int*int) list + val list_ : by:string -> string -> (string*int*int) list (** split the given string along the given separator [by]. Should only be used with very small separators, otherwise use {!Containers_string.KMP}. @@ -103,18 +101,18 @@ module Split : sig the slice. @raise Failure if [by = ""] *) - val gen : by:t -> t -> (t*int*int) gen + val gen : by:string -> string -> (string*int*int) gen - val seq : by:t -> t -> (t*int*int) sequence + val seq : by:string -> string -> (string*int*int) sequence - val klist : by:t -> t -> (t*int*int) klist + val klist : by:string -> string -> (string*int*int) klist (** {6 Copying functions} Those split functions actually copy the substrings, which can be more convenient but less efficient in general *) - val list_cpy : by:t -> t -> t list + val list_cpy : by:string -> string -> string list (*$T Split.list_cpy ~by:"," "aa,bb,cc" = ["aa"; "bb"; "cc"] @@ -122,11 +120,11 @@ module Split : sig Split.list_cpy ~by:" " "hello world aie" = ["hello"; ""; "world"; "aie"] *) - val gen_cpy : by:t -> t -> t gen + val gen_cpy : by:string -> string -> string gen - val seq_cpy : by:t -> t -> t sequence + val seq_cpy : by:string -> string -> string sequence - val klist_cpy : by:t -> t -> t klist + val klist_cpy : by:string -> string -> string klist end (** {2 Slices} A contiguous part of a string *) From 059e0b064d924d993b983e178dc3481d2b7a9a2d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 2 Sep 2014 23:46:06 +0200 Subject: [PATCH 03/28] CCPervasives module, replacing modules of the standard library --- .ocamlinit | 2 + README.md | 5 +- _oasis | 7 ++ _tags | 161 ++++++++++++++++++++++--------------- pervasives/CCPervasives.ml | 48 +++++++++++ 5 files changed, 155 insertions(+), 68 deletions(-) create mode 100644 pervasives/CCPervasives.ml diff --git a/.ocamlinit b/.ocamlinit index be85d342..499825da 100644 --- a/.ocamlinit +++ b/.ocamlinit @@ -2,11 +2,13 @@ #thread #directory "_build/core";; #directory "_build/misc";; +#directory "_build/pervasives/";; #directory "_build/string";; #directory "_build/threads";; #directory "_build/tests/";; #load "containers.cma";; #load "containers_string.cma";; +#load "containers_pervasives.cma";; #load "containers_misc.cma";; #thread;; #load "containers_thread.cma";; diff --git a/README.md b/README.md index 9e9fa580..52b2c3e2 100644 --- a/README.md +++ b/README.md @@ -12,7 +12,10 @@ ocaml-containers KMP search algorithm, and a few naive utils). Again, modules are independent and sometimes parametric on the string and char types (so they should be able to deal with your favorite unicode library). -3. Random stuff, with *NO* *GUARANTEE* of even being barely usable or tested, +3. A drop-in replacement to the standard library, `containers.pervasives`, + that defined a `CCPervasives` module intented to be opened to extend some + modules of the stdlib. +4. Random stuff, with *NO* *GUARANTEE* of even being barely usable or tested, in other dirs (mostly `misc` but also `lwt` and `threads`). It's where I tend to write code when I want to test some idea, so half the modules (at least) are unfinished or don't really work. diff --git a/_oasis b/_oasis index f9204fb4..601e1ddf 100644 --- a/_oasis +++ b/_oasis @@ -58,6 +58,13 @@ Library "containers_string" FindlibName: string FindlibParent: containers +Library "containers_pervasives" + Path: pervasives + Modules: CCPervasives + BuildDepends: containers + FindlibName: pervasives + FindlibParent: containers + Library "containers_misc" Path: misc Pack: true diff --git a/_tags b/_tags index 25a336b6..865829e3 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 1907902d29ff8cd23331587c97b0f346) +# DO NOT EDIT (digest: fbebfae7c483734f1144067d9ae9954b) # 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 @@ -14,61 +14,56 @@ "_darcs": -traverse "_darcs": not_hygienic # Library containers -"containers.cmxs": use_containers -"cache.cmx": for-pack(Containers) -"deque.cmx": for-pack(Containers) -"gen.cmx": for-pack(Containers) -"fHashtbl.cmx": for-pack(Containers) -"fQueue.cmx": for-pack(Containers) -"flatHashtbl.cmx": for-pack(Containers) -"hashset.cmx": for-pack(Containers) -"heap.cmx": for-pack(Containers) -"lazyGraph.cmx": for-pack(Containers) -"persistentGraph.cmx": for-pack(Containers) -"persistentHashtbl.cmx": for-pack(Containers) -"pHashtbl.cmx": for-pack(Containers) -"sequence.cmx": for-pack(Containers) -"skipList.cmx": for-pack(Containers) -"splayTree.cmx": for-pack(Containers) -"splayMap.cmx": for-pack(Containers) -"univ.cmx": for-pack(Containers) -"vector.cmx": for-pack(Containers) -"bij.cmx": for-pack(Containers) -"piCalculus.cmx": for-pack(Containers) -"bencode.cmx": for-pack(Containers) -"sexp.cmx": for-pack(Containers) -"RAL.cmx": for-pack(Containers) -"multiSet.cmx": for-pack(Containers) -"unionFind.cmx": for-pack(Containers) -"smallSet.cmx": for-pack(Containers) -"leftistheap.cmx": for-pack(Containers) -"absSet.cmx": for-pack(Containers) -"CSM.cmx": for-pack(Containers) -"multiMap.cmx": for-pack(Containers) -"actionMan.cmx": for-pack(Containers) -"BV.cmx": for-pack(Containers) -"qCheck.cmx": for-pack(Containers) -"bencodeOnDisk.cmx": for-pack(Containers) -"show.cmx": for-pack(Containers) -"tTree.cmx": for-pack(Containers) -"hGraph.cmx": for-pack(Containers) -"automaton.cmx": for-pack(Containers) -"conv.cmx": for-pack(Containers) -"levenshtein.cmx": for-pack(Containers) -"bidir.cmx": for-pack(Containers) -"iteratee.cmx": for-pack(Containers) -"ty.cmx": for-pack(Containers) -"tell.cmx": for-pack(Containers) -"bencodeStream.cmx": for-pack(Containers) -"ratTerm.cmx": for-pack(Containers) -"cause.cmx": for-pack(Containers) -"KMP.cmx": for-pack(Containers) -"circList.cmx": for-pack(Containers) -<*.ml{,i}>: package(unix) +"core/containers.cmxs": use_containers +# Library containers_string +"string/containers_string.cmxs": use_containers_string +"string/KMP.cmx": for-pack(Containers_string) +"string/levenshtein.cmx": for-pack(Containers_string) +# Library containers_misc +"misc/containers_misc.cmxs": use_containers_misc +"misc/cache.cmx": for-pack(Containers_misc) +"misc/fHashtbl.cmx": for-pack(Containers_misc) +"misc/flatHashtbl.cmx": for-pack(Containers_misc) +"misc/hashset.cmx": for-pack(Containers_misc) +"misc/heap.cmx": for-pack(Containers_misc) +"misc/lazyGraph.cmx": for-pack(Containers_misc) +"misc/persistentGraph.cmx": for-pack(Containers_misc) +"misc/pHashtbl.cmx": for-pack(Containers_misc) +"misc/skipList.cmx": for-pack(Containers_misc) +"misc/splayTree.cmx": for-pack(Containers_misc) +"misc/splayMap.cmx": for-pack(Containers_misc) +"misc/univ.cmx": for-pack(Containers_misc) +"misc/bij.cmx": for-pack(Containers_misc) +"misc/piCalculus.cmx": for-pack(Containers_misc) +"misc/bencode.cmx": for-pack(Containers_misc) +"misc/sexp.cmx": for-pack(Containers_misc) +"misc/RAL.cmx": for-pack(Containers_misc) +"misc/unionFind.cmx": for-pack(Containers_misc) +"misc/smallSet.cmx": for-pack(Containers_misc) +"misc/absSet.cmx": for-pack(Containers_misc) +"misc/CSM.cmx": for-pack(Containers_misc) +"misc/actionMan.cmx": for-pack(Containers_misc) +"misc/bencodeOnDisk.cmx": for-pack(Containers_misc) +"misc/tTree.cmx": for-pack(Containers_misc) +"misc/printBox.cmx": for-pack(Containers_misc) +"misc/hGraph.cmx": for-pack(Containers_misc) +"misc/automaton.cmx": for-pack(Containers_misc) +"misc/conv.cmx": for-pack(Containers_misc) +"misc/bidir.cmx": for-pack(Containers_misc) +"misc/iteratee.cmx": for-pack(Containers_misc) +"misc/bTree.cmx": for-pack(Containers_misc) +"misc/ty.cmx": for-pack(Containers_misc) +"misc/tell.cmx": for-pack(Containers_misc) +"misc/bencodeStream.cmx": for-pack(Containers_misc) +"misc/ratTerm.cmx": for-pack(Containers_misc) +"misc/cause.cmx": for-pack(Containers_misc) +"misc/AVL.cmx": for-pack(Containers_misc) +"misc/parseReact.cmx": for-pack(Containers_misc) +: package(unix) +: use_containers # Library containers_thread "threads/containers_thread.cmxs": use_containers_thread : package(threads) -: package(unix) : use_containers # Library containers_lwt "lwt/containers_lwt.cmxs": use_containers_lwt @@ -78,50 +73,82 @@ : package(lwt.unix) : package(unix) : use_containers +: use_containers_misc # Library containers_cgi "cgi/containers_cgi.cmxs": use_containers_cgi : package(CamlGI) -: package(unix) : use_containers # Executable benchs "tests/benchs.native": package(bench) "tests/benchs.native": package(unix) "tests/benchs.native": use_containers +"tests/benchs.native": use_containers_misc +"tests/benchs.native": use_containers_string : package(bench) +: use_containers_string # Executable bench_conv "tests/bench_conv.native": package(benchmark) -"tests/bench_conv.native": package(unix) "tests/bench_conv.native": use_containers +# Executable bench_batch +"tests/bench_batch.native": package(benchmark) +"tests/bench_batch.native": use_containers : package(benchmark) +# Executable bench_hash +"tests/bench_hash.native": package(unix) +"tests/bench_hash.native": use_containers +"tests/bench_hash.native": use_containers_misc +: package(unix) +: use_containers_misc # Executable test_levenshtein "tests/test_levenshtein.native": package(qcheck) -"tests/test_levenshtein.native": package(unix) "tests/test_levenshtein.native": use_containers -: package(qcheck) +# Executable test_lwt +: package(lwt) +: package(lwt.unix) +: package(oUnit) +: package(unix) +: use_containers +: use_containers_lwt +: use_containers_misc +: package(lwt) +: package(lwt.unix) +: package(oUnit) +: package(unix) +: use_containers +: use_containers_lwt +: use_containers_misc +# Executable test_threads +: package(oUnit) +: package(threads) +: use_containers +: use_containers_thread +: package(oUnit) +: package(threads) +: use_containers +: use_containers_thread # Executable run_tests -"tests/run_tests.native": package(lwt) -"tests/run_tests.native": package(lwt.unix) "tests/run_tests.native": package(oUnit) -"tests/run_tests.native": package(threads) -"tests/run_tests.native": package(unix) +"tests/run_tests.native": package(qcheck) "tests/run_tests.native": use_containers -: package(lwt) -: package(lwt.unix) : package(oUnit) -: package(threads) -: package(unix) +: package(qcheck) : use_containers # Executable web_pwd "examples/cgi/web_pwd.byte": package(CamlGI) "examples/cgi/web_pwd.byte": package(threads) -"examples/cgi/web_pwd.byte": package(unix) "examples/cgi/web_pwd.byte": use_containers "examples/cgi/web_pwd.byte": use_containers_cgi : package(CamlGI) : package(threads) -: package(unix) : use_containers : use_containers_cgi +# Executable lambda +"examples/lambda.byte": package(unix) +"examples/lambda.byte": use_containers +"examples/lambda.byte": use_containers_misc +: package(unix) +: use_containers +: use_containers_misc # OASIS_STOP : thread : thread diff --git a/pervasives/CCPervasives.ml b/pervasives/CCPervasives.ml new file mode 100644 index 00000000..acaaf6ef --- /dev/null +++ b/pervasives/CCPervasives.ml @@ -0,0 +1,48 @@ + +(* +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 Drop-In replacement to Stdlib} + +This module is meant to be opened if one doesn't want to use both, say, +[List] and [CCList]. Instead, [List] is now an alias to +{[struct + include List + include CCList + end +]} + +*) + +module Array = struct include Array include CCArray end +module Bool = CCBool +module Error = CCError +module Fun = CCFun +module Int = CCInt +module List = struct include List include CCList end +module Opt = CCOpt +module Pair = CCPair +module String = struct include String include CCString end +module Vector = CCVector From 46205b1e26d764cce949c1151b8bd8652f9ab4a5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 3 Sep 2014 01:07:11 +0200 Subject: [PATCH 04/28] forgot @since tag --- pervasives/CCPervasives.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/pervasives/CCPervasives.ml b/pervasives/CCPervasives.ml index acaaf6ef..0454038d 100644 --- a/pervasives/CCPervasives.ml +++ b/pervasives/CCPervasives.ml @@ -34,6 +34,7 @@ This module is meant to be opened if one doesn't want to use both, say, end ]} +@since NEXT_RELEASE *) module Array = struct include Array include CCArray end From 8ade96b2f63492505d33befafa33107c68855c40 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 3 Sep 2014 01:07:48 +0200 Subject: [PATCH 05/28] moved CCHashtbl to CCFlatHashtbl; new module CCHashtbl that wraps and extends the standard hashtable --- README.md | 2 + _oasis | 3 +- configure | 4 +- core/CCFlatHashtbl.ml | 272 ++++++++++++++++++++++++++++ core/CCFlatHashtbl.mli | 84 +++++++++ core/CCHashtbl.ml | 398 ++++++++++++++++++----------------------- core/CCHashtbl.mli | 145 +++++++++++---- 7 files changed, 649 insertions(+), 259 deletions(-) create mode 100644 core/CCFlatHashtbl.ml create mode 100644 core/CCFlatHashtbl.mli diff --git a/README.md b/README.md index 52b2c3e2..fad32d2e 100644 --- a/README.md +++ b/README.md @@ -62,6 +62,8 @@ structures comprise (some modules in `misc/`, some other in `core/`): - `CCArray`, utilities on arrays and slices - `CCLinq`, high-level query language over collections - `CCMultimap` and `CCMultiset`, functors defining persistent structures +- `CCHashtbl`, an extension of the standard hashtbl module +- `CCFlatHashtbl`, a flat (open-addressing) hashtable functorial implementation - `CCKTree`, an abstract lazy tree structure (similar to what `CCKlist` is to lists) - small modules (basic types, utilities): - `CCInt` diff --git a/_oasis b/_oasis index 601e1ddf..57e59880 100644 --- a/_oasis +++ b/_oasis @@ -48,7 +48,8 @@ Library "containers" CCMultiSet, CCBV, CCPrint, CCPersistentHashtbl, CCError, CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCCat, CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, CCIO, - CCRandom, CCLinq, CCKTree, CCTrie, CCString, CCHashtbl + CCRandom, CCLinq, CCKTree, CCTrie, CCString, CCHashtbl, + CCFlatHashtbl FindlibName: containers Library "containers_string" diff --git a/configure b/configure index d2a26d17..42fb4c31 100755 --- a/configure +++ b/configure @@ -1,7 +1,7 @@ #!/bin/sh # OASIS_START -# DO NOT EDIT (digest: 6f7b8221311e800a7093dc3b793f67ca) +# DO NOT EDIT (digest: 82230d61386befb40bc7377608e1f16e) set -e FST=true @@ -23,5 +23,5 @@ for i in "$@"; do esac done -make configure CONFIGUREFLAGS="$*" +make configure CONFIGUREFLAGS="$@" # OASIS_STOP diff --git a/core/CCFlatHashtbl.ml b/core/CCFlatHashtbl.ml new file mode 100644 index 00000000..5de3a2a2 --- /dev/null +++ b/core/CCFlatHashtbl.ml @@ -0,0 +1,272 @@ + +(* +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; } + + (* 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' + + let _pred tbl i = + if i = 0 then Array.length tbl.arr - 1 else i-1 + + (* 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 - 1) + + (* insert k->v in [tbl], currently at index [i] *) + let rec _linear_probe tbl k v h_k i = + 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') -> + if _dib tbl h_k i < _dib tbl h_k' i + then ( + (* replace *) + tbl.arr.(i) <- Key (k, v, h_k); + _linear_probe tbl k' v' h_k' (_succ tbl i) + ) else + (* go further *) + _linear_probe tbl k v h_k (_succ tbl i) + + (* 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) + ) 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) + + (* shift back elements that have a DIB > 0 until an empty bucket is + met, or some element doesn't need shifting *) + let rec _backward_shift tbl i = + match tbl.arr.(i) with + | Empty -> () + | Key (_, _, h_k) when _dib tbl h_k i = 0 -> + () (* stop *) + | Key (k, v, h_k) as bucket -> + assert (_dib tbl h_k i > 0); + (* shift backward *) + tbl.arr.(_pred tbl i) <- bucket; + tbl.arr.(i) <- Empty; + _backward_shift tbl (_succ tbl i) + + (* linear probing for removal of [k] *) + let rec _linear_probe_remove tbl k h_k i = + match tbl.arr.(i) with + | Empty -> () + | Key (k', _, _) when X.equal k k' -> + tbl.arr.(i) <- Empty; + tbl.size <- tbl.size - 1; + _backward_shift tbl (_succ tbl i) + | Key (_, _, h_k') -> + if _dib tbl h_k' i < _dib tbl h_k i + then () (* [k] not present, would be here otherwise *) + else _linear_probe_remove tbl k h_k (_succ tbl i) + + let remove tbl k = + let h_k = X.hash k in + _linear_probe_remove tbl k h_k (_initial_idx tbl h_k) + + let rec _get_exn 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 tbl h_k' i < dib + then raise Not_found (* [k] would be here otherwise *) + else _get_exn 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 + 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 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 +end + diff --git a/core/CCFlatHashtbl.mli b/core/CCFlatHashtbl.mli new file mode 100644 index 00000000..746e31b6 --- /dev/null +++ b/core/CCFlatHashtbl.mli @@ -0,0 +1,84 @@ + +(* +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 NEXT_RELEASE *) + +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/core/CCHashtbl.ml b/core/CCHashtbl.ml index 5de3a2a2..1a00239a 100644 --- a/core/CCHashtbl.ml +++ b/core/CCHashtbl.ml @@ -24,249 +24,207 @@ 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. *) +(** {1 Extension to the standard Hashtbl} *) type 'a sequence = ('a -> unit) -> unit +type 'a eq = 'a -> 'a -> bool +type 'a hash = 'a -> int + +(** {2 Polymorphic tables} *) + +let get tbl x = + try Some (Hashtbl.find tbl x) + with Not_found -> None + +let keys tbl k = Hashtbl.iter (fun key _ -> k key) tbl + +let values tbl k = Hashtbl.iter (fun _ v -> k v) tbl + +let to_seq tbl k = Hashtbl.iter (fun key v -> k (key,v)) tbl + +let of_seq seq = + let tbl = Hashtbl.create 32 in + seq (fun (k,v) -> Hashtbl.add tbl k v); + tbl + +let to_list tbl = + Hashtbl.fold + (fun k v l -> (k,v) :: l) + tbl [] + +let of_list l = + let tbl = Hashtbl.create 32 in + List.iter (fun (k,v) -> Hashtbl.add tbl k v) l; + tbl + +(** {2 Functor} *) module type S = sig - type key - type 'a t + include Hashtbl.S - val create : int -> 'a t - (** Create a new table of the given initial capacity *) + val get : 'a t -> key -> 'a option + (** Safe version of {!Hashtbl.find} *) - val mem : 'a t -> key -> bool - (** [mem tbl k] returns [true] iff [k] is mapped to some value - in [tbl] *) + val keys : 'a t -> key sequence + (** Iterate on keys (similar order as {!Hashtbl.iter}) *) - val find : 'a t -> key -> 'a option + val values : 'a t -> 'a sequence + (** Iterate on values in the table *) - 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 to_seq : 'a t -> (key * 'a) sequence + (** Iterate on values in the table *) val of_seq : (key * 'a) sequence -> 'a t - val to_seq : 'a t -> (key * 'a) sequence + (** From the given bindings, added in order *) - val keys : _ t -> key sequence - val values : 'a t -> 'a sequence + val to_list : 'a t -> (key * 'a) list + (** List of bindings (order unspecified) *) + + val of_list : (key * 'a) list -> 'a t + (** From the given list of bindings, added in order *) end -module type HASHABLE = sig - type t - val equal : t -> t -> bool - val hash : t -> int -end +module Make(X : Hashtbl.HashedType) = struct + include Hashtbl.Make(X) -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; } - - (* 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' - - let _pred tbl i = - if i = 0 then Array.length tbl.arr - 1 else i-1 - - (* 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 - 1) - - (* insert k->v in [tbl], currently at index [i] *) - let rec _linear_probe tbl k v h_k i = - 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') -> - if _dib tbl h_k i < _dib tbl h_k' i - then ( - (* replace *) - tbl.arr.(i) <- Key (k, v, h_k); - _linear_probe tbl k' v' h_k' (_succ tbl i) - ) else - (* go further *) - _linear_probe tbl k v h_k (_succ tbl i) - - (* 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) - ) 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) - - (* shift back elements that have a DIB > 0 until an empty bucket is - met, or some element doesn't need shifting *) - let rec _backward_shift tbl i = - match tbl.arr.(i) with - | Empty -> () - | Key (_, _, h_k) when _dib tbl h_k i = 0 -> - () (* stop *) - | Key (k, v, h_k) as bucket -> - assert (_dib tbl h_k i > 0); - (* shift backward *) - tbl.arr.(_pred tbl i) <- bucket; - tbl.arr.(i) <- Empty; - _backward_shift tbl (_succ tbl i) - - (* linear probing for removal of [k] *) - let rec _linear_probe_remove tbl k h_k i = - match tbl.arr.(i) with - | Empty -> () - | Key (k', _, _) when X.equal k k' -> - tbl.arr.(i) <- Empty; - tbl.size <- tbl.size - 1; - _backward_shift tbl (_succ tbl i) - | Key (_, _, h_k') -> - if _dib tbl h_k' i < _dib tbl h_k i - then () (* [k] not present, would be here otherwise *) - else _linear_probe_remove tbl k h_k (_succ tbl i) - - let remove tbl k = - let h_k = X.hash k in - _linear_probe_remove tbl k h_k (_initial_idx tbl h_k) - - let rec _get_exn 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 tbl h_k' i < dib - then raise Not_found (* [k] would be here otherwise *) - else _get_exn 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 - 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 tbl k h_k (_succ tbl i2) 3 - - let get k tbl = - try Some (get_exn k tbl) + let get tbl x = + try Some (find tbl x) with Not_found -> None - let find_exn tbl k = get_exn k tbl + let keys tbl k = iter (fun key _ -> k key) tbl - let find tbl k = - try Some (get_exn k tbl) - with Not_found -> None + let values tbl k = iter (fun _ v -> k v) tbl - 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 to_seq tbl k = iter (fun key v -> k (key,v)) tbl let of_seq seq = - let tbl = create 16 in + let tbl = create 32 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 to_list tbl = + fold + (fun k v l -> (k,v) :: l) + tbl [] - 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 of_list l = + let tbl = create 32 in + List.iter (fun (k,v) -> add tbl k v) l; + tbl end +(** {2 Default Table} *) + +module type DEFAULT = sig + type key + + type 'a t + (** A hashtable for keys of type [key] and values of type ['a] *) + + val create : ?size:int -> 'a -> 'a t + (** [create d] makes a new table that maps every key to [d] by default. + @param size optional size of the initial table *) + + val create_with : ?size:int -> (key -> 'a) -> 'a t + (** Similar to [create d] but here [d] is a function called to obtain a + new default value for each distinct key. Useful if the default + value is stateful. *) + + val get : 'a t -> key -> 'a + (** Unfailing retrieval (possibly returns the default value) *) + + val set : 'a t -> key -> 'a -> unit + (** Replace the current binding for this key *) + + val remove : 'a t -> key -> unit + (** Remove the binding for this key. If [get tbl k] is called later, the + default value for the table will be returned *) + + val to_seq : 'a t -> (key * 'a) sequence + (** Pairs of [(elem, count)] for all elements whose count is positive *) +end + +module MakeDefault(X : Hashtbl.HashedType) = struct + type key = X.t + + module T = Hashtbl.Make(X) + + type 'a t = { + default : key -> 'a; + tbl : 'a T.t + } + + let create_with ?(size=32) default = { default; tbl=T.create size } + + let create ?size d = create_with ?size (fun _ -> d) + + let get tbl k = + try T.find tbl.tbl k + with Not_found -> + let v = tbl.default k in + T.add tbl.tbl k v; + v + + let set tbl k v = T.replace tbl.tbl k v + + let remove tbl k = T.remove tbl.tbl k + + let to_seq tbl k = T.iter (fun key v -> k (key,v)) tbl.tbl +end + +(** {2 Count occurrences using a Hashtbl} *) + +module type COUNTER = sig + type elt + (** Elements that are to be counted *) + + type t + + val create : int -> t + (** A counter maps elements to natural numbers (the number of times this + element occurred) *) + + val incr : t -> elt -> unit + (** Increment the counter for the given element *) + + val incr_by : t -> int -> elt -> unit + (** Add several occurrences at once *) + + val get : t -> elt -> int + (** Number of occurrences for this element *) + + val add_seq : t -> elt sequence -> unit + (** Increment each element of the sequence *) + + val of_seq : elt sequence -> t + (** [of_seq s] is the same as [add_seq (create ())] *) +end + +module MakeCounter(X : Hashtbl.HashedType) = struct + type elt = X.t + + module T = Hashtbl.Make(X) + + type t = int T.t + + let create size = T.create size + + let get tbl x = try T.find tbl x with Not_found -> 0 + + let incr tbl x = + let n = get tbl x in + T.replace tbl x (n+1) + + let incr_by tbl n x = + let n' = get tbl x in + if n' + n <= 0 + then T.remove tbl x + else T.replace tbl x (n+n') + + let add_seq tbl seq = seq (incr tbl) + + let of_seq seq = + let tbl = create 32 in + add_seq tbl seq; + tbl +end diff --git a/core/CCHashtbl.mli b/core/CCHashtbl.mli index bd4085f9..f160a609 100644 --- a/core/CCHashtbl.mli +++ b/core/CCHashtbl.mli @@ -25,55 +25,128 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(** {1 Open-Addressing Hash-table} *) +(** {1 Extension to the standard Hashtbl} + +@since NEXT_RELEASE *) type 'a sequence = ('a -> unit) -> unit +type 'a eq = 'a -> 'a -> bool +type 'a hash = 'a -> int + +(** {2 Polymorphic tables} *) + +val get : ('a,'b) Hashtbl.t -> 'a -> 'b option +(** Safe version of {!Hashtbl.find} *) + +val keys : ('a,'b) Hashtbl.t -> 'a sequence +(** Iterate on keys (similar order as {!Hashtbl.iter}) *) + +val values : ('a,'b) Hashtbl.t -> 'b sequence +(** Iterate on values in the table *) + +val to_seq : ('a,'b) Hashtbl.t -> ('a * 'b) sequence +(** Iterate on bindings in the table *) + +val of_seq : ('a * 'b) sequence -> ('a,'b) Hashtbl.t +(** From the given bindings, added in order *) + +val to_list : ('a,'b) Hashtbl.t -> ('a * 'b) list +(** List of bindings (order unspecified) *) + +val of_list : ('a * 'b) list -> ('a,'b) Hashtbl.t +(** From the given list of bindings, added in order *) + +(** {2 Functor} *) module type S = sig - type key - type 'a t + include Hashtbl.S - val create : int -> 'a t - (** Create a new table of the given initial capacity *) + val get : 'a t -> key -> 'a option + (** Safe version of {!Hashtbl.find} *) - val mem : 'a t -> key -> bool - (** [mem tbl k] returns [true] iff [k] is mapped to some value - in [tbl] *) + val keys : 'a t -> key sequence + (** Iterate on keys (similar order as {!Hashtbl.iter}) *) - val find : 'a t -> key -> 'a option + val values : 'a t -> 'a sequence + (** Iterate on values in the table *) - 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 to_seq : 'a t -> (key * 'a) sequence + (** Iterate on values in the table *) val of_seq : (key * 'a) sequence -> 'a t + (** From the given bindings, added in order *) + + val to_list : 'a t -> (key * 'a) list + (** List of bindings (order unspecified) *) + + val of_list : (key * 'a) list -> 'a t + (** From the given list of bindings, added in order *) +end + +module Make(X : Hashtbl.HashedType) : S with type key = X.t + +(** {2 Default Table} + +A table with a default element for keys that were never added. *) + +module type DEFAULT = sig + type key + + type 'a t + (** A hashtable for keys of type [key] and values of type ['a] *) + + val create : ?size:int -> 'a -> 'a t + (** [create d] makes a new table that maps every key to [d] by default. + @param size optional size of the initial table *) + + val create_with : ?size:int -> (key -> 'a) -> 'a t + (** Similar to [create d] but here [d] is a function called to obtain a + new default value for each distinct key. Useful if the default + value is stateful. *) + + val get : 'a t -> key -> 'a + (** Unfailing retrieval (possibly returns the default value). This will + modify the table if the key wasn't present. *) + + val set : 'a t -> key -> 'a -> unit + (** Replace the current binding for this key *) + + val remove : 'a t -> key -> unit + (** Remove the binding for this key. If [get tbl k] is called later, the + default value for the table will be returned *) + val to_seq : 'a t -> (key * 'a) sequence - - val keys : _ t -> key sequence - val values : 'a t -> 'a sequence + (** Pairs of [(elem, value)] for all elements on which [get] was called *) end -module type HASHABLE = sig +module MakeDefault(X : Hashtbl.HashedType) : DEFAULT with type key = X.t + +(** {2 Count occurrences using a Hashtbl} *) + +module type COUNTER = sig + type elt + (** Elements that are to be counted *) + type t - val equal : t -> t -> bool - val hash : t -> int + + val create : int -> t + (** A counter maps elements to natural numbers (the number of times this + element occurred) *) + + val incr : t -> elt -> unit + (** Increment the counter for the given element *) + + val incr_by : t -> int -> elt -> unit + (** Add several occurrences at once *) + + val get : t -> elt -> int + (** Number of occurrences for this element *) + + val add_seq : t -> elt sequence -> unit + (** Increment each element of the sequence *) + + val of_seq : elt sequence -> t + (** [of_seq s] is the same as [add_seq (create ())] *) end -module Make(X : HASHABLE) : S with type key = X.t +module MakeCounter(X : Hashtbl.HashedType) : COUNTER with type elt = X.t From c14a0a4bbbf210fa3c3f0552d2c2b206fb25fd59 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 3 Sep 2014 10:20:34 +0200 Subject: [PATCH 06/28] patch tests --- tests/benchs.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/benchs.ml b/tests/benchs.ml index a6553124..3a871049 100644 --- a/tests/benchs.ml +++ b/tests/benchs.ml @@ -31,7 +31,7 @@ module IMap = Map.Make(struct let compare i j = i - j end) -module ICCHashtbl = CCHashtbl.Make(struct +module ICCHashtbl = CCFlatHashtbl.Make(struct type t = int let equal i j = i = j let hash i = i @@ -111,7 +111,7 @@ let bench_maps1 () = "ipersistenthashtbl_add", (fun n -> ignore (ipersistenthashtbl_add n)); "skiplist_add", (fun n -> ignore (skiplist_add n)); "imap_add", (fun n -> ignore (imap_add n)); - "cchashtbl_add", (fun n -> ignore (icchashtbl_add n)) + "ccflathashtbl_add", (fun n -> ignore (icchashtbl_add n)) ] in Bench.summarize 1. res @@ -217,7 +217,7 @@ let bench_maps2 () = "ipersistenthashtbl_replace", (fun n -> ignore (ipersistenthashtbl_replace n)); "skiplist_replace", (fun n -> ignore (skiplist_replace n)); "imap_replace", (fun n -> ignore (imap_replace n)); - "cchashtbl_replace", (fun n -> ignore (icchashtbl_replace n)); + "ccflathashtbl_replace", (fun n -> ignore (icchashtbl_replace n)); ] in Bench.summarize 1. res From c33576a7e1dcec73d14c879bf56476cd770c9285 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 5 Sep 2014 10:38:43 +0200 Subject: [PATCH 07/28] some small improvements to CCRandom --- core/CCRandom.ml | 4 ++++ core/CCRandom.mli | 21 +++++++++++++++++++++ 2 files changed, 25 insertions(+) diff --git a/core/CCRandom.ml b/core/CCRandom.ml index 86b1e6db..286fbbb5 100644 --- a/core/CCRandom.ml +++ b/core/CCRandom.ml @@ -41,6 +41,8 @@ let map f g st = f (g st) let (>|=) g f st = map f g st +let delay f st = f () st + let _choose_array a st = if Array.length a = 0 then invalid_arg "CCRandom.choose_array"; a.(Random.State.int st (Array.length a)) @@ -69,6 +71,8 @@ let replicate n g st = if n = 0 then acc else aux (g st :: acc) (n-1) in aux [] n +let list_seq l st = List.map (fun f -> f st) l + exception SplitFail let _split i st = diff --git a/core/CCRandom.mli b/core/CCRandom.mli index fcf00d42..77f28ab1 100644 --- a/core/CCRandom.mli +++ b/core/CCRandom.mli @@ -45,6 +45,21 @@ val map : ('a -> 'b) -> 'a t -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t +val delay : (unit -> 'a t) -> 'a t +(** Delay evaluation. Useful for side-effectful generators that + need some code to run for every call. + Example: + {[ + let gensym = let r = ref 0 in fun () -> incr r; !r ;; + + delay (fun () -> + let name = gensym() in + small_int >>= fun i -> return (name,i) + ) + ]} + @since NEXT_RELEASE +*) + val choose : 'a t list -> 'a option t (** Choose a generator within the list. *) @@ -59,6 +74,12 @@ val choose_return : 'a list -> 'a t @raise Invalid_argument if the list is empty *) val replicate : int -> 'a t -> 'a list t +(** [replace n g] makes a list of [n] elements which are all generated + randomly using [g] *) + +val list_seq : 'a t list -> 'a list t +(** Build random lists from lists of random generators + @since NEXT_RELEASE *) val small_int : int t From 67824b333a7b520bd656124a09286f1b7475d207 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Sep 2014 22:11:36 +0200 Subject: [PATCH 08/28] .merlin --- .merlin | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.merlin b/.merlin index 8d5ebfe5..728816da 100644 --- a/.merlin +++ b/.merlin @@ -1,11 +1,13 @@ S core S misc S string +S pervasives S tests S examples B _build/core B _build/misc B _build/string +B _build/pervasives B _build/tests B _build/examples PKG oUnit From 25139d7bb5f5faac1200bbc7fb98e4fcefa8e944 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Sep 2014 22:11:42 +0200 Subject: [PATCH 09/28] CCPair.print --- core/CCPair.ml | 4 ++++ core/CCPair.mli | 3 +++ 2 files changed, 7 insertions(+) diff --git a/core/CCPair.ml b/core/CCPair.ml index fa15d4c9..21e1b06c 100644 --- a/core/CCPair.ml +++ b/core/CCPair.ml @@ -64,6 +64,10 @@ let compare f g (x1,y1) (x2,y2) = if c <> 0 then c else g y1 y2 type 'a printer = Buffer.t -> 'a -> unit +type 'a formatter = Format.formatter -> 'a -> unit let pp pp_x pp_y buf (x,y) = Printf.bprintf buf "(%a, %a)" pp_x x pp_y y + +let print pa pb fmt (x,y) = + Format.fprintf fmt "(%a, %a)" pa x pb y diff --git a/core/CCPair.mli b/core/CCPair.mli index 1e6ddaf3..e2ccd3ba 100644 --- a/core/CCPair.mli +++ b/core/CCPair.mli @@ -83,5 +83,8 @@ val equal : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a * 'b) -> ('a * 'b) - val compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a * 'b) -> ('a * 'b) -> int type 'a printer = Buffer.t -> 'a -> unit +type 'a formatter = Format.formatter -> 'a -> unit val pp : 'a printer -> 'b printer -> ('a*'b) printer + +val print : 'a formatter -> 'b formatter -> ('a*'b) formatter From c946a4ea2619c7e9cfd6fa033cf2ffdbb141601c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 00:45:33 +0200 Subject: [PATCH 10/28] re-written Sexp (in misc) to resemble sexplib --- misc/sexp.ml | 542 ++++++++++++++++++++++++++++++-------------------- misc/sexp.mli | 101 ++++++---- 2 files changed, 393 insertions(+), 250 deletions(-) diff --git a/misc/sexp.ml b/misc/sexp.ml index adff2c5c..8c0247fe 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -25,11 +25,13 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Simple S-expression parsing/printing} *) +type 'a or_error = [ `Ok of 'a | `Error of string ] +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + type t = - | K of string * t (* keyword *) - | I of int - | S of string - | L of t list + | Atom of string + | List of t list let eq a b = a = b @@ -39,242 +41,354 @@ let hash a = Hashtbl.hash a (** {2 Serialization (encoding)} *) +let _must_escape s = + try + for i = 0 to String.length s - 1 do + let c = String.unsafe_get s i in + match c with + | ' ' | ')' | '(' | '\n' | '\t' -> raise Exit + | _ -> () + done; + false + with Exit -> true + let rec to_buf b t = match t with - | I i -> Printf.bprintf b "%d" i - | S s -> Buffer.add_string b (String.escaped s) - | K (s, t') -> - assert (s.[0] = ':'); - Buffer.add_string b s; - Buffer.add_char b ' '; - to_buf b t' - | L l -> - Buffer.add_char b '('; - List.iteri (fun i t' -> (if i > 0 then Buffer.add_char b ' '; to_buf b t')) l; - Buffer.add_char b ')' + | Atom s when _must_escape s -> Printf.bprintf b "\"%s\"" (String.escaped s) + | Atom s -> Buffer.add_string b s + | List [] -> Buffer.add_string b "()" + | List [x] -> Printf.bprintf b "(%a)" to_buf x + | List l -> + Buffer.add_char b '('; + List.iteri + (fun i t' -> (if i > 0 then Buffer.add_char b ' '; to_buf b t')) + l; + Buffer.add_char b ')' let to_string t = - let b = Buffer.create 32 in + let b = Buffer.create 128 in to_buf b t; Buffer.contents b -(* TODO: improve (slow and ugly) *) -let fmt fmt t = - let b = Buffer.create 32 in - to_buf b t; - Format.pp_print_string fmt (Buffer.contents b) +let rec print fmt t = match t with + | Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s) + | Atom s -> Format.pp_print_string fmt s + | List [] -> Format.pp_print_string fmt "()" + | List [x] -> Format.fprintf fmt "(%a)" print x + | List l -> + Format.pp_print_char fmt '('; + List.iteri + (fun i t' -> (if i > 0 then Format.fprintf fmt "@ "; print fmt t')) + l; + Format.pp_print_char fmt ')' (** {2 Deserialization (decoding)} *) -(** Deserialization is based on the {! decoder} type. Parsing can be - incremental, in which case the input is provided chunk by chunk and - the decoder contains the parsing state. Once a Sexpr value - has been parsed, other values can still be read. *) +type 'a parse_result = ['a or_error | `End ] +type 'a partial_result = [ 'a parse_result | `Await ] -type decoder = { - mutable buf : string; (* input buffer *) - mutable i : int; (* index in buf *) - mutable len : int; (* length of substring to read *) - mutable c : int; (* line *) - mutable l : int; (* column *) - mutable state : parse_result; - mutable stack : partial_state list; -} (** Decoding state *) +module Streaming = struct + type token = + | Open + | Close + | Atom of string -(** Result of parsing *) -and parse_result = - | ParseOk of t - | ParseError of string - | ParsePartial + type decode_state = + | St_start + | St_atom + | St_quoted + | St_escaped + | St_yield of token + | St_error of string + | St_end -(** Partial state of the parser *) -and partial_state = - | PS_I of bool * int (* sign and integer *) - | PS_S of Buffer.t (* parsing a string *) - | PS_S_escape of Buffer.t (* parsing a string; prev char is \ *) - | PS_L of t list - | PS_key of string (* key, waiting for value *) - | PS_return of t (* bottom of stack *) - | PS_error of string (* error *) + type decoder = { + mutable st : decode_state; + mutable i : int; + mutable line : int; + mutable col : int; + mutable stop : bool; + buf : Buffer.t; + atom : Buffer.t; (* atom being parsed *) + } -let mk_decoder () = - let dec = { - buf = ""; + let mk_decoder () = { i = 0; - len = 0; - c = 0; - l = 0; - state = ParsePartial; - stack = []; - } in - dec + st = St_start; + line = 0; + col = 0; + stop = false; + buf=Buffer.create 32; + atom = Buffer.create 32; + } -let is_empty dec = dec.len = 0 -let cur dec = dec.buf.[dec.i] + exception NeedMoar + exception Error of string + exception EOI -let junk dec = - (* update line/column *) - (if cur dec = '\n' - then (dec.c <- 0; dec.l <- dec.l + 1) - else dec.c <- dec.c + 1); - dec.i <- dec.i + 1; - dec.len <- dec.len - 1 + (* yield [x] with current state [st] *) + let _yield d st x = + d.st <- st; + x -let next dec = - let c = cur dec in - junk dec; - c + (* read the next char *) + let _next_char d = + if d.i = Buffer.length d.buf + then ( + (* need more input; reset buffer to put it in *) + Buffer.clear d.buf; + d.i <- 0; + raise NeedMoar + ) else ( + let c = Buffer.nth d.buf d.i in + d.i <- d.i + 1; + c + ) -(* parse value *) -let rec parse_rec dec = - match dec.stack with - | [PS_return v] -> (* return value *) - dec.stack <- []; - dec.state <- ParseOk v; - dec.state - | [PS_error s] -> (* failure *) - dec.stack <- []; - dec.state <- ParseError s; - dec.state - | _ -> - if is_empty dec then ParsePartial (* wait *) - else begin - let c = next dec in - (match dec.stack, c with - | PS_S_escape b :: stack, 'n' -> - Buffer.add_char b '\n'; - dec.stack <- PS_S b :: stack - | PS_S_escape b :: stack, 't' -> - Buffer.add_char b '\t'; - dec.stack <- PS_S b :: stack - | (PS_S_escape b) :: stack, ('(' | '\\' | ')' | ' ') -> - Buffer.add_char b c; - dec.stack <- (PS_S b) :: stack; - | (PS_key s) :: _, (')' | '\n' | ' ' | '\t') -> (* error *) - error dec ("keyword " ^ s ^ " expected value") - | _, ')' -> (* special case for ')' *) - close_paren dec - | ((PS_L _ | PS_key _) :: _ | []), '-' -> (* negative num *) - dec.stack <- PS_I (false, 0) :: dec.stack - | ((PS_L _ | PS_key _) :: _ | []), '0' .. '9' -> (* positive num *) - dec.stack <- PS_I (true, Char.code c - Char.code '0') :: dec.stack - | (PS_I (sign, i)) :: stack, '0' .. '9' -> - dec.stack <- PS_I (sign, (Char.code c - Char.code '0') + 10 * i) :: stack; - | (PS_I (sign, i)) :: stack, (' ' | '\t' | '\n') -> - terminate_token dec - | stack, '(' -> - dec.stack <- PS_L [] :: stack (* push new list *) - | PS_S b :: stack, (' ' | '\t' | '\n') -> (* parsed a string *) - terminate_token dec - | PS_S b :: stack, '\\' -> - dec.stack <- PS_S_escape b :: stack (* escape next char *) - | PS_S b :: _, _ -> - Buffer.add_char b c (* just a char of the string *) - | _, (' ' | '\t' | '\n') -> (* skip *) - () - | stack, c -> - let b = Buffer.create 7 in - Buffer.add_char b c; - dec.stack <- PS_S b :: stack - ); - parse_rec dec - end -(* When a value is parsed, push it on the stack (possibly collapsing it) *) -and push_value dec v = - match v, dec.stack with - | _, [] -> - dec.stack <- [PS_return v] (* finished *) - | _, (PS_L l) :: stack -> - (* add to list *) - dec.stack <- (PS_L (v :: l)) :: stack; - | v, ((PS_key s) :: stack) -> - (* parsed a key/value *) - dec.stack <- stack; - push_value dec (K (s, v)) - | _ -> - error dec "unexpected value" -(* closing parenthesis: may terminate several states at once *) -and close_paren dec = - match dec.stack with - | PS_L l :: stack -> - dec.stack <- stack; - push_value dec (L (List.rev l)) - | (PS_I _ | PS_S _) :: stack -> - terminate_token dec; - close_paren dec (* parenthesis still not closed *) - | _ -> - error dec "Sexp: unexpected ')'" -(* terminate current token *) -and terminate_token dec = - match dec.stack with - | [] -> assert false - | (PS_I (sign, i)) :: stack -> - dec.stack <- stack; - push_value dec (I (if sign then i else ~- i)) (* parsed int *) - | (PS_S b) :: stack -> - dec.stack <- stack; + let _take_buffer b = let s = Buffer.contents b in - if s.[0] = ':' - then dec.stack <- (PS_key s) :: stack (* keyword, wait for value *) - else push_value dec (S s) - | _ -> - error dec "Sexp: ill-terminated token" -(* signal error *) -and error dec msg = - let msg = Printf.sprintf "Sexp: error at line %d, column %d: %s" - dec.l dec.c msg in - dec.stack <- [PS_error msg] + Buffer.clear b; + s -(* exported parse function *) -let parse dec s i len = - (if i < 0 || i+len > String.length s - then invalid_arg "Sexp.parse: not a valid substring"); - (* add the input to [dec] *) - if dec.len = 0 - then begin - dec.buf <- s; - dec.i <- i; - dec.len <- len; - end else begin - (* use a buffer to merge the stored input and the new input *) - let b = Buffer.create (dec.len + len) in - Buffer.add_substring b dec.buf dec.i dec.len; - Buffer.add_substring b s i len; - dec.buf <- Buffer.contents b; - dec.i <- 0; - dec.len <- dec.len + len; - end; - (* state machine *) - parse_rec dec + let _newline d = + d.line <- d.line + 1; + d.col <- 0; + () -let reset dec = - dec.l <- 0; - dec.c <- 0; - dec.i <- 0; - dec.len <- 0; - dec.state <- ParsePartial; - dec.stack <- []; - () + (* raise an error *) + let _error d msg = + let msg' = Printf.sprintf "at %d,%d: %s" d.line d.col msg in + d.st <- St_error msg'; + raise (Error msg') -let state dec = dec.state + (* next token *) + let rec _next d st = match st with + | St_error msg -> raise (Error msg) + | St_end -> raise EOI + | St_yield x -> + (* yield the given token, then start a fresh one *) + _yield d St_start x + | St_start -> + (* start reading next token *) + let c = _next_char d in + begin match c with + | '\n' -> _newline d; _next d St_start + | ' ' | '\t' -> _next d St_start + | '(' -> _yield d St_start Open + | ')' -> _yield d St_start Close + | '"' -> _next d St_quoted + | _ -> (* read regular atom *) + Buffer.add_char d.atom c; + _next d St_atom + end + | St_atom when d.stop -> + let a = _take_buffer d.atom in + _yield d St_end (Atom a) + | St_atom -> + (* reading an unquoted atom *) + let c = _next_char d in + begin match c with + | ' ' | '\t' | '\n' -> + let a = _take_buffer d.atom in + _yield d St_start (Atom a) + | ')' -> + let a = _take_buffer d.atom in + _yield d (St_yield Close) (Atom a) + | '(' -> + let a = _take_buffer d.atom in + _yield d (St_yield Open) (Atom a) + | '\\' -> _error d "unexpected char" + | _ -> + Buffer.add_char d.atom c; + _next d St_atom + end + | St_quoted when d.stop -> + let a = _take_buffer d.atom in + _yield d St_end (Atom a) + | St_quoted -> + (* reading an unquoted atom *) + let c = _next_char d in + begin match c with + | '\\' -> _next d St_escaped + | '"' -> + let a = _take_buffer d.atom in + _yield d St_start (Atom a) + | _ -> + Buffer.add_char d.atom c; + _next d St_atom + end + | St_escaped -> + if d.stop + then _error d "unexpected end of input (escaping)"; + let c = _next_char d in + Buffer.add_char d.atom + (match c with + | 'n' -> '\n' + | 't' -> '\t' + | 'r' -> '\r' + | '\\' -> '\\' + | _ -> _error d "unexpected escaped character" + ); + _next d St_quoted -let rest dec = - String.sub dec.buf dec.i dec.len + let feed d s i len = + if d.stop then failwith "Sexp.Streaming.feed: end of input reached"; + Buffer.add_substring d.buf s i len -let rest_size dec = - dec.len + let reached_end d = + d.stop <- true + + let next_exn d = _next d d.st + + let next d = + try + `Ok (_next d d.st) + with + | NeedMoar -> `Await + | Error msg -> `Error msg + | EOI -> `End +end + +module ParseGen = struct + type 'a t = unit -> 'a parse_result + + let to_list g : 'a list or_error = + let rec aux acc = match g() with + | `Error e -> `Error e + | `Ok x -> aux (x::acc) + | `End -> `Ok (List.rev acc) + in + aux [] + + let head g = match g() with + | `End -> `Error "expected at least one element" + | #or_error as x -> x + + let head_exn g = match g() with + | `Ok x -> x + | `Error msg -> failwith msg + | `End -> failwith "expected at least one element" + + let take n g = + assert (n>=0); + let n = ref n in + fun () -> + if !n = 0 then `End + else ( + decr n; + g() + ) +end + +(* hidden parser state *) +type parser_state = { + ps_d : Streaming.decoder; + mutable ps_stack : t list list; +} + +let mk_ps () = { + ps_d = Streaming.mk_decoder (); + ps_stack = []; +} + +let _error ps msg = + let msg' = Printf.sprintf "at %d,%d: %s" + ps.ps_d.Streaming.line ps.ps_d.Streaming.col msg in + `Error msg' + +(* next token, or await *) +let rec _next ps : t partial_result = match Streaming.next ps.ps_d with + | `Ok (Streaming.Atom s) -> + _push ps (Atom s) + | `Ok Streaming.Open -> + ps.ps_stack <- [] :: ps.ps_stack; + _next ps + | `Ok Streaming.Close -> + begin match ps.ps_stack with + | [] -> _error ps "unbalanced ')'" + | l :: stack -> + ps.ps_stack <- stack; + _push ps (List (List.rev l)) + end + | `Error msg -> `Error msg + | `Await -> `Await + | `End -> `End + +(* push a S-expr on top of the parser stack *) +and _push ps e = match ps.ps_stack with + | [] -> + `Ok e + | l :: tl -> + ps.ps_stack <- (e :: l) :: tl; + _next ps + +let parse_gen g : t ParseGen.t = + let ps = mk_ps() in + let rec next () = match _next ps with + | `Await -> + begin match g() with + | None -> Streaming.reached_end ps.ps_d + | Some s -> Streaming.feed ps.ps_d s 0 (String.length s) + end; + next() + | `Ok x -> `Ok x + | `Error e -> `Error e + | `End -> `End + in + next + +(* singleton generator *) +let _gen1 x = + let first = ref true in + fun () -> + if !first then (first:=false; Some x) else None let parse_string s = - let dec = mk_decoder () in - parse dec s 0 (String.length s) + parse_gen (_gen1 s) -let of_string s = - match parse_string s with - | ParseOk t -> t - | ParsePartial -> invalid_arg "Sexp: partial parse" - | ParseError msg -> invalid_arg msg +let parse_chan ic = + let buf = Buffer.create 512 in + let gen () = + Buffer.clear buf; + Buffer.add_channel buf ic 512; + if Buffer.length buf = 0 + then None + else Some (Buffer.contents buf) + in + parse_gen gen -(* tests: +(** {6 Blocking} *) -let s = Sexp.of_string "(0 a b c 42 :foo 45 :bar (hello-world foo\\tb\\na\\(\\)r -421) (41 -52) 0)";; -Sexp.to_string s;; -*) +let parse1_chan ic = + ParseGen.head (parse_chan ic) + +let parse1_string s = + ParseGen.head (parse_string s) + +let parse_l_chan ic = + ParseGen.to_list (parse_chan ic) + +let parse_l_string s = + ParseGen.to_list (parse_string s) + +let parse_l_gen g = + ParseGen.to_list (parse_gen g) + +let parse_l_seq seq = + let ps = mk_ps() in + let l = ref [] in + (* read as many expressions as possible *) + let rec _nexts () = match _next ps with + | `Ok x -> l := x :: !l; _nexts () + | `Error e -> raise (Streaming.Error e) + | `End -> raise Streaming.EOI + | `Await -> () + in + try + seq + (fun s -> Streaming.feed ps.ps_d s 0 (String.length s); _nexts ()); + Streaming.reached_end ps.ps_d; + _nexts (); + `Ok (List.rev !l) + with + | Streaming.Error msg -> `Error msg + | Streaming.EOI -> `Ok (List.rev !l) diff --git a/misc/sexp.mli b/misc/sexp.mli index e2921285..76f3d3fb 100644 --- a/misc/sexp.mli +++ b/misc/sexp.mli @@ -25,11 +25,15 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Simple S-expression parsing/printing} *) +type 'a or_error = [ `Ok of 'a | `Error of string ] +type 'a sequence = ('a -> unit) -> unit +type 'a gen = unit -> 'a option + +(** {2 Basics} *) + type t = - | K of string * t (* keyword *) - | I of int - | S of string - | L of t list + | Atom of string + | List of t list val eq : t -> t -> bool val compare : t -> t -> int @@ -39,48 +43,73 @@ val hash : t -> int val to_buf : Buffer.t -> t -> unit val to_string : t -> string -val fmt : Format.formatter -> t -> unit +val print : Format.formatter -> t -> unit (** {2 Deserialization (decoding)} *) -(** Deserialization is based on the {! decoder} type. Parsing can be - incremental, in which case the input is provided chunk by chunk and - the decoder contains the parsing state. Once a Sexpr value - has been parsed, other values can still be read. *) +type 'a parse_result = ['a or_error | `End ] +type 'a partial_result = [ 'a parse_result | `Await ] -type decoder - (** Decoding state *) +(** {6 Streaming Parsing} *) -val mk_decoder : unit -> decoder - (** Create a new decoder *) +module Streaming : sig + type decoder -type parse_result = - | ParseOk of t - | ParseError of string - | ParsePartial + val mk_decoder : unit -> decoder -val parse : decoder -> string -> int -> int -> parse_result - (** [parse dec s i len] uses the partial state stored in [dec] and - the substring of [s] starting at index [i] with length [len]. - It can return an error, a value or just [ParsePartial] if - more input is needed *) + val feed : decoder -> string -> int -> int -> unit + (** Feed a chunk of input to the decoder *) -val reset : decoder -> unit - (** Reset the decoder to its pristine state, ready to parse something - different. Before that, {! rest} and {! rest_size} can be used - to recover the part of the input that has not been consumed yet. *) + val reached_end : decoder -> unit + (** Tell the decoder that end of input has been reached *) -val state : decoder -> parse_result - (** Current state of the decoder *) + type token = + | Open + | Close + | Atom of string + (** An individual S-exp token *) -val rest : decoder -> string - (** What remains after parsing (the additional, unused input) *) + val next : decoder -> token partial_result + (** Obtain the next token, an error, or block/end stream *) +end -val rest_size : decoder -> int - (** Length of [rest d]. 0 indicates that the whole input has been consumed. *) +(** {6 Generator with errors} *) +module ParseGen : sig + type 'a t = unit -> 'a parse_result + (** A generator-like structure, but with the possibility of errors. + When called, it can yield a new element, signal the end of stream, + or signal an error. *) -val parse_string : string -> parse_result - (** Parse a full value from this string. *) + val to_list : 'a t -> 'a list or_error -val of_string : string -> t - (** Parse the string. @raise Invalid_argument if it fails to parse. *) + val head : 'a t -> 'a or_error + + val head_exn : 'a t -> 'a + + val take : int -> 'a t -> 'a t +end + +(** {6 Stream Parser} *) + +val parse_string : string -> t ParseGen.t +(** Parse a string *) + +val parse_chan : in_channel -> t ParseGen.t +(** Parse a channel *) + +val parse_gen : string gen -> t ParseGen.t +(** Parse chunks of string *) + +(** {6 Blocking} *) + +val parse1_chan : in_channel -> t or_error + +val parse1_string : string -> t or_error + +val parse_l_chan : in_channel -> t list or_error + +val parse_l_string : string -> t list or_error + +val parse_l_gen : string gen -> t list or_error + +val parse_l_seq : string sequence -> t list or_error From 3615d208dc763515e403211806c1477d4a4cc2c3 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 01:35:15 +0200 Subject: [PATCH 11/28] some bugfixes in Sexp --- misc/sexp.ml | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/misc/sexp.ml b/misc/sexp.ml index 8c0247fe..fb0f90e7 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -46,7 +46,7 @@ let _must_escape s = for i = 0 to String.length s - 1 do let c = String.unsafe_get s i in match c with - | ' ' | ')' | '(' | '\n' | '\t' -> raise Exit + | ' ' | ')' | '(' | '"' | '\n' | '\t' -> raise Exit | _ -> () done; false @@ -141,6 +141,7 @@ module Streaming = struct ) else ( let c = Buffer.nth d.buf d.i in d.i <- d.i + 1; + d.col <- d.col + 1; c ) @@ -160,13 +161,18 @@ module Streaming = struct d.st <- St_error msg'; raise (Error msg') + let _end d = + d.st <- St_end; + raise EOI + (* next token *) let rec _next d st = match st with | St_error msg -> raise (Error msg) - | St_end -> raise EOI + | St_end -> _end d | St_yield x -> (* yield the given token, then start a fresh one *) _yield d St_start x + | St_start when d.stop -> _end d | St_start -> (* start reading next token *) let c = _next_char d in @@ -196,7 +202,8 @@ module Streaming = struct | '(' -> let a = _take_buffer d.atom in _yield d (St_yield Open) (Atom a) - | '\\' -> _error d "unexpected char" + | '"' -> _error d "unexpected \"" + | '\\' -> _error d "unexpected \\" | _ -> Buffer.add_char d.atom c; _next d St_atom @@ -214,7 +221,7 @@ module Streaming = struct _yield d St_start (Atom a) | _ -> Buffer.add_char d.atom c; - _next d St_atom + _next d St_quoted end | St_escaped -> if d.stop @@ -225,6 +232,7 @@ module Streaming = struct | 'n' -> '\n' | 't' -> '\t' | 'r' -> '\r' + | '"' -> '"' | '\\' -> '\\' | _ -> _error d "unexpected escaped character" ); @@ -237,8 +245,6 @@ module Streaming = struct let reached_end d = d.stop <- true - let next_exn d = _next d d.st - let next d = try `Ok (_next d d.st) From 0aaae830bcd1c4d704d33b726220891a046afc30 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 14:09:13 +0200 Subject: [PATCH 12/28] CCError.{iter,get_exn} --- core/CCError.ml | 8 ++++++++ core/CCError.mli | 9 +++++++++ 2 files changed, 17 insertions(+) diff --git a/core/CCError.ml b/core/CCError.ml index eb8990f6..abe716f7 100644 --- a/core/CCError.ml +++ b/core/CCError.ml @@ -72,6 +72,14 @@ let map2 f g e = match e with | `Ok x -> `Ok (f x) | `Error s -> `Error (g s) +let iter f e = match e with + | `Ok x -> f x + | `Error _ -> () + +let get_exn = function + | `Ok x -> x + | `Error _ -> raise (Invalid_argument "CCError.get_exn") + let flat_map f e = match e with | `Ok x -> f x | `Error s -> `Error s diff --git a/core/CCError.mli b/core/CCError.mli index 3fefdcb3..ee2368dd 100644 --- a/core/CCError.mli +++ b/core/CCError.mli @@ -56,6 +56,15 @@ val map2 : ('a -> 'b) -> (string -> string) -> 'a t -> 'b t (** Same as {!map}, but also with a function that can transform the error message in case of failure *) +val iter : ('a -> unit) -> 'a t -> unit +(** Apply the function only in case of `Ok *) + +val get_exn : 'a t -> 'a +(** Extract the value [x] from [`Ok x], fails otherwise. + You should be careful with this function, and favor other combinators + whenever possible. + @raise Invalid_argument if the value is an error. *) + val flat_map : ('a -> 'b t) -> 'a t -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t From d5eb60d0aeb2b202fba4537b1571bddf96df3afb Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 14:09:33 +0200 Subject: [PATCH 13/28] bugfix in Sexp; better pretty-printing --- misc/sexp.ml | 35 ++++++++++++++++++++++++----------- 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/misc/sexp.ml b/misc/sexp.ml index fb0f90e7..aca00757 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -73,13 +73,15 @@ let rec print fmt t = match t with | Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s) | Atom s -> Format.pp_print_string fmt s | List [] -> Format.pp_print_string fmt "()" - | List [x] -> Format.fprintf fmt "(%a)" print x + | List [x] -> Format.fprintf fmt "@[(%a)@]" print x | List l -> + Format.open_hovbox 2; Format.pp_print_char fmt '('; List.iteri (fun i t' -> (if i > 0 then Format.fprintf fmt "@ "; print fmt t')) l; - Format.pp_print_char fmt ')' + Format.pp_print_char fmt ')'; + Format.close_box () (** {2 Deserialization (decoding)} *) @@ -114,8 +116,8 @@ module Streaming = struct let mk_decoder () = { i = 0; st = St_start; - line = 0; - col = 0; + line = 1; + col = 1; stop = false; buf=Buffer.create 32; atom = Buffer.create 32; @@ -157,16 +159,23 @@ module Streaming = struct (* raise an error *) let _error d msg = - let msg' = Printf.sprintf "at %d,%d: %s" d.line d.col msg in - d.st <- St_error msg'; - raise (Error msg') + let b = Buffer.create 32 in + Printf.bprintf b "at %d, %d: " d.line d.col; + Printf.kbprintf + (fun b -> + let msg' = Buffer.contents b in + d.st <- St_error msg'; + raise (Error msg')) + b msg let _end d = d.st <- St_end; raise EOI (* next token *) - let rec _next d st = match st with + let rec _next d st = + d.st <- st; + match st with | St_error msg -> raise (Error msg) | St_end -> _end d | St_yield x -> @@ -193,7 +202,11 @@ module Streaming = struct (* reading an unquoted atom *) let c = _next_char d in begin match c with - | ' ' | '\t' | '\n' -> + | '\n' -> + _newline d; + let a = _take_buffer d.atom in + _yield d St_start (Atom a) + | ' ' | '\t' -> let a = _take_buffer d.atom in _yield d St_start (Atom a) | ')' -> @@ -202,7 +215,7 @@ module Streaming = struct | '(' -> let a = _take_buffer d.atom in _yield d (St_yield Open) (Atom a) - | '"' -> _error d "unexpected \"" + | '"' -> _error d "unexpected \" (parsing atom %s)" (Buffer.contents d.atom) | '\\' -> _error d "unexpected \\" | _ -> Buffer.add_char d.atom c; @@ -234,7 +247,7 @@ module Streaming = struct | 'r' -> '\r' | '"' -> '"' | '\\' -> '\\' - | _ -> _error d "unexpected escaped character" + | c -> _error d "unexpected escaped character %c" c ); _next d St_quoted From dd1f3318347da1155ffe1bfcb48996fd17bf68cd Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 14:35:04 +0200 Subject: [PATCH 14/28] support raw chars in Sexp --- misc/sexp.ml | 42 ++++++++++++++++++++++++++++++------------ 1 file changed, 30 insertions(+), 12 deletions(-) diff --git a/misc/sexp.ml b/misc/sexp.ml index aca00757..943776f0 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -47,6 +47,7 @@ let _must_escape s = let c = String.unsafe_get s i in match c with | ' ' | ')' | '(' | '"' | '\n' | '\t' -> raise Exit + | _ when Char.code c > 127 -> raise Exit (* non-ascii *) | _ -> () done; false @@ -99,6 +100,8 @@ module Streaming = struct | St_atom | St_quoted | St_escaped + | St_raw_char1 of int + | St_raw_char2 of int | St_yield of token | St_error of string | St_end @@ -172,6 +175,9 @@ module Streaming = struct d.st <- St_end; raise EOI + let _is_digit c = Char.code '0' <= Char.code c && Char.code c <= Char.code '9' + let _digit2i c = Char.code c - Char.code '0' + (* next token *) let rec _next d st = d.st <- st; @@ -236,20 +242,32 @@ module Streaming = struct Buffer.add_char d.atom c; _next d St_quoted end + | (St_escaped | St_raw_char1 _ | St_raw_char2 _) when d.stop -> + _error d "unexpected end of input (escaping)" | St_escaped -> - if d.stop - then _error d "unexpected end of input (escaping)"; - let c = _next_char d in - Buffer.add_char d.atom - (match c with - | 'n' -> '\n' - | 't' -> '\t' - | 'r' -> '\r' - | '"' -> '"' - | '\\' -> '\\' + begin match _next_char d with + | 'n' -> Buffer.add_char d.atom '\n'; _next d St_quoted + | 't' -> Buffer.add_char d.atom '\t'; _next d St_quoted + | 'r' -> Buffer.add_char d.atom '\r'; _next d St_quoted + | 'b' -> Buffer.add_char d.atom '\b'; _next d St_quoted + | '"' -> Buffer.add_char d.atom '"'; _next d St_quoted + | '\\' -> Buffer.add_char d.atom '\\'; _next d St_quoted + | c when _is_digit c -> _next d (St_raw_char1 (_digit2i c)) | c -> _error d "unexpected escaped character %c" c - ); - _next d St_quoted + end + | St_raw_char1 i -> + begin match _next_char d with + | c when _is_digit c -> _next d (St_raw_char2 (i*10 + _digit2i c)) + | c -> _error d "expected digit, got %c" c + end + | St_raw_char2 i -> + begin match _next_char d with + | c when _is_digit c -> + (* read an escaped char *) + Buffer.add_char d.atom (Char.chr (i*10+_digit2i c)); + _next d St_quoted + | c -> _error d "expected digit, got %c" c + end let feed d s i len = if d.stop then failwith "Sexp.Streaming.feed: end of input reached"; From 8bb6440344d937d00202c543db6af97f28243f35 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 15:00:26 +0200 Subject: [PATCH 15/28] richer API for sexp (print/parse files) --- misc/sexp.ml | 72 ++++++++++++++++++++++++++++++++++++++++++--------- misc/sexp.mli | 15 +++++++++-- 2 files changed, 73 insertions(+), 14 deletions(-) diff --git a/misc/sexp.ml b/misc/sexp.ml index 943776f0..a42b3178 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -84,6 +84,35 @@ let rec print fmt t = match t with Format.pp_print_char fmt ')'; Format.close_box () +let rec print_noindent fmt t = match t with + | Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s) + | Atom s -> Format.pp_print_string fmt s + | List [] -> Format.pp_print_string fmt "()" + | List [x] -> Format.fprintf fmt "(%a)" print_noindent x + | List l -> + Format.pp_print_char fmt '('; + List.iteri + (fun i t' -> (if i > 0 then Format.pp_print_char fmt ' '; print_noindent fmt t')) + l; + Format.pp_print_char fmt ')' + +let to_chan oc t = + let fmt = Format.formatter_of_out_channel oc in + print fmt t; + Format.pp_print_flush fmt () + +let seq_to_file filename seq = + let oc = open_out filename in + try + seq + (fun t -> to_chan oc t; output_char oc '\n'); + close_out oc + with e -> + close_out oc; + raise e + +let to_file filename t = seq_to_file filename (fun k -> k t) + (** {2 Deserialization (decoding)} *) type 'a parse_result = ['a or_error | `End ] @@ -358,13 +387,14 @@ and _push ps e = match ps.ps_stack with ps.ps_stack <- (e :: l) :: tl; _next ps -let parse_gen g : t ParseGen.t = +(* parse from a generator of string slices *) +let _parse_gen g : t ParseGen.t = let ps = mk_ps() in let rec next () = match _next ps with | `Await -> begin match g() with | None -> Streaming.reached_end ps.ps_d - | Some s -> Streaming.feed ps.ps_d s 0 (String.length s) + | Some (s,i,len) -> Streaming.feed ps.ps_d s i len end; next() | `Ok x -> `Ok x @@ -373,6 +403,14 @@ let parse_gen g : t ParseGen.t = in next +let parse_gen g = + _parse_gen + (fun () -> + match g() with + | None -> None + | Some s -> Some (s,0,String.length s) + ) + (* singleton generator *) let _gen1 x = let first = ref true in @@ -382,16 +420,16 @@ let _gen1 x = let parse_string s = parse_gen (_gen1 s) -let parse_chan ic = - let buf = Buffer.create 512 in +let parse_chan ?(bufsize=1024) ic = + let buf = String.make bufsize ' ' in + let stop = ref false in let gen () = - Buffer.clear buf; - Buffer.add_channel buf ic 512; - if Buffer.length buf = 0 - then None - else Some (Buffer.contents buf) + if !stop then None + else + let n = input ic buf 0 bufsize in + if n=0 then (stop:=true; None) else Some (buf,0,n) in - parse_gen gen + _parse_gen gen (** {6 Blocking} *) @@ -401,8 +439,18 @@ let parse1_chan ic = let parse1_string s = ParseGen.head (parse_string s) -let parse_l_chan ic = - ParseGen.to_list (parse_chan ic) +let parse_l_chan ?bufsize ic = + ParseGen.to_list (parse_chan ?bufsize ic) + +let parse_l_file ?bufsize filename = + let ic = open_in filename in + try + let l = parse_l_chan ?bufsize ic in + close_in ic; + l + with e -> + close_in ic; + `Error (Printexc.to_string e) let parse_l_string s = ParseGen.to_list (parse_string s) diff --git a/misc/sexp.mli b/misc/sexp.mli index 76f3d3fb..897cf654 100644 --- a/misc/sexp.mli +++ b/misc/sexp.mli @@ -43,8 +43,15 @@ val hash : t -> int val to_buf : Buffer.t -> t -> unit val to_string : t -> string +val to_file : string -> t -> unit +val to_chan : out_channel -> t -> unit + val print : Format.formatter -> t -> unit +val print_noindent : Format.formatter -> t -> unit + +val seq_to_file : string -> t sequence -> unit + (** {2 Deserialization (decoding)} *) type 'a parse_result = ['a or_error | `End ] @@ -94,7 +101,7 @@ end val parse_string : string -> t ParseGen.t (** Parse a string *) -val parse_chan : in_channel -> t ParseGen.t +val parse_chan : ?bufsize:int -> in_channel -> t ParseGen.t (** Parse a channel *) val parse_gen : string gen -> t ParseGen.t @@ -106,7 +113,11 @@ val parse1_chan : in_channel -> t or_error val parse1_string : string -> t or_error -val parse_l_chan : in_channel -> t list or_error +val parse_l_chan : ?bufsize:int -> in_channel -> t list or_error +(** Parse values from a channel. *) + +val parse_l_file : ?bufsize:int -> string -> t list or_error +(** Parse a file *) val parse_l_string : string -> t list or_error From dcf134b1eb899d943e79a643342774e563a19d10 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 15:14:12 +0200 Subject: [PATCH 16/28] examples/id_sexp (parser then prints S-expressions) --- Makefile | 4 +- _oasis | 8 + _tags | 9 +- examples/id_sexp.ml | 13 + setup.ml | 7832 ++++++++++++++++++++++++++++++++++++++++++- 5 files changed, 7840 insertions(+), 26 deletions(-) create mode 100644 examples/id_sexp.ml diff --git a/Makefile b/Makefile index 15342953..ecc2b83e 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 9a60866e2fa295c5e33a3fe33b8f3a32) +# DO NOT EDIT (digest: 46f8bd9984975bd4727bed22d0876cd2) SETUP = ./setup.exe @@ -38,7 +38,7 @@ configure: $(SETUP) $(SETUP) -configure $(CONFIGUREFLAGS) setup.exe: setup.ml - ocamlfind ocamlopt -o $@ -linkpkg -package oasis.dynrun $< || ocamlfind ocamlc -o $@ -linkpkg -package oasis.dynrun $< || true + ocamlfind ocamlopt -o $@ $< || ocamlfind ocamlc -o $@ $< || true $(RM) setup.cmi setup.cmo setup.cmx setup.o .PHONY: build doc test all install uninstall reinstall clean distclean configure diff --git a/_oasis b/_oasis index 57e59880..e9dad9ac 100644 --- a/_oasis +++ b/_oasis @@ -219,6 +219,14 @@ Executable lambda Build$: flag(misc) BuildDepends: containers,containers.misc +Executable id_sexp + Path: examples/ + Install: false + CompiledObject: native + MainIs: id_sexp.ml + Build$: flag(misc) + BuildDepends: containers,containers.misc + SourceRepository head Type: git Location: https://github.com/c-cube/ocaml-containers diff --git a/_tags b/_tags index 865829e3..9bdfa3d1 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: fbebfae7c483734f1144067d9ae9954b) +# DO NOT EDIT (digest: c9667e55919ea370f2e3a33376a7eec4) # 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 @@ -19,6 +19,9 @@ "string/containers_string.cmxs": use_containers_string "string/KMP.cmx": for-pack(Containers_string) "string/levenshtein.cmx": for-pack(Containers_string) +# Library containers_pervasives +"pervasives/containers_pervasives.cmxs": use_containers_pervasives +: use_containers # Library containers_misc "misc/containers_misc.cmxs": use_containers_misc "misc/cache.cmx": for-pack(Containers_misc) @@ -146,6 +149,10 @@ "examples/lambda.byte": package(unix) "examples/lambda.byte": use_containers "examples/lambda.byte": use_containers_misc +# Executable id_sexp +"examples/id_sexp.native": package(unix) +"examples/id_sexp.native": use_containers +"examples/id_sexp.native": use_containers_misc : package(unix) : use_containers : use_containers_misc diff --git a/examples/id_sexp.ml b/examples/id_sexp.ml new file mode 100644 index 00000000..3280466d --- /dev/null +++ b/examples/id_sexp.ml @@ -0,0 +1,13 @@ + + +let () = + if Array.length Sys.argv <> 2 then failwith "usage: id_sexp file"; + let f = Sys.argv.(1) in + let s = Sexp.parse_l_file f in + match s with + | `Ok l -> + List.iter + (fun s -> Format.printf "@[%a@]@." Sexp.print s) + l + | `Error msg -> + Format.printf "error: %s@." msg diff --git a/setup.ml b/setup.ml index e4c486de..5e40039e 100644 --- a/setup.ml +++ b/setup.ml @@ -1,30 +1,7816 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 172e37fc4b327922311f6cf9389bc560) *) -(******************************************************************************) -(* OASIS: architecture for building OCaml libraries and applications *) -(* *) -(* Copyright (C) 2011-2013, Sylvain Le Gall *) -(* Copyright (C) 2008-2011, OCamlCore SARL *) -(* *) -(* This library is free software; you can redistribute it and/or modify it *) -(* under the terms of the GNU Lesser General Public License as published by *) -(* the Free Software Foundation; either version 2.1 of the License, or (at *) -(* your option) any later version, with the OCaml static compilation *) -(* exception. *) -(* *) -(* This library is distributed in the hope that it will be useful, but *) -(* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *) -(* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *) -(* details. *) -(* *) -(* You should have received a copy of the GNU Lesser General Public License *) -(* along with this library; if not, write to the Free Software Foundation, *) -(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) -(******************************************************************************) +(* DO NOT EDIT (digest: 5dcf1a764c1172114f4240aaf1b034a4) *) +(* + Regenerated by OASIS v0.4.4 + Visit http://oasis.forge.ocamlcore.org for more information and + documentation about functions used in this file. +*) +module OASISGettext = struct +(* # 22 "src/oasis/OASISGettext.ml" *) -open OASISDynRun + let ns_ str = + str + + + let s_ str = + str + + + let f_ (str: ('a, 'b, 'c, 'd) format4) = + str + + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + + let init = + [] + + +end + +module OASISContext = struct +(* # 22 "src/oasis/OASISContext.ml" *) + + + open OASISGettext + + + type level = + [ `Debug + | `Info + | `Warning + | `Error] + + + type t = + { + (* TODO: replace this by a proplist. *) + quiet: bool; + info: bool; + debug: bool; + ignore_plugins: bool; + ignore_unknown_fields: bool; + printf: level -> string -> unit; + } + + + let printf lvl str = + let beg = + match lvl with + | `Error -> s_ "E: " + | `Warning -> s_ "W: " + | `Info -> s_ "I: " + | `Debug -> s_ "D: " + in + prerr_endline (beg^str) + + + let default = + ref + { + quiet = false; + info = false; + debug = false; + ignore_plugins = false; + ignore_unknown_fields = false; + printf = printf; + } + + + let quiet = + {!default with quiet = true} + + + let fspecs () = + (* TODO: don't act on default. *) + let ignore_plugins = ref false in + ["-quiet", + Arg.Unit (fun () -> default := {!default with quiet = true}), + s_ " Run quietly"; + + "-info", + Arg.Unit (fun () -> default := {!default with info = true}), + s_ " Display information message"; + + + "-debug", + Arg.Unit (fun () -> default := {!default with debug = true}), + s_ " Output debug message"; + + "-ignore-plugins", + Arg.Set ignore_plugins, + s_ " Ignore plugin's field."; + + "-C", + (* TODO: remove this chdir. *) + Arg.String (fun str -> Sys.chdir str), + s_ "dir Change directory before running."], + fun () -> {!default with ignore_plugins = !ignore_plugins} +end + +module OASISString = struct +(* # 22 "src/oasis/OASISString.ml" *) + + + (** Various string utilities. + + Mostly inspired by extlib and batteries ExtString and BatString libraries. + + @author Sylvain Le Gall + *) + + + let nsplitf str f = + if str = "" then + [] + else + let buf = Buffer.create 13 in + let lst = ref [] in + let push () = + lst := Buffer.contents buf :: !lst; + Buffer.clear buf + in + let str_len = String.length str in + for i = 0 to str_len - 1 do + if f str.[i] then + push () + else + Buffer.add_char buf str.[i] + done; + push (); + List.rev !lst + + + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the + separator. + *) + let nsplit str c = + nsplitf str ((=) c) + + + let find ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + what_idx := 0; + incr str_idx + done; + if !what_idx <> String.length what then + raise Not_found + else + !str_idx - !what_idx + + + let sub_start str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str len (str_len - len) + + + let sub_end ?(offset=0) str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str 0 (str_len - len) + + + let starts_with ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + let ok = ref true in + while !ok && + !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + ok := false; + incr str_idx + done; + if !what_idx = String.length what then + true + else + false + + + let strip_starts_with ~what str = + if starts_with ~what str then + sub_start str (String.length what) + else + raise Not_found + + + let ends_with ~what ?(offset=0) str = + let what_idx = ref ((String.length what) - 1) in + let str_idx = ref ((String.length str) - 1) in + let ok = ref true in + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx + else + ok := false; + decr str_idx + done; + if !what_idx = -1 then + true + else + false + + + let strip_ends_with ~what str = + if ends_with ~what str then + sub_end str (String.length what) + else + raise Not_found + + + let replace_chars f s = + let buf = String.make (String.length s) 'X' in + for i = 0 to String.length s - 1 do + buf.[i] <- f s.[i] + done; + buf + + +end + +module OASISUtils = struct +(* # 22 "src/oasis/OASISUtils.ml" *) + + + open OASISGettext + + + module MapExt = + struct + module type S = + sig + include Map.S + val add_list: 'a t -> (key * 'a) list -> 'a t + val of_list: (key * 'a) list -> 'a t + val to_list: 'a t -> (key * 'a) list + end + + module Make (Ord: Map.OrderedType) = + struct + include Map.Make(Ord) + + let rec add_list t = + function + | (k, v) :: tl -> add_list (add k v t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] + end + end + + + module MapString = MapExt.Make(String) + + + module SetExt = + struct + module type S = + sig + include Set.S + val add_list: t -> elt list -> t + val of_list: elt list -> t + val to_list: t -> elt list + end + + module Make (Ord: Set.OrderedType) = + struct + include Set.Make(Ord) + + let rec add_list t = + function + | e :: tl -> add_list (add e t) tl + | [] -> t + + let of_list lst = add_list empty lst + + let to_list = elements + end + end + + + module SetString = SetExt.Make(String) + + + let compare_csl s1 s2 = + String.compare (String.lowercase s1) (String.lowercase s2) + + + module HashStringCsl = + Hashtbl.Make + (struct + type t = string + + let equal s1 s2 = + (String.lowercase s1) = (String.lowercase s2) + + let hash s = + Hashtbl.hash (String.lowercase s) + end) + + module SetStringCsl = + SetExt.Make + (struct + type t = string + let compare = compare_csl + end) + + + let varname_of_string ?(hyphen='_') s = + if String.length s = 0 then + begin + invalid_arg "varname_of_string" + end + else + begin + let buf = + OASISString.replace_chars + (fun c -> + if ('a' <= c && c <= 'z') + || + ('A' <= c && c <= 'Z') + || + ('0' <= c && c <= '9') then + c + else + hyphen) + s; + in + let buf = + (* Start with a _ if digit *) + if '0' <= s.[0] && s.[0] <= '9' then + "_"^buf + else + buf + in + String.lowercase buf + end + + + let varname_concat ?(hyphen='_') p s = + let what = String.make 1 hyphen in + let p = + try + OASISString.strip_ends_with ~what p + with Not_found -> + p + in + let s = + try + OASISString.strip_starts_with ~what s + with Not_found -> + s + in + p^what^s + + + let is_varname str = + str = varname_of_string str + + + let failwithf fmt = Printf.ksprintf failwith fmt + + +end + +module PropList = struct +(* # 22 "src/oasis/PropList.ml" *) + + + open OASISGettext + + + type name = string + + + exception Not_set of name * string option + exception No_printer of name + exception Unknown_field of name * name + + + let () = + Printexc.register_printer + (function + | Not_set (nm, Some rsn) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) + | Not_set (nm, None) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set") nm) + | No_printer nm -> + Some + (Printf.sprintf (f_ "No default printer for value %s") nm) + | Unknown_field (nm, schm) -> + Some + (Printf.sprintf + (f_ "Field %s is not defined in schema %s") nm schm) + | _ -> + None) + + + module Data = + struct + type t = + (name, unit -> unit) Hashtbl.t + + let create () = + Hashtbl.create 13 + + let clear t = + Hashtbl.clear t + + +(* # 78 "src/oasis/PropList.ml" *) + end + + + module Schema = + struct + type ('ctxt, 'extra) value = + { + get: Data.t -> string; + set: Data.t -> ?context:'ctxt -> string -> unit; + help: (unit -> string) option; + extra: 'extra; + } + + type ('ctxt, 'extra) t = + { + name: name; + fields: (name, ('ctxt, 'extra) value) Hashtbl.t; + order: name Queue.t; + name_norm: string -> string; + } + + let create ?(case_insensitive=false) nm = + { + name = nm; + fields = Hashtbl.create 13; + order = Queue.create (); + name_norm = + (if case_insensitive then + String.lowercase + else + fun s -> s); + } + + let add t nm set get extra help = + let key = + t.name_norm nm + in + + if Hashtbl.mem t.fields key then + failwith + (Printf.sprintf + (f_ "Field '%s' is already defined in schema '%s'") + nm t.name); + Hashtbl.add + t.fields + key + { + set = set; + get = get; + help = help; + extra = extra; + }; + Queue.add nm t.order + + let mem t nm = + Hashtbl.mem t.fields nm + + let find t nm = + try + Hashtbl.find t.fields (t.name_norm nm) + with Not_found -> + raise (Unknown_field (nm, t.name)) + + let get t data nm = + (find t nm).get data + + let set t data nm ?context x = + (find t nm).set + data + ?context + x + + let fold f acc t = + Queue.fold + (fun acc k -> + let v = + find t k + in + f acc k v.extra v.help) + acc + t.order + + let iter f t = + fold + (fun () -> f) + () + t + + let name t = + t.name + end + + + module Field = + struct + type ('ctxt, 'value, 'extra) t = + { + set: Data.t -> ?context:'ctxt -> 'value -> unit; + get: Data.t -> 'value; + sets: Data.t -> ?context:'ctxt -> string -> unit; + gets: Data.t -> string; + help: (unit -> string) option; + extra: 'extra; + } + + let new_id = + let last_id = + ref 0 + in + fun () -> incr last_id; !last_id + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + (* Default value container *) + let v = + ref None + in + + (* If name is not given, create unique one *) + let nm = + match name with + | Some s -> s + | None -> Printf.sprintf "_anon_%d" (new_id ()) + in + + (* Last chance to get a value: the default *) + let default () = + match default with + | Some d -> d + | None -> raise (Not_set (nm, Some (s_ "no default value"))) + in + + (* Get data *) + let get data = + (* Get value *) + try + (Hashtbl.find data nm) (); + match !v with + | Some x -> x + | None -> default () + with Not_found -> + default () + in + + (* Set data *) + let set data ?context x = + let x = + match update with + | Some f -> + begin + try + f ?context (get data) x + with Not_set _ -> + x + end + | None -> + x + in + Hashtbl.replace + data + nm + (fun () -> v := Some x) + in + + (* Parse string value, if possible *) + let parse = + match parse with + | Some f -> + f + | None -> + fun ?context s -> + failwith + (Printf.sprintf + (f_ "Cannot parse field '%s' when setting value %S") + nm + s) + in + + (* Set data, from string *) + let sets data ?context s = + set ?context data (parse ?context s) + in + + (* Output value as string, if possible *) + let print = + match print with + | Some f -> + f + | None -> + fun _ -> raise (No_printer nm) + in + + (* Get data, as a string *) + let gets data = + print (get data) + in + + begin + match schema with + | Some t -> + Schema.add t nm sets gets extra help + | None -> + () + end; + + { + set = set; + get = get; + sets = sets; + gets = gets; + help = help; + extra = extra; + } + + let fset data t ?context x = + t.set data ?context x + + let fget data t = + t.get data + + let fsets data t ?context s = + t.sets data ?context s + + let fgets data t = + t.gets data + end + + + module FieldRO = + struct + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + let fld = + Field.create ?schema ?name ?parse ?print ?default ?update ?help extra + in + fun data -> Field.fget data fld + end +end + +module OASISMessage = struct +(* # 22 "src/oasis/OASISMessage.ml" *) + + + open OASISGettext + open OASISContext + + + let generic_message ~ctxt lvl fmt = + let cond = + if ctxt.quiet then + false + else + match lvl with + | `Debug -> ctxt.debug + | `Info -> ctxt.info + | _ -> true + in + Printf.ksprintf + (fun str -> + if cond then + begin + ctxt.printf lvl str + end) + fmt + + + let debug ~ctxt fmt = + generic_message ~ctxt `Debug fmt + + + let info ~ctxt fmt = + generic_message ~ctxt `Info fmt + + + let warning ~ctxt fmt = + generic_message ~ctxt `Warning fmt + + + let error ~ctxt fmt = + generic_message ~ctxt `Error fmt + +end + +module OASISVersion = struct +(* # 22 "src/oasis/OASISVersion.ml" *) + + + open OASISGettext + + + + + + type s = string + + + type t = string + + + type comparator = + | VGreater of t + | VGreaterEqual of t + | VEqual of t + | VLesser of t + | VLesserEqual of t + | VOr of comparator * comparator + | VAnd of comparator * comparator + + + + (* Range of allowed characters *) + let is_digit c = + '0' <= c && c <= '9' + + + let is_alpha c = + ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') + + + let is_special = + function + | '.' | '+' | '-' | '~' -> true + | _ -> false + + + let rec version_compare v1 v2 = + if v1 <> "" || v2 <> "" then + begin + (* Compare ascii string, using special meaning for version + * related char + *) + let val_ascii c = + if c = '~' then -1 + else if is_digit c then 0 + else if c = '\000' then 0 + else if is_alpha c then Char.code c + else (Char.code c) + 256 + in + + let len1 = String.length v1 in + let len2 = String.length v2 in + + let p = ref 0 in + + (** Compare ascii part *) + let compare_vascii () = + let cmp = ref 0 in + while !cmp = 0 && + !p < len1 && !p < len2 && + not (is_digit v1.[!p] && is_digit v2.[!p]) do + cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); + incr p + done; + if !cmp = 0 && !p < len1 && !p = len2 then + val_ascii v1.[!p] + else if !cmp = 0 && !p = len1 && !p < len2 then + - (val_ascii v2.[!p]) + else + !cmp + in + + (** Compare digit part *) + let compare_digit () = + let extract_int v p = + let start_p = !p in + while !p < String.length v && is_digit v.[!p] do + incr p + done; + let substr = + String.sub v !p ((String.length v) - !p) + in + let res = + match String.sub v start_p (!p - start_p) with + | "" -> 0 + | s -> int_of_string s + in + res, substr + in + let i1, tl1 = extract_int v1 (ref !p) in + let i2, tl2 = extract_int v2 (ref !p) in + i1 - i2, tl1, tl2 + in + + match compare_vascii () with + | 0 -> + begin + match compare_digit () with + | 0, tl1, tl2 -> + if tl1 <> "" && is_digit tl1.[0] then + 1 + else if tl2 <> "" && is_digit tl2.[0] then + -1 + else + version_compare tl1 tl2 + | n, _, _ -> + n + end + | n -> + n + end + else + begin + 0 + end + + + let version_of_string str = str + + + let string_of_version t = t + + + let version_compare_string s1 s2 = + version_compare (version_of_string s1) (version_of_string s2) + + + let chop t = + try + let pos = + String.rindex t '.' + in + String.sub t 0 pos + with Not_found -> + t + + + let rec comparator_apply v op = + match op with + | VGreater cv -> + (version_compare v cv) > 0 + | VGreaterEqual cv -> + (version_compare v cv) >= 0 + | VLesser cv -> + (version_compare v cv) < 0 + | VLesserEqual cv -> + (version_compare v cv) <= 0 + | VEqual cv -> + (version_compare v cv) = 0 + | VOr (op1, op2) -> + (comparator_apply v op1) || (comparator_apply v op2) + | VAnd (op1, op2) -> + (comparator_apply v op1) && (comparator_apply v op2) + + + let rec string_of_comparator = + function + | VGreater v -> "> "^(string_of_version v) + | VEqual v -> "= "^(string_of_version v) + | VLesser v -> "< "^(string_of_version v) + | VGreaterEqual v -> ">= "^(string_of_version v) + | VLesserEqual v -> "<= "^(string_of_version v) + | VOr (c1, c2) -> + (string_of_comparator c1)^" || "^(string_of_comparator c2) + | VAnd (c1, c2) -> + (string_of_comparator c1)^" && "^(string_of_comparator c2) + + + let rec varname_of_comparator = + let concat p v = + OASISUtils.varname_concat + p + (OASISUtils.varname_of_string + (string_of_version v)) + in + function + | VGreater v -> concat "gt" v + | VLesser v -> concat "lt" v + | VEqual v -> concat "eq" v + | VGreaterEqual v -> concat "ge" v + | VLesserEqual v -> concat "le" v + | VOr (c1, c2) -> + (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) + | VAnd (c1, c2) -> + (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) + + + let rec comparator_ge v' = + let cmp v = version_compare v v' >= 0 in + function + | VEqual v + | VGreaterEqual v + | VGreater v -> cmp v + | VLesserEqual _ + | VLesser _ -> false + | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 + | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 + + +end + +module OASISLicense = struct +(* # 22 "src/oasis/OASISLicense.ml" *) + + + (** License for _oasis fields + @author Sylvain Le Gall + *) + + + + + + type license = string + + + type license_exception = string + + + type license_version = + | Version of OASISVersion.t + | VersionOrLater of OASISVersion.t + | NoVersion + + + + type license_dep_5_unit = + { + license: license; + excption: license_exception option; + version: license_version; + } + + + + type license_dep_5 = + | DEP5Unit of license_dep_5_unit + | DEP5Or of license_dep_5 list + | DEP5And of license_dep_5 list + + + type t = + | DEP5License of license_dep_5 + | OtherLicense of string (* URL *) + + + +end + +module OASISExpr = struct +(* # 22 "src/oasis/OASISExpr.ml" *) + + + + + + open OASISGettext + + + type test = string + + + type flag = string + + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + + type 'a choices = (t * 'a) list + + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + + +end + +module OASISText = struct +(* # 22 "src/oasis/OASISText.ml" *) + + + + type elt = + | Para of string + | Verbatim of string + | BlankLine + + + type t = elt list + +end + +module OASISTypes = struct +(* # 22 "src/oasis/OASISTypes.ml" *) + + + + + + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) + + + type findlib_name = string + type findlib_full = string + + + type compiled_object = + | Byte + | Native + | Best + + + + type dependency = + | FindlibPackage of findlib_full * OASISVersion.comparator option + | InternalLibrary of name + + + + type tool = + | ExternalTool of name + | InternalExecutable of name + + + + type vcs = + | Darcs + | Git + | Svn + | Cvs + | Hg + | Bzr + | Arch + | Monotone + | OtherVCS of url + + + + type plugin_kind = + [ `Configure + | `Build + | `Doc + | `Test + | `Install + | `Extra + ] + + + type plugin_data_purpose = + [ `Configure + | `Build + | `Install + | `Clean + | `Distclean + | `Install + | `Uninstall + | `Test + | `Doc + | `Extra + | `Other of string + ] + + + type 'a plugin = 'a * name * OASISVersion.t option + + + type all_plugin = plugin_kind plugin + + + type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list + + +(* # 115 "src/oasis/OASISTypes.ml" *) + + + type 'a conditional = 'a OASISExpr.choices + + + type custom = + { + pre_command: (command_line option) conditional; + post_command: (command_line option) conditional; + } + + + + type common_section = + { + cs_name: name; + cs_data: PropList.Data.t; + cs_plugin_data: plugin_data; + } + + + + type build_section = + { + bs_build: bool conditional; + bs_install: bool conditional; + bs_path: unix_dirname; + bs_compiled_object: compiled_object; + bs_build_depends: dependency list; + bs_build_tools: tool list; + bs_c_sources: unix_filename list; + bs_data_files: (unix_filename * unix_filename option) list; + bs_ccopt: args conditional; + bs_cclib: args conditional; + bs_dlllib: args conditional; + bs_dllpath: args conditional; + bs_byteopt: args conditional; + bs_nativeopt: args conditional; + } + + + + type library = + { + lib_modules: string list; + lib_pack: bool; + lib_internal_modules: string list; + lib_findlib_parent: findlib_name option; + lib_findlib_name: findlib_name option; + lib_findlib_containers: findlib_name list; + } + + + type object_ = + { + obj_modules: string list; + obj_findlib_fullname: findlib_name list option; + } + + + type executable = + { + exec_custom: bool; + exec_main_is: unix_filename; + } + + + type flag = + { + flag_description: string option; + flag_default: bool conditional; + } + + + type source_repository = + { + src_repo_type: vcs; + src_repo_location: url; + src_repo_browser: url option; + src_repo_module: string option; + src_repo_branch: string option; + src_repo_tag: string option; + src_repo_subdir: unix_filename option; + } + + + type test = + { + test_type: [`Test] plugin; + test_command: command_line conditional; + test_custom: custom; + test_working_directory: unix_filename option; + test_run: bool conditional; + test_tools: tool list; + } + + + type doc_format = + | HTML of unix_filename + | DocText + | PDF + | PostScript + | Info of unix_filename + | DVI + | OtherDoc + + + + type doc = + { + doc_type: [`Doc] plugin; + doc_custom: custom; + doc_build: bool conditional; + doc_install: bool conditional; + doc_install_dir: unix_filename; + doc_title: string; + doc_authors: string list; + doc_abstract: string option; + doc_format: doc_format; + doc_data_files: (unix_filename * unix_filename option) list; + doc_build_tools: tool list; + } + + + type section = + | Library of common_section * build_section * library + | Object of common_section * build_section * object_ + | Executable of common_section * build_section * executable + | Flag of common_section * flag + | SrcRepo of common_section * source_repository + | Test of common_section * test + | Doc of common_section * doc + + + + type section_kind = + [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + + + type package = + { + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: OASISText.t option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + disable_oasis_section: unix_filename list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } + + +end + +module OASISFeatures = struct +(* # 22 "src/oasis/OASISFeatures.ml" *) + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISVersion + + module MapPlugin = + Map.Make + (struct + type t = plugin_kind * name + let compare = Pervasives.compare + end) + + module Data = + struct + type t = + { + oasis_version: OASISVersion.t; + plugin_versions: OASISVersion.t option MapPlugin.t; + alpha_features: string list; + beta_features: string list; + } + + let create oasis_version alpha_features beta_features = + { + oasis_version = oasis_version; + plugin_versions = MapPlugin.empty; + alpha_features = alpha_features; + beta_features = beta_features + } + + let of_package pkg = + create + pkg.OASISTypes.oasis_version + pkg.OASISTypes.alpha_features + pkg.OASISTypes.beta_features + + let add_plugin (plugin_kind, plugin_name, plugin_version) t = + {t with + plugin_versions = MapPlugin.add + (plugin_kind, plugin_name) + plugin_version + t.plugin_versions} + + let plugin_version plugin_kind plugin_name t = + MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions + + let to_string t = + Printf.sprintf + "oasis_version: %s; alpha_features: %s; beta_features: %s; \ + plugins_version: %s" + (OASISVersion.string_of_version t.oasis_version) + (String.concat ", " t.alpha_features) + (String.concat ", " t.beta_features) + (String.concat ", " + (MapPlugin.fold + (fun (_, plg) ver_opt acc -> + (plg^ + (match ver_opt with + | Some v -> + " "^(OASISVersion.string_of_version v) + | None -> "")) + :: acc) + t.plugin_versions [])) + end + + type origin = + | Field of string * string + | Section of string + | NoOrigin + + type stage = Alpha | Beta + + + let string_of_stage = + function + | Alpha -> "alpha" + | Beta -> "beta" + + + let field_of_stage = + function + | Alpha -> "AlphaFeatures" + | Beta -> "BetaFeatures" + + type publication = InDev of stage | SinceVersion of OASISVersion.t + + type t = + { + name: string; + plugin: all_plugin option; + publication: publication; + description: unit -> string; + } + + (* TODO: mutex protect this. *) + let all_features = Hashtbl.create 13 + + + let since_version ver_str = SinceVersion (version_of_string ver_str) + let alpha = InDev Alpha + let beta = InDev Beta + + + let to_string t = + Printf.sprintf + "feature: %s; plugin: %s; publication: %s" + t.name + (match t.plugin with + | None -> "" + | Some (_, nm, _) -> nm) + (match t.publication with + | InDev stage -> string_of_stage stage + | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) + + let data_check t data origin = + let no_message = "no message" in + + let check_feature features stage = + let has_feature = List.mem t.name features in + if not has_feature then + match origin with + | Field (fld, where) -> + Some + (Printf.sprintf + (f_ "Field %s in %s is only available when feature %s \ + is in field %s.") + fld where t.name (field_of_stage stage)) + | Section sct -> + Some + (Printf.sprintf + (f_ "Section %s is only available when features %s \ + is in field %s.") + sct t.name (field_of_stage stage)) + | NoOrigin -> + Some no_message + else + None + in + + let version_is_good ~min_version version fmt = + let version_is_good = + OASISVersion.comparator_apply + version (OASISVersion.VGreaterEqual min_version) + in + Printf.ksprintf + (fun str -> + if version_is_good then + None + else + Some str) + fmt + in + + match origin, t.plugin, t.publication with + | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha + | _, _, InDev Beta -> check_feature data.Data.beta_features Beta + | Field(fld, where), None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Field %s in %s is only valid since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking \ + OASIS changelog.") + fld where (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Field(fld, where), Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Field %s in %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + fld where plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Field %s in %s is only valid when the OASIS plugin %s \ + is defined.") + fld where plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Field %s in %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + fld where plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | Section sct, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Section %s is only valid for since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking OASIS \ + changelog.") + sct (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Section sct, Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Section %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + sct plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Section %s is only valid when the OASIS plugin %s \ + is defined.") + sct plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Section %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + sct plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | NoOrigin, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version "%s" no_message + + | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> + begin + try + let plugin_version_current = + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> raise Not_found + in + version_is_good ~min_version plugin_version_current + "%s" no_message + with Not_found -> + Some no_message + end + + + let data_assert t data origin = + match data_check t data origin with + | None -> () + | Some str -> failwith str + + + let data_test t data = + match data_check t data NoOrigin with + | None -> true + | Some str -> false + + + let package_test t pkg = + data_test t (Data.of_package pkg) + + + let create ?plugin name publication description = + let () = + if Hashtbl.mem all_features name then + failwithf "Feature '%s' is already declared." name + in + let t = + { + name = name; + plugin = plugin; + publication = publication; + description = description; + } + in + Hashtbl.add all_features name t; + t + + + let get_stage name = + try + (Hashtbl.find all_features name).publication + with Not_found -> + failwithf (f_ "Feature %s doesn't exist.") name + + + let list () = + Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] + + (* + * Real flags. + *) + + + let features = + create "features_fields" + (since_version "0.4") + (fun () -> + s_ "Enable to experiment not yet official features.") + + + let flag_docs = + create "flag_docs" + (since_version "0.3") + (fun () -> + s_ "Building docs require '-docs' flag at configure.") + + + let flag_tests = + create "flag_tests" + (since_version "0.3") + (fun () -> + s_ "Running tests require '-tests' flag at configure.") + + + let pack = + create "pack" + (since_version "0.3") + (fun () -> + s_ "Allow to create packed library.") + + + let section_object = + create "section_object" beta + (fun () -> + s_ "Implement an object section.") + + + let dynrun_for_release = + create "dynrun_for_release" alpha + (fun () -> + s_ "Make '-setup-update dynamic' suitable for releasing project.") + + + let compiled_setup_ml = + create "compiled_setup_ml" alpha + (fun () -> + s_ "It compiles the setup.ml and speed-up actions done with it.") + + let disable_oasis_section = + create "disable_oasis_section" alpha + (fun () -> + s_ "Allows the OASIS section comments and digest to be omitted in \ + generated files.") +end + +module OASISUnixPath = struct +(* # 22 "src/oasis/OASISUnixPath.ml" *) + + + type unix_filename = string + type unix_dirname = string + + + type host_filename = string + type host_dirname = string + + + let current_dir_name = "." + + + let parent_dir_name = ".." + + + let is_current_dir fn = + fn = current_dir_name || fn = "" + + + let concat f1 f2 = + if is_current_dir f1 then + f2 + else + let f1' = + try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 + in + f1'^"/"^f2 + + + let make = + function + | hd :: tl -> + List.fold_left + (fun f p -> concat f p) + hd + tl + | [] -> + invalid_arg "OASISUnixPath.make" + + + let dirname f = + try + String.sub f 0 (String.rindex f '/') + with Not_found -> + current_dir_name + + + let basename f = + try + let pos_start = + (String.rindex f '/') + 1 + in + String.sub f pos_start ((String.length f) - pos_start) + with Not_found -> + f + + + let chop_extension f = + try + let last_dot = + String.rindex f '.' + in + let sub = + String.sub f 0 last_dot + in + try + let last_slash = + String.rindex f '/' + in + if last_slash < last_dot then + sub + else + f + with Not_found -> + sub + + with Not_found -> + f + + + let capitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.capitalize base) + + + let uncapitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.uncapitalize base) + + +end + +module OASISHostPath = struct +(* # 22 "src/oasis/OASISHostPath.ml" *) + + + open Filename + + + module Unix = OASISUnixPath + + + let make = + function + | [] -> + invalid_arg "OASISHostPath.make" + | hd :: tl -> + List.fold_left Filename.concat hd tl + + + let of_unix ufn = + if Sys.os_type = "Unix" then + ufn + else + make + (List.map + (fun p -> + if p = Unix.current_dir_name then + current_dir_name + else if p = Unix.parent_dir_name then + parent_dir_name + else + p) + (OASISString.nsplit ufn '/')) + + +end + +module OASISSection = struct +(* # 22 "src/oasis/OASISSection.ml" *) + + + open OASISTypes + + + let section_kind_common = + function + | Library (cs, _, _) -> + `Library, cs + | Object (cs, _, _) -> + `Object, cs + | Executable (cs, _, _) -> + `Executable, cs + | Flag (cs, _) -> + `Flag, cs + | SrcRepo (cs, _) -> + `SrcRepo, cs + | Test (cs, _) -> + `Test, cs + | Doc (cs, _) -> + `Doc, cs + + + let section_common sct = + snd (section_kind_common sct) + + + let section_common_set cs = + function + | Library (_, bs, lib) -> Library (cs, bs, lib) + | Object (_, bs, obj) -> Object (cs, bs, obj) + | Executable (_, bs, exec) -> Executable (cs, bs, exec) + | Flag (_, flg) -> Flag (cs, flg) + | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) + | Test (_, tst) -> Test (cs, tst) + | Doc (_, doc) -> Doc (cs, doc) + + + (** Key used to identify section + *) + let section_id sct = + let k, cs = + section_kind_common sct + in + k, cs.cs_name + + + let string_of_section sct = + let k, nm = + section_id sct + in + (match k with + | `Library -> "library" + | `Object -> "object" + | `Executable -> "executable" + | `Flag -> "flag" + | `SrcRepo -> "src repository" + | `Test -> "test" + | `Doc -> "doc") + ^" "^nm + + + let section_find id scts = + List.find + (fun sct -> id = section_id sct) + scts + + + module CSection = + struct + type t = section + + let id = section_id + + let compare t1 t2 = + compare (id t1) (id t2) + + let equal t1 t2 = + (id t1) = (id t2) + + let hash t = + Hashtbl.hash (id t) + end + + + module MapSection = Map.Make(CSection) + module SetSection = Set.Make(CSection) + + +end + +module OASISBuildSection = struct +(* # 22 "src/oasis/OASISBuildSection.ml" *) + + +end + +module OASISExecutable = struct +(* # 22 "src/oasis/OASISExecutable.ml" *) + + + open OASISTypes + + + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = + OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.dirname exec.exec_main_is) + in + let is_native_exec = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native () + | Byte -> false + in + + OASISUnixPath.concat + dir + (cs.cs_name^(suffix_program ())), + + if not is_native_exec && + not exec.exec_custom && + bs.bs_c_sources <> [] then + Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) + else + None + + +end + +module OASISLibrary = struct +(* # 22 "src/oasis/OASISLibrary.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + + (* Look for a module file, considering capitalization or not. *) + let find_module source_file_exists bs modul = + let possible_base_fn = + List.map + (OASISUnixPath.concat bs.bs_path) + [modul; + OASISUnixPath.uncapitalize_file modul; + OASISUnixPath.capitalize_file modul] + in + (* TODO: we should be able to be able to determine the source for every + * files. Hence we should introduce a Module(source: fn) for the fields + * Modules and InternalModules + *) + List.fold_left + (fun acc base_fn -> + match acc with + | `No_sources _ -> + begin + let file_found = + List.fold_left + (fun acc ext -> + if source_file_exists (base_fn^ext) then + (base_fn^ext) :: acc + else + acc) + [] + [".ml"; ".mli"; ".mll"; ".mly"] + in + match file_found with + | [] -> + acc + | lst -> + `Sources (base_fn, lst) + end + | `Sources _ -> + acc) + (`No_sources possible_base_fn) + possible_base_fn + + + let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = + List.fold_left + (fun acc modul -> + match find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + acc) + [] + (lib.lib_modules @ lib.lib_internal_modules) + + + let generated_unix_files + ~ctxt + ~is_native + ~has_native_dynlink + ~ext_lib + ~ext_dll + ~source_file_exists + (cs, bs, lib) = + + let find_modules lst ext = + let find_module modul = + match find_module source_file_exists bs modul with + | `Sources (base_fn, [fn]) when ext <> "cmi" + && Filename.check_suffix fn ".mli" -> + None (* No implementation files for pure interface. *) + | `Sources (base_fn, _) -> + Some [base_fn] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + Some lst + in + List.fold_left + (fun acc nm -> + match find_module nm with + | None -> acc + | Some base_fns -> + List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) + [] + lst + in + + (* The headers that should be compiled along *) + let headers = + if lib.lib_pack then + [] + else + find_modules + lib.lib_modules + "cmi" + in + + (* The .cmx that be compiled along *) + let cmxs = + let should_be_built = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native + | Byte -> false + in + if should_be_built then + if lib.lib_pack then + find_modules + [cs.cs_name] + "cmx" + else + find_modules + (lib.lib_modules @ lib.lib_internal_modules) + "cmx" + else + [] + in + + let acc_nopath = + [] + in + + (* Compute what libraries should be built *) + let acc_nopath = + (* Add the packed header file if required *) + let add_pack_header acc = + if lib.lib_pack then + [cs.cs_name^".cmi"] :: acc + else + acc + in + let byte acc = + add_pack_header ([cs.cs_name^".cma"] :: acc) + in + let native acc = + let acc = + add_pack_header + (if has_native_dynlink then + [cs.cs_name^".cmxs"] :: acc + else acc) + in + [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc + in + match bs.bs_compiled_object with + | Native -> + byte (native acc_nopath) + | Best when is_native -> + byte (native acc_nopath) + | Byte | Best -> + byte acc_nopath + in + + (* Add C library to be built *) + let acc_nopath = + if bs.bs_c_sources <> [] then + begin + ["lib"^cs.cs_name^"_stubs"^ext_lib] + :: + ["dll"^cs.cs_name^"_stubs"^ext_dll] + :: + acc_nopath + end + else + acc_nopath + in + + (* All the files generated *) + List.rev_append + (List.rev_map + (List.rev_map + (OASISUnixPath.concat bs.bs_path)) + acc_nopath) + (headers @ cmxs) + + +end + +module OASISObject = struct +(* # 22 "src/oasis/OASISObject.ml" *) + + + open OASISTypes + open OASISGettext + + + let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = + List.fold_left + (fun acc modul -> + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name; + acc) + [] + obj.obj_modules + + + let generated_unix_files + ~ctxt + ~is_native + ~source_file_exists + (cs, bs, obj) = + + let find_module ext modul = + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, _) -> [base_fn ^ ext] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name ; + lst + in + + let header, byte, native, c_object, f = + match obj.obj_modules with + | [ m ] -> (find_module ".cmi" m, + find_module ".cmo" m, + find_module ".cmx" m, + find_module ".o" m, + fun x -> x) + | _ -> ([cs.cs_name ^ ".cmi"], + [cs.cs_name ^ ".cmo"], + [cs.cs_name ^ ".cmx"], + [cs.cs_name ^ ".o"], + OASISUnixPath.concat bs.bs_path) + in + List.map (List.map f) ( + match bs.bs_compiled_object with + | Native -> + native :: c_object :: byte :: header :: [] + | Best when is_native -> + native :: c_object :: byte :: header :: [] + | Byte | Best -> + byte :: header :: []) + + +end + +module OASISFindlib = struct +(* # 22 "src/oasis/OASISFindlib.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + [`Library of library | `Object of object_] * + group_t list) + + + type data = common_section * + build_section * + [`Library of library | `Object of object_] + type tree = + | Node of (data option) * (tree MapString.t) + | Leaf of data + + + let findlib_mapping pkg = + (* Map from library name to either full findlib name or parts + parent. *) + let fndlb_parts_of_lib_name = + let fndlb_parts cs lib = + let name = + match lib.lib_findlib_name with + | Some nm -> nm + | None -> cs.cs_name + in + let name = + String.concat "." (lib.lib_findlib_containers @ [name]) + in + name + in + List.fold_left + (fun mp -> + function + | Library (cs, _, lib) -> + begin + let lib_name = cs.cs_name in + let fndlb_parts = fndlb_parts cs lib in + if MapString.mem lib_name mp then + failwithf + (f_ "The library name '%s' is used more than once.") + lib_name; + match lib.lib_findlib_parent with + | Some lib_name_parent -> + MapString.add + lib_name + (`Unsolved (lib_name_parent, fndlb_parts)) + mp + | None -> + MapString.add + lib_name + (`Solved fndlb_parts) + mp + end + + | Object (cs, _, obj) -> + begin + let obj_name = cs.cs_name in + if MapString.mem obj_name mp then + failwithf + (f_ "The object name '%s' is used more than once.") + obj_name; + let findlib_full_name = match obj.obj_findlib_fullname with + | Some ns -> String.concat "." ns + | None -> obj_name + in + MapString.add + obj_name + (`Solved findlib_full_name) + mp + end + + | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> + mp) + MapString.empty + pkg.sections + in + + (* Solve the above graph to be only library name to full findlib name. *) + let fndlb_name_of_lib_name = + let rec solve visited mp lib_name lib_name_child = + if SetString.mem lib_name visited then + failwithf + (f_ "Library '%s' is involved in a cycle \ + with regard to findlib naming.") + lib_name; + let visited = SetString.add lib_name visited in + try + match MapString.find lib_name mp with + | `Solved fndlb_nm -> + fndlb_nm, mp + | `Unsolved (lib_nm_parent, post_fndlb_nm) -> + let pre_fndlb_nm, mp = + solve visited mp lib_nm_parent lib_name + in + let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in + fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp + with Not_found -> + failwithf + (f_ "Library '%s', which is defined as the findlib parent of \ + library '%s', doesn't exist.") + lib_name lib_name_child + in + let mp = + MapString.fold + (fun lib_name status mp -> + match status with + | `Solved _ -> + (* Solved initialy, no need to go further *) + mp + | `Unsolved _ -> + let _, mp = solve SetString.empty mp lib_name "" in + mp) + fndlb_parts_of_lib_name + fndlb_parts_of_lib_name + in + MapString.map + (function + | `Solved fndlb_nm -> fndlb_nm + | `Unsolved _ -> assert false) + mp + in + + (* Convert an internal library name to a findlib name. *) + let findlib_name_of_library_name lib_nm = + try + MapString.find lib_nm fndlb_name_of_lib_name + with Not_found -> + raise (InternalLibraryNotFound lib_nm) + in + + (* Add a library to the tree. + *) + let add sct mp = + let fndlb_fullname = + let cs, _, _ = sct in + let lib_name = cs.cs_name in + findlib_name_of_library_name lib_name + in + let rec add_children nm_lst (children: tree MapString.t) = + match nm_lst with + | (hd :: tl) -> + begin + let node = + try + add_node tl (MapString.find hd children) + with Not_found -> + (* New node *) + new_node tl + in + MapString.add hd node children + end + | [] -> + (* Should not have a nameless library. *) + assert false + and add_node tl node = + if tl = [] then + begin + match node with + | Node (None, children) -> + Node (Some sct, children) + | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> + (* TODO: allow to merge Package, i.e. + * archive(byte) = "foo.cma foo_init.cmo" + *) + let cs, _, _ = sct in + failwithf + (f_ "Library '%s' and '%s' have the same findlib name '%s'") + cs.cs_name cs'.cs_name fndlb_fullname + end + else + begin + match node with + | Leaf data -> + Node (Some data, add_children tl MapString.empty) + | Node (data_opt, children) -> + Node (data_opt, add_children tl children) + end + and new_node = + function + | [] -> + Leaf sct + | hd :: tl -> + Node (None, MapString.add hd (new_node tl) MapString.empty) + in + add_children (OASISString.nsplit fndlb_fullname '.') mp + in + + let rec group_of_tree mp = + MapString.fold + (fun nm node acc -> + let cur = + match node with + | Node (Some (cs, bs, lib), children) -> + Package (nm, cs, bs, lib, group_of_tree children) + | Node (None, children) -> + Container (nm, group_of_tree children) + | Leaf (cs, bs, lib) -> + Package (nm, cs, bs, lib, []) + in + cur :: acc) + mp [] + in + + let group_mp = + List.fold_left + (fun mp -> + function + | Library (cs, bs, lib) -> + add (cs, bs, `Library lib) mp + | Object (cs, bs, obj) -> + add (cs, bs, `Object obj) mp + | _ -> + mp) + MapString.empty + pkg.sections + in + + let groups = + group_of_tree group_mp + in + + let library_name_of_findlib_name = + Lazy.lazy_from_fun + (fun () -> + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty) + in + let library_name_of_findlib_name fndlb_nm = + try + MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) + with Not_found -> + raise (FindlibPackageNotFound fndlb_nm) + in + + groups, + findlib_name_of_library_name, + library_name_of_findlib_name + + + let findlib_of_group = + function + | Container (fndlb_nm, _) + | Package (fndlb_nm, _, _, _, _) -> fndlb_nm + + + let root_of_group grp = + let rec root_lib_aux = + (* We do a DFS in the group. *) + function + | Container (_, children) -> + List.fold_left + (fun res grp -> + if res = None then + root_lib_aux grp + else + res) + None + children + | Package (_, cs, bs, lib, _) -> + Some (cs, bs, lib) + in + match root_lib_aux grp with + | Some res -> + res + | None -> + failwithf + (f_ "Unable to determine root library of findlib library '%s'") + (findlib_of_group grp) + + +end + +module OASISFlag = struct +(* # 22 "src/oasis/OASISFlag.ml" *) + + +end + +module OASISPackage = struct +(* # 22 "src/oasis/OASISPackage.ml" *) + + +end + +module OASISSourceRepository = struct +(* # 22 "src/oasis/OASISSourceRepository.ml" *) + + +end + +module OASISTest = struct +(* # 22 "src/oasis/OASISTest.ml" *) + + +end + +module OASISDocument = struct +(* # 22 "src/oasis/OASISDocument.ml" *) + + +end + +module OASISExec = struct +(* # 22 "src/oasis/OASISExec.ml" *) + + + open OASISGettext + open OASISUtils + open OASISMessage + + + (* TODO: I don't like this quote, it is there because $(rm) foo expands to + * 'rm -f' foo... + *) + let run ~ctxt ?f_exit_code ?(quote=true) cmd args = + let cmd = + if quote then + if Sys.os_type = "Win32" then + if String.contains cmd ' ' then + (* Double the 1st double quote... win32... sigh *) + "\""^(Filename.quote cmd) + else + cmd + else + Filename.quote cmd + else + cmd + in + let cmdline = + String.concat " " (cmd :: args) + in + info ~ctxt (f_ "Running command '%s'") cmdline; + match f_exit_code, Sys.command cmdline with + | None, 0 -> () + | None, i -> + failwithf + (f_ "Command '%s' terminated with error code %d") + cmdline i + | Some f, i -> + f i + + + let run_read_output ~ctxt ?f_exit_code cmd args = + let fn = + Filename.temp_file "oasis-" ".txt" + in + try + begin + let () = + run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) + in + let chn = + open_in fn + in + let routput = + ref [] + in + begin + try + while true do + routput := (input_line chn) :: !routput + done + with End_of_file -> + () + end; + close_in chn; + Sys.remove fn; + List.rev !routput + end + with e -> + (try Sys.remove fn with _ -> ()); + raise e + + + let run_read_one_line ~ctxt ?f_exit_code cmd args = + match run_read_output ~ctxt ?f_exit_code cmd args with + | [fst] -> + fst + | lst -> + failwithf + (f_ "Command return unexpected output %S") + (String.concat "\n" lst) +end + +module OASISFileUtil = struct +(* # 22 "src/oasis/OASISFileUtil.ml" *) + + + open OASISGettext + + + let file_exists_case fn = + let dirname = Filename.dirname fn in + let basename = Filename.basename fn in + if Sys.file_exists dirname then + if basename = Filename.current_dir_name then + true + else + List.mem + basename + (Array.to_list (Sys.readdir dirname)) + else + false + + + let find_file ?(case_sensitive=true) paths exts = + + (* Cardinal product of two list *) + let ( * ) lst1 lst2 = + List.flatten + (List.map + (fun a -> + List.map + (fun b -> a, b) + lst2) + lst1) + in + + let rec combined_paths lst = + match lst with + | p1 :: p2 :: tl -> + let acc = + (List.map + (fun (a, b) -> Filename.concat a b) + (p1 * p2)) + in + combined_paths (acc :: tl) + | [e] -> + e + | [] -> + [] + in + + let alternatives = + List.map + (fun (p, e) -> + if String.length e > 0 && e.[0] <> '.' then + p ^ "." ^ e + else + p ^ e) + ((combined_paths paths) * exts) + in + List.find (fun file -> + (if case_sensitive then + file_exists_case file + else + Sys.file_exists file) + && not (Sys.is_directory file) + ) alternatives + + + let which ~ctxt prg = + let path_sep = + match Sys.os_type with + | "Win32" -> + ';' + | _ -> + ':' + in + let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in + let exec_ext = + match Sys.os_type with + | "Win32" -> + "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) + | _ -> + [""] + in + find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + + + (**/**) + let rec fix_dir dn = + (* Windows hack because Sys.file_exists "src\\" = false when + * Sys.file_exists "src" = true + *) + let ln = + String.length dn + in + if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then + fix_dir (String.sub dn 0 (ln - 1)) + else + dn + + + let q = Filename.quote + (**/**) + + + let cp ~ctxt ?(recurse=false) src tgt = + if recurse then + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt + "xcopy" [q src; q tgt; "/E"] + | _ -> + OASISExec.run ~ctxt + "cp" ["-r"; q src; q tgt] + else + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "copy" + | _ -> "cp") + [q src; q tgt] + + + let mkdir ~ctxt tgt = + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "md" + | _ -> "mkdir") + [q tgt] + + + let rec mkdir_parent ~ctxt f tgt = + let tgt = + fix_dir tgt + in + if Sys.file_exists tgt then + begin + if not (Sys.is_directory tgt) then + OASISUtils.failwithf + (f_ "Cannot create directory '%s', a file of the same name already \ + exists") + tgt + end + else + begin + mkdir_parent ~ctxt f (Filename.dirname tgt); + if not (Sys.file_exists tgt) then + begin + f tgt; + mkdir ~ctxt tgt + end + end + + + let rmdir ~ctxt tgt = + if Sys.readdir tgt = [||] then begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end else begin + OASISMessage.error ~ctxt + (f_ "Cannot remove directory '%s': not empty.") + tgt + end + + + let glob ~ctxt fn = + let basename = + Filename.basename fn + in + if String.length basename >= 2 && + basename.[0] = '*' && + basename.[1] = '.' then + begin + let ext_len = + (String.length basename) - 2 + in + let ext = + String.sub basename 2 ext_len + in + let dirname = + Filename.dirname fn + in + Array.fold_left + (fun acc fn -> + try + let fn_ext = + String.sub + fn + ((String.length fn) - ext_len) + ext_len + in + if fn_ext = ext then + (Filename.concat dirname fn) :: acc + else + acc + with Invalid_argument _ -> + acc) + [] + (Sys.readdir dirname) + end + else + begin + if file_exists_case fn then + [fn] + else + [] + end +end + + +# 2878 "setup.ml" +module BaseEnvLight = struct +(* # 22 "src/base/BaseEnvLight.ml" *) + + + module MapString = Map.Make(String) + + + type t = string MapString.t + + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + + let rec var_expand str env = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 2983 "setup.ml" +module BaseContext = struct +(* # 22 "src/base/BaseContext.ml" *) + + (* TODO: get rid of this module. *) + open OASISContext + + + let args () = fst (fspecs ()) + + + let default = default + +end + +module BaseMessage = struct +(* # 22 "src/base/BaseMessage.ml" *) + + + (** Message to user, overrid for Base + @author Sylvain Le Gall + *) + open OASISMessage + open BaseContext + + + let debug fmt = debug ~ctxt:!default fmt + + + let info fmt = info ~ctxt:!default fmt + + + let warning fmt = warning ~ctxt:!default fmt + + + let error fmt = error ~ctxt:!default fmt + +end + +module BaseEnv = struct +(* # 22 "src/base/BaseEnv.ml" *) + + open OASISGettext + open OASISUtils + open PropList + + + module MapString = BaseEnvLight.MapString + + + type origin_t = + | ODefault + | OGetEnv + | OFileLoad + | OCommandLine + + + type cli_handle_t = + | CLINone + | CLIAuto + | CLIWith + | CLIEnable + | CLIUser of (Arg.key * Arg.spec * Arg.doc) list + + + type definition_t = + { + hide: bool; + dump: bool; + cli: cli_handle_t; + arg_help: string option; + group: string option; + } + + + let schema = + Schema.create "environment" + + + (* Environment data *) + let env = + Data.create () + + + (* Environment data from file *) + let env_from_file = + ref MapString.empty + + + (* Lexer for var *) + let var_lxr = + Genlex.make_lexer [] + + + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + (* TODO: this is a quick hack to allow calling Test.Command + * without defining executable name really. I.e. if there is + * an exec Executable toto, then $(toto) should be replace + * by its real name. It is however useful to have this function + * for other variable that depend on the host and should be + * written better than that. + *) + let st = + var_lxr (Stream.of_string var) + in + match Stream.npeek 3 st with + | [Genlex.Ident "utoh"; Genlex.Ident nm] -> + OASISHostPath.of_unix (var_get nm) + | [Genlex.Ident "utoh"; Genlex.String s] -> + OASISHostPath.of_unix s + | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> + String.escaped (var_get nm) + | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> + String.escaped s + | [Genlex.Ident nm] -> + var_get nm + | _ -> + failwithf + (f_ "Unknown expression '%s' in variable expansion of %s.") + var + str + with + | Unknown_field (_, _) -> + failwithf + (f_ "No variable %s defined when trying to expand %S.") + var + str + | Stream.Error e -> + failwithf + (f_ "Syntax error when parsing '%s' when trying to \ + expand %S: %s") + var + str + e) + str; + Buffer.contents buff + + + and var_get name = + let vl = + try + Schema.get schema env name + with Unknown_field _ as e -> + begin + try + MapString.find name !env_from_file + with Not_found -> + raise e + end + in + var_expand vl + + + let var_choose ?printer ?name lst = + OASISExpr.choose + ?printer + ?name + var_get + lst + + + let var_protect vl = + let buff = + Buffer.create (String.length vl) + in + String.iter + (function + | '$' -> Buffer.add_string buff "\\$" + | c -> Buffer.add_char buff c) + vl; + Buffer.contents buff + + + let var_define + ?(hide=false) + ?(dump=true) + ?short_desc + ?(cli=CLINone) + ?arg_help + ?group + name (* TODO: type constraint on the fact that name must be a valid OCaml + id *) + dflt = + + let default = + [ + OFileLoad, (fun () -> MapString.find name !env_from_file); + ODefault, dflt; + OGetEnv, (fun () -> Sys.getenv name); + ] + in + + let extra = + { + hide = hide; + dump = dump; + cli = cli; + arg_help = arg_help; + group = group; + } + in + + (* Try to find a value that can be defined + *) + let var_get_low lst = + let errors, res = + List.fold_left + (fun (errors, res) (o, v) -> + if res = None then + begin + try + errors, Some (v ()) + with + | Not_found -> + errors, res + | Failure rsn -> + (rsn :: errors), res + | e -> + (Printexc.to_string e) :: errors, res + end + else + errors, res) + ([], None) + (List.sort + (fun (o1, _) (o2, _) -> + Pervasives.compare o2 o1) + lst) + in + match res, errors with + | Some v, _ -> + v + | None, [] -> + raise (Not_set (name, None)) + | None, lst -> + raise (Not_set (name, Some (String.concat (s_ ", ") lst))) + in + + let help = + match short_desc with + | Some fs -> Some fs + | None -> None + in + + let var_get_lst = + FieldRO.create + ~schema + ~name + ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) + ~print:var_get_low + ~default + ~update:(fun ?context x old_x -> x @ old_x) + ?help + extra + in + + fun () -> + var_expand (var_get_low (var_get_lst env)) + + + let var_redefine + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt = + if Schema.mem schema name then + begin + (* TODO: look suspsicious, we want to memorize dflt not dflt () *) + Schema.set schema env ~context:ODefault name (dflt ()); + fun () -> var_get name + end + else + begin + var_define + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt + end + + + let var_ignore (e: unit -> string) = () + + + let print_hidden = + var_define + ~hide:true + ~dump:false + ~cli:CLIAuto + ~arg_help:"Print even non-printable variable. (debug)" + "print_hidden" + (fun () -> "false") + + + let var_all () = + List.rev + (Schema.fold + (fun acc nm def _ -> + if not def.hide || bool_of_string (print_hidden ()) then + nm :: acc + else + acc) + [] + schema) + + + let default_filename = + BaseEnvLight.default_filename + + + let load ?allow_empty ?filename () = + env_from_file := BaseEnvLight.load ?allow_empty ?filename () + + + let unload () = + env_from_file := MapString.empty; + Data.clear env + + + let dump ?(filename=default_filename) () = + let chn = + open_out_bin filename + in + let output nm value = + Printf.fprintf chn "%s=%S\n" nm value + in + let mp_todo = + (* Dump data from schema *) + Schema.fold + (fun mp_todo nm def _ -> + if def.dump then + begin + try + let value = + Schema.get + schema + env + nm + in + output nm value + with Not_set _ -> + () + end; + MapString.remove nm mp_todo) + !env_from_file + schema + in + (* Dump data defined outside of schema *) + MapString.iter output mp_todo; + + (* End of the dump *) + close_out chn + + + let print () = + let printable_vars = + Schema.fold + (fun acc nm def short_descr_opt -> + if not def.hide || bool_of_string (print_hidden ()) then + begin + try + let value = + Schema.get + schema + env + nm + in + let txt = + match short_descr_opt with + | Some s -> s () + | None -> nm + in + (txt, value) :: acc + with Not_set _ -> + acc + end + else + acc) + [] + schema + in + let max_length = + List.fold_left max 0 + (List.rev_map String.length + (List.rev_map fst printable_vars)) + in + let dot_pad str = + String.make ((max_length - (String.length str)) + 3) '.' + in + + Printf.printf "\nConfiguration: \n"; + List.iter + (fun (name, value) -> + Printf.printf "%s: %s %s\n" name (dot_pad name) value) + (List.rev printable_vars); + Printf.printf "\n%!" + + + let args () = + let arg_concat = + OASISUtils.varname_concat ~hyphen:'-' + in + [ + "--override", + Arg.Tuple + ( + let rvr = ref "" + in + let rvl = ref "" + in + [ + Arg.Set_string rvr; + Arg.Set_string rvl; + Arg.Unit + (fun () -> + Schema.set + schema + env + ~context:OCommandLine + !rvr + !rvl) + ] + ), + "var+val Override any configuration variable."; + + ] + @ + List.flatten + (Schema.fold + (fun acc name def short_descr_opt -> + let var_set s = + Schema.set + schema + env + ~context:OCommandLine + name + s + in + + let arg_name = + OASISUtils.varname_of_string ~hyphen:'-' name + in + + let hlp = + match short_descr_opt with + | Some txt -> txt () + | None -> "" + in + + let arg_hlp = + match def.arg_help with + | Some s -> s + | None -> "str" + in + + let default_value = + try + Printf.sprintf + (f_ " [%s]") + (Schema.get + schema + env + name) + with Not_set _ -> + "" + in + + let args = + match def.cli with + | CLINone -> + [] + | CLIAuto -> + [ + arg_concat "--" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIWith -> + [ + arg_concat "--with-" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIEnable -> + let dflt = + if default_value = " [true]" then + s_ " [default: enabled]" + else + s_ " [default: disabled]" + in + [ + arg_concat "--enable-" arg_name, + Arg.Unit (fun () -> var_set "true"), + Printf.sprintf (f_ " %s%s") hlp dflt; + + arg_concat "--disable-" arg_name, + Arg.Unit (fun () -> var_set "false"), + Printf.sprintf (f_ " %s%s") hlp dflt + ] + | CLIUser lst -> + lst + in + args :: acc) + [] + schema) +end + +module BaseArgExt = struct +(* # 22 "src/base/BaseArgExt.ml" *) + + + open OASISUtils + open OASISGettext + + + let parse argv args = + (* Simulate command line for Arg *) + let current = + ref 0 + in + + try + Arg.parse_argv + ~current:current + (Array.concat [[|"none"|]; argv]) + (Arg.align args) + (failwithf (f_ "Don't know what to do with arguments: '%s'")) + (s_ "configure options:") + with + | Arg.Help txt -> + print_endline txt; + exit 0 + | Arg.Bad txt -> + prerr_endline txt; + exit 1 +end + +module BaseCheck = struct +(* # 22 "src/base/BaseCheck.ml" *) + + + open BaseEnv + open BaseMessage + open OASISUtils + open OASISGettext + + + let prog_best prg prg_lst = + var_redefine + prg + (fun () -> + let alternate = + List.fold_left + (fun res e -> + match res with + | Some _ -> + res + | None -> + try + Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) + with Not_found -> + None) + None + prg_lst + in + match alternate with + | Some prg -> prg + | None -> raise Not_found) + + + let prog prg = + prog_best prg [prg] + + + let prog_opt prg = + prog_best prg [prg^".opt"; prg] + + + let ocamlfind = + prog "ocamlfind" + + + let version + var_prefix + cmp + fversion + () = + (* Really compare version provided *) + let var = + var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) + in + var_redefine + ~hide:true + var + (fun () -> + let version_str = + match fversion () with + | "[Distributed with OCaml]" -> + begin + try + (var_get "ocaml_version") + with Not_found -> + warning + (f_ "Variable ocaml_version not defined, fallback \ + to default"); + Sys.ocaml_version + end + | res -> + res + in + let version = + OASISVersion.version_of_string version_str + in + if OASISVersion.comparator_apply version cmp then + version_str + else + failwithf + (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") + var_prefix + (OASISVersion.string_of_comparator cmp) + version_str) + () + + + let package_version pkg = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%v"; pkg] + + + let package ?version_comparator pkg () = + let var = + OASISUtils.varname_concat + "pkg_" + (OASISUtils.varname_of_string pkg) + in + let findlib_dir pkg = + let dir = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%d"; pkg] + in + if Sys.file_exists dir && Sys.is_directory dir then + dir + else + failwithf + (f_ "When looking for findlib package %s, \ + directory %s return doesn't exist") + pkg dir + in + let vl = + var_redefine + var + (fun () -> findlib_dir pkg) + () + in + ( + match version_comparator with + | Some ver_cmp -> + ignore + (version + var + ver_cmp + (fun _ -> package_version pkg) + ()) + | None -> + () + ); + vl +end + +module BaseOCamlcConfig = struct +(* # 22 "src/base/BaseOCamlcConfig.ml" *) + + + open BaseEnv + open OASISUtils + open OASISGettext + + + module SMap = Map.Make(String) + + + let ocamlc = + BaseCheck.prog_opt "ocamlc" + + + let ocamlc_config_map = + (* Map name to value for ocamlc -config output + (name ^": "^value) + *) + let rec split_field mp lst = + match lst with + | line :: tl -> + let mp = + try + let pos_semicolon = + String.index line ':' + in + if pos_semicolon > 1 then + ( + let name = + String.sub line 0 pos_semicolon + in + let linelen = + String.length line + in + let value = + if linelen > pos_semicolon + 2 then + String.sub + line + (pos_semicolon + 2) + (linelen - pos_semicolon - 2) + else + "" + in + SMap.add name value mp + ) + else + ( + mp + ) + with Not_found -> + ( + mp + ) + in + split_field mp tl + | [] -> + mp + in + + let cache = + lazy + (var_protect + (Marshal.to_string + (split_field + SMap.empty + (OASISExec.run_read_output + ~ctxt:!BaseContext.default + (ocamlc ()) ["-config"])) + [])) + in + var_redefine + "ocamlc_config_map" + ~hide:true + ~dump:false + (fun () -> + (* TODO: update if ocamlc change !!! *) + Lazy.force cache) + + + let var_define nm = + (* Extract data from ocamlc -config *) + let avlbl_config_get () = + Marshal.from_string + (ocamlc_config_map ()) + 0 + in + let chop_version_suffix s = + try + String.sub s 0 (String.index s '+') + with _ -> + s + in + + let nm_config, value_config = + match nm with + | "ocaml_version" -> + "version", chop_version_suffix + | _ -> nm, (fun x -> x) + in + var_redefine + nm + (fun () -> + try + let map = + avlbl_config_get () + in + let value = + SMap.find nm_config map + in + value_config value + with Not_found -> + failwithf + (f_ "Cannot find field '%s' in '%s -config' output") + nm + (ocamlc ())) + +end + +module BaseStandardVar = struct +(* # 22 "src/base/BaseStandardVar.ml" *) + + + open OASISGettext + open OASISTypes + open OASISExpr + open BaseCheck + open BaseEnv + + + let ocamlfind = BaseCheck.ocamlfind + let ocamlc = BaseOCamlcConfig.ocamlc + let ocamlopt = prog_opt "ocamlopt" + let ocamlbuild = prog "ocamlbuild" + + + (**/**) + let rpkg = + ref None + + + let pkg_get () = + match !rpkg with + | Some pkg -> pkg + | None -> failwith (s_ "OASIS Package is not set") + + + let var_cond = ref [] + + + let var_define_cond ~since_version f dflt = + let holder = ref (fun () -> dflt) in + let since_version = + OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) + in + var_cond := + (fun ver -> + if OASISVersion.comparator_apply ver since_version then + holder := f ()) :: !var_cond; + fun () -> !holder () + + + (**/**) + + + let pkg_name = + var_define + ~short_desc:(fun () -> s_ "Package name") + "pkg_name" + (fun () -> (pkg_get ()).name) + + + let pkg_version = + var_define + ~short_desc:(fun () -> s_ "Package version") + "pkg_version" + (fun () -> + (OASISVersion.string_of_version (pkg_get ()).version)) + + + let c = BaseOCamlcConfig.var_define + + + let os_type = c "os_type" + let system = c "system" + let architecture = c "architecture" + let ccomp_type = c "ccomp_type" + let ocaml_version = c "ocaml_version" + + + (* TODO: Check standard variable presence at runtime *) + + + let standard_library_default = c "standard_library_default" + let standard_library = c "standard_library" + let standard_runtime = c "standard_runtime" + let bytecomp_c_compiler = c "bytecomp_c_compiler" + let native_c_compiler = c "native_c_compiler" + let model = c "model" + let ext_obj = c "ext_obj" + let ext_asm = c "ext_asm" + let ext_lib = c "ext_lib" + let ext_dll = c "ext_dll" + let default_executable_name = c "default_executable_name" + let systhread_supported = c "systhread_supported" + + + let flexlink = + BaseCheck.prog "flexlink" + + + let flexdll_version = + var_define + ~short_desc:(fun () -> "FlexDLL version (Win32)") + "flexdll_version" + (fun () -> + let lst = + OASISExec.run_read_output ~ctxt:!BaseContext.default + (flexlink ()) ["-help"] + in + match lst with + | line :: _ -> + Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) + | [] -> + raise Not_found) + + + (**/**) + let p name hlp dflt = + var_define + ~short_desc:hlp + ~cli:CLIAuto + ~arg_help:"dir" + name + dflt + + + let (/) a b = + if os_type () = Sys.os_type then + Filename.concat a b + else if os_type () = "Unix" then + OASISUnixPath.concat a b + else + OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") + (os_type ()) + (**/**) + + + let prefix = + p "prefix" + (fun () -> s_ "Install architecture-independent files dir") + (fun () -> + match os_type () with + | "Win32" -> + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) + | _ -> + "/usr/local") + + + let exec_prefix = + p "exec_prefix" + (fun () -> s_ "Install architecture-dependent files in dir") + (fun () -> "$prefix") + + + let bindir = + p "bindir" + (fun () -> s_ "User executables") + (fun () -> "$exec_prefix"/"bin") + + + let sbindir = + p "sbindir" + (fun () -> s_ "System admin executables") + (fun () -> "$exec_prefix"/"sbin") + + + let libexecdir = + p "libexecdir" + (fun () -> s_ "Program executables") + (fun () -> "$exec_prefix"/"libexec") + + + let sysconfdir = + p "sysconfdir" + (fun () -> s_ "Read-only single-machine data") + (fun () -> "$prefix"/"etc") + + + let sharedstatedir = + p "sharedstatedir" + (fun () -> s_ "Modifiable architecture-independent data") + (fun () -> "$prefix"/"com") + + + let localstatedir = + p "localstatedir" + (fun () -> s_ "Modifiable single-machine data") + (fun () -> "$prefix"/"var") + + + let libdir = + p "libdir" + (fun () -> s_ "Object code libraries") + (fun () -> "$exec_prefix"/"lib") + + + let datarootdir = + p "datarootdir" + (fun () -> s_ "Read-only arch-independent data root") + (fun () -> "$prefix"/"share") + + + let datadir = + p "datadir" + (fun () -> s_ "Read-only architecture-independent data") + (fun () -> "$datarootdir") + + + let infodir = + p "infodir" + (fun () -> s_ "Info documentation") + (fun () -> "$datarootdir"/"info") + + + let localedir = + p "localedir" + (fun () -> s_ "Locale-dependent data") + (fun () -> "$datarootdir"/"locale") + + + let mandir = + p "mandir" + (fun () -> s_ "Man documentation") + (fun () -> "$datarootdir"/"man") + + + let docdir = + p "docdir" + (fun () -> s_ "Documentation root") + (fun () -> "$datarootdir"/"doc"/"$pkg_name") + + + let htmldir = + p "htmldir" + (fun () -> s_ "HTML documentation") + (fun () -> "$docdir") + + + let dvidir = + p "dvidir" + (fun () -> s_ "DVI documentation") + (fun () -> "$docdir") + + + let pdfdir = + p "pdfdir" + (fun () -> s_ "PDF documentation") + (fun () -> "$docdir") + + + let psdir = + p "psdir" + (fun () -> s_ "PS documentation") + (fun () -> "$docdir") + + + let destdir = + p "destdir" + (fun () -> s_ "Prepend a path when installing package") + (fun () -> + raise + (PropList.Not_set + ("destdir", + Some (s_ "undefined by construct")))) + + + let findlib_version = + var_define + "findlib_version" + (fun () -> + BaseCheck.package_version "findlib") + + + let is_native = + var_define + "is_native" + (fun () -> + try + let _s: string = + ocamlopt () + in + "true" + with PropList.Not_set _ -> + let _s: string = + ocamlc () + in + "false") + + + let ext_program = + var_define + "suffix_program" + (fun () -> + match os_type () with + | "Win32" | "Cygwin" -> ".exe" + | _ -> "") + + + let rm = + var_define + ~short_desc:(fun () -> s_ "Remove a file.") + "rm" + (fun () -> + match os_type () with + | "Win32" -> "del" + | _ -> "rm -f") + + + let rmdir = + var_define + ~short_desc:(fun () -> s_ "Remove a directory.") + "rmdir" + (fun () -> + match os_type () with + | "Win32" -> "rd" + | _ -> "rm -rf") + + + let debug = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") + ~cli:CLIEnable + "debug" + (fun () -> "true") + + + let profile = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") + ~cli:CLIEnable + "profile" + (fun () -> "false") + + + let tests = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> + s_ "Compile tests executable and library and run them") + ~cli:CLIEnable + "tests" + (fun () -> "false")) + "true" + + + let docs = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> s_ "Create documentations") + ~cli:CLIEnable + "docs" + (fun () -> "true")) + "true" + + + let native_dynlink = + var_define + ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") + ~cli:CLINone + "native_dynlink" + (fun () -> + let res = + let ocaml_lt_312 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (ocaml_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "3.12.0")) + in + let flexdll_lt_030 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (flexdll_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "0.30")) + in + let has_native_dynlink = + let ocamlfind = ocamlfind () in + try + let fn = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ocamlfind + ["query"; "-predicates"; "native"; "dynlink"; + "-format"; "%d/%a"] + in + Sys.file_exists fn + with _ -> + false + in + if not has_native_dynlink then + false + else if ocaml_lt_312 () then + false + else if (os_type () = "Win32" || os_type () = "Cygwin") + && flexdll_lt_030 () then + begin + BaseMessage.warning + (f_ ".cmxs generation disabled because FlexDLL needs to be \ + at least 0.30. Please upgrade FlexDLL from %s to 0.30.") + (flexdll_version ()); + false + end + else + true + in + string_of_bool res) + + + let init pkg = + rpkg := Some pkg; + List.iter (fun f -> f pkg.oasis_version) !var_cond + +end + +module BaseFileAB = struct +(* # 22 "src/base/BaseFileAB.ml" *) + + + open BaseEnv + open OASISGettext + open BaseMessage + + + let to_filename fn = + let fn = + OASISHostPath.of_unix fn + in + if not (Filename.check_suffix fn ".ab") then + warning + (f_ "File '%s' doesn't have '.ab' extension") + fn; + Filename.chop_extension fn + + + let replace fn_lst = + let buff = + Buffer.create 13 + in + List.iter + (fun fn -> + let fn = + OASISHostPath.of_unix fn + in + let chn_in = + open_in fn + in + let chn_out = + open_out (to_filename fn) + in + ( + try + while true do + Buffer.add_string buff (var_expand (input_line chn_in)); + Buffer.add_char buff '\n' + done + with End_of_file -> + () + ); + Buffer.output_buffer chn_out buff; + Buffer.clear buff; + close_in chn_in; + close_out chn_out) + fn_lst +end + +module BaseLog = struct +(* # 22 "src/base/BaseLog.ml" *) + + + open OASISUtils + + + let default_filename = + Filename.concat + (Filename.dirname BaseEnv.default_filename) + "setup.log" + + + module SetTupleString = + Set.Make + (struct + type t = string * string + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with + | 0 -> String.compare s12 s22 + | n -> n + end) + + + let load () = + if Sys.file_exists default_filename then + begin + let chn = + open_in default_filename + in + let scbuf = + Scanf.Scanning.from_file default_filename + in + let rec read_aux (st, lst) = + if not (Scanf.Scanning.end_of_input scbuf) then + begin + let acc = + try + Scanf.bscanf scbuf "%S %S\n" + (fun e d -> + let t = + e, d + in + if SetTupleString.mem t st then + st, lst + else + SetTupleString.add t st, + t :: lst) + with Scanf.Scan_failure _ -> + failwith + (Scanf.bscanf scbuf + "%l" + (fun line -> + Printf.sprintf + "Malformed log file '%s' at line %d" + default_filename + line)) + in + read_aux acc + end + else + begin + close_in chn; + List.rev lst + end + in + read_aux (SetTupleString.empty, []) + end + else + begin + [] + end + + + let register event data = + let chn_out = + open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename + in + Printf.fprintf chn_out "%S %S\n" event data; + close_out chn_out + + + let unregister event data = + if Sys.file_exists default_filename then + begin + let lst = + load () + in + let chn_out = + open_out default_filename + in + let write_something = + ref false + in + List.iter + (fun (e, d) -> + if e <> event || d <> data then + begin + write_something := true; + Printf.fprintf chn_out "%S %S\n" e d + end) + lst; + close_out chn_out; + if not !write_something then + Sys.remove default_filename + end + + + let filter events = + let st_events = + List.fold_left + (fun st e -> + SetString.add e st) + SetString.empty + events + in + List.filter + (fun (e, _) -> SetString.mem e st_events) + (load ()) + + + let exists event data = + List.exists + (fun v -> (event, data) = v) + (load ()) +end + +module BaseBuilt = struct +(* # 22 "src/base/BaseBuilt.ml" *) + + + open OASISTypes + open OASISGettext + open BaseStandardVar + open BaseMessage + + + type t = + | BExec (* Executable *) + | BExecLib (* Library coming with executable *) + | BLib (* Library *) + | BObj (* Library *) + | BDoc (* Document *) + + + let to_log_event_file t nm = + "built_"^ + (match t with + | BExec -> "exec" + | BExecLib -> "exec_lib" + | BLib -> "lib" + | BObj -> "obj" + | BDoc -> "doc")^ + "_"^nm + + + let to_log_event_done t nm = + "is_"^(to_log_event_file t nm) + + + let register t nm lst = + BaseLog.register + (to_log_event_done t nm) + "true"; + List.iter + (fun alt -> + let registered = + List.fold_left + (fun registered fn -> + if OASISFileUtil.file_exists_case fn then + begin + BaseLog.register + (to_log_event_file t nm) + (if Filename.is_relative fn then + Filename.concat (Sys.getcwd ()) fn + else + fn); + true + end + else + registered) + false + alt + in + if not registered then + warning + (f_ "Cannot find an existing alternative files among: %s") + (String.concat (s_ ", ") alt)) + lst + + + let unregister t nm = + List.iter + (fun (e, d) -> + BaseLog.unregister e d) + (BaseLog.filter + [to_log_event_file t nm; + to_log_event_done t nm]) + + + let fold t nm f acc = + List.fold_left + (fun acc (_, fn) -> + if OASISFileUtil.file_exists_case fn then + begin + f acc fn + end + else + begin + warning + (f_ "File '%s' has been marked as built \ + for %s but doesn't exist") + fn + (Printf.sprintf + (match t with + | BExec | BExecLib -> + (f_ "executable %s") + | BLib -> + (f_ "library %s") + | BObj -> + (f_ "object %s") + | BDoc -> + (f_ "documentation %s")) + nm); + acc + end) + acc + (BaseLog.filter + [to_log_event_file t nm]) + + + let is_built t nm = + List.fold_left + (fun is_built (_, d) -> + (try + bool_of_string d + with _ -> + false)) + false + (BaseLog.filter + [to_log_event_done t nm]) + + + let of_executable ffn (cs, bs, exec) = + let unix_exec_is, unix_dll_opt = + OASISExecutable.unix_exec_is + (cs, bs, exec) + (fun () -> + bool_of_string + (is_native ())) + ext_dll + ext_program + in + let evs = + (BExec, cs.cs_name, [[ffn unix_exec_is]]) + :: + (match unix_dll_opt with + | Some fn -> + [BExecLib, cs.cs_name, [[ffn fn]]] + | None -> + []) + in + evs, + unix_exec_is, + unix_dll_opt + + + let of_library ffn (cs, bs, lib) = + let unix_lst = + OASISLibrary.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + ~has_native_dynlink:(bool_of_string (native_dynlink ())) + ~ext_lib:(ext_lib ()) + ~ext_dll:(ext_dll ()) + (cs, bs, lib) + in + let evs = + [BLib, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + + + let of_object ffn (cs, bs, obj) = + let unix_lst = + OASISObject.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + (cs, bs, obj) + in + let evs = + [BObj, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + +end + +module BaseCustom = struct +(* # 22 "src/base/BaseCustom.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + + let run cmd args extra_args = + OASISExec.run ~ctxt:!BaseContext.default ~quote:false + (var_expand cmd) + (List.map + var_expand + (args @ (Array.to_list extra_args))) + + + let hook ?(failsafe=false) cstm f e = + let optional_command lst = + let printer = + function + | Some (cmd, args) -> String.concat " " (cmd :: args) + | None -> s_ "No command" + in + match + var_choose + ~name:(s_ "Pre/Post Command") + ~printer + lst with + | Some (cmd, args) -> + begin + try + run cmd args [||] + with e when failsafe -> + warning + (f_ "Command '%s' fail with error: %s") + (String.concat " " (cmd :: args)) + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + end + | None -> + () + in + let res = + optional_command cstm.pre_command; + f e + in + optional_command cstm.post_command; + res +end + +module BaseDynVar = struct +(* # 22 "src/base/BaseDynVar.ml" *) + + + open OASISTypes + open OASISGettext + open BaseEnv + open BaseBuilt + + + let init pkg = + (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) + (* TODO: provide compile option for library libary_byte_args_VARNAME... *) + List.iter + (function + | Executable (cs, bs, exec) -> + if var_choose bs.bs_build then + var_ignore + (var_redefine + (* We don't save this variable *) + ~dump:false + ~short_desc:(fun () -> + Printf.sprintf + (f_ "Filename of executable '%s'") + cs.cs_name) + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + let fn_opt = + fold + BExec cs.cs_name + (fun _ fn -> Some fn) + None + in + match fn_opt with + | Some fn -> fn + | None -> + raise + (PropList.Not_set + (cs.cs_name, + Some (Printf.sprintf + (f_ "Executable '%s' not yet built.") + cs.cs_name))))) + + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + ()) + pkg.sections +end + +module BaseTest = struct +(* # 22 "src/base/BaseTest.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISExpr + open OASISGettext + + + let test lst pkg extra_args = + + let one_test (failure, n) (test_plugin, cs, test) = + if var_choose + ~name:(Printf.sprintf + (f_ "test %s run") + cs.cs_name) + ~printer:string_of_bool + test.test_run then + begin + let () = + info (f_ "Running test '%s'") cs.cs_name + in + let back_cwd = + match test.test_working_directory with + | Some dir -> + let cwd = + Sys.getcwd () + in + let chdir d = + info (f_ "Changing directory to '%s'") d; + Sys.chdir d + in + chdir dir; + fun () -> chdir cwd + + | None -> + fun () -> () + in + try + let failure_percent = + BaseCustom.hook + test.test_custom + (test_plugin pkg (cs, test)) + extra_args + in + back_cwd (); + (failure_percent +. failure, n + 1) + with e -> + begin + back_cwd (); + raise e + end + end + else + begin + info (f_ "Skipping test '%s'") cs.cs_name; + (failure, n) + end + in + let failed, n = + List.fold_left + one_test + (0.0, 0) + lst + in + let failure_percent = + if n = 0 then + 0.0 + else + failed /. (float_of_int n) + in + let msg = + Printf.sprintf + (f_ "Tests had a %.2f%% failure rate") + (100. *. failure_percent) + in + if failure_percent > 0.0 then + failwith msg + else + info "%s" msg; + + (* Possible explanation why the tests where not run. *) + if OASISFeatures.package_test OASISFeatures.flag_tests pkg && + not (bool_of_string (BaseStandardVar.tests ())) && + lst <> [] then + BaseMessage.warning + "Tests are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-tests'" +end + +module BaseDoc = struct +(* # 22 "src/base/BaseDoc.ml" *) + + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + + let doc lst pkg extra_args = + + let one_doc (doc_plugin, cs, doc) = + if var_choose + ~name:(Printf.sprintf + (f_ "documentation %s build") + cs.cs_name) + ~printer:string_of_bool + doc.doc_build then + begin + info (f_ "Building documentation '%s'") cs.cs_name; + BaseCustom.hook + doc.doc_custom + (doc_plugin pkg (cs, doc)) + extra_args + end + in + List.iter one_doc lst; + + if OASISFeatures.package_test OASISFeatures.flag_docs pkg && + not (bool_of_string (BaseStandardVar.docs ())) && + lst <> [] then + BaseMessage.warning + "Docs are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-docs'" +end + +module BaseSetup = struct +(* # 22 "src/base/BaseSetup.ml" *) + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISSection + open OASISGettext + open OASISUtils + + + type std_args_fun = + package -> string array -> unit + + + type ('a, 'b) section_args_fun = + name * (package -> (common_section * 'a) -> string array -> 'b) + + + type t = + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + oasis_fn: string option; + oasis_version: string; + oasis_digest: Digest.t option; + oasis_exec: string option; + oasis_setup_args: string list; + setup_update: bool; + } + + + (* Associate a plugin function with data from package *) + let join_plugin_sections filter_map lst = + List.rev + (List.fold_left + (fun acc sct -> + match filter_map sct with + | Some e -> + e :: acc + | None -> + acc) + [] + lst) + + + (* Search for plugin data associated with a section name *) + let lookup_plugin_section plugin action nm lst = + try + List.assoc nm lst + with Not_found -> + failwithf + (f_ "Cannot find plugin %s matching section %s for %s action") + plugin + nm + action + + + let configure t args = + (* Run configure *) + BaseCustom.hook + t.package.conf_custom + (fun () -> + (* Reload if preconf has changed it *) + begin + try + unload (); + load (); + with _ -> + () + end; + + (* Run plugin's configure *) + t.configure t.package args; + + (* Dump to allow postconf to change it *) + dump ()) + (); + + (* Reload environment *) + unload (); + load (); + + (* Save environment *) + print (); + + (* Replace data in file *) + BaseFileAB.replace t.package.files_ab + + + let build t args = + BaseCustom.hook + t.package.build_custom + (t.build t.package) + args + + + let doc t args = + BaseDoc.doc + (join_plugin_sections + (function + | Doc (cs, e) -> + Some + (lookup_plugin_section + "documentation" + (s_ "build") + cs.cs_name + t.doc, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + + let test t args = + BaseTest.test + (join_plugin_sections + (function + | Test (cs, e) -> + Some + (lookup_plugin_section + "test" + (s_ "run") + cs.cs_name + t.test, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + + let all t args = + let rno_doc = + ref false + in + let rno_test = + ref false + in + let arg_rest = + ref [] + in + Arg.parse_argv + ~current:(ref 0) + (Array.of_list + ((Sys.executable_name^" all") :: + (Array.to_list args))) + [ + "-no-doc", + Arg.Set rno_doc, + s_ "Don't run doc target"; + + "-no-test", + Arg.Set rno_test, + s_ "Don't run test target"; + + "--", + Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), + s_ "All arguments for configure."; + ] + (failwithf (f_ "Don't know what to do with '%s'")) + ""; + + info "Running configure step"; + configure t (Array.of_list (List.rev !arg_rest)); + + info "Running build step"; + build t [||]; + + (* Load setup.log dynamic variables *) + BaseDynVar.init t.package; + + if not !rno_doc then + begin + info "Running doc step"; + doc t [||]; + end + else + begin + info "Skipping doc step" + end; + + if not !rno_test then + begin + info "Running test step"; + test t [||] + end + else + begin + info "Skipping test step" + end + + + let install t args = + BaseCustom.hook + t.package.install_custom + (t.install t.package) + args + + + let uninstall t args = + BaseCustom.hook + t.package.uninstall_custom + (t.uninstall t.package) + args + + + let reinstall t args = + uninstall t args; + install t args + + + let clean, distclean = + let failsafe f a = + try + f a + with e -> + warning + (f_ "Action fail with error: %s") + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + in + + let generic_clean t cstm mains docs tests args = + BaseCustom.hook + ~failsafe:true + cstm + (fun () -> + (* Clean section *) + List.iter + (function + | Test (cs, test) -> + let f = + try + List.assoc cs.cs_name tests + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, test)) + args + | Doc (cs, doc) -> + let f = + try + List.assoc cs.cs_name docs + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, doc)) + args + | Library _ + | Object _ + | Executable _ + | Flag _ + | SrcRepo _ -> + ()) + t.package.sections; + (* Clean whole package *) + List.iter + (fun f -> + failsafe + (f t.package) + args) + mains) + () + in + + let clean t args = + generic_clean + t + t.package.clean_custom + t.clean + t.clean_doc + t.clean_test + args + in + + let distclean t args = + (* Call clean *) + clean t args; + + (* Call distclean code *) + generic_clean + t + t.package.distclean_custom + t.distclean + t.distclean_doc + t.distclean_test + args; + + (* Remove generated file *) + List.iter + (fun fn -> + if Sys.file_exists fn then + begin + info (f_ "Remove '%s'") fn; + Sys.remove fn + end) + (BaseEnv.default_filename + :: + BaseLog.default_filename + :: + (List.rev_map BaseFileAB.to_filename t.package.files_ab)) + in + + clean, distclean + + + let version t _ = + print_endline t.oasis_version + + + let update_setup_ml, no_update_setup_ml_cli = + let b = ref true in + b, + ("-no-update-setup-ml", + Arg.Clear b, + s_ " Don't try to update setup.ml, even if _oasis has changed.") + + + let default_oasis_fn = "_oasis" + + + let update_setup_ml t = + let oasis_fn = + match t.oasis_fn with + | Some fn -> fn + | None -> default_oasis_fn + in + let oasis_exec = + match t.oasis_exec with + | Some fn -> fn + | None -> "oasis" + in + let ocaml = + Sys.executable_name + in + let setup_ml, args = + match Array.to_list Sys.argv with + | setup_ml :: args -> + setup_ml, args + | [] -> + failwith + (s_ "Expecting non-empty command line arguments.") + in + let ocaml, setup_ml = + if Sys.executable_name = Sys.argv.(0) then + (* We are not running in standard mode, probably the script + * is precompiled. + *) + "ocaml", "setup.ml" + else + ocaml, setup_ml + in + let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in + let do_update () = + let oasis_exec_version = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | 1 -> + failwithf + (f_ "Executable '%s' is probably an old version \ + of oasis (< 0.3.0), please update to version \ + v%s.") + oasis_exec t.oasis_version + | 127 -> + failwithf + (f_ "Cannot find executable '%s', please install \ + oasis v%s.") + oasis_exec t.oasis_version + | n -> + failwithf + (f_ "Command '%s version' exited with code %d.") + oasis_exec n) + oasis_exec ["version"] + in + if OASISVersion.comparator_apply + (OASISVersion.version_of_string oasis_exec_version) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string t.oasis_version)) then + begin + (* We have a version >= for the executable oasis, proceed with + * update. + *) + (* TODO: delegate this check to 'oasis setup'. *) + if Sys.os_type = "Win32" then + failwithf + (f_ "It is not possible to update the running script \ + setup.ml on Windows. Please update setup.ml by \ + running '%s'.") + (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) + else + begin + OASISExec.run + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | n -> + failwithf + (f_ "Unable to update setup.ml using '%s', \ + please fix the problem and retry.") + oasis_exec) + oasis_exec ("setup" :: t.oasis_setup_args); + OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) + end + end + else + failwithf + (f_ "The version of '%s' (v%s) doesn't match the version of \ + oasis used to generate the %s file. Please install at \ + least oasis v%s.") + oasis_exec oasis_exec_version setup_ml t.oasis_version + in + + if !update_setup_ml then + begin + try + match t.oasis_digest with + | Some dgst -> + if Sys.file_exists oasis_fn && + dgst <> Digest.file default_oasis_fn then + begin + do_update (); + true + end + else + false + | None -> + false + with e -> + error + (f_ "Error when updating setup.ml. If you want to avoid this error, \ + you can bypass the update of %s by running '%s %s %s %s'") + setup_ml ocaml setup_ml no_update_setup_ml_cli + (String.concat " " args); + raise e + end + else + false + + + let setup t = + let catch_exn = + ref true + in + try + let act_ref = + ref (fun _ -> + failwithf + (f_ "No action defined, run '%s %s -help'") + Sys.executable_name + Sys.argv.(0)) + + in + let extra_args_ref = + ref [] + in + let allow_empty_env_ref = + ref false + in + let arg_handle ?(allow_empty_env=false) act = + Arg.Tuple + [ + Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); + + Arg.Unit + (fun () -> + allow_empty_env_ref := allow_empty_env; + act_ref := act); + ] + in + + Arg.parse + (Arg.align + ([ + "-configure", + arg_handle ~allow_empty_env:true configure, + s_ "[options*] Configure the whole build process."; + + "-build", + arg_handle build, + s_ "[options*] Build executables and libraries."; + + "-doc", + arg_handle doc, + s_ "[options*] Build documents."; + + "-test", + arg_handle test, + s_ "[options*] Run tests."; + + "-all", + arg_handle ~allow_empty_env:true all, + s_ "[options*] Run configure, build, doc and test targets."; + + "-install", + arg_handle install, + s_ "[options*] Install libraries, data, executables \ + and documents."; + + "-uninstall", + arg_handle uninstall, + s_ "[options*] Uninstall libraries, data, executables \ + and documents."; + + "-reinstall", + arg_handle reinstall, + s_ "[options*] Uninstall and install libraries, data, \ + executables and documents."; + + "-clean", + arg_handle ~allow_empty_env:true clean, + s_ "[options*] Clean files generated by a build."; + + "-distclean", + arg_handle ~allow_empty_env:true distclean, + s_ "[options*] Clean files generated by a build and configure."; + + "-version", + arg_handle ~allow_empty_env:true version, + s_ " Display version of OASIS used to generate this setup.ml."; + + "-no-catch-exn", + Arg.Clear catch_exn, + s_ " Don't catch exception, useful for debugging."; + ] + @ + (if t.setup_update then + [no_update_setup_ml_cli] + else + []) + @ (BaseContext.args ()))) + (failwithf (f_ "Don't know what to do with '%s'")) + (s_ "Setup and run build process current package\n"); + + (* Build initial environment *) + load ~allow_empty:!allow_empty_env_ref (); + + (** Initialize flags *) + List.iter + (function + | Flag (cs, {flag_description = hlp; + flag_default = choices}) -> + begin + let apply ?short_desc () = + var_ignore + (var_define + ~cli:CLIEnable + ?short_desc + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + string_of_bool + (var_choose + ~name:(Printf.sprintf + (f_ "default value of flag %s") + cs.cs_name) + ~printer:string_of_bool + choices))) + in + match hlp with + | Some hlp -> + apply ~short_desc:(fun () -> hlp) () + | None -> + apply () + end + | _ -> + ()) + t.package.sections; + + BaseStandardVar.init t.package; + + BaseDynVar.init t.package; + + if t.setup_update && update_setup_ml t then + () + else + !act_ref t (Array.of_list (List.rev !extra_args_ref)) + + with e when !catch_exn -> + error "%s" (Printexc.to_string e); + exit 1 + + +end + + +# 5394 "setup.ml" +module InternalConfigurePlugin = struct +(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) + + + (** Configure using internal scheme + @author Sylvain Le Gall + *) + + + open BaseEnv + open OASISTypes + open OASISUtils + open OASISGettext + open BaseMessage + + + (** Configure build using provided series of check to be done + * and then output corresponding file. + *) + let configure pkg argv = + let var_ignore_eval var = let _s: string = var () in () in + let errors = ref SetString.empty in + let buff = Buffer.create 13 in + + let add_errors fmt = + Printf.kbprintf + (fun b -> + errors := SetString.add (Buffer.contents b) !errors; + Buffer.clear b) + buff + fmt + in + + let warn_exception e = + warning "%s" (Printexc.to_string e) + in + + (* Check tools *) + let check_tools lst = + List.iter + (function + | ExternalTool tool -> + begin + try + var_ignore_eval (BaseCheck.prog tool) + with e -> + warn_exception e; + add_errors (f_ "Cannot find external tool '%s'") tool + end + | InternalExecutable nm1 -> + (* Check that matching tool is built *) + List.iter + (function + | Executable ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal executable \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + lst + in + + let build_checks sct bs = + if var_choose bs.bs_build then + begin + if bs.bs_compiled_object = Native then + begin + try + var_ignore_eval BaseStandardVar.ocamlopt + with e -> + warn_exception e; + add_errors + (f_ "Section %s requires native compilation") + (OASISSection.string_of_section sct) + end; + + (* Check tools *) + check_tools bs.bs_build_tools; + + (* Check depends *) + List.iter + (function + | FindlibPackage (findlib_pkg, version_comparator) -> + begin + try + var_ignore_eval + (BaseCheck.package ?version_comparator findlib_pkg) + with e -> + warn_exception e; + match version_comparator with + | None -> + add_errors + (f_ "Cannot find findlib package %s") + findlib_pkg + | Some ver_cmp -> + add_errors + (f_ "Cannot find findlib package %s (%s)") + findlib_pkg + (OASISVersion.string_of_comparator ver_cmp) + end + | InternalLibrary nm1 -> + (* Check that matching library is built *) + List.iter + (function + | Library ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal library \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + bs.bs_build_depends + end + in + + (* Parse command line *) + BaseArgExt.parse argv (BaseEnv.args ()); + + (* OCaml version *) + begin + match pkg.ocaml_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "ocaml" + ver_cmp + BaseStandardVar.ocaml_version) + with e -> + warn_exception e; + add_errors + (f_ "OCaml version %s doesn't match version constraint %s") + (BaseStandardVar.ocaml_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* Findlib version *) + begin + match pkg.findlib_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "findlib" + ver_cmp + BaseStandardVar.findlib_version) + with e -> + warn_exception e; + add_errors + (f_ "Findlib version %s doesn't match version constraint %s") + (BaseStandardVar.findlib_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + (* Make sure the findlib version is fine for the OCaml compiler. *) + begin + let ocaml_ge4 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) + (OASISVersion.version_of_string "4.0.0") >= 0 in + if ocaml_ge4 then + let findlib_lt132 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) + (OASISVersion.version_of_string "1.3.2") < 0 in + if findlib_lt132 then + add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" + end; + + (* FlexDLL *) + if BaseStandardVar.os_type () = "Win32" || + BaseStandardVar.os_type () = "Cygwin" then + begin + try + var_ignore_eval BaseStandardVar.flexlink + with e -> + warn_exception e; + add_errors (f_ "Cannot find 'flexlink'") + end; + + (* Check build depends *) + List.iter + (function + | Executable (_, bs, _) + | Library (_, bs, _) as sct -> + build_checks sct bs + | Doc (_, doc) -> + if var_choose doc.doc_build then + check_tools doc.doc_build_tools + | Test (_, test) -> + if var_choose test.test_run then + check_tools test.test_tools + | _ -> + ()) + pkg.sections; + + (* Check if we need native dynlink (presence of libraries that compile to + * native) + *) + begin + let has_cmxa = + List.exists + (function + | Library (_, bs, _) -> + var_choose bs.bs_build && + (bs.bs_compiled_object = Native || + (bs.bs_compiled_object = Best && + bool_of_string (BaseStandardVar.is_native ()))) + | _ -> + false) + pkg.sections + in + if has_cmxa then + var_ignore_eval BaseStandardVar.native_dynlink + end; + + (* Check errors *) + if SetString.empty != !errors then + begin + List.iter + (fun e -> error "%s" e) + (SetString.elements !errors); + failwithf + (fn_ + "%d configuration error" + "%d configuration errors" + (SetString.cardinal !errors)) + (SetString.cardinal !errors) + end + + +end + +module InternalInstallPlugin = struct +(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) + + + (** Install using internal scheme + @author Sylvain Le Gall + *) + + + open BaseEnv + open BaseStandardVar + open BaseMessage + open OASISTypes + open OASISFindlib + open OASISGettext + open OASISUtils + + + let exec_hook = + ref (fun (cs, bs, exec) -> cs, bs, exec) + + + let lib_hook = + ref (fun (cs, bs, lib) -> cs, bs, lib, []) + + + let obj_hook = + ref (fun (cs, bs, obj) -> cs, bs, obj, []) + + + let doc_hook = + ref (fun (cs, doc) -> cs, doc) + + + let install_file_ev = + "install-file" + + + let install_dir_ev = + "install-dir" + + + let install_findlib_ev = + "install-findlib" + + + let win32_max_command_line_length = 8000 + + + let split_install_command ocamlfind findlib_name meta files = + if Sys.os_type = "Win32" then + (* Arguments for the first command: *) + let first_args = ["install"; findlib_name; meta] in + (* Arguments for remaining commands: *) + let other_args = ["install"; findlib_name; "-add"] in + (* Extract as much files as possible from [files], [len] is + the current command line length: *) + let rec get_files len acc files = + match files with + | [] -> + (List.rev acc, []) + | file :: rest -> + let len = len + 1 + String.length file in + if len > win32_max_command_line_length then + (List.rev acc, files) + else + get_files len (file :: acc) rest + in + (* Split the command into several commands. *) + let rec split args files = + match files with + | [] -> + [] + | _ -> + (* Length of "ocamlfind install [META|-add]" *) + let len = + List.fold_left + (fun len arg -> + len + 1 (* for the space *) + String.length arg) + (String.length ocamlfind) + args + in + match get_files len [] files with + | ([], _) -> + failwith (s_ "Command line too long.") + | (firsts, others) -> + let cmd = args @ firsts in + (* Use -add for remaining commands: *) + let () = + let findlib_ge_132 = + OASISVersion.comparator_apply + (OASISVersion.version_of_string + (BaseStandardVar.findlib_version ())) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string "1.3.2")) + in + if not findlib_ge_132 then + failwithf + (f_ "Installing the library %s require to use the \ + flag '-add' of ocamlfind because the command \ + line is too long. This flag is only available \ + for findlib 1.3.2. Please upgrade findlib from \ + %s to 1.3.2") + findlib_name (BaseStandardVar.findlib_version ()) + in + let cmds = split other_args others in + cmd :: cmds + in + (* The first command does not use -add: *) + split first_args files + else + ["install" :: findlib_name :: meta :: files] + + + let install pkg argv = + + let in_destdir = + try + let destdir = + destdir () + in + (* Practically speaking destdir is prepended + * at the beginning of the target filename + *) + fun fn -> destdir^fn + with PropList.Not_set _ -> + fun fn -> fn + in + + let install_file ?tgt_fn src_file envdir = + let tgt_dir = + in_destdir (envdir ()) + in + let tgt_file = + Filename.concat + tgt_dir + (match tgt_fn with + | Some fn -> + fn + | None -> + Filename.basename src_file) + in + (* Create target directory if needed *) + OASISFileUtil.mkdir_parent + ~ctxt:!BaseContext.default + (fun dn -> + info (f_ "Creating directory '%s'") dn; + BaseLog.register install_dir_ev dn) + tgt_dir; + + (* Really install files *) + info (f_ "Copying file '%s' to '%s'") src_file tgt_file; + OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; + BaseLog.register install_file_ev tgt_file + in + + (* Install data into defined directory *) + let install_data srcdir lst tgtdir = + let tgtdir = + OASISHostPath.of_unix (var_expand tgtdir) + in + List.iter + (fun (src, tgt_opt) -> + let real_srcs = + OASISFileUtil.glob + ~ctxt:!BaseContext.default + (Filename.concat srcdir src) + in + if real_srcs = [] then + failwithf + (f_ "Wildcard '%s' doesn't match any files") + src; + List.iter + (fun fn -> + install_file + fn + (fun () -> + match tgt_opt with + | Some s -> + OASISHostPath.of_unix (var_expand s) + | None -> + tgtdir)) + real_srcs) + lst + in + + (** Install all libraries *) + let install_libs pkg = + + let files_of_library (f_data, acc) data_lib = + let cs, bs, lib, lib_extra = + !lib_hook data_lib + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then + begin + let acc = + (* Start with acc + lib_extra *) + List.rev_append lib_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in library %s") + modul cs.cs_name; + acc + end) + acc + lib.lib_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BLib + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the library *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + and files_of_object (f_data, acc) data_obj = + let cs, bs, obj, obj_extra = + !obj_hook data_obj + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then + begin + let acc = + (* Start with acc + obj_extra *) + List.rev_append obj_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in object %s") + modul cs.cs_name; + acc + end) + acc + obj.obj_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BObj + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the object *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + + in + + (* Install one group of library *) + let install_group_lib grp = + (* Iterate through all group nodes *) + let rec install_group_lib_aux data_and_files grp = + let data_and_files, children = + match grp with + | Container (_, children) -> + data_and_files, children + | Package (_, cs, bs, `Library lib, children) -> + files_of_library data_and_files (cs, bs, lib), children + | Package (_, cs, bs, `Object obj, children) -> + files_of_object data_and_files (cs, bs, obj), children + in + List.fold_left + install_group_lib_aux + data_and_files + children + in + + (* Findlib name of the root library *) + let findlib_name = + findlib_of_group grp + in + + (* Determine root library *) + let root_lib = + root_of_group grp + in + + (* All files to install for this library *) + let f_data, files = + install_group_lib_aux (ignore, []) grp + in + + (* Really install, if there is something to install *) + if files = [] then + begin + warning + (f_ "Nothing to install for findlib library '%s'") + findlib_name + end + else + begin + let meta = + (* Search META file *) + let _, bs, _ = + root_lib + in + let res = + Filename.concat bs.bs_path "META" + in + if not (OASISFileUtil.file_exists_case res) then + failwithf + (f_ "Cannot find file '%s' for findlib library %s") + res + findlib_name; + res + in + let files = + (* Make filename shorter to avoid hitting command max line length + * too early, esp. on Windows. + *) + let remove_prefix p n = + let plen = String.length p in + let nlen = String.length n in + if plen <= nlen && String.sub n 0 plen = p then + begin + let fn_sep = + if Sys.os_type = "Win32" then + '\\' + else + '/' + in + let cutpoint = plen + + (if plen < nlen && n.[plen] = fn_sep then + 1 + else + 0) + in + String.sub n cutpoint (nlen - cutpoint) + end + else + n + in + List.map (remove_prefix (Sys.getcwd ())) files + in + info + (f_ "Installing findlib library '%s'") + findlib_name; + let ocamlfind = ocamlfind () in + let commands = + split_install_command + ocamlfind + findlib_name + meta + files + in + List.iter + (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) + commands; + BaseLog.register install_findlib_ev findlib_name + end; + + (* Install data files *) + f_data (); + + in + + let group_libs, _, _ = + findlib_mapping pkg + in + + (* We install libraries in groups *) + List.iter install_group_lib group_libs + in + + let install_execs pkg = + let install_exec data_exec = + let cs, bs, exec = + !exec_hook data_exec + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then + begin + let exec_libdir () = + Filename.concat + (libdir ()) + pkg.name + in + BaseBuilt.fold + BaseBuilt.BExec + cs.cs_name + (fun () fn -> + install_file + ~tgt_fn:(cs.cs_name ^ ext_program ()) + fn + bindir) + (); + BaseBuilt.fold + BaseBuilt.BExecLib + cs.cs_name + (fun () fn -> + install_file + fn + exec_libdir) + (); + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name) + end + in + List.iter + (function + | Executable (cs, bs, exec)-> + install_exec (cs, bs, exec) + | _ -> + ()) + pkg.sections + in + + let install_docs pkg = + let install_doc data = + let cs, doc = + !doc_hook data + in + if var_choose doc.doc_install && + BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then + begin + let tgt_dir = + OASISHostPath.of_unix (var_expand doc.doc_install_dir) + in + BaseBuilt.fold + BaseBuilt.BDoc + cs.cs_name + (fun () fn -> + install_file + fn + (fun () -> tgt_dir)) + (); + install_data + Filename.current_dir_name + doc.doc_data_files + doc.doc_install_dir + end + in + List.iter + (function + | Doc (cs, doc) -> + install_doc (cs, doc) + | _ -> + ()) + pkg.sections + in + + install_libs pkg; + install_execs pkg; + install_docs pkg + + + (* Uninstall already installed data *) + let uninstall _ argv = + List.iter + (fun (ev, data) -> + if ev = install_file_ev then + begin + if OASISFileUtil.file_exists_case data then + begin + info + (f_ "Removing file '%s'") + data; + Sys.remove data + end + else + begin + warning + (f_ "File '%s' doesn't exist anymore") + data + end + end + else if ev = install_dir_ev then + begin + if Sys.file_exists data && Sys.is_directory data then + begin + if Sys.readdir data = [||] then + begin + info + (f_ "Removing directory '%s'") + data; + OASISFileUtil.rmdir ~ctxt:!BaseContext.default data + end + else + begin + warning + (f_ "Directory '%s' is not empty (%s)") + data + (String.concat + ", " + (Array.to_list + (Sys.readdir data))) + end + end + else + begin + warning + (f_ "Directory '%s' doesn't exist anymore") + data + end + end + else if ev = install_findlib_ev then + begin + info (f_ "Removing findlib library '%s'") data; + OASISExec.run ~ctxt:!BaseContext.default + (ocamlfind ()) ["remove"; data] + end + else + failwithf (f_ "Unknown log event '%s'") ev; + BaseLog.unregister ev data) + (* We process event in reverse order *) + (List.rev + (BaseLog.filter + [install_file_ev; + install_dir_ev; + install_findlib_ev])) + + +end + + +# 6243 "setup.ml" +module OCamlbuildCommon = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) + + + (** Functions common to OCamlbuild build and doc plugin + *) + + + open OASISGettext + open BaseEnv + open BaseStandardVar + open OASISTypes + + + + + type extra_args = string list + + + let ocamlbuild_clean_ev = "ocamlbuild-clean" + + + let ocamlbuildflags = + var_define + ~short_desc:(fun () -> "OCamlbuild additional flags") + "ocamlbuildflags" + (fun () -> "") + + + (** Fix special arguments depending on environment *) + let fix_args args extra_argv = + List.flatten + [ + if (os_type ()) = "Win32" then + [ + "-classic-display"; + "-no-log"; + "-no-links"; + "-install-lib-dir"; + (Filename.concat (standard_library ()) "ocamlbuild") + ] + else + []; + + if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then + [ + "-byte-plugin" + ] + else + []; + args; + + if bool_of_string (debug ()) then + ["-tag"; "debug"] + else + []; + + if bool_of_string (profile ()) then + ["-tag"; "profile"] + else + []; + + OASISString.nsplit (ocamlbuildflags ()) ' '; + + Array.to_list extra_argv; + ] + + + (** Run 'ocamlbuild -clean' if not already done *) + let run_clean extra_argv = + let extra_cli = + String.concat " " (Array.to_list extra_argv) + in + (* Run if never called with these args *) + if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then + begin + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args ["-clean"] extra_argv); + BaseLog.register ocamlbuild_clean_ev extra_cli; + at_exit + (fun () -> + try + BaseLog.unregister ocamlbuild_clean_ev extra_cli + with _ -> + ()) + end + + + (** Run ocamlbuild, unregister all clean events *) + let run_ocamlbuild args extra_argv = + (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html + *) + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args args extra_argv); + (* Remove any clean event, we must run it again *) + List.iter + (fun (e, d) -> BaseLog.unregister e d) + (BaseLog.filter [ocamlbuild_clean_ev]) + + + (** Determine real build directory *) + let build_dir extra_argv = + let rec search_args dir = + function + | "-build-dir" :: dir :: tl -> + search_args dir tl + | _ :: tl -> + search_args dir tl + | [] -> + dir + in + search_args "_build" (fix_args [] extra_argv) + + +end + +module OCamlbuildPlugin = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) + + + (** Build using ocamlbuild + @author Sylvain Le Gall + *) + + + open OASISTypes + open OASISGettext + open OASISUtils + open OASISString + open BaseEnv + open OCamlbuildCommon + open BaseStandardVar + open BaseMessage + + + + + + let cond_targets_hook = + ref (fun lst -> lst) + + + let build extra_args pkg argv = + (* Return the filename in build directory *) + let in_build_dir fn = + Filename.concat + (build_dir argv) + fn + in + + (* Return the unix filename in host build directory *) + let in_build_dir_of_unix fn = + in_build_dir (OASISHostPath.of_unix fn) + in + + let cond_targets = + List.fold_left + (fun acc -> + function + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_library + in_build_dir_of_unix + (cs, bs, lib) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ~what:".cma" fn + || ends_with ~what:".cmxs" fn + || ends_with ~what:".cmxa" fn + || ends_with ~what:(ext_lib ()) fn + || ends_with ~what:(ext_dll ()) fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for library %s") + cs.cs_name + end + + | Object (cs, bs, obj) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_object + in_build_dir_of_unix + (cs, bs, obj) + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ".cmo" fn + || ends_with ".cmx" fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for object %s") + cs.cs_name + end + + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, unix_exec_is, unix_dll_opt = + BaseBuilt.of_executable + in_build_dir_of_unix + (cs, bs, exec) + in + + let target ext = + let unix_tgt = + (OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.chop_extension + exec.exec_main_is))^ext + in + let evs = + (* Fix evs, we want to use the unix_tgt, without copying *) + List.map + (function + | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> + BaseBuilt.BExec, nm, + [[in_build_dir_of_unix unix_tgt]] + | ev -> + ev) + evs + in + evs, [unix_tgt] + in + + (* Add executable *) + let acc = + match bs.bs_compiled_object with + | Native -> + (target ".native") :: acc + | Best when bool_of_string (is_native ()) -> + (target ".native") :: acc + | Byte + | Best -> + (target ".byte") :: acc + in + acc + end + + | Library _ | Object _ | Executable _ | Test _ + | SrcRepo _ | Flag _ | Doc _ -> + acc) + [] + (* Keep the pkg.sections ordered *) + (List.rev pkg.sections); + in + + (* Check and register built files *) + let check_and_register (bt, bnm, lst) = + List.iter + (fun fns -> + if not (List.exists OASISFileUtil.file_exists_case fns) then + failwithf + (fn_ + "Expected built file %s doesn't exist." + "None of expected built files %s exists." + (List.length fns)) + (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) + lst; + (BaseBuilt.register bt bnm lst) + in + + (* Run the hook *) + let cond_targets = !cond_targets_hook cond_targets in + + (* Run a list of target... *) + run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; + (* ... and register events *) + List.iter check_and_register (List.flatten (List.map fst cond_targets)) + + + let clean pkg extra_args = + run_clean extra_args; + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + +end + +module OCamlbuildDocPlugin = struct +(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) + + + (* Create documentation using ocamlbuild .odocl files + @author Sylvain Le Gall + *) + + + open OASISTypes + open OASISGettext + open OASISMessage + open OCamlbuildCommon + open BaseStandardVar + + + + + type run_t = + { + extra_args: string list; + run_path: unix_filename; + } + + + let doc_build run pkg (cs, doc) argv = + let index_html = + OASISUnixPath.make + [ + run.run_path; + cs.cs_name^".docdir"; + "index.html"; + ] + in + let tgt_dir = + OASISHostPath.make + [ + build_dir argv; + OASISHostPath.of_unix run.run_path; + cs.cs_name^".docdir"; + ] + in + run_ocamlbuild (index_html :: run.extra_args) argv; + List.iter + (fun glb -> + BaseBuilt.register + BaseBuilt.BDoc + cs.cs_name + [OASISFileUtil.glob ~ctxt:!BaseContext.default + (Filename.concat tgt_dir glb)]) + ["*.html"; "*.css"] + + + let doc_clean run pkg (cs, doc) argv = + run_clean argv; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + + +end + + +# 6616 "setup.ml" +module CustomPlugin = struct +(* # 22 "src/plugins/custom/CustomPlugin.ml" *) + + + (** Generate custom configure/build/doc/test/install system + @author + *) + + + open BaseEnv + open OASISGettext + open OASISTypes + + + + + + type t = + { + cmd_main: command_line conditional; + cmd_clean: (command_line option) conditional; + cmd_distclean: (command_line option) conditional; + } + + + let run = BaseCustom.run + + + let main t _ extra_args = + let cmd, args = + var_choose + ~name:(s_ "main command") + t.cmd_main + in + run cmd args extra_args + + + let clean t pkg extra_args = + match var_choose t.cmd_clean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + + let distclean t pkg extra_args = + match var_choose t.cmd_distclean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + + module Build = + struct + let main t pkg extra_args = + main t pkg extra_args; + List.iter + (fun sct -> + let evs = + match sct with + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, _ = + BaseBuilt.of_library + OASISHostPath.of_unix + (cs, bs, lib) + in + evs + end + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, _, _ = + BaseBuilt.of_executable + OASISHostPath.of_unix + (cs, bs, exec) + in + evs + end + | _ -> + [] + in + List.iter + (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) + evs) + pkg.sections + + let clean t pkg extra_args = + clean t pkg extra_args; + (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild + * considering moving this to BaseSetup? + *) + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + let distclean t pkg extra_args = + distclean t pkg extra_args + end + + + module Test = + struct + let main t pkg (cs, test) extra_args = + try + main t pkg extra_args; + 0.0 + with Failure s -> + BaseMessage.warning + (f_ "Test '%s' fails: %s") + cs.cs_name + s; + 1.0 + + let clean t pkg (cs, test) extra_args = + clean t pkg extra_args + + let distclean t pkg (cs, test) extra_args = + distclean t pkg extra_args + end + + + module Doc = + struct + let main t pkg (cs, _) extra_args = + main t pkg extra_args; + BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] + + let clean t pkg (cs, _) extra_args = + clean t pkg extra_args; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + + let distclean t pkg (cs, _) extra_args = + distclean t pkg extra_args + end + + +end + + +# 6764 "setup.ml" +open OASISTypes;; + +let setup_t = + { + BaseSetup.configure = InternalConfigurePlugin.configure; + build = OCamlbuildPlugin.build ["-use-ocamlfind"]; + test = + [ + ("all", + CustomPlugin.Test.main + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("make", ["test-all"]))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + doc = + [ + ("containers", + OCamlbuildDocPlugin.doc_build + { + OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; + run_path = "." + }); + ("containers_misc", + OCamlbuildDocPlugin.doc_build + { + OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; + run_path = "." + }); + ("containers_string", + OCamlbuildDocPlugin.doc_build + { + OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; + run_path = "." + }) + ]; + install = InternalInstallPlugin.install; + uninstall = InternalInstallPlugin.uninstall; + clean = [OCamlbuildPlugin.clean]; + clean_test = + [ + ("all", + CustomPlugin.Test.clean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("make", ["test-all"]))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + clean_doc = + [ + ("containers", + OCamlbuildDocPlugin.doc_clean + { + OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; + run_path = "." + }); + ("containers_misc", + OCamlbuildDocPlugin.doc_clean + { + OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; + run_path = "." + }); + ("containers_string", + OCamlbuildDocPlugin.doc_clean + { + OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; + run_path = "." + }) + ]; + distclean = []; + distclean_test = + [ + ("all", + CustomPlugin.Test.distclean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("make", ["test-all"]))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)] + }) + ]; + distclean_doc = []; + package = + { + oasis_version = "0.4"; + ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1"); + findlib_version = None; + alpha_features = ["compiled_setup_ml"]; + beta_features = []; + name = "containers"; + version = "dev"; + license = + OASISLicense.DEP5License + (OASISLicense.DEP5Unit + { + OASISLicense.license = "BSD-2-clause"; + excption = None; + version = OASISLicense.NoVersion + }); + license_file = Some "LICENSE"; + copyrights = []; + maintainers = []; + authors = ["Simon Cruanes"]; + homepage = Some "https://github.com/c-cube/ocaml-containers"; + 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 an optional library for dealing with strings, and a `misc` library full of experimental ideas (not stable, not necessarily usable)." + ]; + categories = []; + conf_type = (`Configure, "internal", Some "0.4"); + conf_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + build_type = (`Build, "ocamlbuild", Some "0.4"); + build_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + install_type = (`Install, "internal", Some "0.4"); + install_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + uninstall_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + clean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + distclean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + files_ab = []; + sections = + [ + Flag + ({ + cs_name = "misc"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + flag_description = + Some + "Build the misc library, containing everything from\nthe rotating kitchen sink to automatic banana distributors"; + flag_default = [(OASISExpr.EBool true, false)] + }); + Flag + ({ + cs_name = "cgi"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + flag_description = + Some + "Build modules related to FastCGI, depending on CamlGI"; + flag_default = [(OASISExpr.EBool true, false)] + }); + Flag + ({ + cs_name = "lwt"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + flag_description = + Some "Build modules which depend on Lwt"; + flag_default = [(OASISExpr.EBool true, false)] + }); + 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, false)] + }); + Flag + ({ + cs_name = "bench"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + flag_description = Some "Build and run benchmarks"; + flag_default = [(OASISExpr.EBool true, false)] + }); + 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 = "core"; + bs_compiled_object = Best; + bs_build_depends = []; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = + [ + "CCVector"; + "CCDeque"; + "CCGen"; + "CCSequence"; + "CCFQueue"; + "CCMultiMap"; + "CCMultiSet"; + "CCBV"; + "CCPrint"; + "CCPersistentHashtbl"; + "CCError"; + "CCHeap"; + "CCList"; + "CCOpt"; + "CCPair"; + "CCFun"; + "CCHash"; + "CCCat"; + "CCKList"; + "CCInt"; + "CCBool"; + "CCArray"; + "CCBatch"; + "CCOrd"; + "CCIO"; + "CCRandom"; + "CCLinq"; + "CCKTree"; + "CCTrie"; + "CCString"; + "CCHashtbl"; + "CCFlatHashtbl" + ]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = None; + lib_findlib_name = Some "containers"; + lib_findlib_containers = [] + }); + Library + ({ + cs_name = "containers_string"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "string"; + bs_compiled_object = Best; + bs_build_depends = []; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = ["KMP"; "Levenshtein"]; + lib_pack = true; + lib_internal_modules = []; + lib_findlib_parent = Some "containers"; + lib_findlib_name = Some "string"; + lib_findlib_containers = [] + }); + Library + ({ + cs_name = "containers_pervasives"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "pervasives"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "containers"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = ["CCPervasives"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "containers"; + lib_findlib_name = Some "pervasives"; + lib_findlib_containers = [] + }); + Library + ({ + cs_name = "containers_misc"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "misc"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("unix", None); + InternalLibrary "containers" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = + [ + "Cache"; + "FHashtbl"; + "FlatHashtbl"; + "Hashset"; + "Heap"; + "LazyGraph"; + "PersistentGraph"; + "PHashtbl"; + "SkipList"; + "SplayTree"; + "SplayMap"; + "Univ"; + "Bij"; + "PiCalculus"; + "Bencode"; + "Sexp"; + "RAL"; + "UnionFind"; + "SmallSet"; + "AbsSet"; + "CSM"; + "ActionMan"; + "BencodeOnDisk"; + "TTree"; + "PrintBox"; + "HGraph"; + "Automaton"; + "Conv"; + "Bidir"; + "Iteratee"; + "BTree"; + "Ty"; + "Tell"; + "BencodeStream"; + "RatTerm"; + "Cause"; + "AVL"; + "ParseReact" + ]; + lib_pack = true; + lib_internal_modules = []; + lib_findlib_parent = Some "containers"; + lib_findlib_name = Some "misc"; + 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 = "threads/"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "containers"; + FindlibPackage ("threads", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = ["CCFuture"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "containers"; + lib_findlib_name = Some "thread"; + lib_findlib_containers = [] + }); + Library + ({ + cs_name = "containers_lwt"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EAnd + (OASISExpr.EFlag "lwt", OASISExpr.EFlag "misc"), + true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EAnd + (OASISExpr.EFlag "lwt", OASISExpr.EFlag "misc"), + true) + ]; + bs_path = "lwt"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "containers"; + FindlibPackage ("lwt", None); + FindlibPackage ("lwt.unix", None); + InternalLibrary "containers_misc" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = ["Behavior"; "Lwt_automaton"]; + lib_pack = true; + lib_internal_modules = []; + lib_findlib_parent = Some "containers"; + lib_findlib_name = Some "lwt"; + lib_findlib_containers = [] + }); + Library + ({ + cs_name = "containers_cgi"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "cgi", true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "cgi", true) + ]; + bs_path = "cgi"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "containers"; + FindlibPackage ("CamlGI", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + lib_modules = ["ToWeb"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "containers"; + lib_findlib_name = Some "cgi"; + lib_findlib_containers = [] + }); + Doc + ({ + cs_name = "containers"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + doc_type = (`Doc, "ocamlbuild", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$docdir"; + doc_title = "Containers docs"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = []; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] + }); + Doc + ({ + cs_name = "containers_misc"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + doc_type = (`Doc, "ocamlbuild", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$docdir"; + doc_title = "Containers_misc docs"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = []; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] + }); + Doc + ({ + cs_name = "containers_string"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + doc_type = (`Doc, "ocamlbuild", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$docdir"; + doc_title = "Containers_string docs"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = []; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] + }); + Executable + ({ + cs_name = "benchs"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "bench", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests/"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "containers"; + InternalLibrary "containers_string"; + InternalLibrary "containers_misc"; + FindlibPackage ("bench", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "benchs.ml"}); + Executable + ({ + cs_name = "bench_conv"; + 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 = "tests/"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "containers"; + FindlibPackage ("benchmark", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "bench_conv.ml"}); + Executable + ({ + cs_name = "bench_batch"; + 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 = "tests/"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "containers"; + FindlibPackage ("benchmark", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "bench_batch.ml"}); + Executable + ({ + cs_name = "bench_hash"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EAnd + (OASISExpr.EFlag "bench", + OASISExpr.EFlag "misc"), + true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests/"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "containers"; + InternalLibrary "containers_misc" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "bench_hash.ml"}); + Executable + ({ + cs_name = "test_levenshtein"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "tests", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests/"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "containers"; + FindlibPackage ("qcheck", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "test_levenshtein.ml" + }); + Executable + ({ + cs_name = "test_lwt"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EAnd + (OASISExpr.EFlag "tests", + OASISExpr.EFlag "lwt"), + true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests/lwt/"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "containers"; + FindlibPackage ("lwt", None); + FindlibPackage ("lwt.unix", None); + FindlibPackage ("oUnit", None); + InternalLibrary "containers_lwt" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "test_Behavior.ml"}); + Executable + ({ + cs_name = "test_threads"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EAnd + (OASISExpr.EFlag "tests", + OASISExpr.EFlag "thread"), + true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests/threads/"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "containers"; + FindlibPackage ("threads", None); + FindlibPackage ("oUnit", None); + InternalLibrary "containers_thread" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "test_future.ml"}); + Executable + ({ + cs_name = "run_tests"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "tests", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests/"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "containers"; + FindlibPackage ("oUnit", None); + FindlibPackage ("qcheck", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "run_tests.ml"}); + Test + ({ + cs_name = "all"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + test_type = (`Test, "custom", Some "0.4"); + test_command = + [(OASISExpr.EBool true, ("make", ["test-all"]))]; + test_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + test_working_directory = None; + test_run = + [ + (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); + (OASISExpr.EFlag "tests", false); + (OASISExpr.EAnd + (OASISExpr.EFlag "tests", + OASISExpr.EFlag "tests"), + true) + ]; + test_tools = + [ + ExternalTool "ocamlbuild"; + InternalExecutable "run_tests" + ] + }); + Executable + ({ + cs_name = "web_pwd"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "cgi", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples/cgi/"; + bs_compiled_object = Byte; + bs_build_depends = + [ + InternalLibrary "containers"; + InternalLibrary "containers_cgi"; + FindlibPackage ("threads", None); + FindlibPackage ("CamlGI", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "web_pwd.ml"}); + Executable + ({ + cs_name = "lambda"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "misc", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples/"; + bs_compiled_object = Byte; + bs_build_depends = + [ + InternalLibrary "containers"; + InternalLibrary "containers_misc" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "lambda.ml"}); + Executable + ({ + cs_name = "id_sexp"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "misc", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples/"; + bs_compiled_object = Native; + bs_build_depends = + [ + InternalLibrary "containers"; + InternalLibrary "containers_misc" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = false; exec_main_is = "id_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 + }) + ]; + plugins = + [(`Extra, "META", Some "0.3"); (`Extra, "DevFiles", Some "0.3")]; + disable_oasis_section = []; + schema_data = PropList.Data.create (); + plugin_data = [] + }; + oasis_fn = Some "_oasis"; + oasis_version = "0.4.4"; + oasis_digest = Some "h\149C\237\220`t\024\024\161\129c\000\004\171\020"; + oasis_exec = None; + oasis_setup_args = []; + setup_update = false + };; + +let setup () = BaseSetup.setup setup_t;; + +# 7815 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 33d33ec6e4de4d7c7ef46b982250ce2a0735462a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 20:46:33 +0200 Subject: [PATCH 17/28] new interface for Sexp.Streaming, allowing to provide a 'source' (generator of tokens) --- misc/sexp.ml | 419 ++++++++++++++++++++++++++++---------------------- misc/sexp.mli | 68 +++++++- 2 files changed, 291 insertions(+), 196 deletions(-) diff --git a/misc/sexp.ml b/misc/sexp.ml index a42b3178..3cfd4b46 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -118,7 +118,96 @@ let to_file filename t = seq_to_file filename (fun k -> k t) type 'a parse_result = ['a or_error | `End ] type 'a partial_result = [ 'a parse_result | `Await ] -module Streaming = struct +module Source = struct + type individual_char = + | NC_yield of char + | NC_end + | NC_await + + type t = unit -> individual_char + type source = t + + module Manual = struct + type t = { + mutable i : int; (* offset *) + mutable stop : bool; + buf : Buffer.t; (* accessible chunk of input *) + } + + let make() = { + i = 0; + stop = false; + buf=Buffer.create 32; + } + + let to_src d () = + if d.i = Buffer.length d.buf + then + if d.stop then NC_end else NC_await + else ( + let c = Buffer.nth d.buf d.i in + d.i <- d.i + 1; + NC_yield c + ) + + let feed d s i len = + if d.stop then failwith "Sexp.Streaming.Manual.feed: reached EOI"; + Buffer.add_substring d.buf s i len + + let reached_end d = d.stop <- true + end + + let of_string s = + let i = ref 0 in + fun () -> + if !i=String.length s + then NC_end + else ( + let c = String.get s !i in + incr i; + NC_yield c + ) + + let of_chan ?(bufsize=1024) ic = + let buf = String.make bufsize ' ' in + let i = ref 0 in + let n = ref 0 in + let stop = ref false in + let rec next() = + if !stop then NC_end + else if !i = !n + then ( (* refill *) + i := 0; + n := input ic buf 0 bufsize; + if !n = 0 then (stop := true; NC_end) else next() + ) else ( (* yield *) + let c = String.get buf !i in + incr i; + NC_yield c + ) + in next + + let of_gen g = + let s = ref "" in + let i = ref 0 in + let stop = ref false in + let rec next() = + if !stop then NC_end + else if !i = String.length !s + then ( + match g() with + | None -> stop := true; NC_end + | Some buf -> s := buf; i := 0; next () + ) else ( + let c = String.get !s !i in + incr i; + NC_yield c + ) + in next +end + +module Lexer = struct + (** An individual character returned by a source *) type token = | Open | Close @@ -135,60 +224,39 @@ module Streaming = struct | St_error of string | St_end - type decoder = { + type t = { + src : Source.t; + atom : Buffer.t; (* atom being parsed *) mutable st : decode_state; - mutable i : int; mutable line : int; mutable col : int; - mutable stop : bool; - buf : Buffer.t; - atom : Buffer.t; (* atom being parsed *) } - let mk_decoder () = { - i = 0; + let make src = { + src; st = St_start; line = 1; col = 1; - stop = false; - buf=Buffer.create 32; atom = Buffer.create 32; } - exception NeedMoar - exception Error of string - exception EOI + let of_string s = make (Source.of_string s) + + let of_chan ic = make (Source.of_chan ic) + + let line t = t.line + let col t = t.col (* yield [x] with current state [st] *) let _yield d st x = d.st <- st; - x - - (* read the next char *) - let _next_char d = - if d.i = Buffer.length d.buf - then ( - (* need more input; reset buffer to put it in *) - Buffer.clear d.buf; - d.i <- 0; - raise NeedMoar - ) else ( - let c = Buffer.nth d.buf d.i in - d.i <- d.i + 1; - d.col <- d.col + 1; - c - ) + `Ok x let _take_buffer b = let s = Buffer.contents b in Buffer.clear b; s - let _newline d = - d.line <- d.line + 1; - d.col <- 0; - () - (* raise an error *) let _error d msg = let b = Buffer.create 32 in @@ -197,121 +265,116 @@ module Streaming = struct (fun b -> let msg' = Buffer.contents b in d.st <- St_error msg'; - raise (Error msg')) + `Error msg') b msg let _end d = d.st <- St_end; - raise EOI + `End let _is_digit c = Char.code '0' <= Char.code c && Char.code c <= Char.code '9' let _digit2i c = Char.code c - Char.code '0' (* next token *) - let rec _next d st = - d.st <- st; + let rec _next d st : token partial_result = match st with - | St_error msg -> raise (Error msg) + | St_error msg -> `Error msg | St_end -> _end d | St_yield x -> (* yield the given token, then start a fresh one *) _yield d St_start x - | St_start when d.stop -> _end d - | St_start -> - (* start reading next token *) - let c = _next_char d in - begin match c with - | '\n' -> _newline d; _next d St_start - | ' ' | '\t' -> _next d St_start - | '(' -> _yield d St_start Open - | ')' -> _yield d St_start Close - | '"' -> _next d St_quoted - | _ -> (* read regular atom *) - Buffer.add_char d.atom c; - _next d St_atom - end - | St_atom when d.stop -> - let a = _take_buffer d.atom in - _yield d St_end (Atom a) - | St_atom -> - (* reading an unquoted atom *) - let c = _next_char d in - begin match c with - | '\n' -> - _newline d; - let a = _take_buffer d.atom in - _yield d St_start (Atom a) - | ' ' | '\t' -> - let a = _take_buffer d.atom in - _yield d St_start (Atom a) - | ')' -> - let a = _take_buffer d.atom in - _yield d (St_yield Close) (Atom a) - | '(' -> - let a = _take_buffer d.atom in - _yield d (St_yield Open) (Atom a) - | '"' -> _error d "unexpected \" (parsing atom %s)" (Buffer.contents d.atom) - | '\\' -> _error d "unexpected \\" - | _ -> - Buffer.add_char d.atom c; - _next d St_atom - end - | St_quoted when d.stop -> - let a = _take_buffer d.atom in - _yield d St_end (Atom a) - | St_quoted -> - (* reading an unquoted atom *) - let c = _next_char d in - begin match c with - | '\\' -> _next d St_escaped - | '"' -> - let a = _take_buffer d.atom in - _yield d St_start (Atom a) - | _ -> - Buffer.add_char d.atom c; - _next d St_quoted - end - | (St_escaped | St_raw_char1 _ | St_raw_char2 _) when d.stop -> - _error d "unexpected end of input (escaping)" - | St_escaped -> - begin match _next_char d with - | 'n' -> Buffer.add_char d.atom '\n'; _next d St_quoted - | 't' -> Buffer.add_char d.atom '\t'; _next d St_quoted - | 'r' -> Buffer.add_char d.atom '\r'; _next d St_quoted - | 'b' -> Buffer.add_char d.atom '\b'; _next d St_quoted - | '"' -> Buffer.add_char d.atom '"'; _next d St_quoted - | '\\' -> Buffer.add_char d.atom '\\'; _next d St_quoted - | c when _is_digit c -> _next d (St_raw_char1 (_digit2i c)) - | c -> _error d "unexpected escaped character %c" c - end - | St_raw_char1 i -> - begin match _next_char d with - | c when _is_digit c -> _next d (St_raw_char2 (i*10 + _digit2i c)) - | c -> _error d "expected digit, got %c" c - end - | St_raw_char2 i -> - begin match _next_char d with - | c when _is_digit c -> - (* read an escaped char *) - Buffer.add_char d.atom (Char.chr (i*10+_digit2i c)); - _next d St_quoted - | c -> _error d "expected digit, got %c" c - end + | _ -> + d.st <- st; + _process_next d st - let feed d s i len = - if d.stop then failwith "Sexp.Streaming.feed: end of input reached"; - Buffer.add_substring d.buf s i len + (* read and proces the next character *) + and _process_next d st = + match d.src () with + | Source.NC_end -> + begin match st with + | St_error _ | St_end | St_yield _ -> assert false + | St_start -> _end d + | St_atom -> + let a = _take_buffer d.atom in + _yield d St_end (Atom a) + | St_quoted -> + let a = _take_buffer d.atom in + _yield d St_end (Atom a) + | (St_escaped | St_raw_char1 _ | St_raw_char2 _) -> + _error d "unexpected end of input (escaping)" + end + | Source.NC_await -> `Await + | Source.NC_yield c -> + if c='\n' + then (d.col <- 1; d.line <- d.line + 1) + else (d.col <- d.col + 1); + (* use the next char *) + match st with + | St_error _ | St_end | St_yield _ -> assert false + | St_start -> + begin match c with + | ' ' | '\t' | '\n' -> _next d St_start + | '(' -> _yield d St_start Open + | ')' -> _yield d St_start Close + | '"' -> _next d St_quoted + | _ -> (* read regular atom *) + Buffer.add_char d.atom c; + _next d St_atom + end + | St_atom -> + begin match c with + | ' ' | '\t' | '\n' -> + let a = _take_buffer d.atom in + _yield d St_start (Atom a) + | ')' -> + let a = _take_buffer d.atom in + _yield d (St_yield Close) (Atom a) + | '(' -> + let a = _take_buffer d.atom in + _yield d (St_yield Open) (Atom a) + | '"' -> _error d "unexpected \" (parsing atom %s)" (Buffer.contents d.atom) + | '\\' -> _error d "unexpected \\" + | _ -> + Buffer.add_char d.atom c; + _next d St_atom + end + | St_quoted -> + (* reading an unquoted atom *) + begin match c with + | '\\' -> _next d St_escaped + | '"' -> + let a = _take_buffer d.atom in + _yield d St_start (Atom a) + | _ -> + Buffer.add_char d.atom c; + _next d St_quoted + end + | St_escaped -> + begin match c with + | 'n' -> Buffer.add_char d.atom '\n'; _next d St_quoted + | 't' -> Buffer.add_char d.atom '\t'; _next d St_quoted + | 'r' -> Buffer.add_char d.atom '\r'; _next d St_quoted + | 'b' -> Buffer.add_char d.atom '\b'; _next d St_quoted + | '"' -> Buffer.add_char d.atom '"'; _next d St_quoted + | '\\' -> Buffer.add_char d.atom '\\'; _next d St_quoted + | _ when _is_digit c -> _next d (St_raw_char1 (_digit2i c)) + | _ -> _error d "unexpected escaped character %c" c + end + | St_raw_char1 i -> + begin match c with + | _ when _is_digit c -> _next d (St_raw_char2 (i*10 + _digit2i c)) + | _ -> _error d "expected digit, got %c" c + end + | St_raw_char2 i -> + begin match c with + | c when _is_digit c -> + (* read an escaped char *) + Buffer.add_char d.atom (Char.chr (i*10+_digit2i c)); + _next d St_quoted + | c -> _error d "expected digit, got %c" c + end - let reached_end d = - d.stop <- true - - let next d = - try - `Ok (_next d d.st) - with - | NeedMoar -> `Await - | Error msg -> `Error msg - | EOI -> `End + let next d = _next d d.st end module ParseGen = struct @@ -347,28 +410,28 @@ end (* hidden parser state *) type parser_state = { - ps_d : Streaming.decoder; + ps_d : Lexer.t; mutable ps_stack : t list list; } -let mk_ps () = { - ps_d = Streaming.mk_decoder (); +let mk_ps src = { + ps_d = Lexer.make src; ps_stack = []; } let _error ps msg = - let msg' = Printf.sprintf "at %d,%d: %s" - ps.ps_d.Streaming.line ps.ps_d.Streaming.col msg in + let msg' = Printf.sprintf "at %d,%d: %s" (Lexer.line ps.ps_d) (Lexer.col ps.ps_d) msg in `Error msg' (* next token, or await *) -let rec _next ps : t partial_result = match Streaming.next ps.ps_d with - | `Ok (Streaming.Atom s) -> +let rec _next ps : t partial_result = + match Lexer.next ps.ps_d with + | `Ok (Lexer.Atom s) -> _push ps (Atom s) - | `Ok Streaming.Open -> + | `Ok Lexer.Open -> ps.ps_stack <- [] :: ps.ps_stack; _next ps - | `Ok Streaming.Close -> + | `Ok Lexer.Close -> begin match ps.ps_stack with | [] -> _error ps "unbalanced ')'" | l :: stack -> @@ -387,49 +450,25 @@ and _push ps e = match ps.ps_stack with ps.ps_stack <- (e :: l) :: tl; _next ps +(* assume [ps] never needs [`Await] *) +let _never_block ps () = match _next ps with + | `Await -> assert false + | `Ok x -> `Ok x + | `Error e -> `Error e + | `End -> `End + (* parse from a generator of string slices *) -let _parse_gen g : t ParseGen.t = - let ps = mk_ps() in - let rec next () = match _next ps with - | `Await -> - begin match g() with - | None -> Streaming.reached_end ps.ps_d - | Some (s,i,len) -> Streaming.feed ps.ps_d s i len - end; - next() - | `Ok x -> `Ok x - | `Error e -> `Error e - | `End -> `End - in - next - -let parse_gen g = - _parse_gen - (fun () -> - match g() with - | None -> None - | Some s -> Some (s,0,String.length s) - ) - -(* singleton generator *) -let _gen1 x = - let first = ref true in - fun () -> - if !first then (first:=false; Some x) else None +let parse_gen g : t ParseGen.t = + let ps = mk_ps (Source.of_gen g) in + _never_block ps let parse_string s = - parse_gen (_gen1 s) + let ps = mk_ps (Source.of_string s) in + _never_block ps -let parse_chan ?(bufsize=1024) ic = - let buf = String.make bufsize ' ' in - let stop = ref false in - let gen () = - if !stop then None - else - let n = input ic buf 0 bufsize in - if n=0 then (stop:=true; None) else Some (buf,0,n) - in - _parse_gen gen +let parse_chan ?bufsize ic = + let ps = mk_ps (Source.of_chan ?bufsize ic) in + _never_block ps (** {6 Blocking} *) @@ -458,22 +497,26 @@ let parse_l_string s = let parse_l_gen g = ParseGen.to_list (parse_gen g) +exception OhNoes of string +exception StopNaow + let parse_l_seq seq = - let ps = mk_ps() in + let src = Source.Manual.make () in + let ps = mk_ps (Source.Manual.to_src src) in let l = ref [] in (* read as many expressions as possible *) let rec _nexts () = match _next ps with | `Ok x -> l := x :: !l; _nexts () - | `Error e -> raise (Streaming.Error e) - | `End -> raise Streaming.EOI + | `Error e -> raise (OhNoes e) + | `End -> raise StopNaow | `Await -> () in try seq - (fun s -> Streaming.feed ps.ps_d s 0 (String.length s); _nexts ()); - Streaming.reached_end ps.ps_d; + (fun s -> Source.Manual.feed src s 0 (String.length s); _nexts ()); + Source.Manual.reached_end src; _nexts (); `Ok (List.rev !l) with - | Streaming.Error msg -> `Error msg - | Streaming.EOI -> `Ok (List.rev !l) + | OhNoes msg -> `Error msg + | StopNaow -> `Ok (List.rev !l) diff --git a/misc/sexp.mli b/misc/sexp.mli index 897cf654..319dd495 100644 --- a/misc/sexp.mli +++ b/misc/sexp.mli @@ -47,10 +47,13 @@ val to_file : string -> t -> unit val to_chan : out_channel -> t -> unit val print : Format.formatter -> t -> unit +(** Pretty-printer nice on human eyes (including indentation) *) val print_noindent : Format.formatter -> t -> unit +(** Raw, direct printing as compact as possible *) val seq_to_file : string -> t sequence -> unit +(** Print the given sequence of expressions to a file *) (** {2 Deserialization (decoding)} *) @@ -59,16 +62,65 @@ type 'a partial_result = [ 'a parse_result | `Await ] (** {6 Streaming Parsing} *) -module Streaming : sig - type decoder +module Source : sig + type individual_char = + | NC_yield of char + | NC_end + | NC_await + (** An individual character returned by a source *) - val mk_decoder : unit -> decoder + type t = unit -> individual_char + (** A source of characters can yield them one by one, or signal the end, + or signal that some external intervention is needed *) - val feed : decoder -> string -> int -> int -> unit - (** Feed a chunk of input to the decoder *) + type source = t - val reached_end : decoder -> unit - (** Tell the decoder that end of input has been reached *) + (** A mnual source of individual characters. When it has exhausted its + data, it asked its caller to provide more, or signal that none remains + In particular, useful when the source of data is monadic IO *) + module Manual : sig + type t + + val make : unit -> t + (** Make a new manual source. It needs to be fed input manually, + using {!feed} *) + + val to_src : t -> source + (** The manual source contains a source! *) + + val feed : t -> string -> int -> int -> unit + (** Feed a chunk of input to the manual source *) + + val reached_end : t -> unit + (** Tell the decoder that end of input has been reached. From now + the source will only yield [NC_end] *) + end + + val of_string : string -> t + (** Use a single string as the source *) + + val of_chan : ?bufsize:int -> in_channel -> t + (** Use a channel as the source *) + + val of_gen : string gen -> t +end + +module Lexer : sig + type t + (** A streaming lexer, that parses atomic chunks of S-expressions (atoms + and delimiters) *) + + val make : Source.t -> t + (** Create a lexer that uses the given source of characters as an input *) + + val of_string : string -> t + + val of_chan : in_channel -> t + + val line : t -> int + val col : t -> int + + (** Obtain next token *) type token = | Open @@ -76,7 +128,7 @@ module Streaming : sig | Atom of string (** An individual S-exp token *) - val next : decoder -> token partial_result + val next : t -> token partial_result (** Obtain the next token, an error, or block/end stream *) end From 3a5f71a9e7b0f416a1fc0f00152c7b9d1fc20f6b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 22:58:56 +0200 Subject: [PATCH 18/28] move benchmarks to benchs/ so they are separate from tests; use compiled oasis setup --- Makefile | 4 +- _oasis | 17 +- {tests => benchs}/bench_batch.ml | 0 {tests => benchs}/bench_conv.ml | 0 {tests => benchs}/bench_hash.ml | 0 {tests => benchs}/benchs.ml | 0 setup.ml | 7834 +----------------------------- tests/test_PiCalculus.ml | 1 + tests/test_bencode.ml | 1 + tests/test_bij.ml | 1 + tests/test_fHashtbl.ml | 1 + tests/test_flatHashtbl.ml | 1 + tests/test_graph.ml | 1 + tests/test_heap.ml | 1 + tests/test_levenshtein.ml | 2 + tests/test_pHashtbl.ml | 1 + tests/test_splayMap.ml | 1 + tests/test_univ.ml | 1 + 18 files changed, 46 insertions(+), 7821 deletions(-) rename {tests => benchs}/bench_batch.ml (100%) rename {tests => benchs}/bench_conv.ml (100%) rename {tests => benchs}/bench_hash.ml (100%) rename {tests => benchs}/benchs.ml (100%) diff --git a/Makefile b/Makefile index ecc2b83e..15342953 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 46f8bd9984975bd4727bed22d0876cd2) +# DO NOT EDIT (digest: 9a60866e2fa295c5e33a3fe33b8f3a32) SETUP = ./setup.exe @@ -38,7 +38,7 @@ configure: $(SETUP) $(SETUP) -configure $(CONFIGUREFLAGS) setup.exe: setup.ml - ocamlfind ocamlopt -o $@ $< || ocamlfind ocamlc -o $@ $< || true + ocamlfind ocamlopt -o $@ -linkpkg -package oasis.dynrun $< || ocamlfind ocamlc -o $@ -linkpkg -package oasis.dynrun $< || true $(RM) setup.cmi setup.cmo setup.cmx setup.o .PHONY: build doc test all install uninstall reinstall clean distclean configure diff --git a/_oasis b/_oasis index e9dad9ac..fa5ef1ef 100644 --- a/_oasis +++ b/_oasis @@ -22,8 +22,7 @@ Description: library full of experimental ideas (not stable, not necessarily usable). Flag "misc" - Description: Build the misc library, containing everything from - the rotating kitchen sink to automatic banana distributors + Description: Build the misc library, containing everything from the rotating kitchen sink to automatic banana distributors Default: false Flag "cgi" @@ -137,7 +136,7 @@ Document containers_string XOCamlbuildLibraries: containers.string Executable benchs - Path: tests/ + Path: benchs/ Install: false CompiledObject: native Build$: flag(bench) @@ -145,7 +144,7 @@ Executable benchs BuildDepends: containers,containers.string,containers.misc,bench Executable bench_conv - Path: tests/ + Path: benchs/ Install: false CompiledObject: native Build$: flag(bench) @@ -153,7 +152,7 @@ Executable bench_conv BuildDepends: containers,benchmark Executable bench_batch - Path: tests/ + Path: benchs/ Install: false CompiledObject: native Build$: flag(bench) @@ -161,7 +160,7 @@ Executable bench_batch BuildDepends: containers,benchmark Executable bench_hash - Path: tests/ + Path: benchs/ Install: false CompiledObject: native Build$: flag(bench) && flag(misc) @@ -174,7 +173,7 @@ Executable test_levenshtein CompiledObject: native Build$: flag(tests) MainIs: test_levenshtein.ml - BuildDepends: containers,qcheck + BuildDepends: containers,qcheck,containers.string Executable test_lwt Path: tests/lwt/ @@ -202,8 +201,8 @@ Executable run_tests Install: false CompiledObject: native MainIs: run_tests.ml - Build$: flag(tests) - BuildDepends: containers, oUnit, qcheck + Build$: flag(tests) && flag(misc) + BuildDepends: containers,oUnit,qcheck,containers.misc Executable web_pwd Path: examples/cgi/ diff --git a/tests/bench_batch.ml b/benchs/bench_batch.ml similarity index 100% rename from tests/bench_batch.ml rename to benchs/bench_batch.ml diff --git a/tests/bench_conv.ml b/benchs/bench_conv.ml similarity index 100% rename from tests/bench_conv.ml rename to benchs/bench_conv.ml diff --git a/tests/bench_hash.ml b/benchs/bench_hash.ml similarity index 100% rename from tests/bench_hash.ml rename to benchs/bench_hash.ml diff --git a/tests/benchs.ml b/benchs/benchs.ml similarity index 100% rename from tests/benchs.ml rename to benchs/benchs.ml diff --git a/setup.ml b/setup.ml index 5e40039e..e4c486de 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7816 +1,30 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 5dcf1a764c1172114f4240aaf1b034a4) *) -(* - Regenerated by OASIS v0.4.4 - Visit http://oasis.forge.ocamlcore.org for more information and - documentation about functions used in this file. -*) -module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) +(* DO NOT EDIT (digest: 172e37fc4b327922311f6cf9389bc560) *) +(******************************************************************************) +(* OASIS: architecture for building OCaml libraries and applications *) +(* *) +(* Copyright (C) 2011-2013, Sylvain Le Gall *) +(* Copyright (C) 2008-2011, OCamlCore SARL *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *) +(* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *) +(* details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +open OASISDynRun - - let ns_ str = - str - - - let s_ str = - str - - - let f_ (str: ('a, 'b, 'c, 'd) format4) = - str - - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - - let init = - [] - - -end - -module OASISContext = struct -(* # 22 "src/oasis/OASISContext.ml" *) - - - open OASISGettext - - - type level = - [ `Debug - | `Info - | `Warning - | `Error] - - - type t = - { - (* TODO: replace this by a proplist. *) - quiet: bool; - info: bool; - debug: bool; - ignore_plugins: bool; - ignore_unknown_fields: bool; - printf: level -> string -> unit; - } - - - let printf lvl str = - let beg = - match lvl with - | `Error -> s_ "E: " - | `Warning -> s_ "W: " - | `Info -> s_ "I: " - | `Debug -> s_ "D: " - in - prerr_endline (beg^str) - - - let default = - ref - { - quiet = false; - info = false; - debug = false; - ignore_plugins = false; - ignore_unknown_fields = false; - printf = printf; - } - - - let quiet = - {!default with quiet = true} - - - let fspecs () = - (* TODO: don't act on default. *) - let ignore_plugins = ref false in - ["-quiet", - Arg.Unit (fun () -> default := {!default with quiet = true}), - s_ " Run quietly"; - - "-info", - Arg.Unit (fun () -> default := {!default with info = true}), - s_ " Display information message"; - - - "-debug", - Arg.Unit (fun () -> default := {!default with debug = true}), - s_ " Output debug message"; - - "-ignore-plugins", - Arg.Set ignore_plugins, - s_ " Ignore plugin's field."; - - "-C", - (* TODO: remove this chdir. *) - Arg.String (fun str -> Sys.chdir str), - s_ "dir Change directory before running."], - fun () -> {!default with ignore_plugins = !ignore_plugins} -end - -module OASISString = struct -(* # 22 "src/oasis/OASISString.ml" *) - - - (** Various string utilities. - - Mostly inspired by extlib and batteries ExtString and BatString libraries. - - @author Sylvain Le Gall - *) - - - let nsplitf str f = - if str = "" then - [] - else - let buf = Buffer.create 13 in - let lst = ref [] in - let push () = - lst := Buffer.contents buf :: !lst; - Buffer.clear buf - in - let str_len = String.length str in - for i = 0 to str_len - 1 do - if f str.[i] then - push () - else - Buffer.add_char buf str.[i] - done; - push (); - List.rev !lst - - - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the - separator. - *) - let nsplit str c = - nsplitf str ((=) c) - - - let find ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx - - - let sub_start str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str len (str_len - len) - - - let sub_end ?(offset=0) str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str 0 (str_len - len) - - - let starts_with ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - let ok = ref true in - while !ok && - !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - ok := false; - incr str_idx - done; - if !what_idx = String.length what then - true - else - false - - - let strip_starts_with ~what str = - if starts_with ~what str then - sub_start str (String.length what) - else - raise Not_found - - - let ends_with ~what ?(offset=0) str = - let what_idx = ref ((String.length what) - 1) in - let str_idx = ref ((String.length str) - 1) in - let ok = ref true in - while !ok && - offset <= !str_idx && - 0 <= !what_idx do - if str.[!str_idx] = what.[!what_idx] then - decr what_idx - else - ok := false; - decr str_idx - done; - if !what_idx = -1 then - true - else - false - - - let strip_ends_with ~what str = - if ends_with ~what str then - sub_end str (String.length what) - else - raise Not_found - - - let replace_chars f s = - let buf = String.make (String.length s) 'X' in - for i = 0 to String.length s - 1 do - buf.[i] <- f s.[i] - done; - buf - - -end - -module OASISUtils = struct -(* # 22 "src/oasis/OASISUtils.ml" *) - - - open OASISGettext - - - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end - - - module MapString = MapExt.Make(String) - - - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list = elements - end - end - - - module SetString = SetExt.Make(String) - - - let compare_csl s1 s2 = - String.compare (String.lowercase s1) (String.lowercase s2) - - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - - let equal s1 s2 = - (String.lowercase s1) = (String.lowercase s2) - - let hash s = - Hashtbl.hash (String.lowercase s) - end) - - module SetStringCsl = - SetExt.Make - (struct - type t = string - let compare = compare_csl - end) - - - let varname_of_string ?(hyphen='_') s = - if String.length s = 0 then - begin - invalid_arg "varname_of_string" - end - else - begin - let buf = - OASISString.replace_chars - (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || - ('0' <= c && c <= '9') then - c - else - hyphen) - s; - in - let buf = - (* Start with a _ if digit *) - if '0' <= s.[0] && s.[0] <= '9' then - "_"^buf - else - buf - in - String.lowercase buf - end - - - let varname_concat ?(hyphen='_') p s = - let what = String.make 1 hyphen in - let p = - try - OASISString.strip_ends_with ~what p - with Not_found -> - p - in - let s = - try - OASISString.strip_starts_with ~what s - with Not_found -> - s - in - p^what^s - - - let is_varname str = - str = varname_of_string str - - - let failwithf fmt = Printf.ksprintf failwith fmt - - -end - -module PropList = struct -(* # 22 "src/oasis/PropList.ml" *) - - - open OASISGettext - - - type name = string - - - exception Not_set of name * string option - exception No_printer of name - exception Unknown_field of name * name - - - let () = - Printexc.register_printer - (function - | Not_set (nm, Some rsn) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) - | Not_set (nm, None) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set") nm) - | No_printer nm -> - Some - (Printf.sprintf (f_ "No default printer for value %s") nm) - | Unknown_field (nm, schm) -> - Some - (Printf.sprintf - (f_ "Field %s is not defined in schema %s") nm schm) - | _ -> - None) - - - module Data = - struct - type t = - (name, unit -> unit) Hashtbl.t - - let create () = - Hashtbl.create 13 - - let clear t = - Hashtbl.clear t - - -(* # 78 "src/oasis/PropList.ml" *) - end - - - module Schema = - struct - type ('ctxt, 'extra) value = - { - get: Data.t -> string; - set: Data.t -> ?context:'ctxt -> string -> unit; - help: (unit -> string) option; - extra: 'extra; - } - - type ('ctxt, 'extra) t = - { - name: name; - fields: (name, ('ctxt, 'extra) value) Hashtbl.t; - order: name Queue.t; - name_norm: string -> string; - } - - let create ?(case_insensitive=false) nm = - { - name = nm; - fields = Hashtbl.create 13; - order = Queue.create (); - name_norm = - (if case_insensitive then - String.lowercase - else - fun s -> s); - } - - let add t nm set get extra help = - let key = - t.name_norm nm - in - - if Hashtbl.mem t.fields key then - failwith - (Printf.sprintf - (f_ "Field '%s' is already defined in schema '%s'") - nm t.name); - Hashtbl.add - t.fields - key - { - set = set; - get = get; - help = help; - extra = extra; - }; - Queue.add nm t.order - - let mem t nm = - Hashtbl.mem t.fields nm - - let find t nm = - try - Hashtbl.find t.fields (t.name_norm nm) - with Not_found -> - raise (Unknown_field (nm, t.name)) - - let get t data nm = - (find t nm).get data - - let set t data nm ?context x = - (find t nm).set - data - ?context - x - - let fold f acc t = - Queue.fold - (fun acc k -> - let v = - find t k - in - f acc k v.extra v.help) - acc - t.order - - let iter f t = - fold - (fun () -> f) - () - t - - let name t = - t.name - end - - - module Field = - struct - type ('ctxt, 'value, 'extra) t = - { - set: Data.t -> ?context:'ctxt -> 'value -> unit; - get: Data.t -> 'value; - sets: Data.t -> ?context:'ctxt -> string -> unit; - gets: Data.t -> string; - help: (unit -> string) option; - extra: 'extra; - } - - let new_id = - let last_id = - ref 0 - in - fun () -> incr last_id; !last_id - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - (* Default value container *) - let v = - ref None - in - - (* If name is not given, create unique one *) - let nm = - match name with - | Some s -> s - | None -> Printf.sprintf "_anon_%d" (new_id ()) - in - - (* Last chance to get a value: the default *) - let default () = - match default with - | Some d -> d - | None -> raise (Not_set (nm, Some (s_ "no default value"))) - in - - (* Get data *) - let get data = - (* Get value *) - try - (Hashtbl.find data nm) (); - match !v with - | Some x -> x - | None -> default () - with Not_found -> - default () - in - - (* Set data *) - let set data ?context x = - let x = - match update with - | Some f -> - begin - try - f ?context (get data) x - with Not_set _ -> - x - end - | None -> - x - in - Hashtbl.replace - data - nm - (fun () -> v := Some x) - in - - (* Parse string value, if possible *) - let parse = - match parse with - | Some f -> - f - | None -> - fun ?context s -> - failwith - (Printf.sprintf - (f_ "Cannot parse field '%s' when setting value %S") - nm - s) - in - - (* Set data, from string *) - let sets data ?context s = - set ?context data (parse ?context s) - in - - (* Output value as string, if possible *) - let print = - match print with - | Some f -> - f - | None -> - fun _ -> raise (No_printer nm) - in - - (* Get data, as a string *) - let gets data = - print (get data) - in - - begin - match schema with - | Some t -> - Schema.add t nm sets gets extra help - | None -> - () - end; - - { - set = set; - get = get; - sets = sets; - gets = gets; - help = help; - extra = extra; - } - - let fset data t ?context x = - t.set data ?context x - - let fget data t = - t.get data - - let fsets data t ?context s = - t.sets data ?context s - - let fgets data t = - t.gets data - end - - - module FieldRO = - struct - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - let fld = - Field.create ?schema ?name ?parse ?print ?default ?update ?help extra - in - fun data -> Field.fget data fld - end -end - -module OASISMessage = struct -(* # 22 "src/oasis/OASISMessage.ml" *) - - - open OASISGettext - open OASISContext - - - let generic_message ~ctxt lvl fmt = - let cond = - if ctxt.quiet then - false - else - match lvl with - | `Debug -> ctxt.debug - | `Info -> ctxt.info - | _ -> true - in - Printf.ksprintf - (fun str -> - if cond then - begin - ctxt.printf lvl str - end) - fmt - - - let debug ~ctxt fmt = - generic_message ~ctxt `Debug fmt - - - let info ~ctxt fmt = - generic_message ~ctxt `Info fmt - - - let warning ~ctxt fmt = - generic_message ~ctxt `Warning fmt - - - let error ~ctxt fmt = - generic_message ~ctxt `Error fmt - -end - -module OASISVersion = struct -(* # 22 "src/oasis/OASISVersion.ml" *) - - - open OASISGettext - - - - - - type s = string - - - type t = string - - - type comparator = - | VGreater of t - | VGreaterEqual of t - | VEqual of t - | VLesser of t - | VLesserEqual of t - | VOr of comparator * comparator - | VAnd of comparator * comparator - - - - (* Range of allowed characters *) - let is_digit c = - '0' <= c && c <= '9' - - - let is_alpha c = - ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') - - - let is_special = - function - | '.' | '+' | '-' | '~' -> true - | _ -> false - - - let rec version_compare v1 v2 = - if v1 <> "" || v2 <> "" then - begin - (* Compare ascii string, using special meaning for version - * related char - *) - let val_ascii c = - if c = '~' then -1 - else if is_digit c then 0 - else if c = '\000' then 0 - else if is_alpha c then Char.code c - else (Char.code c) + 256 - in - - let len1 = String.length v1 in - let len2 = String.length v2 in - - let p = ref 0 in - - (** Compare ascii part *) - let compare_vascii () = - let cmp = ref 0 in - while !cmp = 0 && - !p < len1 && !p < len2 && - not (is_digit v1.[!p] && is_digit v2.[!p]) do - cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); - incr p - done; - if !cmp = 0 && !p < len1 && !p = len2 then - val_ascii v1.[!p] - else if !cmp = 0 && !p = len1 && !p < len2 then - - (val_ascii v2.[!p]) - else - !cmp - in - - (** Compare digit part *) - let compare_digit () = - let extract_int v p = - let start_p = !p in - while !p < String.length v && is_digit v.[!p] do - incr p - done; - let substr = - String.sub v !p ((String.length v) - !p) - in - let res = - match String.sub v start_p (!p - start_p) with - | "" -> 0 - | s -> int_of_string s - in - res, substr - in - let i1, tl1 = extract_int v1 (ref !p) in - let i2, tl2 = extract_int v2 (ref !p) in - i1 - i2, tl1, tl2 - in - - match compare_vascii () with - | 0 -> - begin - match compare_digit () with - | 0, tl1, tl2 -> - if tl1 <> "" && is_digit tl1.[0] then - 1 - else if tl2 <> "" && is_digit tl2.[0] then - -1 - else - version_compare tl1 tl2 - | n, _, _ -> - n - end - | n -> - n - end - else - begin - 0 - end - - - let version_of_string str = str - - - let string_of_version t = t - - - let version_compare_string s1 s2 = - version_compare (version_of_string s1) (version_of_string s2) - - - let chop t = - try - let pos = - String.rindex t '.' - in - String.sub t 0 pos - with Not_found -> - t - - - let rec comparator_apply v op = - match op with - | VGreater cv -> - (version_compare v cv) > 0 - | VGreaterEqual cv -> - (version_compare v cv) >= 0 - | VLesser cv -> - (version_compare v cv) < 0 - | VLesserEqual cv -> - (version_compare v cv) <= 0 - | VEqual cv -> - (version_compare v cv) = 0 - | VOr (op1, op2) -> - (comparator_apply v op1) || (comparator_apply v op2) - | VAnd (op1, op2) -> - (comparator_apply v op1) && (comparator_apply v op2) - - - let rec string_of_comparator = - function - | VGreater v -> "> "^(string_of_version v) - | VEqual v -> "= "^(string_of_version v) - | VLesser v -> "< "^(string_of_version v) - | VGreaterEqual v -> ">= "^(string_of_version v) - | VLesserEqual v -> "<= "^(string_of_version v) - | VOr (c1, c2) -> - (string_of_comparator c1)^" || "^(string_of_comparator c2) - | VAnd (c1, c2) -> - (string_of_comparator c1)^" && "^(string_of_comparator c2) - - - let rec varname_of_comparator = - let concat p v = - OASISUtils.varname_concat - p - (OASISUtils.varname_of_string - (string_of_version v)) - in - function - | VGreater v -> concat "gt" v - | VLesser v -> concat "lt" v - | VEqual v -> concat "eq" v - | VGreaterEqual v -> concat "ge" v - | VLesserEqual v -> concat "le" v - | VOr (c1, c2) -> - (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) - | VAnd (c1, c2) -> - (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - - - let rec comparator_ge v' = - let cmp v = version_compare v v' >= 0 in - function - | VEqual v - | VGreaterEqual v - | VGreater v -> cmp v - | VLesserEqual _ - | VLesser _ -> false - | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 - | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 - - -end - -module OASISLicense = struct -(* # 22 "src/oasis/OASISLicense.ml" *) - - - (** License for _oasis fields - @author Sylvain Le Gall - *) - - - - - - type license = string - - - type license_exception = string - - - type license_version = - | Version of OASISVersion.t - | VersionOrLater of OASISVersion.t - | NoVersion - - - - type license_dep_5_unit = - { - license: license; - excption: license_exception option; - version: license_version; - } - - - - type license_dep_5 = - | DEP5Unit of license_dep_5_unit - | DEP5Or of license_dep_5 list - | DEP5And of license_dep_5 list - - - type t = - | DEP5License of license_dep_5 - | OtherLicense of string (* URL *) - - - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - - - - open OASISGettext - - - type test = string - - - type flag = string - - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - - type 'a choices = (t * 'a) list - - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - - -end - -module OASISText = struct -(* # 22 "src/oasis/OASISText.ml" *) - - - - type elt = - | Para of string - | Verbatim of string - | BlankLine - - - type t = elt list - -end - -module OASISTypes = struct -(* # 22 "src/oasis/OASISTypes.ml" *) - - - - - - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) - - - type findlib_name = string - type findlib_full = string - - - type compiled_object = - | Byte - | Native - | Best - - - - type dependency = - | FindlibPackage of findlib_full * OASISVersion.comparator option - | InternalLibrary of name - - - - type tool = - | ExternalTool of name - | InternalExecutable of name - - - - type vcs = - | Darcs - | Git - | Svn - | Cvs - | Hg - | Bzr - | Arch - | Monotone - | OtherVCS of url - - - - type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install - | `Extra - ] - - - type plugin_data_purpose = - [ `Configure - | `Build - | `Install - | `Clean - | `Distclean - | `Install - | `Uninstall - | `Test - | `Doc - | `Extra - | `Other of string - ] - - - type 'a plugin = 'a * name * OASISVersion.t option - - - type all_plugin = plugin_kind plugin - - - type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list - - -(* # 115 "src/oasis/OASISTypes.ml" *) - - - type 'a conditional = 'a OASISExpr.choices - - - type custom = - { - pre_command: (command_line option) conditional; - post_command: (command_line option) conditional; - } - - - - type common_section = - { - cs_name: name; - cs_data: PropList.Data.t; - cs_plugin_data: plugin_data; - } - - - - type build_section = - { - bs_build: bool conditional; - bs_install: bool conditional; - bs_path: unix_dirname; - bs_compiled_object: compiled_object; - bs_build_depends: dependency list; - bs_build_tools: tool list; - bs_c_sources: unix_filename list; - bs_data_files: (unix_filename * unix_filename option) list; - bs_ccopt: args conditional; - bs_cclib: args conditional; - bs_dlllib: args conditional; - bs_dllpath: args conditional; - bs_byteopt: args conditional; - bs_nativeopt: args conditional; - } - - - - type library = - { - lib_modules: string list; - lib_pack: bool; - lib_internal_modules: string list; - lib_findlib_parent: findlib_name option; - lib_findlib_name: findlib_name option; - lib_findlib_containers: findlib_name list; - } - - - type object_ = - { - obj_modules: string list; - obj_findlib_fullname: findlib_name list option; - } - - - type executable = - { - exec_custom: bool; - exec_main_is: unix_filename; - } - - - type flag = - { - flag_description: string option; - flag_default: bool conditional; - } - - - type source_repository = - { - src_repo_type: vcs; - src_repo_location: url; - src_repo_browser: url option; - src_repo_module: string option; - src_repo_branch: string option; - src_repo_tag: string option; - src_repo_subdir: unix_filename option; - } - - - type test = - { - test_type: [`Test] plugin; - test_command: command_line conditional; - test_custom: custom; - test_working_directory: unix_filename option; - test_run: bool conditional; - test_tools: tool list; - } - - - type doc_format = - | HTML of unix_filename - | DocText - | PDF - | PostScript - | Info of unix_filename - | DVI - | OtherDoc - - - - type doc = - { - doc_type: [`Doc] plugin; - doc_custom: custom; - doc_build: bool conditional; - doc_install: bool conditional; - doc_install_dir: unix_filename; - doc_title: string; - doc_authors: string list; - doc_abstract: string option; - doc_format: doc_format; - doc_data_files: (unix_filename * unix_filename option) list; - doc_build_tools: tool list; - } - - - type section = - | Library of common_section * build_section * library - | Object of common_section * build_section * object_ - | Executable of common_section * build_section * executable - | Flag of common_section * flag - | SrcRepo of common_section * source_repository - | Test of common_section * test - | Doc of common_section * doc - - - - type section_kind = - [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] - - - type package = - { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: OASISText.t option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - disable_oasis_section: unix_filename list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } - - -end - -module OASISFeatures = struct -(* # 22 "src/oasis/OASISFeatures.ml" *) - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISVersion - - module MapPlugin = - Map.Make - (struct - type t = plugin_kind * name - let compare = Pervasives.compare - end) - - module Data = - struct - type t = - { - oasis_version: OASISVersion.t; - plugin_versions: OASISVersion.t option MapPlugin.t; - alpha_features: string list; - beta_features: string list; - } - - let create oasis_version alpha_features beta_features = - { - oasis_version = oasis_version; - plugin_versions = MapPlugin.empty; - alpha_features = alpha_features; - beta_features = beta_features - } - - let of_package pkg = - create - pkg.OASISTypes.oasis_version - pkg.OASISTypes.alpha_features - pkg.OASISTypes.beta_features - - let add_plugin (plugin_kind, plugin_name, plugin_version) t = - {t with - plugin_versions = MapPlugin.add - (plugin_kind, plugin_name) - plugin_version - t.plugin_versions} - - let plugin_version plugin_kind plugin_name t = - MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions - - let to_string t = - Printf.sprintf - "oasis_version: %s; alpha_features: %s; beta_features: %s; \ - plugins_version: %s" - (OASISVersion.string_of_version t.oasis_version) - (String.concat ", " t.alpha_features) - (String.concat ", " t.beta_features) - (String.concat ", " - (MapPlugin.fold - (fun (_, plg) ver_opt acc -> - (plg^ - (match ver_opt with - | Some v -> - " "^(OASISVersion.string_of_version v) - | None -> "")) - :: acc) - t.plugin_versions [])) - end - - type origin = - | Field of string * string - | Section of string - | NoOrigin - - type stage = Alpha | Beta - - - let string_of_stage = - function - | Alpha -> "alpha" - | Beta -> "beta" - - - let field_of_stage = - function - | Alpha -> "AlphaFeatures" - | Beta -> "BetaFeatures" - - type publication = InDev of stage | SinceVersion of OASISVersion.t - - type t = - { - name: string; - plugin: all_plugin option; - publication: publication; - description: unit -> string; - } - - (* TODO: mutex protect this. *) - let all_features = Hashtbl.create 13 - - - let since_version ver_str = SinceVersion (version_of_string ver_str) - let alpha = InDev Alpha - let beta = InDev Beta - - - let to_string t = - Printf.sprintf - "feature: %s; plugin: %s; publication: %s" - t.name - (match t.plugin with - | None -> "" - | Some (_, nm, _) -> nm) - (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) - - let data_check t data origin = - let no_message = "no message" in - - let check_feature features stage = - let has_feature = List.mem t.name features in - if not has_feature then - match origin with - | Field (fld, where) -> - Some - (Printf.sprintf - (f_ "Field %s in %s is only available when feature %s \ - is in field %s.") - fld where t.name (field_of_stage stage)) - | Section sct -> - Some - (Printf.sprintf - (f_ "Section %s is only available when features %s \ - is in field %s.") - sct t.name (field_of_stage stage)) - | NoOrigin -> - Some no_message - else - None - in - - let version_is_good ~min_version version fmt = - let version_is_good = - OASISVersion.comparator_apply - version (OASISVersion.VGreaterEqual min_version) - in - Printf.ksprintf - (fun str -> - if version_is_good then - None - else - Some str) - fmt - in - - match origin, t.plugin, t.publication with - | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha - | _, _, InDev Beta -> check_feature data.Data.beta_features Beta - | Field(fld, where), None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Field %s in %s is only valid since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking \ - OASIS changelog.") - fld where (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Field(fld, where), Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Field %s in %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - fld where plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Field %s in %s is only valid when the OASIS plugin %s \ - is defined.") - fld where plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Field %s in %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - fld where plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | Section sct, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Section %s is only valid for since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking OASIS \ - changelog.") - sct (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Section sct, Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Section %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - sct plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Section %s is only valid when the OASIS plugin %s \ - is defined.") - sct plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Section %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - sct plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | NoOrigin, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version "%s" no_message - - | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> - begin - try - let plugin_version_current = - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> raise Not_found - in - version_is_good ~min_version plugin_version_current - "%s" no_message - with Not_found -> - Some no_message - end - - - let data_assert t data origin = - match data_check t data origin with - | None -> () - | Some str -> failwith str - - - let data_test t data = - match data_check t data NoOrigin with - | None -> true - | Some str -> false - - - let package_test t pkg = - data_test t (Data.of_package pkg) - - - let create ?plugin name publication description = - let () = - if Hashtbl.mem all_features name then - failwithf "Feature '%s' is already declared." name - in - let t = - { - name = name; - plugin = plugin; - publication = publication; - description = description; - } - in - Hashtbl.add all_features name t; - t - - - let get_stage name = - try - (Hashtbl.find all_features name).publication - with Not_found -> - failwithf (f_ "Feature %s doesn't exist.") name - - - let list () = - Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] - - (* - * Real flags. - *) - - - let features = - create "features_fields" - (since_version "0.4") - (fun () -> - s_ "Enable to experiment not yet official features.") - - - let flag_docs = - create "flag_docs" - (since_version "0.3") - (fun () -> - s_ "Building docs require '-docs' flag at configure.") - - - let flag_tests = - create "flag_tests" - (since_version "0.3") - (fun () -> - s_ "Running tests require '-tests' flag at configure.") - - - let pack = - create "pack" - (since_version "0.3") - (fun () -> - s_ "Allow to create packed library.") - - - let section_object = - create "section_object" beta - (fun () -> - s_ "Implement an object section.") - - - let dynrun_for_release = - create "dynrun_for_release" alpha - (fun () -> - s_ "Make '-setup-update dynamic' suitable for releasing project.") - - - let compiled_setup_ml = - create "compiled_setup_ml" alpha - (fun () -> - s_ "It compiles the setup.ml and speed-up actions done with it.") - - let disable_oasis_section = - create "disable_oasis_section" alpha - (fun () -> - s_ "Allows the OASIS section comments and digest to be omitted in \ - generated files.") -end - -module OASISUnixPath = struct -(* # 22 "src/oasis/OASISUnixPath.ml" *) - - - type unix_filename = string - type unix_dirname = string - - - type host_filename = string - type host_dirname = string - - - let current_dir_name = "." - - - let parent_dir_name = ".." - - - let is_current_dir fn = - fn = current_dir_name || fn = "" - - - let concat f1 f2 = - if is_current_dir f1 then - f2 - else - let f1' = - try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 - in - f1'^"/"^f2 - - - let make = - function - | hd :: tl -> - List.fold_left - (fun f p -> concat f p) - hd - tl - | [] -> - invalid_arg "OASISUnixPath.make" - - - let dirname f = - try - String.sub f 0 (String.rindex f '/') - with Not_found -> - current_dir_name - - - let basename f = - try - let pos_start = - (String.rindex f '/') + 1 - in - String.sub f pos_start ((String.length f) - pos_start) - with Not_found -> - f - - - let chop_extension f = - try - let last_dot = - String.rindex f '.' - in - let sub = - String.sub f 0 last_dot - in - try - let last_slash = - String.rindex f '/' - in - if last_slash < last_dot then - sub - else - f - with Not_found -> - sub - - with Not_found -> - f - - - let capitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.capitalize base) - - - let uncapitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.uncapitalize base) - - -end - -module OASISHostPath = struct -(* # 22 "src/oasis/OASISHostPath.ml" *) - - - open Filename - - - module Unix = OASISUnixPath - - - let make = - function - | [] -> - invalid_arg "OASISHostPath.make" - | hd :: tl -> - List.fold_left Filename.concat hd tl - - - let of_unix ufn = - if Sys.os_type = "Unix" then - ufn - else - make - (List.map - (fun p -> - if p = Unix.current_dir_name then - current_dir_name - else if p = Unix.parent_dir_name then - parent_dir_name - else - p) - (OASISString.nsplit ufn '/')) - - -end - -module OASISSection = struct -(* # 22 "src/oasis/OASISSection.ml" *) - - - open OASISTypes - - - let section_kind_common = - function - | Library (cs, _, _) -> - `Library, cs - | Object (cs, _, _) -> - `Object, cs - | Executable (cs, _, _) -> - `Executable, cs - | Flag (cs, _) -> - `Flag, cs - | SrcRepo (cs, _) -> - `SrcRepo, cs - | Test (cs, _) -> - `Test, cs - | Doc (cs, _) -> - `Doc, cs - - - let section_common sct = - snd (section_kind_common sct) - - - let section_common_set cs = - function - | Library (_, bs, lib) -> Library (cs, bs, lib) - | Object (_, bs, obj) -> Object (cs, bs, obj) - | Executable (_, bs, exec) -> Executable (cs, bs, exec) - | Flag (_, flg) -> Flag (cs, flg) - | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) - | Test (_, tst) -> Test (cs, tst) - | Doc (_, doc) -> Doc (cs, doc) - - - (** Key used to identify section - *) - let section_id sct = - let k, cs = - section_kind_common sct - in - k, cs.cs_name - - - let string_of_section sct = - let k, nm = - section_id sct - in - (match k with - | `Library -> "library" - | `Object -> "object" - | `Executable -> "executable" - | `Flag -> "flag" - | `SrcRepo -> "src repository" - | `Test -> "test" - | `Doc -> "doc") - ^" "^nm - - - let section_find id scts = - List.find - (fun sct -> id = section_id sct) - scts - - - module CSection = - struct - type t = section - - let id = section_id - - let compare t1 t2 = - compare (id t1) (id t2) - - let equal t1 t2 = - (id t1) = (id t2) - - let hash t = - Hashtbl.hash (id t) - end - - - module MapSection = Map.Make(CSection) - module SetSection = Set.Make(CSection) - - -end - -module OASISBuildSection = struct -(* # 22 "src/oasis/OASISBuildSection.ml" *) - - -end - -module OASISExecutable = struct -(* # 22 "src/oasis/OASISExecutable.ml" *) - - - open OASISTypes - - - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = - OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.dirname exec.exec_main_is) - in - let is_native_exec = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native () - | Byte -> false - in - - OASISUnixPath.concat - dir - (cs.cs_name^(suffix_program ())), - - if not is_native_exec && - not exec.exec_custom && - bs.bs_c_sources <> [] then - Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) - else - None - - -end - -module OASISLibrary = struct -(* # 22 "src/oasis/OASISLibrary.ml" *) - - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISSection - - - (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists bs modul = - let possible_base_fn = - List.map - (OASISUnixPath.concat bs.bs_path) - [modul; - OASISUnixPath.uncapitalize_file modul; - OASISUnixPath.capitalize_file modul] - in - (* TODO: we should be able to be able to determine the source for every - * files. Hence we should introduce a Module(source: fn) for the fields - * Modules and InternalModules - *) - List.fold_left - (fun acc base_fn -> - match acc with - | `No_sources _ -> - begin - let file_found = - List.fold_left - (fun acc ext -> - if source_file_exists (base_fn^ext) then - (base_fn^ext) :: acc - else - acc) - [] - [".ml"; ".mli"; ".mll"; ".mly"] - in - match file_found with - | [] -> - acc - | lst -> - `Sources (base_fn, lst) - end - | `Sources _ -> - acc) - (`No_sources possible_base_fn) - possible_base_fn - - - let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = - List.fold_left - (fun acc modul -> - match find_module source_file_exists bs modul with - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - acc) - [] - (lib.lib_modules @ lib.lib_internal_modules) - - - let generated_unix_files - ~ctxt - ~is_native - ~has_native_dynlink - ~ext_lib - ~ext_dll - ~source_file_exists - (cs, bs, lib) = - - let find_modules lst ext = - let find_module modul = - match find_module source_file_exists bs modul with - | `Sources (base_fn, [fn]) when ext <> "cmi" - && Filename.check_suffix fn ".mli" -> - None (* No implementation files for pure interface. *) - | `Sources (base_fn, _) -> - Some [base_fn] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - Some lst - in - List.fold_left - (fun acc nm -> - match find_module nm with - | None -> acc - | Some base_fns -> - List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) - [] - lst - in - - (* The headers that should be compiled along *) - let headers = - if lib.lib_pack then - [] - else - find_modules - lib.lib_modules - "cmi" - in - - (* The .cmx that be compiled along *) - let cmxs = - let should_be_built = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native - | Byte -> false - in - if should_be_built then - if lib.lib_pack then - find_modules - [cs.cs_name] - "cmx" - else - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" - else - [] - in - - let acc_nopath = - [] - in - - (* Compute what libraries should be built *) - let acc_nopath = - (* Add the packed header file if required *) - let add_pack_header acc = - if lib.lib_pack then - [cs.cs_name^".cmi"] :: acc - else - acc - in - let byte acc = - add_pack_header ([cs.cs_name^".cma"] :: acc) - in - let native acc = - let acc = - add_pack_header - (if has_native_dynlink then - [cs.cs_name^".cmxs"] :: acc - else acc) - in - [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc - in - match bs.bs_compiled_object with - | Native -> - byte (native acc_nopath) - | Best when is_native -> - byte (native acc_nopath) - | Byte | Best -> - byte acc_nopath - in - - (* Add C library to be built *) - let acc_nopath = - if bs.bs_c_sources <> [] then - begin - ["lib"^cs.cs_name^"_stubs"^ext_lib] - :: - ["dll"^cs.cs_name^"_stubs"^ext_dll] - :: - acc_nopath - end - else - acc_nopath - in - - (* All the files generated *) - List.rev_append - (List.rev_map - (List.rev_map - (OASISUnixPath.concat bs.bs_path)) - acc_nopath) - (headers @ cmxs) - - -end - -module OASISObject = struct -(* # 22 "src/oasis/OASISObject.ml" *) - - - open OASISTypes - open OASISGettext - - - let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = - List.fold_left - (fun acc modul -> - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name; - acc) - [] - obj.obj_modules - - - let generated_unix_files - ~ctxt - ~is_native - ~source_file_exists - (cs, bs, obj) = - - let find_module ext modul = - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, _) -> [base_fn ^ ext] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name ; - lst - in - - let header, byte, native, c_object, f = - match obj.obj_modules with - | [ m ] -> (find_module ".cmi" m, - find_module ".cmo" m, - find_module ".cmx" m, - find_module ".o" m, - fun x -> x) - | _ -> ([cs.cs_name ^ ".cmi"], - [cs.cs_name ^ ".cmo"], - [cs.cs_name ^ ".cmx"], - [cs.cs_name ^ ".o"], - OASISUnixPath.concat bs.bs_path) - in - List.map (List.map f) ( - match bs.bs_compiled_object with - | Native -> - native :: c_object :: byte :: header :: [] - | Best when is_native -> - native :: c_object :: byte :: header :: [] - | Byte | Best -> - byte :: header :: []) - - -end - -module OASISFindlib = struct -(* # 22 "src/oasis/OASISFindlib.ml" *) - - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISSection - - - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - [`Library of library | `Object of object_] * - group_t list) - - - type data = common_section * - build_section * - [`Library of library | `Object of object_] - type tree = - | Node of (data option) * (tree MapString.t) - | Leaf of data - - - let findlib_mapping pkg = - (* Map from library name to either full findlib name or parts + parent. *) - let fndlb_parts_of_lib_name = - let fndlb_parts cs lib = - let name = - match lib.lib_findlib_name with - | Some nm -> nm - | None -> cs.cs_name - in - let name = - String.concat "." (lib.lib_findlib_containers @ [name]) - in - name - in - List.fold_left - (fun mp -> - function - | Library (cs, _, lib) -> - begin - let lib_name = cs.cs_name in - let fndlb_parts = fndlb_parts cs lib in - if MapString.mem lib_name mp then - failwithf - (f_ "The library name '%s' is used more than once.") - lib_name; - match lib.lib_findlib_parent with - | Some lib_name_parent -> - MapString.add - lib_name - (`Unsolved (lib_name_parent, fndlb_parts)) - mp - | None -> - MapString.add - lib_name - (`Solved fndlb_parts) - mp - end - - | Object (cs, _, obj) -> - begin - let obj_name = cs.cs_name in - if MapString.mem obj_name mp then - failwithf - (f_ "The object name '%s' is used more than once.") - obj_name; - let findlib_full_name = match obj.obj_findlib_fullname with - | Some ns -> String.concat "." ns - | None -> obj_name - in - MapString.add - obj_name - (`Solved findlib_full_name) - mp - end - - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> - mp) - MapString.empty - pkg.sections - in - - (* Solve the above graph to be only library name to full findlib name. *) - let fndlb_name_of_lib_name = - let rec solve visited mp lib_name lib_name_child = - if SetString.mem lib_name visited then - failwithf - (f_ "Library '%s' is involved in a cycle \ - with regard to findlib naming.") - lib_name; - let visited = SetString.add lib_name visited in - try - match MapString.find lib_name mp with - | `Solved fndlb_nm -> - fndlb_nm, mp - | `Unsolved (lib_nm_parent, post_fndlb_nm) -> - let pre_fndlb_nm, mp = - solve visited mp lib_nm_parent lib_name - in - let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in - fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp - with Not_found -> - failwithf - (f_ "Library '%s', which is defined as the findlib parent of \ - library '%s', doesn't exist.") - lib_name lib_name_child - in - let mp = - MapString.fold - (fun lib_name status mp -> - match status with - | `Solved _ -> - (* Solved initialy, no need to go further *) - mp - | `Unsolved _ -> - let _, mp = solve SetString.empty mp lib_name "" in - mp) - fndlb_parts_of_lib_name - fndlb_parts_of_lib_name - in - MapString.map - (function - | `Solved fndlb_nm -> fndlb_nm - | `Unsolved _ -> assert false) - mp - in - - (* Convert an internal library name to a findlib name. *) - let findlib_name_of_library_name lib_nm = - try - MapString.find lib_nm fndlb_name_of_lib_name - with Not_found -> - raise (InternalLibraryNotFound lib_nm) - in - - (* Add a library to the tree. - *) - let add sct mp = - let fndlb_fullname = - let cs, _, _ = sct in - let lib_name = cs.cs_name in - findlib_name_of_library_name lib_name - in - let rec add_children nm_lst (children: tree MapString.t) = - match nm_lst with - | (hd :: tl) -> - begin - let node = - try - add_node tl (MapString.find hd children) - with Not_found -> - (* New node *) - new_node tl - in - MapString.add hd node children - end - | [] -> - (* Should not have a nameless library. *) - assert false - and add_node tl node = - if tl = [] then - begin - match node with - | Node (None, children) -> - Node (Some sct, children) - | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> - (* TODO: allow to merge Package, i.e. - * archive(byte) = "foo.cma foo_init.cmo" - *) - let cs, _, _ = sct in - failwithf - (f_ "Library '%s' and '%s' have the same findlib name '%s'") - cs.cs_name cs'.cs_name fndlb_fullname - end - else - begin - match node with - | Leaf data -> - Node (Some data, add_children tl MapString.empty) - | Node (data_opt, children) -> - Node (data_opt, add_children tl children) - end - and new_node = - function - | [] -> - Leaf sct - | hd :: tl -> - Node (None, MapString.add hd (new_node tl) MapString.empty) - in - add_children (OASISString.nsplit fndlb_fullname '.') mp - in - - let rec group_of_tree mp = - MapString.fold - (fun nm node acc -> - let cur = - match node with - | Node (Some (cs, bs, lib), children) -> - Package (nm, cs, bs, lib, group_of_tree children) - | Node (None, children) -> - Container (nm, group_of_tree children) - | Leaf (cs, bs, lib) -> - Package (nm, cs, bs, lib, []) - in - cur :: acc) - mp [] - in - - let group_mp = - List.fold_left - (fun mp -> - function - | Library (cs, bs, lib) -> - add (cs, bs, `Library lib) mp - | Object (cs, bs, obj) -> - add (cs, bs, `Object obj) mp - | _ -> - mp) - MapString.empty - pkg.sections - in - - let groups = - group_of_tree group_mp - in - - let library_name_of_findlib_name = - Lazy.lazy_from_fun - (fun () -> - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty) - in - let library_name_of_findlib_name fndlb_nm = - try - MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) - with Not_found -> - raise (FindlibPackageNotFound fndlb_nm) - in - - groups, - findlib_name_of_library_name, - library_name_of_findlib_name - - - let findlib_of_group = - function - | Container (fndlb_nm, _) - | Package (fndlb_nm, _, _, _, _) -> fndlb_nm - - - let root_of_group grp = - let rec root_lib_aux = - (* We do a DFS in the group. *) - function - | Container (_, children) -> - List.fold_left - (fun res grp -> - if res = None then - root_lib_aux grp - else - res) - None - children - | Package (_, cs, bs, lib, _) -> - Some (cs, bs, lib) - in - match root_lib_aux grp with - | Some res -> - res - | None -> - failwithf - (f_ "Unable to determine root library of findlib library '%s'") - (findlib_of_group grp) - - -end - -module OASISFlag = struct -(* # 22 "src/oasis/OASISFlag.ml" *) - - -end - -module OASISPackage = struct -(* # 22 "src/oasis/OASISPackage.ml" *) - - -end - -module OASISSourceRepository = struct -(* # 22 "src/oasis/OASISSourceRepository.ml" *) - - -end - -module OASISTest = struct -(* # 22 "src/oasis/OASISTest.ml" *) - - -end - -module OASISDocument = struct -(* # 22 "src/oasis/OASISDocument.ml" *) - - -end - -module OASISExec = struct -(* # 22 "src/oasis/OASISExec.ml" *) - - - open OASISGettext - open OASISUtils - open OASISMessage - - - (* TODO: I don't like this quote, it is there because $(rm) foo expands to - * 'rm -f' foo... - *) - let run ~ctxt ?f_exit_code ?(quote=true) cmd args = - let cmd = - if quote then - if Sys.os_type = "Win32" then - if String.contains cmd ' ' then - (* Double the 1st double quote... win32... sigh *) - "\""^(Filename.quote cmd) - else - cmd - else - Filename.quote cmd - else - cmd - in - let cmdline = - String.concat " " (cmd :: args) - in - info ~ctxt (f_ "Running command '%s'") cmdline; - match f_exit_code, Sys.command cmdline with - | None, 0 -> () - | None, i -> - failwithf - (f_ "Command '%s' terminated with error code %d") - cmdline i - | Some f, i -> - f i - - - let run_read_output ~ctxt ?f_exit_code cmd args = - let fn = - Filename.temp_file "oasis-" ".txt" - in - try - begin - let () = - run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) - in - let chn = - open_in fn - in - let routput = - ref [] - in - begin - try - while true do - routput := (input_line chn) :: !routput - done - with End_of_file -> - () - end; - close_in chn; - Sys.remove fn; - List.rev !routput - end - with e -> - (try Sys.remove fn with _ -> ()); - raise e - - - let run_read_one_line ~ctxt ?f_exit_code cmd args = - match run_read_output ~ctxt ?f_exit_code cmd args with - | [fst] -> - fst - | lst -> - failwithf - (f_ "Command return unexpected output %S") - (String.concat "\n" lst) -end - -module OASISFileUtil = struct -(* # 22 "src/oasis/OASISFileUtil.ml" *) - - - open OASISGettext - - - let file_exists_case fn = - let dirname = Filename.dirname fn in - let basename = Filename.basename fn in - if Sys.file_exists dirname then - if basename = Filename.current_dir_name then - true - else - List.mem - basename - (Array.to_list (Sys.readdir dirname)) - else - false - - - let find_file ?(case_sensitive=true) paths exts = - - (* Cardinal product of two list *) - let ( * ) lst1 lst2 = - List.flatten - (List.map - (fun a -> - List.map - (fun b -> a, b) - lst2) - lst1) - in - - let rec combined_paths lst = - match lst with - | p1 :: p2 :: tl -> - let acc = - (List.map - (fun (a, b) -> Filename.concat a b) - (p1 * p2)) - in - combined_paths (acc :: tl) - | [e] -> - e - | [] -> - [] - in - - let alternatives = - List.map - (fun (p, e) -> - if String.length e > 0 && e.[0] <> '.' then - p ^ "." ^ e - else - p ^ e) - ((combined_paths paths) * exts) - in - List.find (fun file -> - (if case_sensitive then - file_exists_case file - else - Sys.file_exists file) - && not (Sys.is_directory file) - ) alternatives - - - let which ~ctxt prg = - let path_sep = - match Sys.os_type with - | "Win32" -> - ';' - | _ -> - ':' - in - let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in - let exec_ext = - match Sys.os_type with - | "Win32" -> - "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) - | _ -> - [""] - in - find_file ~case_sensitive:false [path_lst; [prg]] exec_ext - - - (**/**) - let rec fix_dir dn = - (* Windows hack because Sys.file_exists "src\\" = false when - * Sys.file_exists "src" = true - *) - let ln = - String.length dn - in - if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then - fix_dir (String.sub dn 0 (ln - 1)) - else - dn - - - let q = Filename.quote - (**/**) - - - let cp ~ctxt ?(recurse=false) src tgt = - if recurse then - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt - "xcopy" [q src; q tgt; "/E"] - | _ -> - OASISExec.run ~ctxt - "cp" ["-r"; q src; q tgt] - else - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "copy" - | _ -> "cp") - [q src; q tgt] - - - let mkdir ~ctxt tgt = - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "md" - | _ -> "mkdir") - [q tgt] - - - let rec mkdir_parent ~ctxt f tgt = - let tgt = - fix_dir tgt - in - if Sys.file_exists tgt then - begin - if not (Sys.is_directory tgt) then - OASISUtils.failwithf - (f_ "Cannot create directory '%s', a file of the same name already \ - exists") - tgt - end - else - begin - mkdir_parent ~ctxt f (Filename.dirname tgt); - if not (Sys.file_exists tgt) then - begin - f tgt; - mkdir ~ctxt tgt - end - end - - - let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end else begin - OASISMessage.error ~ctxt - (f_ "Cannot remove directory '%s': not empty.") - tgt - end - - - let glob ~ctxt fn = - let basename = - Filename.basename fn - in - if String.length basename >= 2 && - basename.[0] = '*' && - basename.[1] = '.' then - begin - let ext_len = - (String.length basename) - 2 - in - let ext = - String.sub basename 2 ext_len - in - let dirname = - Filename.dirname fn - in - Array.fold_left - (fun acc fn -> - try - let fn_ext = - String.sub - fn - ((String.length fn) - ext_len) - ext_len - in - if fn_ext = ext then - (Filename.concat dirname fn) :: acc - else - acc - with Invalid_argument _ -> - acc) - [] - (Sys.readdir dirname) - end - else - begin - if file_exists_case fn then - [fn] - else - [] - end -end - - -# 2878 "setup.ml" -module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - - - module MapString = Map.Make(String) - - - type t = string MapString.t - - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - - let rec var_expand str env = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = - var_expand (MapString.find name env) env - - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -# 2983 "setup.ml" -module BaseContext = struct -(* # 22 "src/base/BaseContext.ml" *) - - (* TODO: get rid of this module. *) - open OASISContext - - - let args () = fst (fspecs ()) - - - let default = default - -end - -module BaseMessage = struct -(* # 22 "src/base/BaseMessage.ml" *) - - - (** Message to user, overrid for Base - @author Sylvain Le Gall - *) - open OASISMessage - open BaseContext - - - let debug fmt = debug ~ctxt:!default fmt - - - let info fmt = info ~ctxt:!default fmt - - - let warning fmt = warning ~ctxt:!default fmt - - - let error fmt = error ~ctxt:!default fmt - -end - -module BaseEnv = struct -(* # 22 "src/base/BaseEnv.ml" *) - - open OASISGettext - open OASISUtils - open PropList - - - module MapString = BaseEnvLight.MapString - - - type origin_t = - | ODefault - | OGetEnv - | OFileLoad - | OCommandLine - - - type cli_handle_t = - | CLINone - | CLIAuto - | CLIWith - | CLIEnable - | CLIUser of (Arg.key * Arg.spec * Arg.doc) list - - - type definition_t = - { - hide: bool; - dump: bool; - cli: cli_handle_t; - arg_help: string option; - group: string option; - } - - - let schema = - Schema.create "environment" - - - (* Environment data *) - let env = - Data.create () - - - (* Environment data from file *) - let env_from_file = - ref MapString.empty - - - (* Lexer for var *) - let var_lxr = - Genlex.make_lexer [] - - - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - (* TODO: this is a quick hack to allow calling Test.Command - * without defining executable name really. I.e. if there is - * an exec Executable toto, then $(toto) should be replace - * by its real name. It is however useful to have this function - * for other variable that depend on the host and should be - * written better than that. - *) - let st = - var_lxr (Stream.of_string var) - in - match Stream.npeek 3 st with - | [Genlex.Ident "utoh"; Genlex.Ident nm] -> - OASISHostPath.of_unix (var_get nm) - | [Genlex.Ident "utoh"; Genlex.String s] -> - OASISHostPath.of_unix s - | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> - String.escaped (var_get nm) - | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> - String.escaped s - | [Genlex.Ident nm] -> - var_get nm - | _ -> - failwithf - (f_ "Unknown expression '%s' in variable expansion of %s.") - var - str - with - | Unknown_field (_, _) -> - failwithf - (f_ "No variable %s defined when trying to expand %S.") - var - str - | Stream.Error e -> - failwithf - (f_ "Syntax error when parsing '%s' when trying to \ - expand %S: %s") - var - str - e) - str; - Buffer.contents buff - - - and var_get name = - let vl = - try - Schema.get schema env name - with Unknown_field _ as e -> - begin - try - MapString.find name !env_from_file - with Not_found -> - raise e - end - in - var_expand vl - - - let var_choose ?printer ?name lst = - OASISExpr.choose - ?printer - ?name - var_get - lst - - - let var_protect vl = - let buff = - Buffer.create (String.length vl) - in - String.iter - (function - | '$' -> Buffer.add_string buff "\\$" - | c -> Buffer.add_char buff c) - vl; - Buffer.contents buff - - - let var_define - ?(hide=false) - ?(dump=true) - ?short_desc - ?(cli=CLINone) - ?arg_help - ?group - name (* TODO: type constraint on the fact that name must be a valid OCaml - id *) - dflt = - - let default = - [ - OFileLoad, (fun () -> MapString.find name !env_from_file); - ODefault, dflt; - OGetEnv, (fun () -> Sys.getenv name); - ] - in - - let extra = - { - hide = hide; - dump = dump; - cli = cli; - arg_help = arg_help; - group = group; - } - in - - (* Try to find a value that can be defined - *) - let var_get_low lst = - let errors, res = - List.fold_left - (fun (errors, res) (o, v) -> - if res = None then - begin - try - errors, Some (v ()) - with - | Not_found -> - errors, res - | Failure rsn -> - (rsn :: errors), res - | e -> - (Printexc.to_string e) :: errors, res - end - else - errors, res) - ([], None) - (List.sort - (fun (o1, _) (o2, _) -> - Pervasives.compare o2 o1) - lst) - in - match res, errors with - | Some v, _ -> - v - | None, [] -> - raise (Not_set (name, None)) - | None, lst -> - raise (Not_set (name, Some (String.concat (s_ ", ") lst))) - in - - let help = - match short_desc with - | Some fs -> Some fs - | None -> None - in - - let var_get_lst = - FieldRO.create - ~schema - ~name - ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) - ~print:var_get_low - ~default - ~update:(fun ?context x old_x -> x @ old_x) - ?help - extra - in - - fun () -> - var_expand (var_get_low (var_get_lst env)) - - - let var_redefine - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt = - if Schema.mem schema name then - begin - (* TODO: look suspsicious, we want to memorize dflt not dflt () *) - Schema.set schema env ~context:ODefault name (dflt ()); - fun () -> var_get name - end - else - begin - var_define - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt - end - - - let var_ignore (e: unit -> string) = () - - - let print_hidden = - var_define - ~hide:true - ~dump:false - ~cli:CLIAuto - ~arg_help:"Print even non-printable variable. (debug)" - "print_hidden" - (fun () -> "false") - - - let var_all () = - List.rev - (Schema.fold - (fun acc nm def _ -> - if not def.hide || bool_of_string (print_hidden ()) then - nm :: acc - else - acc) - [] - schema) - - - let default_filename = - BaseEnvLight.default_filename - - - let load ?allow_empty ?filename () = - env_from_file := BaseEnvLight.load ?allow_empty ?filename () - - - let unload () = - env_from_file := MapString.empty; - Data.clear env - - - let dump ?(filename=default_filename) () = - let chn = - open_out_bin filename - in - let output nm value = - Printf.fprintf chn "%s=%S\n" nm value - in - let mp_todo = - (* Dump data from schema *) - Schema.fold - (fun mp_todo nm def _ -> - if def.dump then - begin - try - let value = - Schema.get - schema - env - nm - in - output nm value - with Not_set _ -> - () - end; - MapString.remove nm mp_todo) - !env_from_file - schema - in - (* Dump data defined outside of schema *) - MapString.iter output mp_todo; - - (* End of the dump *) - close_out chn - - - let print () = - let printable_vars = - Schema.fold - (fun acc nm def short_descr_opt -> - if not def.hide || bool_of_string (print_hidden ()) then - begin - try - let value = - Schema.get - schema - env - nm - in - let txt = - match short_descr_opt with - | Some s -> s () - | None -> nm - in - (txt, value) :: acc - with Not_set _ -> - acc - end - else - acc) - [] - schema - in - let max_length = - List.fold_left max 0 - (List.rev_map String.length - (List.rev_map fst printable_vars)) - in - let dot_pad str = - String.make ((max_length - (String.length str)) + 3) '.' - in - - Printf.printf "\nConfiguration: \n"; - List.iter - (fun (name, value) -> - Printf.printf "%s: %s %s\n" name (dot_pad name) value) - (List.rev printable_vars); - Printf.printf "\n%!" - - - let args () = - let arg_concat = - OASISUtils.varname_concat ~hyphen:'-' - in - [ - "--override", - Arg.Tuple - ( - let rvr = ref "" - in - let rvl = ref "" - in - [ - Arg.Set_string rvr; - Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set - schema - env - ~context:OCommandLine - !rvr - !rvl) - ] - ), - "var+val Override any configuration variable."; - - ] - @ - List.flatten - (Schema.fold - (fun acc name def short_descr_opt -> - let var_set s = - Schema.set - schema - env - ~context:OCommandLine - name - s - in - - let arg_name = - OASISUtils.varname_of_string ~hyphen:'-' name - in - - let hlp = - match short_descr_opt with - | Some txt -> txt () - | None -> "" - in - - let arg_hlp = - match def.arg_help with - | Some s -> s - | None -> "str" - in - - let default_value = - try - Printf.sprintf - (f_ " [%s]") - (Schema.get - schema - env - name) - with Not_set _ -> - "" - in - - let args = - match def.cli with - | CLINone -> - [] - | CLIAuto -> - [ - arg_concat "--" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIWith -> - [ - arg_concat "--with-" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIEnable -> - let dflt = - if default_value = " [true]" then - s_ " [default: enabled]" - else - s_ " [default: disabled]" - in - [ - arg_concat "--enable-" arg_name, - Arg.Unit (fun () -> var_set "true"), - Printf.sprintf (f_ " %s%s") hlp dflt; - - arg_concat "--disable-" arg_name, - Arg.Unit (fun () -> var_set "false"), - Printf.sprintf (f_ " %s%s") hlp dflt - ] - | CLIUser lst -> - lst - in - args :: acc) - [] - schema) -end - -module BaseArgExt = struct -(* # 22 "src/base/BaseArgExt.ml" *) - - - open OASISUtils - open OASISGettext - - - let parse argv args = - (* Simulate command line for Arg *) - let current = - ref 0 - in - - try - Arg.parse_argv - ~current:current - (Array.concat [[|"none"|]; argv]) - (Arg.align args) - (failwithf (f_ "Don't know what to do with arguments: '%s'")) - (s_ "configure options:") - with - | Arg.Help txt -> - print_endline txt; - exit 0 - | Arg.Bad txt -> - prerr_endline txt; - exit 1 -end - -module BaseCheck = struct -(* # 22 "src/base/BaseCheck.ml" *) - - - open BaseEnv - open BaseMessage - open OASISUtils - open OASISGettext - - - let prog_best prg prg_lst = - var_redefine - prg - (fun () -> - let alternate = - List.fold_left - (fun res e -> - match res with - | Some _ -> - res - | None -> - try - Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) - with Not_found -> - None) - None - prg_lst - in - match alternate with - | Some prg -> prg - | None -> raise Not_found) - - - let prog prg = - prog_best prg [prg] - - - let prog_opt prg = - prog_best prg [prg^".opt"; prg] - - - let ocamlfind = - prog "ocamlfind" - - - let version - var_prefix - cmp - fversion - () = - (* Really compare version provided *) - let var = - var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) - in - var_redefine - ~hide:true - var - (fun () -> - let version_str = - match fversion () with - | "[Distributed with OCaml]" -> - begin - try - (var_get "ocaml_version") - with Not_found -> - warning - (f_ "Variable ocaml_version not defined, fallback \ - to default"); - Sys.ocaml_version - end - | res -> - res - in - let version = - OASISVersion.version_of_string version_str - in - if OASISVersion.comparator_apply version cmp then - version_str - else - failwithf - (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") - var_prefix - (OASISVersion.string_of_comparator cmp) - version_str) - () - - - let package_version pkg = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%v"; pkg] - - - let package ?version_comparator pkg () = - let var = - OASISUtils.varname_concat - "pkg_" - (OASISUtils.varname_of_string pkg) - in - let findlib_dir pkg = - let dir = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%d"; pkg] - in - if Sys.file_exists dir && Sys.is_directory dir then - dir - else - failwithf - (f_ "When looking for findlib package %s, \ - directory %s return doesn't exist") - pkg dir - in - let vl = - var_redefine - var - (fun () -> findlib_dir pkg) - () - in - ( - match version_comparator with - | Some ver_cmp -> - ignore - (version - var - ver_cmp - (fun _ -> package_version pkg) - ()) - | None -> - () - ); - vl -end - -module BaseOCamlcConfig = struct -(* # 22 "src/base/BaseOCamlcConfig.ml" *) - - - open BaseEnv - open OASISUtils - open OASISGettext - - - module SMap = Map.Make(String) - - - let ocamlc = - BaseCheck.prog_opt "ocamlc" - - - let ocamlc_config_map = - (* Map name to value for ocamlc -config output - (name ^": "^value) - *) - let rec split_field mp lst = - match lst with - | line :: tl -> - let mp = - try - let pos_semicolon = - String.index line ':' - in - if pos_semicolon > 1 then - ( - let name = - String.sub line 0 pos_semicolon - in - let linelen = - String.length line - in - let value = - if linelen > pos_semicolon + 2 then - String.sub - line - (pos_semicolon + 2) - (linelen - pos_semicolon - 2) - else - "" - in - SMap.add name value mp - ) - else - ( - mp - ) - with Not_found -> - ( - mp - ) - in - split_field mp tl - | [] -> - mp - in - - let cache = - lazy - (var_protect - (Marshal.to_string - (split_field - SMap.empty - (OASISExec.run_read_output - ~ctxt:!BaseContext.default - (ocamlc ()) ["-config"])) - [])) - in - var_redefine - "ocamlc_config_map" - ~hide:true - ~dump:false - (fun () -> - (* TODO: update if ocamlc change !!! *) - Lazy.force cache) - - - let var_define nm = - (* Extract data from ocamlc -config *) - let avlbl_config_get () = - Marshal.from_string - (ocamlc_config_map ()) - 0 - in - let chop_version_suffix s = - try - String.sub s 0 (String.index s '+') - with _ -> - s - in - - let nm_config, value_config = - match nm with - | "ocaml_version" -> - "version", chop_version_suffix - | _ -> nm, (fun x -> x) - in - var_redefine - nm - (fun () -> - try - let map = - avlbl_config_get () - in - let value = - SMap.find nm_config map - in - value_config value - with Not_found -> - failwithf - (f_ "Cannot find field '%s' in '%s -config' output") - nm - (ocamlc ())) - -end - -module BaseStandardVar = struct -(* # 22 "src/base/BaseStandardVar.ml" *) - - - open OASISGettext - open OASISTypes - open OASISExpr - open BaseCheck - open BaseEnv - - - let ocamlfind = BaseCheck.ocamlfind - let ocamlc = BaseOCamlcConfig.ocamlc - let ocamlopt = prog_opt "ocamlopt" - let ocamlbuild = prog "ocamlbuild" - - - (**/**) - let rpkg = - ref None - - - let pkg_get () = - match !rpkg with - | Some pkg -> pkg - | None -> failwith (s_ "OASIS Package is not set") - - - let var_cond = ref [] - - - let var_define_cond ~since_version f dflt = - let holder = ref (fun () -> dflt) in - let since_version = - OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) - in - var_cond := - (fun ver -> - if OASISVersion.comparator_apply ver since_version then - holder := f ()) :: !var_cond; - fun () -> !holder () - - - (**/**) - - - let pkg_name = - var_define - ~short_desc:(fun () -> s_ "Package name") - "pkg_name" - (fun () -> (pkg_get ()).name) - - - let pkg_version = - var_define - ~short_desc:(fun () -> s_ "Package version") - "pkg_version" - (fun () -> - (OASISVersion.string_of_version (pkg_get ()).version)) - - - let c = BaseOCamlcConfig.var_define - - - let os_type = c "os_type" - let system = c "system" - let architecture = c "architecture" - let ccomp_type = c "ccomp_type" - let ocaml_version = c "ocaml_version" - - - (* TODO: Check standard variable presence at runtime *) - - - let standard_library_default = c "standard_library_default" - let standard_library = c "standard_library" - let standard_runtime = c "standard_runtime" - let bytecomp_c_compiler = c "bytecomp_c_compiler" - let native_c_compiler = c "native_c_compiler" - let model = c "model" - let ext_obj = c "ext_obj" - let ext_asm = c "ext_asm" - let ext_lib = c "ext_lib" - let ext_dll = c "ext_dll" - let default_executable_name = c "default_executable_name" - let systhread_supported = c "systhread_supported" - - - let flexlink = - BaseCheck.prog "flexlink" - - - let flexdll_version = - var_define - ~short_desc:(fun () -> "FlexDLL version (Win32)") - "flexdll_version" - (fun () -> - let lst = - OASISExec.run_read_output ~ctxt:!BaseContext.default - (flexlink ()) ["-help"] - in - match lst with - | line :: _ -> - Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) - | [] -> - raise Not_found) - - - (**/**) - let p name hlp dflt = - var_define - ~short_desc:hlp - ~cli:CLIAuto - ~arg_help:"dir" - name - dflt - - - let (/) a b = - if os_type () = Sys.os_type then - Filename.concat a b - else if os_type () = "Unix" then - OASISUnixPath.concat a b - else - OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") - (os_type ()) - (**/**) - - - let prefix = - p "prefix" - (fun () -> s_ "Install architecture-independent files dir") - (fun () -> - match os_type () with - | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) - | _ -> - "/usr/local") - - - let exec_prefix = - p "exec_prefix" - (fun () -> s_ "Install architecture-dependent files in dir") - (fun () -> "$prefix") - - - let bindir = - p "bindir" - (fun () -> s_ "User executables") - (fun () -> "$exec_prefix"/"bin") - - - let sbindir = - p "sbindir" - (fun () -> s_ "System admin executables") - (fun () -> "$exec_prefix"/"sbin") - - - let libexecdir = - p "libexecdir" - (fun () -> s_ "Program executables") - (fun () -> "$exec_prefix"/"libexec") - - - let sysconfdir = - p "sysconfdir" - (fun () -> s_ "Read-only single-machine data") - (fun () -> "$prefix"/"etc") - - - let sharedstatedir = - p "sharedstatedir" - (fun () -> s_ "Modifiable architecture-independent data") - (fun () -> "$prefix"/"com") - - - let localstatedir = - p "localstatedir" - (fun () -> s_ "Modifiable single-machine data") - (fun () -> "$prefix"/"var") - - - let libdir = - p "libdir" - (fun () -> s_ "Object code libraries") - (fun () -> "$exec_prefix"/"lib") - - - let datarootdir = - p "datarootdir" - (fun () -> s_ "Read-only arch-independent data root") - (fun () -> "$prefix"/"share") - - - let datadir = - p "datadir" - (fun () -> s_ "Read-only architecture-independent data") - (fun () -> "$datarootdir") - - - let infodir = - p "infodir" - (fun () -> s_ "Info documentation") - (fun () -> "$datarootdir"/"info") - - - let localedir = - p "localedir" - (fun () -> s_ "Locale-dependent data") - (fun () -> "$datarootdir"/"locale") - - - let mandir = - p "mandir" - (fun () -> s_ "Man documentation") - (fun () -> "$datarootdir"/"man") - - - let docdir = - p "docdir" - (fun () -> s_ "Documentation root") - (fun () -> "$datarootdir"/"doc"/"$pkg_name") - - - let htmldir = - p "htmldir" - (fun () -> s_ "HTML documentation") - (fun () -> "$docdir") - - - let dvidir = - p "dvidir" - (fun () -> s_ "DVI documentation") - (fun () -> "$docdir") - - - let pdfdir = - p "pdfdir" - (fun () -> s_ "PDF documentation") - (fun () -> "$docdir") - - - let psdir = - p "psdir" - (fun () -> s_ "PS documentation") - (fun () -> "$docdir") - - - let destdir = - p "destdir" - (fun () -> s_ "Prepend a path when installing package") - (fun () -> - raise - (PropList.Not_set - ("destdir", - Some (s_ "undefined by construct")))) - - - let findlib_version = - var_define - "findlib_version" - (fun () -> - BaseCheck.package_version "findlib") - - - let is_native = - var_define - "is_native" - (fun () -> - try - let _s: string = - ocamlopt () - in - "true" - with PropList.Not_set _ -> - let _s: string = - ocamlc () - in - "false") - - - let ext_program = - var_define - "suffix_program" - (fun () -> - match os_type () with - | "Win32" | "Cygwin" -> ".exe" - | _ -> "") - - - let rm = - var_define - ~short_desc:(fun () -> s_ "Remove a file.") - "rm" - (fun () -> - match os_type () with - | "Win32" -> "del" - | _ -> "rm -f") - - - let rmdir = - var_define - ~short_desc:(fun () -> s_ "Remove a directory.") - "rmdir" - (fun () -> - match os_type () with - | "Win32" -> "rd" - | _ -> "rm -rf") - - - let debug = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") - ~cli:CLIEnable - "debug" - (fun () -> "true") - - - let profile = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") - ~cli:CLIEnable - "profile" - (fun () -> "false") - - - let tests = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> - s_ "Compile tests executable and library and run them") - ~cli:CLIEnable - "tests" - (fun () -> "false")) - "true" - - - let docs = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> s_ "Create documentations") - ~cli:CLIEnable - "docs" - (fun () -> "true")) - "true" - - - let native_dynlink = - var_define - ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") - ~cli:CLINone - "native_dynlink" - (fun () -> - let res = - let ocaml_lt_312 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "3.12.0")) - in - let flexdll_lt_030 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (flexdll_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "0.30")) - in - let has_native_dynlink = - let ocamlfind = ocamlfind () in - try - let fn = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ocamlfind - ["query"; "-predicates"; "native"; "dynlink"; - "-format"; "%d/%a"] - in - Sys.file_exists fn - with _ -> - false - in - if not has_native_dynlink then - false - else if ocaml_lt_312 () then - false - else if (os_type () = "Win32" || os_type () = "Cygwin") - && flexdll_lt_030 () then - begin - BaseMessage.warning - (f_ ".cmxs generation disabled because FlexDLL needs to be \ - at least 0.30. Please upgrade FlexDLL from %s to 0.30.") - (flexdll_version ()); - false - end - else - true - in - string_of_bool res) - - - let init pkg = - rpkg := Some pkg; - List.iter (fun f -> f pkg.oasis_version) !var_cond - -end - -module BaseFileAB = struct -(* # 22 "src/base/BaseFileAB.ml" *) - - - open BaseEnv - open OASISGettext - open BaseMessage - - - let to_filename fn = - let fn = - OASISHostPath.of_unix fn - in - if not (Filename.check_suffix fn ".ab") then - warning - (f_ "File '%s' doesn't have '.ab' extension") - fn; - Filename.chop_extension fn - - - let replace fn_lst = - let buff = - Buffer.create 13 - in - List.iter - (fun fn -> - let fn = - OASISHostPath.of_unix fn - in - let chn_in = - open_in fn - in - let chn_out = - open_out (to_filename fn) - in - ( - try - while true do - Buffer.add_string buff (var_expand (input_line chn_in)); - Buffer.add_char buff '\n' - done - with End_of_file -> - () - ); - Buffer.output_buffer chn_out buff; - Buffer.clear buff; - close_in chn_in; - close_out chn_out) - fn_lst -end - -module BaseLog = struct -(* # 22 "src/base/BaseLog.ml" *) - - - open OASISUtils - - - let default_filename = - Filename.concat - (Filename.dirname BaseEnv.default_filename) - "setup.log" - - - module SetTupleString = - Set.Make - (struct - type t = string * string - let compare (s11, s12) (s21, s22) = - match String.compare s11 s21 with - | 0 -> String.compare s12 s22 - | n -> n - end) - - - let load () = - if Sys.file_exists default_filename then - begin - let chn = - open_in default_filename - in - let scbuf = - Scanf.Scanning.from_file default_filename - in - let rec read_aux (st, lst) = - if not (Scanf.Scanning.end_of_input scbuf) then - begin - let acc = - try - Scanf.bscanf scbuf "%S %S\n" - (fun e d -> - let t = - e, d - in - if SetTupleString.mem t st then - st, lst - else - SetTupleString.add t st, - t :: lst) - with Scanf.Scan_failure _ -> - failwith - (Scanf.bscanf scbuf - "%l" - (fun line -> - Printf.sprintf - "Malformed log file '%s' at line %d" - default_filename - line)) - in - read_aux acc - end - else - begin - close_in chn; - List.rev lst - end - in - read_aux (SetTupleString.empty, []) - end - else - begin - [] - end - - - let register event data = - let chn_out = - open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename - in - Printf.fprintf chn_out "%S %S\n" event data; - close_out chn_out - - - let unregister event data = - if Sys.file_exists default_filename then - begin - let lst = - load () - in - let chn_out = - open_out default_filename - in - let write_something = - ref false - in - List.iter - (fun (e, d) -> - if e <> event || d <> data then - begin - write_something := true; - Printf.fprintf chn_out "%S %S\n" e d - end) - lst; - close_out chn_out; - if not !write_something then - Sys.remove default_filename - end - - - let filter events = - let st_events = - List.fold_left - (fun st e -> - SetString.add e st) - SetString.empty - events - in - List.filter - (fun (e, _) -> SetString.mem e st_events) - (load ()) - - - let exists event data = - List.exists - (fun v -> (event, data) = v) - (load ()) -end - -module BaseBuilt = struct -(* # 22 "src/base/BaseBuilt.ml" *) - - - open OASISTypes - open OASISGettext - open BaseStandardVar - open BaseMessage - - - type t = - | BExec (* Executable *) - | BExecLib (* Library coming with executable *) - | BLib (* Library *) - | BObj (* Library *) - | BDoc (* Document *) - - - let to_log_event_file t nm = - "built_"^ - (match t with - | BExec -> "exec" - | BExecLib -> "exec_lib" - | BLib -> "lib" - | BObj -> "obj" - | BDoc -> "doc")^ - "_"^nm - - - let to_log_event_done t nm = - "is_"^(to_log_event_file t nm) - - - let register t nm lst = - BaseLog.register - (to_log_event_done t nm) - "true"; - List.iter - (fun alt -> - let registered = - List.fold_left - (fun registered fn -> - if OASISFileUtil.file_exists_case fn then - begin - BaseLog.register - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end - else - registered) - false - alt - in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) - lst - - - let unregister t nm = - List.iter - (fun (e, d) -> - BaseLog.unregister e d) - (BaseLog.filter - [to_log_event_file t nm; - to_log_event_done t nm]) - - - let fold t nm f acc = - List.fold_left - (fun acc (_, fn) -> - if OASISFileUtil.file_exists_case fn then - begin - f acc fn - end - else - begin - warning - (f_ "File '%s' has been marked as built \ - for %s but doesn't exist") - fn - (Printf.sprintf - (match t with - | BExec | BExecLib -> - (f_ "executable %s") - | BLib -> - (f_ "library %s") - | BObj -> - (f_ "object %s") - | BDoc -> - (f_ "documentation %s")) - nm); - acc - end) - acc - (BaseLog.filter - [to_log_event_file t nm]) - - - let is_built t nm = - List.fold_left - (fun is_built (_, d) -> - (try - bool_of_string d - with _ -> - false)) - false - (BaseLog.filter - [to_log_event_done t nm]) - - - let of_executable ffn (cs, bs, exec) = - let unix_exec_is, unix_dll_opt = - OASISExecutable.unix_exec_is - (cs, bs, exec) - (fun () -> - bool_of_string - (is_native ())) - ext_dll - ext_program - in - let evs = - (BExec, cs.cs_name, [[ffn unix_exec_is]]) - :: - (match unix_dll_opt with - | Some fn -> - [BExecLib, cs.cs_name, [[ffn fn]]] - | None -> - []) - in - evs, - unix_exec_is, - unix_dll_opt - - - let of_library ffn (cs, bs, lib) = - let unix_lst = - OASISLibrary.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - ~has_native_dynlink:(bool_of_string (native_dynlink ())) - ~ext_lib:(ext_lib ()) - ~ext_dll:(ext_dll ()) - (cs, bs, lib) - in - let evs = - [BLib, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - - - let of_object ffn (cs, bs, obj) = - let unix_lst = - OASISObject.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - (cs, bs, obj) - in - let evs = - [BObj, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - -end - -module BaseCustom = struct -(* # 22 "src/base/BaseCustom.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let run cmd args extra_args = - OASISExec.run ~ctxt:!BaseContext.default ~quote:false - (var_expand cmd) - (List.map - var_expand - (args @ (Array.to_list extra_args))) - - - let hook ?(failsafe=false) cstm f e = - let optional_command lst = - let printer = - function - | Some (cmd, args) -> String.concat " " (cmd :: args) - | None -> s_ "No command" - in - match - var_choose - ~name:(s_ "Pre/Post Command") - ~printer - lst with - | Some (cmd, args) -> - begin - try - run cmd args [||] - with e when failsafe -> - warning - (f_ "Command '%s' fail with error: %s") - (String.concat " " (cmd :: args)) - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - end - | None -> - () - in - let res = - optional_command cstm.pre_command; - f e - in - optional_command cstm.post_command; - res -end - -module BaseDynVar = struct -(* # 22 "src/base/BaseDynVar.ml" *) - - - open OASISTypes - open OASISGettext - open BaseEnv - open BaseBuilt - - - let init pkg = - (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) - (* TODO: provide compile option for library libary_byte_args_VARNAME... *) - List.iter - (function - | Executable (cs, bs, exec) -> - if var_choose bs.bs_build then - var_ignore - (var_redefine - (* We don't save this variable *) - ~dump:false - ~short_desc:(fun () -> - Printf.sprintf - (f_ "Filename of executable '%s'") - cs.cs_name) - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - let fn_opt = - fold - BExec cs.cs_name - (fun _ fn -> Some fn) - None - in - match fn_opt with - | Some fn -> fn - | None -> - raise - (PropList.Not_set - (cs.cs_name, - Some (Printf.sprintf - (f_ "Executable '%s' not yet built.") - cs.cs_name))))) - - | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> - ()) - pkg.sections -end - -module BaseTest = struct -(* # 22 "src/base/BaseTest.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISExpr - open OASISGettext - - - let test lst pkg extra_args = - - let one_test (failure, n) (test_plugin, cs, test) = - if var_choose - ~name:(Printf.sprintf - (f_ "test %s run") - cs.cs_name) - ~printer:string_of_bool - test.test_run then - begin - let () = - info (f_ "Running test '%s'") cs.cs_name - in - let back_cwd = - match test.test_working_directory with - | Some dir -> - let cwd = - Sys.getcwd () - in - let chdir d = - info (f_ "Changing directory to '%s'") d; - Sys.chdir d - in - chdir dir; - fun () -> chdir cwd - - | None -> - fun () -> () - in - try - let failure_percent = - BaseCustom.hook - test.test_custom - (test_plugin pkg (cs, test)) - extra_args - in - back_cwd (); - (failure_percent +. failure, n + 1) - with e -> - begin - back_cwd (); - raise e - end - end - else - begin - info (f_ "Skipping test '%s'") cs.cs_name; - (failure, n) - end - in - let failed, n = - List.fold_left - one_test - (0.0, 0) - lst - in - let failure_percent = - if n = 0 then - 0.0 - else - failed /. (float_of_int n) - in - let msg = - Printf.sprintf - (f_ "Tests had a %.2f%% failure rate") - (100. *. failure_percent) - in - if failure_percent > 0.0 then - failwith msg - else - info "%s" msg; - - (* Possible explanation why the tests where not run. *) - if OASISFeatures.package_test OASISFeatures.flag_tests pkg && - not (bool_of_string (BaseStandardVar.tests ())) && - lst <> [] then - BaseMessage.warning - "Tests are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-tests'" -end - -module BaseDoc = struct -(* # 22 "src/base/BaseDoc.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let doc lst pkg extra_args = - - let one_doc (doc_plugin, cs, doc) = - if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") - cs.cs_name) - ~printer:string_of_bool - doc.doc_build then - begin - info (f_ "Building documentation '%s'") cs.cs_name; - BaseCustom.hook - doc.doc_custom - (doc_plugin pkg (cs, doc)) - extra_args - end - in - List.iter one_doc lst; - - if OASISFeatures.package_test OASISFeatures.flag_docs pkg && - not (bool_of_string (BaseStandardVar.docs ())) && - lst <> [] then - BaseMessage.warning - "Docs are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-docs'" -end - -module BaseSetup = struct -(* # 22 "src/base/BaseSetup.ml" *) - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISSection - open OASISGettext - open OASISUtils - - - type std_args_fun = - package -> string array -> unit - - - type ('a, 'b) section_args_fun = - name * (package -> (common_section * 'a) -> string array -> 'b) - - - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } - - - (* Associate a plugin function with data from package *) - let join_plugin_sections filter_map lst = - List.rev - (List.fold_left - (fun acc sct -> - match filter_map sct with - | Some e -> - e :: acc - | None -> - acc) - [] - lst) - - - (* Search for plugin data associated with a section name *) - let lookup_plugin_section plugin action nm lst = - try - List.assoc nm lst - with Not_found -> - failwithf - (f_ "Cannot find plugin %s matching section %s for %s action") - plugin - nm - action - - - let configure t args = - (* Run configure *) - BaseCustom.hook - t.package.conf_custom - (fun () -> - (* Reload if preconf has changed it *) - begin - try - unload (); - load (); - with _ -> - () - end; - - (* Run plugin's configure *) - t.configure t.package args; - - (* Dump to allow postconf to change it *) - dump ()) - (); - - (* Reload environment *) - unload (); - load (); - - (* Save environment *) - print (); - - (* Replace data in file *) - BaseFileAB.replace t.package.files_ab - - - let build t args = - BaseCustom.hook - t.package.build_custom - (t.build t.package) - args - - - let doc t args = - BaseDoc.doc - (join_plugin_sections - (function - | Doc (cs, e) -> - Some - (lookup_plugin_section - "documentation" - (s_ "build") - cs.cs_name - t.doc, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let test t args = - BaseTest.test - (join_plugin_sections - (function - | Test (cs, e) -> - Some - (lookup_plugin_section - "test" - (s_ "run") - cs.cs_name - t.test, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let all t args = - let rno_doc = - ref false - in - let rno_test = - ref false - in - let arg_rest = - ref [] - in - Arg.parse_argv - ~current:(ref 0) - (Array.of_list - ((Sys.executable_name^" all") :: - (Array.to_list args))) - [ - "-no-doc", - Arg.Set rno_doc, - s_ "Don't run doc target"; - - "-no-test", - Arg.Set rno_test, - s_ "Don't run test target"; - - "--", - Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), - s_ "All arguments for configure."; - ] - (failwithf (f_ "Don't know what to do with '%s'")) - ""; - - info "Running configure step"; - configure t (Array.of_list (List.rev !arg_rest)); - - info "Running build step"; - build t [||]; - - (* Load setup.log dynamic variables *) - BaseDynVar.init t.package; - - if not !rno_doc then - begin - info "Running doc step"; - doc t [||]; - end - else - begin - info "Skipping doc step" - end; - - if not !rno_test then - begin - info "Running test step"; - test t [||] - end - else - begin - info "Skipping test step" - end - - - let install t args = - BaseCustom.hook - t.package.install_custom - (t.install t.package) - args - - - let uninstall t args = - BaseCustom.hook - t.package.uninstall_custom - (t.uninstall t.package) - args - - - let reinstall t args = - uninstall t args; - install t args - - - let clean, distclean = - let failsafe f a = - try - f a - with e -> - warning - (f_ "Action fail with error: %s") - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - in - - let generic_clean t cstm mains docs tests args = - BaseCustom.hook - ~failsafe:true - cstm - (fun () -> - (* Clean section *) - List.iter - (function - | Test (cs, test) -> - let f = - try - List.assoc cs.cs_name tests - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, test)) - args - | Doc (cs, doc) -> - let f = - try - List.assoc cs.cs_name docs - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, doc)) - args - | Library _ - | Object _ - | Executable _ - | Flag _ - | SrcRepo _ -> - ()) - t.package.sections; - (* Clean whole package *) - List.iter - (fun f -> - failsafe - (f t.package) - args) - mains) - () - in - - let clean t args = - generic_clean - t - t.package.clean_custom - t.clean - t.clean_doc - t.clean_test - args - in - - let distclean t args = - (* Call clean *) - clean t args; - - (* Call distclean code *) - generic_clean - t - t.package.distclean_custom - t.distclean - t.distclean_doc - t.distclean_test - args; - - (* Remove generated file *) - List.iter - (fun fn -> - if Sys.file_exists fn then - begin - info (f_ "Remove '%s'") fn; - Sys.remove fn - end) - (BaseEnv.default_filename - :: - BaseLog.default_filename - :: - (List.rev_map BaseFileAB.to_filename t.package.files_ab)) - in - - clean, distclean - - - let version t _ = - print_endline t.oasis_version - - - let update_setup_ml, no_update_setup_ml_cli = - let b = ref true in - b, - ("-no-update-setup-ml", - Arg.Clear b, - s_ " Don't try to update setup.ml, even if _oasis has changed.") - - - let default_oasis_fn = "_oasis" - - - let update_setup_ml t = - let oasis_fn = - match t.oasis_fn with - | Some fn -> fn - | None -> default_oasis_fn - in - let oasis_exec = - match t.oasis_exec with - | Some fn -> fn - | None -> "oasis" - in - let ocaml = - Sys.executable_name - in - let setup_ml, args = - match Array.to_list Sys.argv with - | setup_ml :: args -> - setup_ml, args - | [] -> - failwith - (s_ "Expecting non-empty command line arguments.") - in - let ocaml, setup_ml = - if Sys.executable_name = Sys.argv.(0) then - (* We are not running in standard mode, probably the script - * is precompiled. - *) - "ocaml", "setup.ml" - else - ocaml, setup_ml - in - let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in - let do_update () = - let oasis_exec_version = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | 1 -> - failwithf - (f_ "Executable '%s' is probably an old version \ - of oasis (< 0.3.0), please update to version \ - v%s.") - oasis_exec t.oasis_version - | 127 -> - failwithf - (f_ "Cannot find executable '%s', please install \ - oasis v%s.") - oasis_exec t.oasis_version - | n -> - failwithf - (f_ "Command '%s version' exited with code %d.") - oasis_exec n) - oasis_exec ["version"] - in - if OASISVersion.comparator_apply - (OASISVersion.version_of_string oasis_exec_version) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string t.oasis_version)) then - begin - (* We have a version >= for the executable oasis, proceed with - * update. - *) - (* TODO: delegate this check to 'oasis setup'. *) - if Sys.os_type = "Win32" then - failwithf - (f_ "It is not possible to update the running script \ - setup.ml on Windows. Please update setup.ml by \ - running '%s'.") - (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) - else - begin - OASISExec.run - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | n -> - failwithf - (f_ "Unable to update setup.ml using '%s', \ - please fix the problem and retry.") - oasis_exec) - oasis_exec ("setup" :: t.oasis_setup_args); - OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) - end - end - else - failwithf - (f_ "The version of '%s' (v%s) doesn't match the version of \ - oasis used to generate the %s file. Please install at \ - least oasis v%s.") - oasis_exec oasis_exec_version setup_ml t.oasis_version - in - - if !update_setup_ml then - begin - try - match t.oasis_digest with - | Some dgst -> - if Sys.file_exists oasis_fn && - dgst <> Digest.file default_oasis_fn then - begin - do_update (); - true - end - else - false - | None -> - false - with e -> - error - (f_ "Error when updating setup.ml. If you want to avoid this error, \ - you can bypass the update of %s by running '%s %s %s %s'") - setup_ml ocaml setup_ml no_update_setup_ml_cli - (String.concat " " args); - raise e - end - else - false - - - let setup t = - let catch_exn = - ref true - in - try - let act_ref = - ref (fun _ -> - failwithf - (f_ "No action defined, run '%s %s -help'") - Sys.executable_name - Sys.argv.(0)) - - in - let extra_args_ref = - ref [] - in - let allow_empty_env_ref = - ref false - in - let arg_handle ?(allow_empty_env=false) act = - Arg.Tuple - [ - Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); - - Arg.Unit - (fun () -> - allow_empty_env_ref := allow_empty_env; - act_ref := act); - ] - in - - Arg.parse - (Arg.align - ([ - "-configure", - arg_handle ~allow_empty_env:true configure, - s_ "[options*] Configure the whole build process."; - - "-build", - arg_handle build, - s_ "[options*] Build executables and libraries."; - - "-doc", - arg_handle doc, - s_ "[options*] Build documents."; - - "-test", - arg_handle test, - s_ "[options*] Run tests."; - - "-all", - arg_handle ~allow_empty_env:true all, - s_ "[options*] Run configure, build, doc and test targets."; - - "-install", - arg_handle install, - s_ "[options*] Install libraries, data, executables \ - and documents."; - - "-uninstall", - arg_handle uninstall, - s_ "[options*] Uninstall libraries, data, executables \ - and documents."; - - "-reinstall", - arg_handle reinstall, - s_ "[options*] Uninstall and install libraries, data, \ - executables and documents."; - - "-clean", - arg_handle ~allow_empty_env:true clean, - s_ "[options*] Clean files generated by a build."; - - "-distclean", - arg_handle ~allow_empty_env:true distclean, - s_ "[options*] Clean files generated by a build and configure."; - - "-version", - arg_handle ~allow_empty_env:true version, - s_ " Display version of OASIS used to generate this setup.ml."; - - "-no-catch-exn", - Arg.Clear catch_exn, - s_ " Don't catch exception, useful for debugging."; - ] - @ - (if t.setup_update then - [no_update_setup_ml_cli] - else - []) - @ (BaseContext.args ()))) - (failwithf (f_ "Don't know what to do with '%s'")) - (s_ "Setup and run build process current package\n"); - - (* Build initial environment *) - load ~allow_empty:!allow_empty_env_ref (); - - (** Initialize flags *) - List.iter - (function - | Flag (cs, {flag_description = hlp; - flag_default = choices}) -> - begin - let apply ?short_desc () = - var_ignore - (var_define - ~cli:CLIEnable - ?short_desc - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - string_of_bool - (var_choose - ~name:(Printf.sprintf - (f_ "default value of flag %s") - cs.cs_name) - ~printer:string_of_bool - choices))) - in - match hlp with - | Some hlp -> - apply ~short_desc:(fun () -> hlp) () - | None -> - apply () - end - | _ -> - ()) - t.package.sections; - - BaseStandardVar.init t.package; - - BaseDynVar.init t.package; - - if t.setup_update && update_setup_ml t then - () - else - !act_ref t (Array.of_list (List.rev !extra_args_ref)) - - with e when !catch_exn -> - error "%s" (Printexc.to_string e); - exit 1 - - -end - - -# 5394 "setup.ml" -module InternalConfigurePlugin = struct -(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) - - - (** Configure using internal scheme - @author Sylvain Le Gall - *) - - - open BaseEnv - open OASISTypes - open OASISUtils - open OASISGettext - open BaseMessage - - - (** Configure build using provided series of check to be done - * and then output corresponding file. - *) - let configure pkg argv = - let var_ignore_eval var = let _s: string = var () in () in - let errors = ref SetString.empty in - let buff = Buffer.create 13 in - - let add_errors fmt = - Printf.kbprintf - (fun b -> - errors := SetString.add (Buffer.contents b) !errors; - Buffer.clear b) - buff - fmt - in - - let warn_exception e = - warning "%s" (Printexc.to_string e) - in - - (* Check tools *) - let check_tools lst = - List.iter - (function - | ExternalTool tool -> - begin - try - var_ignore_eval (BaseCheck.prog tool) - with e -> - warn_exception e; - add_errors (f_ "Cannot find external tool '%s'") tool - end - | InternalExecutable nm1 -> - (* Check that matching tool is built *) - List.iter - (function - | Executable ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal executable \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - lst - in - - let build_checks sct bs = - if var_choose bs.bs_build then - begin - if bs.bs_compiled_object = Native then - begin - try - var_ignore_eval BaseStandardVar.ocamlopt - with e -> - warn_exception e; - add_errors - (f_ "Section %s requires native compilation") - (OASISSection.string_of_section sct) - end; - - (* Check tools *) - check_tools bs.bs_build_tools; - - (* Check depends *) - List.iter - (function - | FindlibPackage (findlib_pkg, version_comparator) -> - begin - try - var_ignore_eval - (BaseCheck.package ?version_comparator findlib_pkg) - with e -> - warn_exception e; - match version_comparator with - | None -> - add_errors - (f_ "Cannot find findlib package %s") - findlib_pkg - | Some ver_cmp -> - add_errors - (f_ "Cannot find findlib package %s (%s)") - findlib_pkg - (OASISVersion.string_of_comparator ver_cmp) - end - | InternalLibrary nm1 -> - (* Check that matching library is built *) - List.iter - (function - | Library ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal library \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - bs.bs_build_depends - end - in - - (* Parse command line *) - BaseArgExt.parse argv (BaseEnv.args ()); - - (* OCaml version *) - begin - match pkg.ocaml_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "ocaml" - ver_cmp - BaseStandardVar.ocaml_version) - with e -> - warn_exception e; - add_errors - (f_ "OCaml version %s doesn't match version constraint %s") - (BaseStandardVar.ocaml_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* Findlib version *) - begin - match pkg.findlib_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "findlib" - ver_cmp - BaseStandardVar.findlib_version) - with e -> - warn_exception e; - add_errors - (f_ "Findlib version %s doesn't match version constraint %s") - (BaseStandardVar.findlib_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - (* Make sure the findlib version is fine for the OCaml compiler. *) - begin - let ocaml_ge4 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) - (OASISVersion.version_of_string "4.0.0") >= 0 in - if ocaml_ge4 then - let findlib_lt132 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) - (OASISVersion.version_of_string "1.3.2") < 0 in - if findlib_lt132 then - add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" - end; - - (* FlexDLL *) - if BaseStandardVar.os_type () = "Win32" || - BaseStandardVar.os_type () = "Cygwin" then - begin - try - var_ignore_eval BaseStandardVar.flexlink - with e -> - warn_exception e; - add_errors (f_ "Cannot find 'flexlink'") - end; - - (* Check build depends *) - List.iter - (function - | Executable (_, bs, _) - | Library (_, bs, _) as sct -> - build_checks sct bs - | Doc (_, doc) -> - if var_choose doc.doc_build then - check_tools doc.doc_build_tools - | Test (_, test) -> - if var_choose test.test_run then - check_tools test.test_tools - | _ -> - ()) - pkg.sections; - - (* Check if we need native dynlink (presence of libraries that compile to - * native) - *) - begin - let has_cmxa = - List.exists - (function - | Library (_, bs, _) -> - var_choose bs.bs_build && - (bs.bs_compiled_object = Native || - (bs.bs_compiled_object = Best && - bool_of_string (BaseStandardVar.is_native ()))) - | _ -> - false) - pkg.sections - in - if has_cmxa then - var_ignore_eval BaseStandardVar.native_dynlink - end; - - (* Check errors *) - if SetString.empty != !errors then - begin - List.iter - (fun e -> error "%s" e) - (SetString.elements !errors); - failwithf - (fn_ - "%d configuration error" - "%d configuration errors" - (SetString.cardinal !errors)) - (SetString.cardinal !errors) - end - - -end - -module InternalInstallPlugin = struct -(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) - - - (** Install using internal scheme - @author Sylvain Le Gall - *) - - - open BaseEnv - open BaseStandardVar - open BaseMessage - open OASISTypes - open OASISFindlib - open OASISGettext - open OASISUtils - - - let exec_hook = - ref (fun (cs, bs, exec) -> cs, bs, exec) - - - let lib_hook = - ref (fun (cs, bs, lib) -> cs, bs, lib, []) - - - let obj_hook = - ref (fun (cs, bs, obj) -> cs, bs, obj, []) - - - let doc_hook = - ref (fun (cs, doc) -> cs, doc) - - - let install_file_ev = - "install-file" - - - let install_dir_ev = - "install-dir" - - - let install_findlib_ev = - "install-findlib" - - - let win32_max_command_line_length = 8000 - - - let split_install_command ocamlfind findlib_name meta files = - if Sys.os_type = "Win32" then - (* Arguments for the first command: *) - let first_args = ["install"; findlib_name; meta] in - (* Arguments for remaining commands: *) - let other_args = ["install"; findlib_name; "-add"] in - (* Extract as much files as possible from [files], [len] is - the current command line length: *) - let rec get_files len acc files = - match files with - | [] -> - (List.rev acc, []) - | file :: rest -> - let len = len + 1 + String.length file in - if len > win32_max_command_line_length then - (List.rev acc, files) - else - get_files len (file :: acc) rest - in - (* Split the command into several commands. *) - let rec split args files = - match files with - | [] -> - [] - | _ -> - (* Length of "ocamlfind install [META|-add]" *) - let len = - List.fold_left - (fun len arg -> - len + 1 (* for the space *) + String.length arg) - (String.length ocamlfind) - args - in - match get_files len [] files with - | ([], _) -> - failwith (s_ "Command line too long.") - | (firsts, others) -> - let cmd = args @ firsts in - (* Use -add for remaining commands: *) - let () = - let findlib_ge_132 = - OASISVersion.comparator_apply - (OASISVersion.version_of_string - (BaseStandardVar.findlib_version ())) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string "1.3.2")) - in - if not findlib_ge_132 then - failwithf - (f_ "Installing the library %s require to use the \ - flag '-add' of ocamlfind because the command \ - line is too long. This flag is only available \ - for findlib 1.3.2. Please upgrade findlib from \ - %s to 1.3.2") - findlib_name (BaseStandardVar.findlib_version ()) - in - let cmds = split other_args others in - cmd :: cmds - in - (* The first command does not use -add: *) - split first_args files - else - ["install" :: findlib_name :: meta :: files] - - - let install pkg argv = - - let in_destdir = - try - let destdir = - destdir () - in - (* Practically speaking destdir is prepended - * at the beginning of the target filename - *) - fun fn -> destdir^fn - with PropList.Not_set _ -> - fun fn -> fn - in - - let install_file ?tgt_fn src_file envdir = - let tgt_dir = - in_destdir (envdir ()) - in - let tgt_file = - Filename.concat - tgt_dir - (match tgt_fn with - | Some fn -> - fn - | None -> - Filename.basename src_file) - in - (* Create target directory if needed *) - OASISFileUtil.mkdir_parent - ~ctxt:!BaseContext.default - (fun dn -> - info (f_ "Creating directory '%s'") dn; - BaseLog.register install_dir_ev dn) - tgt_dir; - - (* Really install files *) - info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; - BaseLog.register install_file_ev tgt_file - in - - (* Install data into defined directory *) - let install_data srcdir lst tgtdir = - let tgtdir = - OASISHostPath.of_unix (var_expand tgtdir) - in - List.iter - (fun (src, tgt_opt) -> - let real_srcs = - OASISFileUtil.glob - ~ctxt:!BaseContext.default - (Filename.concat srcdir src) - in - if real_srcs = [] then - failwithf - (f_ "Wildcard '%s' doesn't match any files") - src; - List.iter - (fun fn -> - install_file - fn - (fun () -> - match tgt_opt with - | Some s -> - OASISHostPath.of_unix (var_expand s) - | None -> - tgtdir)) - real_srcs) - lst - in - - (** Install all libraries *) - let install_libs pkg = - - let files_of_library (f_data, acc) data_lib = - let cs, bs, lib, lib_extra = - !lib_hook data_lib - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then - begin - let acc = - (* Start with acc + lib_extra *) - List.rev_append lib_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - OASISHostPath.of_unix bs.bs_path - in - List.fold_left - (fun acc modul -> - try - List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - String.uncapitalize modul^".mli"; - String.capitalize modul^".mli"; - String.uncapitalize modul^".ml"; - String.capitalize modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - acc - end) - acc - lib.lib_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the library *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - and files_of_object (f_data, acc) data_obj = - let cs, bs, obj, obj_extra = - !obj_hook data_obj - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then - begin - let acc = - (* Start with acc + obj_extra *) - List.rev_append obj_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - OASISHostPath.of_unix bs.bs_path - in - List.fold_left - (fun acc modul -> - try - List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - String.uncapitalize modul^".mli"; - String.capitalize modul^".mli"; - String.uncapitalize modul^".ml"; - String.capitalize modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - acc - end) - acc - obj.obj_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BObj - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the object *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - - in - - (* Install one group of library *) - let install_group_lib grp = - (* Iterate through all group nodes *) - let rec install_group_lib_aux data_and_files grp = - let data_and_files, children = - match grp with - | Container (_, children) -> - data_and_files, children - | Package (_, cs, bs, `Library lib, children) -> - files_of_library data_and_files (cs, bs, lib), children - | Package (_, cs, bs, `Object obj, children) -> - files_of_object data_and_files (cs, bs, obj), children - in - List.fold_left - install_group_lib_aux - data_and_files - children - in - - (* Findlib name of the root library *) - let findlib_name = - findlib_of_group grp - in - - (* Determine root library *) - let root_lib = - root_of_group grp - in - - (* All files to install for this library *) - let f_data, files = - install_group_lib_aux (ignore, []) grp - in - - (* Really install, if there is something to install *) - if files = [] then - begin - warning - (f_ "Nothing to install for findlib library '%s'") - findlib_name - end - else - begin - let meta = - (* Search META file *) - let _, bs, _ = - root_lib - in - let res = - Filename.concat bs.bs_path "META" - in - if not (OASISFileUtil.file_exists_case res) then - failwithf - (f_ "Cannot find file '%s' for findlib library %s") - res - findlib_name; - res - in - let files = - (* Make filename shorter to avoid hitting command max line length - * too early, esp. on Windows. - *) - let remove_prefix p n = - let plen = String.length p in - let nlen = String.length n in - if plen <= nlen && String.sub n 0 plen = p then - begin - let fn_sep = - if Sys.os_type = "Win32" then - '\\' - else - '/' - in - let cutpoint = plen + - (if plen < nlen && n.[plen] = fn_sep then - 1 - else - 0) - in - String.sub n cutpoint (nlen - cutpoint) - end - else - n - in - List.map (remove_prefix (Sys.getcwd ())) files - in - info - (f_ "Installing findlib library '%s'") - findlib_name; - let ocamlfind = ocamlfind () in - let commands = - split_install_command - ocamlfind - findlib_name - meta - files - in - List.iter - (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) - commands; - BaseLog.register install_findlib_ev findlib_name - end; - - (* Install data files *) - f_data (); - - in - - let group_libs, _, _ = - findlib_mapping pkg - in - - (* We install libraries in groups *) - List.iter install_group_lib group_libs - in - - let install_execs pkg = - let install_exec data_exec = - let cs, bs, exec = - !exec_hook data_exec - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then - begin - let exec_libdir () = - Filename.concat - (libdir ()) - pkg.name - in - BaseBuilt.fold - BaseBuilt.BExec - cs.cs_name - (fun () fn -> - install_file - ~tgt_fn:(cs.cs_name ^ ext_program ()) - fn - bindir) - (); - BaseBuilt.fold - BaseBuilt.BExecLib - cs.cs_name - (fun () fn -> - install_file - fn - exec_libdir) - (); - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name) - end - in - List.iter - (function - | Executable (cs, bs, exec)-> - install_exec (cs, bs, exec) - | _ -> - ()) - pkg.sections - in - - let install_docs pkg = - let install_doc data = - let cs, doc = - !doc_hook data - in - if var_choose doc.doc_install && - BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then - begin - let tgt_dir = - OASISHostPath.of_unix (var_expand doc.doc_install_dir) - in - BaseBuilt.fold - BaseBuilt.BDoc - cs.cs_name - (fun () fn -> - install_file - fn - (fun () -> tgt_dir)) - (); - install_data - Filename.current_dir_name - doc.doc_data_files - doc.doc_install_dir - end - in - List.iter - (function - | Doc (cs, doc) -> - install_doc (cs, doc) - | _ -> - ()) - pkg.sections - in - - install_libs pkg; - install_execs pkg; - install_docs pkg - - - (* Uninstall already installed data *) - let uninstall _ argv = - List.iter - (fun (ev, data) -> - if ev = install_file_ev then - begin - if OASISFileUtil.file_exists_case data then - begin - info - (f_ "Removing file '%s'") - data; - Sys.remove data - end - else - begin - warning - (f_ "File '%s' doesn't exist anymore") - data - end - end - else if ev = install_dir_ev then - begin - if Sys.file_exists data && Sys.is_directory data then - begin - if Sys.readdir data = [||] then - begin - info - (f_ "Removing directory '%s'") - data; - OASISFileUtil.rmdir ~ctxt:!BaseContext.default data - end - else - begin - warning - (f_ "Directory '%s' is not empty (%s)") - data - (String.concat - ", " - (Array.to_list - (Sys.readdir data))) - end - end - else - begin - warning - (f_ "Directory '%s' doesn't exist anymore") - data - end - end - else if ev = install_findlib_ev then - begin - info (f_ "Removing findlib library '%s'") data; - OASISExec.run ~ctxt:!BaseContext.default - (ocamlfind ()) ["remove"; data] - end - else - failwithf (f_ "Unknown log event '%s'") ev; - BaseLog.unregister ev data) - (* We process event in reverse order *) - (List.rev - (BaseLog.filter - [install_file_ev; - install_dir_ev; - install_findlib_ev])) - - -end - - -# 6243 "setup.ml" -module OCamlbuildCommon = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) - - - (** Functions common to OCamlbuild build and doc plugin - *) - - - open OASISGettext - open BaseEnv - open BaseStandardVar - open OASISTypes - - - - - type extra_args = string list - - - let ocamlbuild_clean_ev = "ocamlbuild-clean" - - - let ocamlbuildflags = - var_define - ~short_desc:(fun () -> "OCamlbuild additional flags") - "ocamlbuildflags" - (fun () -> "") - - - (** Fix special arguments depending on environment *) - let fix_args args extra_argv = - List.flatten - [ - if (os_type ()) = "Win32" then - [ - "-classic-display"; - "-no-log"; - "-no-links"; - "-install-lib-dir"; - (Filename.concat (standard_library ()) "ocamlbuild") - ] - else - []; - - if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then - [ - "-byte-plugin" - ] - else - []; - args; - - if bool_of_string (debug ()) then - ["-tag"; "debug"] - else - []; - - if bool_of_string (profile ()) then - ["-tag"; "profile"] - else - []; - - OASISString.nsplit (ocamlbuildflags ()) ' '; - - Array.to_list extra_argv; - ] - - - (** Run 'ocamlbuild -clean' if not already done *) - let run_clean extra_argv = - let extra_cli = - String.concat " " (Array.to_list extra_argv) - in - (* Run if never called with these args *) - if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then - begin - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args ["-clean"] extra_argv); - BaseLog.register ocamlbuild_clean_ev extra_cli; - at_exit - (fun () -> - try - BaseLog.unregister ocamlbuild_clean_ev extra_cli - with _ -> - ()) - end - - - (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild args extra_argv = - (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args args extra_argv); - (* Remove any clean event, we must run it again *) - List.iter - (fun (e, d) -> BaseLog.unregister e d) - (BaseLog.filter [ocamlbuild_clean_ev]) - - - (** Determine real build directory *) - let build_dir extra_argv = - let rec search_args dir = - function - | "-build-dir" :: dir :: tl -> - search_args dir tl - | _ :: tl -> - search_args dir tl - | [] -> - dir - in - search_args "_build" (fix_args [] extra_argv) - - -end - -module OCamlbuildPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) - - - (** Build using ocamlbuild - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OASISUtils - open OASISString - open BaseEnv - open OCamlbuildCommon - open BaseStandardVar - open BaseMessage - - - - - - let cond_targets_hook = - ref (fun lst -> lst) - - - let build extra_args pkg argv = - (* Return the filename in build directory *) - let in_build_dir fn = - Filename.concat - (build_dir argv) - fn - in - - (* Return the unix filename in host build directory *) - let in_build_dir_of_unix fn = - in_build_dir (OASISHostPath.of_unix fn) - in - - let cond_targets = - List.fold_left - (fun acc -> - function - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_library - in_build_dir_of_unix - (cs, bs, lib) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ~what:".cma" fn - || ends_with ~what:".cmxs" fn - || ends_with ~what:".cmxa" fn - || ends_with ~what:(ext_lib ()) fn - || ends_with ~what:(ext_dll ()) fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for library %s") - cs.cs_name - end - - | Object (cs, bs, obj) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_object - in_build_dir_of_unix - (cs, bs, obj) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ".cmo" fn - || ends_with ".cmx" fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for object %s") - cs.cs_name - end - - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, unix_exec_is, unix_dll_opt = - BaseBuilt.of_executable - in_build_dir_of_unix - (cs, bs, exec) - in - - let target ext = - let unix_tgt = - (OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.chop_extension - exec.exec_main_is))^ext - in - let evs = - (* Fix evs, we want to use the unix_tgt, without copying *) - List.map - (function - | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> - BaseBuilt.BExec, nm, - [[in_build_dir_of_unix unix_tgt]] - | ev -> - ev) - evs - in - evs, [unix_tgt] - in - - (* Add executable *) - let acc = - match bs.bs_compiled_object with - | Native -> - (target ".native") :: acc - | Best when bool_of_string (is_native ()) -> - (target ".native") :: acc - | Byte - | Best -> - (target ".byte") :: acc - in - acc - end - - | Library _ | Object _ | Executable _ | Test _ - | SrcRepo _ | Flag _ | Doc _ -> - acc) - [] - (* Keep the pkg.sections ordered *) - (List.rev pkg.sections); - in - - (* Check and register built files *) - let check_and_register (bt, bnm, lst) = - List.iter - (fun fns -> - if not (List.exists OASISFileUtil.file_exists_case fns) then - failwithf - (fn_ - "Expected built file %s doesn't exist." - "None of expected built files %s exists." - (List.length fns)) - (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) - lst; - (BaseBuilt.register bt bnm lst) - in - - (* Run the hook *) - let cond_targets = !cond_targets_hook cond_targets in - - (* Run a list of target... *) - run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; - (* ... and register events *) - List.iter check_and_register (List.flatten (List.map fst cond_targets)) - - - let clean pkg extra_args = - run_clean extra_args; - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - -end - -module OCamlbuildDocPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) - - - (* Create documentation using ocamlbuild .odocl files - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OASISMessage - open OCamlbuildCommon - open BaseStandardVar - - - - - type run_t = - { - extra_args: string list; - run_path: unix_filename; - } - - - let doc_build run pkg (cs, doc) argv = - let index_html = - OASISUnixPath.make - [ - run.run_path; - cs.cs_name^".docdir"; - "index.html"; - ] - in - let tgt_dir = - OASISHostPath.make - [ - build_dir argv; - OASISHostPath.of_unix run.run_path; - cs.cs_name^".docdir"; - ] - in - run_ocamlbuild (index_html :: run.extra_args) argv; - List.iter - (fun glb -> - BaseBuilt.register - BaseBuilt.BDoc - cs.cs_name - [OASISFileUtil.glob ~ctxt:!BaseContext.default - (Filename.concat tgt_dir glb)]) - ["*.html"; "*.css"] - - - let doc_clean run pkg (cs, doc) argv = - run_clean argv; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - - -end - - -# 6616 "setup.ml" -module CustomPlugin = struct -(* # 22 "src/plugins/custom/CustomPlugin.ml" *) - - - (** Generate custom configure/build/doc/test/install system - @author - *) - - - open BaseEnv - open OASISGettext - open OASISTypes - - - - - - type t = - { - cmd_main: command_line conditional; - cmd_clean: (command_line option) conditional; - cmd_distclean: (command_line option) conditional; - } - - - let run = BaseCustom.run - - - let main t _ extra_args = - let cmd, args = - var_choose - ~name:(s_ "main command") - t.cmd_main - in - run cmd args extra_args - - - let clean t pkg extra_args = - match var_choose t.cmd_clean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - - let distclean t pkg extra_args = - match var_choose t.cmd_distclean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - - module Build = - struct - let main t pkg extra_args = - main t pkg extra_args; - List.iter - (fun sct -> - let evs = - match sct with - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, _ = - BaseBuilt.of_library - OASISHostPath.of_unix - (cs, bs, lib) - in - evs - end - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, _, _ = - BaseBuilt.of_executable - OASISHostPath.of_unix - (cs, bs, exec) - in - evs - end - | _ -> - [] - in - List.iter - (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) - evs) - pkg.sections - - let clean t pkg extra_args = - clean t pkg extra_args; - (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild - * considering moving this to BaseSetup? - *) - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - let distclean t pkg extra_args = - distclean t pkg extra_args - end - - - module Test = - struct - let main t pkg (cs, test) extra_args = - try - main t pkg extra_args; - 0.0 - with Failure s -> - BaseMessage.warning - (f_ "Test '%s' fails: %s") - cs.cs_name - s; - 1.0 - - let clean t pkg (cs, test) extra_args = - clean t pkg extra_args - - let distclean t pkg (cs, test) extra_args = - distclean t pkg extra_args - end - - - module Doc = - struct - let main t pkg (cs, _) extra_args = - main t pkg extra_args; - BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] - - let clean t pkg (cs, _) extra_args = - clean t pkg extra_args; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - - let distclean t pkg (cs, _) extra_args = - distclean t pkg extra_args - end - - -end - - -# 6764 "setup.ml" -open OASISTypes;; - -let setup_t = - { - BaseSetup.configure = InternalConfigurePlugin.configure; - build = OCamlbuildPlugin.build ["-use-ocamlfind"]; - test = - [ - ("all", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - doc = - [ - ("containers", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_misc", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_string", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }) - ]; - install = InternalInstallPlugin.install; - uninstall = InternalInstallPlugin.uninstall; - clean = [OCamlbuildPlugin.clean]; - clean_test = - [ - ("all", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - clean_doc = - [ - ("containers", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_misc", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }); - ("containers_string", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"]; - run_path = "." - }) - ]; - distclean = []; - distclean_test = - [ - ("all", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - distclean_doc = []; - package = - { - oasis_version = "0.4"; - ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1"); - findlib_version = None; - alpha_features = ["compiled_setup_ml"]; - beta_features = []; - name = "containers"; - version = "dev"; - license = - OASISLicense.DEP5License - (OASISLicense.DEP5Unit - { - OASISLicense.license = "BSD-2-clause"; - excption = None; - version = OASISLicense.NoVersion - }); - license_file = Some "LICENSE"; - copyrights = []; - maintainers = []; - authors = ["Simon Cruanes"]; - homepage = Some "https://github.com/c-cube/ocaml-containers"; - 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 an optional library for dealing with strings, and a `misc` library full of experimental ideas (not stable, not necessarily usable)." - ]; - categories = []; - conf_type = (`Configure, "internal", Some "0.4"); - conf_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - build_type = (`Build, "ocamlbuild", Some "0.4"); - build_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - install_type = (`Install, "internal", Some "0.4"); - install_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - uninstall_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - clean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - distclean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - files_ab = []; - sections = - [ - Flag - ({ - cs_name = "misc"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some - "Build the misc library, containing everything from\nthe rotating kitchen sink to automatic banana distributors"; - flag_default = [(OASISExpr.EBool true, false)] - }); - Flag - ({ - cs_name = "cgi"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some - "Build modules related to FastCGI, depending on CamlGI"; - flag_default = [(OASISExpr.EBool true, false)] - }); - Flag - ({ - cs_name = "lwt"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some "Build modules which depend on Lwt"; - flag_default = [(OASISExpr.EBool true, false)] - }); - 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, false)] - }); - Flag - ({ - cs_name = "bench"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = Some "Build and run benchmarks"; - flag_default = [(OASISExpr.EBool true, false)] - }); - 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 = "core"; - bs_compiled_object = Best; - bs_build_depends = []; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - [ - "CCVector"; - "CCDeque"; - "CCGen"; - "CCSequence"; - "CCFQueue"; - "CCMultiMap"; - "CCMultiSet"; - "CCBV"; - "CCPrint"; - "CCPersistentHashtbl"; - "CCError"; - "CCHeap"; - "CCList"; - "CCOpt"; - "CCPair"; - "CCFun"; - "CCHash"; - "CCCat"; - "CCKList"; - "CCInt"; - "CCBool"; - "CCArray"; - "CCBatch"; - "CCOrd"; - "CCIO"; - "CCRandom"; - "CCLinq"; - "CCKTree"; - "CCTrie"; - "CCString"; - "CCHashtbl"; - "CCFlatHashtbl" - ]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = Some "containers"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_string"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "string"; - bs_compiled_object = Best; - bs_build_depends = []; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["KMP"; "Levenshtein"]; - lib_pack = true; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "string"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_pervasives"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "pervasives"; - bs_compiled_object = Best; - bs_build_depends = [InternalLibrary "containers"]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["CCPervasives"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "pervasives"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_misc"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "misc"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("unix", None); - InternalLibrary "containers" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - [ - "Cache"; - "FHashtbl"; - "FlatHashtbl"; - "Hashset"; - "Heap"; - "LazyGraph"; - "PersistentGraph"; - "PHashtbl"; - "SkipList"; - "SplayTree"; - "SplayMap"; - "Univ"; - "Bij"; - "PiCalculus"; - "Bencode"; - "Sexp"; - "RAL"; - "UnionFind"; - "SmallSet"; - "AbsSet"; - "CSM"; - "ActionMan"; - "BencodeOnDisk"; - "TTree"; - "PrintBox"; - "HGraph"; - "Automaton"; - "Conv"; - "Bidir"; - "Iteratee"; - "BTree"; - "Ty"; - "Tell"; - "BencodeStream"; - "RatTerm"; - "Cause"; - "AVL"; - "ParseReact" - ]; - lib_pack = true; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "misc"; - 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 = "threads/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("threads", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["CCFuture"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "thread"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_lwt"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "lwt", OASISExpr.EFlag "misc"), - true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "lwt", OASISExpr.EFlag "misc"), - true) - ]; - bs_path = "lwt"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("lwt", None); - FindlibPackage ("lwt.unix", None); - InternalLibrary "containers_misc" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["Behavior"; "Lwt_automaton"]; - lib_pack = true; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "lwt"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_cgi"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "cgi", true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "cgi", true) - ]; - bs_path = "cgi"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("CamlGI", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["ToWeb"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "cgi"; - lib_findlib_containers = [] - }); - Doc - ({ - cs_name = "containers"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "Containers docs"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Doc - ({ - cs_name = "containers_misc"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "Containers_misc docs"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Doc - ({ - cs_name = "containers_string"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "Containers_string docs"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Executable - ({ - cs_name = "benchs"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "bench", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_string"; - InternalLibrary "containers_misc"; - FindlibPackage ("bench", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "benchs.ml"}); - Executable - ({ - cs_name = "bench_conv"; - 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 = "tests/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("benchmark", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "bench_conv.ml"}); - Executable - ({ - cs_name = "bench_batch"; - 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 = "tests/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("benchmark", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "bench_batch.ml"}); - Executable - ({ - cs_name = "bench_hash"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "bench", - OASISExpr.EFlag "misc"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_misc" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "bench_hash.ml"}); - Executable - ({ - cs_name = "test_levenshtein"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "tests", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("qcheck", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "test_levenshtein.ml" - }); - Executable - ({ - cs_name = "test_lwt"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "lwt"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/lwt/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("lwt", None); - FindlibPackage ("lwt.unix", None); - FindlibPackage ("oUnit", None); - InternalLibrary "containers_lwt" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "test_Behavior.ml"}); - Executable - ({ - cs_name = "test_threads"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "thread"), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/threads/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("threads", None); - FindlibPackage ("oUnit", None); - InternalLibrary "containers_thread" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "test_future.ml"}); - Executable - ({ - cs_name = "run_tests"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "tests", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "tests/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("oUnit", None); - FindlibPackage ("qcheck", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "run_tests.ml"}); - Test - ({ - cs_name = "all"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - test_type = (`Test, "custom", Some "0.4"); - test_command = - [(OASISExpr.EBool true, ("make", ["test-all"]))]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); - (OASISExpr.EFlag "tests", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EFlag "tests"), - true) - ]; - test_tools = - [ - ExternalTool "ocamlbuild"; - InternalExecutable "run_tests" - ] - }); - Executable - ({ - cs_name = "web_pwd"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "cgi", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "examples/cgi/"; - bs_compiled_object = Byte; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_cgi"; - FindlibPackage ("threads", None); - FindlibPackage ("CamlGI", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "web_pwd.ml"}); - Executable - ({ - cs_name = "lambda"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "misc", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "examples/"; - bs_compiled_object = Byte; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_misc" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "lambda.ml"}); - Executable - ({ - cs_name = "id_sexp"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "misc", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "examples/"; - bs_compiled_object = Native; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_misc" - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "id_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 - }) - ]; - plugins = - [(`Extra, "META", Some "0.3"); (`Extra, "DevFiles", Some "0.3")]; - disable_oasis_section = []; - schema_data = PropList.Data.create (); - plugin_data = [] - }; - oasis_fn = Some "_oasis"; - oasis_version = "0.4.4"; - oasis_digest = Some "h\149C\237\220`t\024\024\161\129c\000\004\171\020"; - oasis_exec = None; - oasis_setup_args = []; - setup_update = false - };; - -let setup () = BaseSetup.setup setup_t;; - -# 7815 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/tests/test_PiCalculus.ml b/tests/test_PiCalculus.ml index 6d20c9b7..1a2a1243 100644 --- a/tests/test_PiCalculus.ml +++ b/tests/test_PiCalculus.ml @@ -1,6 +1,7 @@ open OUnit +open Containers_misc open PiCalculus module Pi = PiCalculus diff --git a/tests/test_bencode.ml b/tests/test_bencode.ml index 0a5ec637..3bfb5c6f 100644 --- a/tests/test_bencode.ml +++ b/tests/test_bencode.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module B = Bencode diff --git a/tests/test_bij.ml b/tests/test_bij.ml index 90fb42ca..869bd9b1 100644 --- a/tests/test_bij.ml +++ b/tests/test_bij.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module Sequence = CCSequence diff --git a/tests/test_fHashtbl.ml b/tests/test_fHashtbl.ml index b45aec07..1c81e37e 100644 --- a/tests/test_fHashtbl.ml +++ b/tests/test_fHashtbl.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module Sequence = CCSequence diff --git a/tests/test_flatHashtbl.ml b/tests/test_flatHashtbl.ml index c88342f8..60437386 100644 --- a/tests/test_flatHashtbl.ml +++ b/tests/test_flatHashtbl.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module Sequence = CCSequence diff --git a/tests/test_graph.ml b/tests/test_graph.ml index 2899b232..a18913a7 100644 --- a/tests/test_graph.ml +++ b/tests/test_graph.ml @@ -3,6 +3,7 @@ open OUnit open Helpers +open Containers_misc module Sequence = CCSequence module G = PersistentGraph diff --git a/tests/test_heap.ml b/tests/test_heap.ml index daa120ba..c4162e23 100644 --- a/tests/test_heap.ml +++ b/tests/test_heap.ml @@ -2,6 +2,7 @@ open OUnit open Helpers +open Containers_misc module Sequence = CCSequence let test_empty () = diff --git a/tests/test_levenshtein.ml b/tests/test_levenshtein.ml index 72263d7a..4cb1876f 100644 --- a/tests/test_levenshtein.ml +++ b/tests/test_levenshtein.ml @@ -1,5 +1,7 @@ (* quickcheck for Levenshtein *) +module Levenshtein = Containers_string.Levenshtein + (* test that automaton accepts its string *) let test_automaton = let gen = QCheck.Arbitrary.(map string (fun s -> s, Levenshtein.of_string ~limit:1 s)) in diff --git a/tests/test_pHashtbl.ml b/tests/test_pHashtbl.ml index 2103eb69..ce663ecd 100644 --- a/tests/test_pHashtbl.ml +++ b/tests/test_pHashtbl.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module Sequence = CCSequence diff --git a/tests/test_splayMap.ml b/tests/test_splayMap.ml index 2bd33c91..aa22a5a1 100644 --- a/tests/test_splayMap.ml +++ b/tests/test_splayMap.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc module Sequence = CCSequence diff --git a/tests/test_univ.ml b/tests/test_univ.ml index 37a7f4a1..51fe80fa 100644 --- a/tests/test_univ.ml +++ b/tests/test_univ.ml @@ -1,5 +1,6 @@ open OUnit +open Containers_misc (** Test Univ embedding *) From 8a095f2298e9add1e39609ef83d84677f1f717c2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 23:09:17 +0200 Subject: [PATCH 19/28] ignore sequence/ dir --- _tags | 1 + 1 file changed, 1 insertion(+) diff --git a/_tags b/_tags index 9bdfa3d1..e89e7e22 100644 --- a/_tags +++ b/_tags @@ -159,4 +159,5 @@ # OASIS_STOP : thread : thread +: -traverse <{string,core}/**/*.ml>: warn_K, warn_Y, warn_X From 0578bedf314df5ab6284f1fe5f17844f62df8e3c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 23:10:38 +0200 Subject: [PATCH 20/28] get rid of deprecated Array.create --- core/CCVector.ml | 2 +- misc/automaton.ml | 4 ++-- misc/cache.ml | 8 ++++---- misc/fHashtbl.ml | 2 +- misc/puf.ml | 2 +- misc/tTree.ml | 2 +- 6 files changed, 10 insertions(+), 10 deletions(-) diff --git a/core/CCVector.ml b/core/CCVector.ml index e9675f23..c7f4b9f2 100644 --- a/core/CCVector.ml +++ b/core/CCVector.ml @@ -86,7 +86,7 @@ let _empty_array v = let _resize v newcapacity = assert (newcapacity >= v.size); assert (not (_empty_array v)); - let new_vec = Array.create newcapacity v.vec.(0) in + let new_vec = Array.make newcapacity v.vec.(0) in Array.blit v.vec 0 new_vec 0 v.size; v.vec <- new_vec; () diff --git a/misc/automaton.ml b/misc/automaton.ml index 53748039..c761fb0a 100644 --- a/misc/automaton.ml +++ b/misc/automaton.ml @@ -92,7 +92,7 @@ module O = struct let create () = let s = { n = 0; - handlers = Array.create 3 nop_handler; + handlers = Array.make 3 nop_handler; alive = NotAlive; } in s @@ -116,7 +116,7 @@ module O = struct (* resize handlers if needed *) (if s.n = Array.length s.handlers then begin - let handlers = Array.create (s.n + 4) nop_handler in + let handlers = Array.make (s.n + 4) nop_handler in Array.blit s.handlers 0 handlers 0 s.n; s.handlers <- handlers end); diff --git a/misc/cache.ml b/misc/cache.ml index 4f9a94f5..bbf59d3c 100644 --- a/misc/cache.ml +++ b/misc/cache.ml @@ -116,7 +116,7 @@ module Linear(X : EQ) = struct let create size = assert (size >= 1); - Array.create size Empty + Array.make size Empty let clear cache = Array.fill cache 0 (Array.length cache) Empty @@ -164,7 +164,7 @@ module Linear2(X : EQ)(Y : EQ) = struct let create size = assert (size >= 1); - Array.create size Empty + Array.make size Empty let clear cache = Array.fill cache 0 (Array.length cache) Empty @@ -214,7 +214,7 @@ module Replacing(X : HASH) = struct and 'a bucket = Empty | Assoc of key * 'a | AssocRaise of key * exn let create size = - Array.create size Empty + Array.make size Empty let clear c = Array.fill c 0 (Array.length c) Empty @@ -256,7 +256,7 @@ module Replacing2(X : HASH)(Y : HASH) = struct and key2 = Y.t let create size = - Array.create size Empty + Array.make size Empty let clear c = Array.fill c 0 (Array.length c) Empty diff --git a/misc/fHashtbl.ml b/misc/fHashtbl.ml index 50e4c8a7..fe1b3ea2 100644 --- a/misc/fHashtbl.ml +++ b/misc/fHashtbl.ml @@ -80,7 +80,7 @@ module PArray = struct (* XXX maybe having a snapshot of the array from point to point may help? *) let make size elt = - let a = Array.create size elt in + let a = Array.make size elt in ref (Array a) (** Recover the given version of the shared array. Returns the array diff --git a/misc/puf.ml b/misc/puf.ml index 7a00564a..d41e637f 100644 --- a/misc/puf.ml +++ b/misc/puf.ml @@ -36,7 +36,7 @@ module PArray = struct (* XXX maybe having a snapshot of the array from point to point may help? *) let make size elt = - let a = Array.create size elt in + let a = Array.make size elt in ref (Array a) let init size f = diff --git a/misc/tTree.ml b/misc/tTree.ml index 538432c0..034f91d9 100644 --- a/misc/tTree.ml +++ b/misc/tTree.ml @@ -40,7 +40,7 @@ module PArray = struct (* XXX maybe having a snapshot of the array from point to point may help? *) let make size elt = - let a = Array.create size elt in + let a = Array.make size elt in ref (Array a) (** Recover the given version of the shared array. Returns the array From daf06196c0d5bb2540300c435b2f44533a72dea7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 23:18:29 +0200 Subject: [PATCH 21/28] details --- .ocamlinit | 1 + core/CCString.mli | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/.ocamlinit b/.ocamlinit index 499825da..4bc62be7 100644 --- a/.ocamlinit +++ b/.ocamlinit @@ -13,6 +13,7 @@ #thread;; #load "containers_thread.cma";; open Containers_misc;; +#install_printer Sexp.print;; #install_printer Bencode.pretty;; #install_printer HGraph.Default.fmt;; #require "CamlGI";; diff --git a/core/CCString.mli b/core/CCString.mli index db14e264..78059fff 100644 --- a/core/CCString.mli +++ b/core/CCString.mli @@ -61,7 +61,7 @@ val compare : string -> string -> int val hash : string -> int val init : int -> (int -> char) -> string -(** Analog stringo [Array.init]. +(** Analog to [Array.init]. @since 0.3.3 *) val of_gen : char gen -> string From 9ca56d8046ff3c4a5d95183e3d21069c03bec3e6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 17 Sep 2014 23:42:59 +0200 Subject: [PATCH 22/28] changed the Sexp api (renamed parsing/printing functions) --- examples/id_sexp.ml | 2 +- misc/sexp.ml | 132 +++++++++++++++++++++++++++----------------- misc/sexp.mli | 60 ++++++++++++++------ 3 files changed, 125 insertions(+), 69 deletions(-) diff --git a/examples/id_sexp.ml b/examples/id_sexp.ml index 3280466d..75f87a6e 100644 --- a/examples/id_sexp.ml +++ b/examples/id_sexp.ml @@ -3,7 +3,7 @@ let () = if Array.length Sys.argv <> 2 then failwith "usage: id_sexp file"; let f = Sys.argv.(1) in - let s = Sexp.parse_l_file f in + let s = Sexp.L.of_file f in match s with | `Ok l -> List.iter diff --git a/misc/sexp.ml b/misc/sexp.ml index 3cfd4b46..e65d6f76 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -33,14 +33,35 @@ type t = | Atom of string | List of t list -let eq a b = a = b +let equal a b = a = b let compare a b = Pervasives.compare a b let hash a = Hashtbl.hash a +let _with_in filename f = + let ic = open_in filename in + try + let x = f ic in + close_in ic; + x + with e -> + close_in ic; + `Error (Printexc.to_string e) + +let _with_out filename f = + let oc = open_out filename in + try + let x = f oc in + close_out oc; + x + with e -> + close_out oc; + raise e + (** {2 Serialization (encoding)} *) +(* shall we escape the string because of one of its chars? *) let _must_escape s = try for i = 0 to String.length s - 1 do @@ -101,17 +122,13 @@ let to_chan oc t = print fmt t; Format.pp_print_flush fmt () -let seq_to_file filename seq = - let oc = open_out filename in - try - seq - (fun t -> to_chan oc t; output_char oc '\n'); - close_out oc - with e -> - close_out oc; - raise e +let to_file_seq filename seq = + _with_out filename + (fun oc -> + seq (fun t -> to_chan oc t; output_char oc '\n') + ) -let to_file filename t = seq_to_file filename (fun k -> k t) +let to_file filename t = to_file_seq filename (fun k -> k t) (** {2 Deserialization (decoding)} *) @@ -472,51 +489,66 @@ let parse_chan ?bufsize ic = (** {6 Blocking} *) -let parse1_chan ic = +let of_chan ic = ParseGen.head (parse_chan ic) -let parse1_string s = +let of_string s = ParseGen.head (parse_string s) -let parse_l_chan ?bufsize ic = - ParseGen.to_list (parse_chan ?bufsize ic) +let of_file f = + _with_in f of_chan -let parse_l_file ?bufsize filename = - let ic = open_in filename in - try - let l = parse_l_chan ?bufsize ic in - close_in ic; - l - with e -> - close_in ic; - `Error (Printexc.to_string e) +module L = struct + let to_buf b l = + List.iter (to_buf b) l -let parse_l_string s = - ParseGen.to_list (parse_string s) + let to_string l = + let b = Buffer.create 32 in + to_buf b l; + Buffer.contents b -let parse_l_gen g = - ParseGen.to_list (parse_gen g) + let to_chan oc l = + let fmt = Format.formatter_of_out_channel oc in + List.iter (Format.fprintf fmt "%a@." print) l; + Format.pp_print_flush fmt () -exception OhNoes of string -exception StopNaow + let to_file filename l = + _with_out filename (fun oc -> to_chan oc l) -let parse_l_seq seq = - let src = Source.Manual.make () in - let ps = mk_ps (Source.Manual.to_src src) in - let l = ref [] in - (* read as many expressions as possible *) - let rec _nexts () = match _next ps with - | `Ok x -> l := x :: !l; _nexts () - | `Error e -> raise (OhNoes e) - | `End -> raise StopNaow - | `Await -> () - in - try - seq - (fun s -> Source.Manual.feed src s 0 (String.length s); _nexts ()); - Source.Manual.reached_end src; - _nexts (); - `Ok (List.rev !l) - with - | OhNoes msg -> `Error msg - | StopNaow -> `Ok (List.rev !l) + let of_chan ?bufsize ic = + ParseGen.to_list (parse_chan ?bufsize ic) + + let of_file ?bufsize filename = + _with_in filename + (fun ic -> of_chan ?bufsize ic) + + let of_string s = + ParseGen.to_list (parse_string s) + + let of_gen g = + ParseGen.to_list (parse_gen g) + + exception OhNoes of string + exception StopNaow + + let of_seq seq = + let src = Source.Manual.make () in + let ps = mk_ps (Source.Manual.to_src src) in + let l = ref [] in + (* read as many expressions as possible *) + let rec _nexts () = match _next ps with + | `Ok x -> l := x :: !l; _nexts () + | `Error e -> raise (OhNoes e) + | `End -> raise StopNaow + | `Await -> () + in + try + seq + (fun s -> Source.Manual.feed src s 0 (String.length s); _nexts ()); + Source.Manual.reached_end src; + _nexts (); + `Ok (List.rev !l) + with + | OhNoes msg -> `Error msg + | StopNaow -> `Ok (List.rev !l) +end diff --git a/misc/sexp.mli b/misc/sexp.mli index 319dd495..50950b53 100644 --- a/misc/sexp.mli +++ b/misc/sexp.mli @@ -23,7 +23,9 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(** {1 Simple S-expression parsing/printing} *) +(** {1 Simple and efficient S-expression parsing/printing} + +@since NEXT_RELEASE *) type 'a or_error = [ `Ok of 'a | `Error of string ] type 'a sequence = ('a -> unit) -> unit @@ -35,15 +37,21 @@ type t = | Atom of string | List of t list -val eq : t -> t -> bool +val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int (** {2 Serialization (encoding)} *) val to_buf : Buffer.t -> t -> unit + val to_string : t -> string + val to_file : string -> t -> unit + +val to_file_seq : string -> t sequence -> unit +(** Print the given sequence of expressions to a file *) + val to_chan : out_channel -> t -> unit val print : Format.formatter -> t -> unit @@ -52,16 +60,12 @@ val print : Format.formatter -> t -> unit val print_noindent : Format.formatter -> t -> unit (** Raw, direct printing as compact as possible *) -val seq_to_file : string -> t sequence -> unit -(** Print the given sequence of expressions to a file *) - (** {2 Deserialization (decoding)} *) type 'a parse_result = ['a or_error | `End ] type 'a partial_result = [ 'a parse_result | `Await ] -(** {6 Streaming Parsing} *) - +(** {6 Source of characters} *) module Source : sig type individual_char = | NC_yield of char @@ -105,6 +109,8 @@ module Source : sig val of_gen : string gen -> t end +(** {6 Streaming Lexer} +splits the input into opening parenthesis, closing ones, and atoms *) module Lexer : sig type t (** A streaming lexer, that parses atomic chunks of S-expressions (atoms @@ -148,7 +154,8 @@ module ParseGen : sig val take : int -> 'a t -> 'a t end -(** {6 Stream Parser} *) +(** {6 Stream Parser} +Returns a lazy stream of S-expressions. *) val parse_string : string -> t ParseGen.t (** Parse a string *) @@ -159,20 +166,37 @@ val parse_chan : ?bufsize:int -> in_channel -> t ParseGen.t val parse_gen : string gen -> t ParseGen.t (** Parse chunks of string *) -(** {6 Blocking} *) +(** {6 Blocking API} +Parse one S-expression from some source. *) -val parse1_chan : in_channel -> t or_error +val of_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) *) -val parse1_string : string -> t or_error +val of_string : string -> t or_error -val parse_l_chan : ?bufsize:int -> in_channel -> t list or_error -(** Parse values from a channel. *) +val of_file : string -> t or_error +(** Open the file and read a S-exp from it *) -val parse_l_file : ?bufsize:int -> string -> t list or_error -(** Parse a file *) +(** {6 Lists of S-exps} *) -val parse_l_string : string -> t list or_error +module L : sig + val to_buf : Buffer.t -> t list -> unit -val parse_l_gen : string gen -> t list or_error + val to_string : t list -> string -val parse_l_seq : string sequence -> t list or_error + val to_file : string -> t list -> unit + + val to_chan : out_channel -> t list -> unit + + val of_chan : ?bufsize:int -> in_channel -> t list or_error + + val of_file : ?bufsize:int -> string -> t list or_error + + val of_string : string -> t list or_error + + val of_gen : string gen -> t list or_error + + val of_seq : string sequence -> t list or_error +end From 05316f7e383b2a56d83ab875bc83fd263d238784 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 18 Sep 2014 00:14:00 +0200 Subject: [PATCH 23/28] Sexp.Traverse, to extract information from S-expr --- misc/sexp.ml | 65 +++++++++++++++++++++++++++++++++++++++++++++++++++ misc/sexp.mli | 41 ++++++++++++++++++++++++++++++++ 2 files changed, 106 insertions(+) diff --git a/misc/sexp.ml b/misc/sexp.ml index e65d6f76..d877817b 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -39,6 +39,15 @@ let compare a b = Pervasives.compare a b let hash a = Hashtbl.hash a +let of_int x = Atom (string_of_int x) +let of_float x = Atom (string_of_float x) +let of_bool x = Atom (string_of_bool x) +let of_string x = Atom x +let of_unit = List [] +let of_list l = List l +let of_pair (x,y) = List[x;y] +let of_triple (x,y,z) = List[x;y;z] + let _with_in filename f = let ic = open_in filename in try @@ -552,3 +561,59 @@ module L = struct | OhNoes msg -> `Error msg | StopNaow -> `Ok (List.rev !l) end + +(** {6 Traversal of S-exp} *) + +module Traverse = struct + let rec _list_any f l = match l with + | [] -> None + | x::tl -> + match f x with + | Some _ as res -> res + | None -> _list_any f tl + + let list_any e f = match e with + | Atom _ -> None + | List l -> _list_any f l + + let rec _list_all f acc l = match l with + | [] -> List.rev acc + | x::tl -> + match f x with + | Some y -> _list_all f (y::acc) tl + | None -> _list_all f acc tl + + let list_all e f = match e with + | Atom _ -> [] + | List l -> _list_all f [] l + + let _try_atom e f = match e with + | List _ -> None + | Atom x -> try Some (f x) with _ -> None + + let to_int e = _try_atom e int_of_string + let to_bool e = _try_atom e bool_of_string + let to_string e = _try_atom e (fun x->x) + + let to_pair e = match e with + | List [x;y] -> Some (x,y) + | _ -> None + + let to_triple e = match e with + | List [x;y;z] -> Some (x,y,z) + | _ -> None + + let to_list e = match e with + | List l -> Some l + | Atom _ -> None + + let return x = Some x + + let (>>=) e f = match e with + | None -> None + | Some x -> f x + + let get_exn e = match e with + | None -> failwith "Sexp.Traverse.get_exn" + | Some x -> x +end diff --git a/misc/sexp.mli b/misc/sexp.mli index 50950b53..6dd731df 100644 --- a/misc/sexp.mli +++ b/misc/sexp.mli @@ -41,6 +41,15 @@ val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int +val of_int : int -> t +val of_bool : bool -> t +val of_list : t list -> t +val of_string : string -> t +val of_float : float -> t +val of_unit : t +val of_pair : t * t -> t +val of_triple : t * t * t -> t + (** {2 Serialization (encoding)} *) val to_buf : Buffer.t -> t -> unit @@ -200,3 +209,35 @@ module L : sig val of_seq : string sequence -> t list or_error end + +(** {6 Traversal of S-exp} *) + +module Traverse : sig + val list_any : t -> (t -> 'a option) -> 'a option + (** [list_any (List l) f] tries [f x] for every element [x] in [List l], + and returns the first non-None result (if any). *) + + val list_all : t -> (t -> 'a option) -> 'a list + (** [list_all (List l) f] returns the list of all [y] such that [x] in [l] + and [f x = Some y] *) + + val to_int : t -> int option + + val to_string : t -> string option + + val to_bool : t -> bool option + + val to_list : t -> t list option + + val to_pair : t -> (t * t) option + + val to_triple : t -> (t * t * t) option + + val (>>=) : 'a option -> ('a -> 'b option) -> 'b option + + val return : 'a -> 'a option + + val get_exn : 'a option -> 'a + (** Unwrap an option, possibly failing. + @raise Invalid_argument if the argument is [None] *) +end From bb070c7f788fa5d1deefd5546c86af88d1569385 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 18 Sep 2014 00:28:58 +0200 Subject: [PATCH 24/28] Sexp: constructors and Sexp.Traverse (with new functions) --- misc/sexp.ml | 28 ++++++++++++++++++++++++++-- misc/sexp.mli | 28 ++++++++++++++++++++++++---- 2 files changed, 50 insertions(+), 6 deletions(-) diff --git a/misc/sexp.ml b/misc/sexp.ml index d877817b..2ba688e5 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -48,6 +48,11 @@ let of_list l = List l let of_pair (x,y) = List[x;y] let of_triple (x,y,z) = List[x;y;z] +let of_variant name args = List (Atom name :: args) +let of_field name t = List [Atom name; t] +let of_record l = + List (List.map (fun (n,x) -> of_field n x) l) + let _with_in filename f = let ic = open_in filename in try @@ -572,7 +577,7 @@ module Traverse = struct | Some _ as res -> res | None -> _list_any f tl - let list_any e f = match e with + let list_any f e = match e with | Atom _ -> None | List l -> _list_any f l @@ -583,7 +588,7 @@ module Traverse = struct | Some y -> _list_all f (y::acc) tl | None -> _list_all f acc tl - let list_all e f = match e with + let list_all f e = match e with | Atom _ -> [] | List l -> _list_all f [] l @@ -607,6 +612,25 @@ module Traverse = struct | List l -> Some l | Atom _ -> None + let rec _get_field name l = match l with + | List [Atom n; x] :: _ when name=n -> Some x + | _ :: tl -> _get_field name tl + | [] -> None + + let get_field name e = match e with + | List l -> _get_field name l + | Atom _ -> None + + let rec _get_variant s args l = match l with + | [] -> None + | (s', f) :: _ when s=s' -> f args + | _ :: tl -> _get_variant s args tl + + let get_variant l e = match e with + | List (Atom s :: args) -> _get_variant s args l + | List _ -> None + | Atom s -> _get_variant s [] l + let return x = Some x let (>>=) e f = match e with diff --git a/misc/sexp.mli b/misc/sexp.mli index 6dd731df..8d8def17 100644 --- a/misc/sexp.mli +++ b/misc/sexp.mli @@ -50,6 +50,17 @@ val of_unit : t val of_pair : t * t -> t val of_triple : t * t * t -> t +val of_variant : string -> t list -> t +(** [of_variant name args] is used to encode algebraic variants + into a S-expr. For instance [of_variant "some" (of_int 1)] + represents the value [Some 1] *) + +val of_field : string -> t -> t +(** Used to represent one record field *) + +val of_record : (string * t) list -> t +(** Represent a record by its named fields *) + (** {2 Serialization (encoding)} *) val to_buf : Buffer.t -> t -> unit @@ -213,12 +224,12 @@ end (** {6 Traversal of S-exp} *) module Traverse : sig - val list_any : t -> (t -> 'a option) -> 'a option - (** [list_any (List l) f] tries [f x] for every element [x] in [List l], + val list_any : (t -> 'a option) -> t -> 'a option + (** [list_any f (List l)] tries [f x] for every element [x] in [List l], and returns the first non-None result (if any). *) - val list_all : t -> (t -> 'a option) -> 'a list - (** [list_all (List l) f] returns the list of all [y] such that [x] in [l] + val list_all : (t -> 'a option) -> t -> 'a list + (** [list_all f (List l)] returns the list of all [y] such that [x] in [l] and [f x = Some y] *) val to_int : t -> int option @@ -233,6 +244,15 @@ module Traverse : sig val to_triple : t -> (t * t * t) option + val get_field : string -> t -> t option + (** [get_field name e], when [e = List [(n1,x1); (n2,x2) ... ]], extracts + the [xi] such that [name = ni], if it can find it. *) + + val get_variant : (string * (t list -> 'a option)) list -> t -> 'a option + (** [get_variant l e] checks whether [e = List (Atom s :: args)], and + if some pair of [l] is [s, f]. In this case, it calls [f args] + and returns its result, otherwise it returns None. *) + val (>>=) : 'a option -> ('a -> 'b option) -> 'b option val return : 'a -> 'a option From f19845f3d6c5d8cf679eb9ef1cd97ad2277f724f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 18 Sep 2014 00:49:24 +0200 Subject: [PATCH 25/28] Sexp.Traverse.field, and an example in doc --- misc/sexp.ml | 19 +++++++++++++------ misc/sexp.mli | 29 ++++++++++++++++++++++++++++- 2 files changed, 41 insertions(+), 7 deletions(-) diff --git a/misc/sexp.ml b/misc/sexp.ml index 2ba688e5..7657c777 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -570,6 +570,16 @@ end (** {6 Traversal of S-exp} *) module Traverse = struct + let return x = Some x + + let (>|=) e f = match e with + | None -> None + | Some x -> Some (f x) + + let (>>=) e f = match e with + | None -> None + | Some x -> f x + let rec _list_any f l = match l with | [] -> None | x::tl -> @@ -621,6 +631,9 @@ module Traverse = struct | List l -> _get_field name l | Atom _ -> None + let field name f e = + get_field name e >>= f + let rec _get_variant s args l = match l with | [] -> None | (s', f) :: _ when s=s' -> f args @@ -631,12 +644,6 @@ module Traverse = struct | List _ -> None | Atom s -> _get_variant s [] l - let return x = Some x - - let (>>=) e f = match e with - | None -> None - | Some x -> f x - let get_exn e = match e with | None -> failwith "Sexp.Traverse.get_exn" | Some x -> x diff --git a/misc/sexp.mli b/misc/sexp.mli index 8d8def17..e7f2ec0b 100644 --- a/misc/sexp.mli +++ b/misc/sexp.mli @@ -221,7 +221,29 @@ module L : sig val of_seq : string sequence -> t list or_error end -(** {6 Traversal of S-exp} *) +(** {6 Traversal of S-exp} + +Example: serializing 2D points +{[ +type pt = {x:int; y:int };; + +let pt_of_sexp e = + Sexp.Traverse.( + field "x" to_int e >>= fun x -> + field "y" to_int e >>= fun y -> + return {x;y} + );; + +let sexp_of_pt pt = Sexp.(of_record ["x", of_int pt.x; "y", of_int pt.y]);; + +let l = [{x=1;y=1}; {x=2;y=10}];; + +let sexp = Sexp.(of_list (List.map sexp_of_pt l));; + +Sexp.Traverse.list_all pt_of_sexp sexp;; +]} + +*) module Traverse : sig val list_any : (t -> 'a option) -> t -> 'a option @@ -248,6 +270,9 @@ module Traverse : sig (** [get_field name e], when [e = List [(n1,x1); (n2,x2) ... ]], extracts the [xi] such that [name = ni], if it can find it. *) + val field : string -> (t -> 'a option) -> t -> 'a option + (** Enriched version of {!get_field}, with a converter as argument *) + val get_variant : (string * (t list -> 'a option)) list -> t -> 'a option (** [get_variant l e] checks whether [e = List (Atom s :: args)], and if some pair of [l] is [s, f]. In this case, it calls [f args] @@ -255,6 +280,8 @@ module Traverse : sig val (>>=) : 'a option -> ('a -> 'b option) -> 'b option + val (>|=) : 'a option -> ('a -> 'b) -> 'b option + val return : 'a -> 'a option val get_exn : 'a option -> 'a From 78ac2f6f7091a29ecebddfb904706839570c2d1f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 18 Sep 2014 11:14:29 +0200 Subject: [PATCH 26/28] forgot a function in Sexp.Traverse --- misc/sexp.ml | 1 + misc/sexp.mli | 2 ++ 2 files changed, 3 insertions(+) diff --git a/misc/sexp.ml b/misc/sexp.ml index 7657c777..d58d99d9 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -608,6 +608,7 @@ module Traverse = struct let to_int e = _try_atom e int_of_string let to_bool e = _try_atom e bool_of_string + let to_float e = _try_atom e float_of_string let to_string e = _try_atom e (fun x->x) let to_pair e = match e with diff --git a/misc/sexp.mli b/misc/sexp.mli index e7f2ec0b..2d20e590 100644 --- a/misc/sexp.mli +++ b/misc/sexp.mli @@ -260,6 +260,8 @@ module Traverse : sig val to_bool : t -> bool option + val to_float : t -> float option + val to_list : t -> t list option val to_pair : t -> (t * t) option From bf6ae8bdb149838807aaaccae7890ab175121993 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 18 Sep 2014 11:50:36 +0200 Subject: [PATCH 27/28] doc --- misc/sexp.mli | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/misc/sexp.mli b/misc/sexp.mli index 2d20e590..c1f05b9d 100644 --- a/misc/sexp.mli +++ b/misc/sexp.mli @@ -99,9 +99,9 @@ module Source : sig type source = t - (** A mnual source of individual characters. When it has exhausted its - data, it asked its caller to provide more, or signal that none remains - In particular, useful when the source of data is monadic IO *) + (** A manual source of individual characters. When it has exhausted its + own input, it asks its caller to provide more or signal that none remains + This is especially useful when the source of data is monadic IO *) module Manual : sig type t From 5cb2bb3538551599d00324a05d9be898029bb658 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 24 Sep 2014 23:44:51 +0200 Subject: [PATCH 28/28] support for ; line comments in Sexp --- misc/sexp.ml | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/misc/sexp.ml b/misc/sexp.ml index d58d99d9..cd81626b 100644 --- a/misc/sexp.ml +++ b/misc/sexp.ml @@ -81,7 +81,7 @@ let _must_escape s = for i = 0 to String.length s - 1 do let c = String.unsafe_get s i in match c with - | ' ' | ')' | '(' | '"' | '\n' | '\t' -> raise Exit + | ' ' | ';' | ')' | '(' | '"' | '\n' | '\t' -> raise Exit | _ when Char.code c > 127 -> raise Exit (* non-ascii *) | _ -> () done; @@ -248,6 +248,7 @@ module Lexer = struct | St_start | St_atom | St_quoted + | St_comment | St_escaped | St_raw_char1 of int | St_raw_char2 of int @@ -324,7 +325,7 @@ module Lexer = struct | Source.NC_end -> begin match st with | St_error _ | St_end | St_yield _ -> assert false - | St_start -> _end d + | St_start | St_comment -> _end d | St_atom -> let a = _take_buffer d.atom in _yield d St_end (Atom a) @@ -342,9 +343,15 @@ module Lexer = struct (* use the next char *) match st with | St_error _ | St_end | St_yield _ -> assert false + | St_comment -> + begin match c with + | '\n' -> _next d St_start + | _ -> _next d St_comment + end | St_start -> begin match c with | ' ' | '\t' | '\n' -> _next d St_start + | ';' -> _next d St_comment | '(' -> _yield d St_start Open | ')' -> _yield d St_start Close | '"' -> _next d St_quoted @@ -357,6 +364,9 @@ module Lexer = struct | ' ' | '\t' | '\n' -> let a = _take_buffer d.atom in _yield d St_start (Atom a) + | ';' -> + let a = _take_buffer d.atom in + _yield d St_comment (Atom a) | ')' -> let a = _take_buffer d.atom in _yield d (St_yield Close) (Atom a)