diff --git a/.gitignore b/.gitignore index d44b4ce6..8d2ffd6d 100644 --- a/.gitignore +++ b/.gitignore @@ -6,6 +6,6 @@ _build .session TAGS *.docdir -setup.log -setup.data +setup.* qtest* +*.html diff --git a/.merlin b/.merlin index d0a5cac0..3b321723 100644 --- a/.merlin +++ b/.merlin @@ -12,22 +12,13 @@ S src/bigarray S benchs S examples S tests -B _build/src/core -B _build/src/data/ -B _build/src/io -B _build/src/iter/ -B _build/src/advanced/ -B _build/src/lwt/ -B _build/src/sexp/ -B _build/src/threads/ -B _build/src/misc -B _build/src/string -B _build/src/bigarray +B _build/src/** B _build/benchs B _build/examples B _build/tests PKG oUnit PKG benchmark +PKG result PKG threads PKG threads.posix PKG lwt diff --git a/CHANGELOG.adoc b/CHANGELOG.adoc index e2ec92c3..ba78c33c 100644 --- a/CHANGELOG.adoc +++ b/CHANGELOG.adoc @@ -1,5 +1,61 @@ = Changelog +== 0.16 + +=== breaking + +- change the signature of `CCHeap.{of_gen,of_seq,of_klist}` +- change the API of `CCMixmap` +- make type `CCHash.state` abstract (used to be `int64`) +- optional argument `~eq` to `CCGraph.Dot.pp` +- rename `CCFuture` into `CCPool` + +=== deprecations + +- deprecate `containers.bigarray` +- deprecate `CCHashtbl.{Counter,Default}` tables +- deprecate `CCLinq` in favor of standalone `OLinq` (to be released) + +=== bugfixes + +- fix wrong signature of `CCHashtbl.Make.{keys,values}_list` +- missing constraint in `CCSexpM.ID_MONAD` + +=== new features + +- add a tutorial file +- add a printer into CCHeap +- add `{CCList,CCOpt}.Infix` modules +- add `CCOpt.map_or`, deprecating `CCopt.maybe` +- add `CCFormat.sprintf_no_color` +- add `CCFormat.{h,v,hov,hv}box` printer combinators +- add `CCFormat.{with_color, with_colorf}` +- add `CCList.hd_tl` +- add `CCResult.{map_or,get_or}` +- add `CCGraph.make` and utils +- add `CCHashtbl.add_list` +- add counter function in `CCHashtbl`, to replace `CCHashtbl.Counter` +- add `CCPair.make` +- add `CCString.Split.{left,right}_exn` +- add `CCIO.File.{read,write,append}` for quickly handling files +- add `CCRandom.pick_{list,array}` +- add `CCList.Assoc.update` +- add `CCList.Assoc.mem` +- add `{CCMap,CCHashtbl}.get_or` for lookup with default value +- add `CCLock.{decr_then_get, get_then_{decr,set,clear}}` +- rename `CCFuture` into `CCPool`, expose the thread pool +- split `CCTimer` out of `CCFuture`, a standalone 1-thread timer +- move `CCThread.Queue` into `CCBlockingQueue` +- add `CCResult`, with dependency on `result` for retrocompat +- add `CCThread.spawn{1,2}` +- add many helpers in `CCUnix` (for sockets, files, and processes) +- add `CCFun.finally{1,2}`, convenience around `finally` +- add `CCLock.update_map` +- add `CCLock.{incr_then_get,get_then_incr}` +- add breaking space in `CCFormat.{pair,triple,quad}` +- update `examples/id_sexp` so it can read on stdin +- add `CCList.fold_map2` + == 0.15 === breaking changes @@ -15,7 +71,7 @@ - add `CCMap.{keys,values}` - add wip `CCAllocCache`, an allocation cache for short-lived arrays - add `CCError.{join,both}` applicative functions for CCError -- opam: depend on ocamlbuild +- opam: depend on ecamlbuild - work on `CCRandom` by octachron: * add an uniformity test * Make `split_list` uniform diff --git a/HOWTO.adoc b/HOWTO.adoc index 533a0d91..528d72e8 100644 --- a/HOWTO.adoc +++ b/HOWTO.adoc @@ -14,7 +14,7 @@ can be removed. 6. commit the changes 7. `git checkout stable` 8. `git merge master` -9. `oasis setup; make tests doc` +9. `oasis setup; make test doc` 10. tag, and push both to github 11. new opam package diff --git a/README.adoc b/README.adoc index 8689a4a3..175483da 100644 --- a/README.adoc +++ b/README.adoc @@ -4,7 +4,7 @@ image::media/logo.png[logo] -What is _containers_? +What is _containers_? (take a look at the link:TUTORIAL.adoc[tutorial]!) - A usable, reasonably well-designed library that extends OCaml's standard library (in 'src/core/', packaged under `containers` in ocamlfind. Modules @@ -31,7 +31,7 @@ What is _containers_? a LINQ-like query module, batch operations using GADTs, and others). - Utilities around the `unix` library in `containers.unix` (mainly to spawn sub-processes) -- A bigstring module using `bigarray` in `containers.bigarray` +- A bigstring module using `bigarray` in `containers.bigarray` (*deprecated*) - A lightweight S-expression printer and streaming parser in `containers.sexp` Some of the modules have been moved to their own repository (e.g. `sequence`, @@ -55,6 +55,8 @@ See link:CHANGELOG.adoc[this file]. == Use +Start with the link:TUTORIAL.adoc[tutorial] + You can either build and install the library (see <>), or just copy files to your own project. The last solution has the benefits that you don't have additional dependencies nor build complications (and it may enable diff --git a/TUTORIAL.adoc b/TUTORIAL.adoc new file mode 100644 index 00000000..9d973e18 --- /dev/null +++ b/TUTORIAL.adoc @@ -0,0 +1,177 @@ += Tutorial +:source-highlighter: pygments + +This tutorial contains a few examples to illustrate the features and +usage of containers. We assume containers is installed and that +the library is loaded, e.g. with: + +[source,OCaml] +---- +#require "containers";; +---- + +== Basics + +We will start with a few list helpers, then look at other parts of +the library, including printers, maps, etc. + +[source,OCaml] +---- + +(* quick reminder of this awesome standard operator *) +# (|>) ;; +- : 'a -> ('a -> 'b) -> 'b = + +# open CCList.Infix;; + +# let l = 1 -- 100;; +val l : int list = [1; 2; .....] + +# l + |> CCList.filter_map + (fun x-> if x mod 3=0 then Some (float x) else None) + |> CCList.take 5 ;; +- : float list = [3.; 6.; 9.; 12.; 15.] + +# let l2 = l |> CCList.take_while (fun x -> x<10) ;; +val l2 : int list = [1; 2; 3; 4; 5; 6; 7; 8; 9] + +(* an extension of Map.Make, compatible with Map.Make(CCInt) *) +# module IntMap = CCMap.Make(CCInt);; + +(* conversions using the "sequence" type, fast iterators that are + pervasively used in containers. Combinators can be found + in the opam library "sequence". *) +# let map = + l2 + |> List.map (fun x -> x, string_of_int x) + |> CCList.to_seq + |> IntMap.of_seq;; +val map : string CCIntMap.t = + +(* check the type *) +# CCList.to_seq ;; +- : 'a list -> 'a sequence = +# IntMap.of_seq ;; +- : (int * 'a) CCMap.sequence -> 'a IntMap.t = + +(* we can print, too *) +# Format.printf "@[<2>map =@ @[%a@]@]@." + (IntMap.print CCFormat.int CCFormat.string_quoted) + map;; +map = + [1 --> "1", 2 --> "2", 3 --> "3", 4 --> "4", 5 --> "5", 6 --> "6", + 7 --> "7", 8 --> "8", 9 --> "9"] +- : unit = () + +(* options are good *) +# IntMap.get 3 map |> CCOpt.map (fun s->s ^ s);; +- : string option = Some "33" + +---- + +== New types: `CCVector`, `CCHeap`, `CCError`, `CCResult` + +Containers also contains (!) a few datatypes that are not from the standard +library but that are useful in a lot of situations: + +CCVector:: + A resizable array, with a mutability parameter. A value of type + `('a, CCVector.ro) CCVector.t` is an immutable vector of values of type `'a`, + whereas a `('a, CCVector.rw) CCVector.t` is a mutable vector that + can be modified. This way, vectors can be used in a quite functional + way, using operations such as `map` or `flat_map`, or in a more + imperative way. +CCHeap:: + A priority queue (currently, leftist heaps) functorized over + a module `sig val t val leq : t -> t -> bool` that provides a type `t` + and a partial order `leq` on `t`. +CCError:: + An error type for making error handling more explicit (an error monad, + really, if you're not afraid of the "M"-word). It is similar to the + more recent `CCResult`, but works with polymorphic variants for + compatibility with the numerous libraries that use the same type, + that is, `type ('a, 'b) CCError.t = [`Ok of 'a | `Error of 'b]`. +CCResult:: + It uses the new `result` type from the standard library (or from + the retrocompatibility package on opam), and presents an interface + similar to `CCError`. In an indeterminate amount of time, it will + totally replace `CCError`. + +Now for a few examples: + +[source,OCaml] +---- + +(* create a new empty vector. It is mutable, for otherwise it would + not be very useful. *) +# CCVector.create;; +- : unit -> ('a, CCVector.rw) CCVector.t = + +(* init, similar to Array.init, can be used to produce a + vector that is mutable OR immutable (see the 'mut parameter?) *) +# CCVector.init ;; +- : int -> (int -> 'a) -> ('a, 'mut) CCVector.t = c + +(* use the infix (--) operator for creating a range. Notice + that v is a vector of integer but its mutability is not + decided yet. *) +# let v = CCVector.(1 -- 10);; +val v : (int, '_a) CCVector.t = + +# Format.printf "v = @[%a@]@." (CCVector.print CCInt.print) v;; +v = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] + +(* now let's mutate v *) +# CCVector.push v 42;; +- : unit = () + +(* now v is a mutable vector *) +# v;; +- : (int, CCVector.rw) CCVector.t = + +(* functional combinators! *) +# let v2 = v + |> CCVector.map (fun x-> x+1) + |> CCVector.filter (fun x-> x mod 2=0) + |> CCVector.rev ;; +val v2 : (int, '_a) CCVector.t = + +# Format.printf "v2 = @[%a@]@." (CCVector.print CCInt.print) v2;; +v2 = [10, 8, 6, 4, 2] + +(* let's transfer to a heap *) +# module IntHeap = CCHeap.Make(struct type t = int let leq = (<=) end);; + +# let h = v2 |> CCVector.to_seq |> IntHeap.of_seq ;; +val h : IntHeap.t = + +(* We can print the content of h + (printing is not necessarily in order, though) *) +# Format.printf "h = [@[%a@]]@." (IntHeap.print CCInt.print) h;; +h = [2,4,6,8,10] + +(* we can remove the first element, which also returns a new heap + that does not contain it — CCHeap is a functional data structure *) +# IntHeap.take h;; +- : (IntHeap.t * int) option = Some (, 2) + +# let h', x = IntHeap.take_exn h ;; +val h' : IntHeap.t = +val x : int = 2 + +(* see, 2 is removed *) +# IntHeap.to_list h' ;; +- : int list = [4; 6; 8; 10] + +---- + +== To go further: containers.data + +There is also a sub-library called `containers.data`, with lots of +more specialized data-structures. +The documentation contains the API for all the modules +(see link:README.adoc[the readme]); they also provide +interface to `sequence` and, as the rest of containers, minimize +dependencies over other modules. + diff --git a/_oasis b/_oasis index 0fd3144b..79a0609e 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: containers -Version: 0.15 +Version: 0.16 Homepage: https://github.com/c-cube/ocaml-containers Authors: Simon Cruanes License: BSD-2-clause @@ -46,8 +46,8 @@ Library "containers" Modules: CCVector, CCPrint, CCError, CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCInt, CCBool, CCFloat, CCArray, CCRef, CCSet, CCOrd, CCRandom, CCString, CCHashtbl, CCMap, CCFormat, CCIO, - CCInt64, CCChar, Containers - BuildDepends: bytes + CCInt64, CCChar, CCResult, Containers + BuildDepends: bytes, result # BuildDepends: bytes, bisect_ppx Library "containers_io" @@ -114,7 +114,8 @@ Library "containers_bigarray" Library "containers_thread" Path: src/threads/ - Modules: CCFuture, CCLock, CCSemaphore, CCThread + Modules: CCPool, CCLock, CCSemaphore, CCThread, CCBlockingQueue, + CCTimer FindlibName: thread FindlibParent: containers Build$: flag(thread) diff --git a/_tags b/_tags index 5f9aea26..73ff6060 100644 --- a/_tags +++ b/_tags @@ -17,6 +17,7 @@ true: annot, bin_annot # Library containers "src/core/containers.cmxs": use_containers : package(bytes) +: package(result) # Library containers_io "src/io/containers_io.cmxs": use_containers_io : package(bytes) @@ -38,16 +39,19 @@ true: annot, bin_annot # Library containers_advanced "src/advanced/containers_advanced.cmxs": use_containers_advanced : package(bytes) +: package(result) : package(sequence) : use_containers # Library containers_bigarray "src/bigarray/containers_bigarray.cmxs": use_containers_bigarray : package(bigarray) : package(bytes) +: package(result) : use_containers # Library containers_thread "src/threads/containers_thread.cmxs": use_containers_thread : package(bytes) +: package(result) : package(threads) : use_containers # Library containers_top @@ -55,6 +59,7 @@ true: annot, bin_annot : package(bigarray) : package(bytes) : package(compiler-libs.common) +: package(result) : package(unix) : use_containers : use_containers_bigarray @@ -68,6 +73,7 @@ true: annot, bin_annot : package(bytes) : package(gen) : package(hamt) +: package(result) : package(sequence) : package(threads) : use_containers @@ -85,6 +91,7 @@ true: annot, bin_annot : use_containers_thread # Executable run_bench_hash : package(bytes) +: package(result) : use_containers # Executable run_qtest : package(QTest2Lib) @@ -92,6 +99,7 @@ true: annot, bin_annot : package(bytes) : package(gen) : package(oUnit) +: package(result) : package(sequence) : package(threads) : package(unix) @@ -110,6 +118,7 @@ true: annot, bin_annot : package(bytes) : package(gen) : package(oUnit) +: package(result) : package(sequence) : package(threads) : package(unix) @@ -126,12 +135,14 @@ true: annot, bin_annot # Executable mem_measure "benchs/mem_measure.native": package(bytes) "benchs/mem_measure.native": package(hamt) +"benchs/mem_measure.native": package(result) "benchs/mem_measure.native": package(sequence) "benchs/mem_measure.native": package(unix) "benchs/mem_measure.native": use_containers "benchs/mem_measure.native": use_containers_data : package(bytes) : package(hamt) +: package(result) : package(sequence) : package(unix) : use_containers diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 555ca079..a7c5c1d1 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -954,7 +954,7 @@ module Deque = struct end module Thread = struct - module Q = CCThread.Queue + module Q = CCBlockingQueue module type TAKE_PUSH = sig val take : 'a Q.t -> 'a @@ -1009,6 +1009,50 @@ module Thread = struct ; "naive", make naive, () ] + let fib_pool_ ~size n = + let module P = CCPool.Make(struct let min_size = 0 let max_size = size end) in + let open P.Fut.Infix in + let rec fib n = + if n<=1 then P.Fut.return 1 + else + let f1 = fib (n-1) + and f2 = fib (n-2) in + P.Fut.return (+) <*> f1 <*> f2 + in + P.Fut.get (fib n) + + let fib_manual n = + let rec fib n = + if n<= 1 then 1 + else fib (n-1) + fib (n-2) + in + fib n + + (* pool of size [size] *) + let bench_pool ~size n = + assert (fib_manual n = fib_pool_ ~size n); + B.throughputN 3 ~repeat + [ "sequential", fib_manual, n + ; "pool", fib_pool_ ~size, n + ] + + let bench_sequence ~size n = + let module P = CCPool.Make(struct let min_size = 0 let max_size = size end) in + let id_ x = Thread.delay 0.0001; x in + let mk_list() = CCList.init n (P.Fut.make1 id_) in + let mk_sequence () = + let l = mk_list() in + P.Fut.sequence_l l |> P.Fut.get + (* reserves a thread for the computation *) + and mk_blocking () = + let l = mk_list() in + P.Fut.make (fun () -> List.map P.Fut.get l) |> P.Fut.get + in + B.throughputN 3 ~repeat + [ "sequence", mk_sequence, () + ; "blocking", mk_blocking, () + ] + let () = B.Tree.register ( let take_push = CCList.map (fun (size,senders,receivers) -> @@ -1028,7 +1072,10 @@ module Thread = struct "thread" @>>> ( take_push @ - [] + [ "fib_size5" @>> app_ints (bench_pool ~size:5) [10; 15; 30; 35] + ; "fib_size15" @>> app_ints (bench_pool ~size:15) [10; 15; 30; 35] + ; "sequence" @>> app_ints (bench_sequence ~size:15) [100; 500; 10_000; 100_000] + ] ) ) end diff --git a/doc/intro.txt b/doc/intro.txt index 338a2596..1b331182 100644 --- a/doc/intro.txt +++ b/doc/intro.txt @@ -44,6 +44,7 @@ CCPair CCPrint CCRandom CCRef +CCResult CCSet CCString CCVector @@ -125,6 +126,7 @@ CCParse {4 Bigarrays} +{b deprecated} (use package bigstring instead) Use bigarrays to hold large strings and map files directly into memory. {!modules: CCBigstring CCArray1} @@ -147,10 +149,12 @@ Moved to its own repository {4 Others} {!modules: -CCFuture +CCBlockingQueue CCLock +CCPool CCSemaphore CCThread +CCTimer } diff --git a/examples/id_sexp.ml b/examples/id_sexp.ml index 90e63c27..cac7b040 100644 --- a/examples/id_sexp.ml +++ b/examples/id_sexp.ml @@ -1,13 +1,18 @@ - -let () = - if Array.length Sys.argv <> 2 then failwith "usage: id_sexp file"; - let f = Sys.argv.(1) in - let s = CCSexpM.parse_file_list f in - match s with +let pp_sexp s = match s with | `Ok l -> List.iter (fun s -> Format.printf "@[%a@]@." CCSexpM.print s) l | `Error msg -> Format.printf "error: %s@." msg + +let () = + match Sys.argv with + | [| _ |] -> + let s = CCSexpM.parse_chan_list stdin in + pp_sexp s + | [| _; file |] -> + let s = CCSexpM.parse_file_list file in + pp_sexp s + | _ -> failwith "usage: id_sexp [file]" diff --git a/opam b/opam index a3b0dfe8..51a80a86 100644 --- a/opam +++ b/opam @@ -27,6 +27,7 @@ remove: [ depends: [ "ocamlfind" {build} "base-bytes" + "result" "cppo" {build} "oasis" {build} "ocamlbuild" {build} diff --git a/setup.ml b/setup.ml index 7999dda7..fe8169fe 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7720 +1,37 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 520720667caa5285972393b25de31806) *) -(* - Regenerated by OASIS v0.4.5 - Visit http://oasis.forge.ocamlcore.org for more information and - documentation about functions used in this file. -*) -module OASISGettext = struct -(* # 22 "src/oasis/OASISGettext.ml" *) +(* DO NOT EDIT (digest: 9852805d5c19ca1cb6abefde2dcea323) *) +(******************************************************************************) +(* OASIS: architecture for building OCaml libraries and applications *) +(* *) +(* Copyright (C) 2011-2013, Sylvain Le Gall *) +(* Copyright (C) 2008-2011, OCamlCore SARL *) +(* *) +(* This library is free software; you can redistribute it and/or modify it *) +(* under the terms of the GNU Lesser General Public License as published by *) +(* the Free Software Foundation; either version 2.1 of the License, or (at *) +(* your option) any later version, with the OCaml static compilation *) +(* exception. *) +(* *) +(* This library is distributed in the hope that it will be useful, but *) +(* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *) +(* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *) +(* details. *) +(* *) +(* You should have received a copy of the GNU Lesser General Public License *) +(* along with this library; if not, write to the Free Software Foundation, *) +(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) +(******************************************************************************) + +let () = + try + Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") + with Not_found -> () +;; +#use "topfind";; +#require "oasis.dynrun";; +open OASISDynRun;; - - let ns_ str = - str - - - let s_ str = - str - - - let f_ (str: ('a, 'b, 'c, 'd) format4) = - str - - - let fn_ fmt1 fmt2 n = - if n = 1 then - fmt1^^"" - else - fmt2^^"" - - - let init = - [] - - -end - -module OASISContext = struct -(* # 22 "src/oasis/OASISContext.ml" *) - - - open OASISGettext - - - type level = - [ `Debug - | `Info - | `Warning - | `Error] - - - type t = - { - (* TODO: replace this by a proplist. *) - quiet: bool; - info: bool; - debug: bool; - ignore_plugins: bool; - ignore_unknown_fields: bool; - printf: level -> string -> unit; - } - - - let printf lvl str = - let beg = - match lvl with - | `Error -> s_ "E: " - | `Warning -> s_ "W: " - | `Info -> s_ "I: " - | `Debug -> s_ "D: " - in - prerr_endline (beg^str) - - - let default = - ref - { - quiet = false; - info = false; - debug = false; - ignore_plugins = false; - ignore_unknown_fields = false; - printf = printf; - } - - - let quiet = - {!default with quiet = true} - - - let fspecs () = - (* TODO: don't act on default. *) - let ignore_plugins = ref false in - ["-quiet", - Arg.Unit (fun () -> default := {!default with quiet = true}), - s_ " Run quietly"; - - "-info", - Arg.Unit (fun () -> default := {!default with info = true}), - s_ " Display information message"; - - - "-debug", - Arg.Unit (fun () -> default := {!default with debug = true}), - s_ " Output debug message"; - - "-ignore-plugins", - Arg.Set ignore_plugins, - s_ " Ignore plugin's field."; - - "-C", - (* TODO: remove this chdir. *) - Arg.String (fun str -> Sys.chdir str), - s_ "dir Change directory before running."], - fun () -> {!default with ignore_plugins = !ignore_plugins} -end - -module OASISString = struct -(* # 22 "src/oasis/OASISString.ml" *) - - - (** Various string utilities. - - Mostly inspired by extlib and batteries ExtString and BatString libraries. - - @author Sylvain Le Gall - *) - - - let nsplitf str f = - if str = "" then - [] - else - let buf = Buffer.create 13 in - let lst = ref [] in - let push () = - lst := Buffer.contents buf :: !lst; - Buffer.clear buf - in - let str_len = String.length str in - for i = 0 to str_len - 1 do - if f str.[i] then - push () - else - Buffer.add_char buf str.[i] - done; - push (); - List.rev !lst - - - (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the - separator. - *) - let nsplit str c = - nsplitf str ((=) c) - - - let find ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx - - - let sub_start str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str len (str_len - len) - - - let sub_end ?(offset=0) str len = - let str_len = String.length str in - if len >= str_len then - "" - else - String.sub str 0 (str_len - len) - - - let starts_with ~what ?(offset=0) str = - let what_idx = ref 0 in - let str_idx = ref offset in - let ok = ref true in - while !ok && - !str_idx < String.length str && - !what_idx < String.length what do - if str.[!str_idx] = what.[!what_idx] then - incr what_idx - else - ok := false; - incr str_idx - done; - if !what_idx = String.length what then - true - else - false - - - let strip_starts_with ~what str = - if starts_with ~what str then - sub_start str (String.length what) - else - raise Not_found - - - let ends_with ~what ?(offset=0) str = - let what_idx = ref ((String.length what) - 1) in - let str_idx = ref ((String.length str) - 1) in - let ok = ref true in - while !ok && - offset <= !str_idx && - 0 <= !what_idx do - if str.[!str_idx] = what.[!what_idx] then - decr what_idx - else - ok := false; - decr str_idx - done; - if !what_idx = -1 then - true - else - false - - - let strip_ends_with ~what str = - if ends_with ~what str then - sub_end str (String.length what) - else - raise Not_found - - - let replace_chars f s = - let buf = Buffer.create (String.length s) in - String.iter (fun c -> Buffer.add_char buf (f c)) s; - Buffer.contents buf - - -end - -module OASISUtils = struct -(* # 22 "src/oasis/OASISUtils.ml" *) - - - open OASISGettext - - - module MapExt = - struct - module type S = - sig - include Map.S - val add_list: 'a t -> (key * 'a) list -> 'a t - val of_list: (key * 'a) list -> 'a t - val to_list: 'a t -> (key * 'a) list - end - - module Make (Ord: Map.OrderedType) = - struct - include Map.Make(Ord) - - let rec add_list t = - function - | (k, v) :: tl -> add_list (add k v t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] - end - end - - - module MapString = MapExt.Make(String) - - - module SetExt = - struct - module type S = - sig - include Set.S - val add_list: t -> elt list -> t - val of_list: elt list -> t - val to_list: t -> elt list - end - - module Make (Ord: Set.OrderedType) = - struct - include Set.Make(Ord) - - let rec add_list t = - function - | e :: tl -> add_list (add e t) tl - | [] -> t - - let of_list lst = add_list empty lst - - let to_list = elements - end - end - - - module SetString = SetExt.Make(String) - - - let compare_csl s1 s2 = - String.compare (String.lowercase s1) (String.lowercase s2) - - - module HashStringCsl = - Hashtbl.Make - (struct - type t = string - - let equal s1 s2 = - (String.lowercase s1) = (String.lowercase s2) - - let hash s = - Hashtbl.hash (String.lowercase s) - end) - - module SetStringCsl = - SetExt.Make - (struct - type t = string - let compare = compare_csl - end) - - - let varname_of_string ?(hyphen='_') s = - if String.length s = 0 then - begin - invalid_arg "varname_of_string" - end - else - begin - let buf = - OASISString.replace_chars - (fun c -> - if ('a' <= c && c <= 'z') - || - ('A' <= c && c <= 'Z') - || - ('0' <= c && c <= '9') then - c - else - hyphen) - s; - in - let buf = - (* Start with a _ if digit *) - if '0' <= s.[0] && s.[0] <= '9' then - "_"^buf - else - buf - in - String.lowercase buf - end - - - let varname_concat ?(hyphen='_') p s = - let what = String.make 1 hyphen in - let p = - try - OASISString.strip_ends_with ~what p - with Not_found -> - p - in - let s = - try - OASISString.strip_starts_with ~what s - with Not_found -> - s - in - p^what^s - - - let is_varname str = - str = varname_of_string str - - - let failwithf fmt = Printf.ksprintf failwith fmt - - -end - -module PropList = struct -(* # 22 "src/oasis/PropList.ml" *) - - - open OASISGettext - - - type name = string - - - exception Not_set of name * string option - exception No_printer of name - exception Unknown_field of name * name - - - let () = - Printexc.register_printer - (function - | Not_set (nm, Some rsn) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) - | Not_set (nm, None) -> - Some - (Printf.sprintf (f_ "Field '%s' is not set") nm) - | No_printer nm -> - Some - (Printf.sprintf (f_ "No default printer for value %s") nm) - | Unknown_field (nm, schm) -> - Some - (Printf.sprintf - (f_ "Field %s is not defined in schema %s") nm schm) - | _ -> - None) - - - module Data = - struct - type t = - (name, unit -> unit) Hashtbl.t - - let create () = - Hashtbl.create 13 - - let clear t = - Hashtbl.clear t - - -(* # 78 "src/oasis/PropList.ml" *) - end - - - module Schema = - struct - type ('ctxt, 'extra) value = - { - get: Data.t -> string; - set: Data.t -> ?context:'ctxt -> string -> unit; - help: (unit -> string) option; - extra: 'extra; - } - - type ('ctxt, 'extra) t = - { - name: name; - fields: (name, ('ctxt, 'extra) value) Hashtbl.t; - order: name Queue.t; - name_norm: string -> string; - } - - let create ?(case_insensitive=false) nm = - { - name = nm; - fields = Hashtbl.create 13; - order = Queue.create (); - name_norm = - (if case_insensitive then - String.lowercase - else - fun s -> s); - } - - let add t nm set get extra help = - let key = - t.name_norm nm - in - - if Hashtbl.mem t.fields key then - failwith - (Printf.sprintf - (f_ "Field '%s' is already defined in schema '%s'") - nm t.name); - Hashtbl.add - t.fields - key - { - set = set; - get = get; - help = help; - extra = extra; - }; - Queue.add nm t.order - - let mem t nm = - Hashtbl.mem t.fields nm - - let find t nm = - try - Hashtbl.find t.fields (t.name_norm nm) - with Not_found -> - raise (Unknown_field (nm, t.name)) - - let get t data nm = - (find t nm).get data - - let set t data nm ?context x = - (find t nm).set - data - ?context - x - - let fold f acc t = - Queue.fold - (fun acc k -> - let v = - find t k - in - f acc k v.extra v.help) - acc - t.order - - let iter f t = - fold - (fun () -> f) - () - t - - let name t = - t.name - end - - - module Field = - struct - type ('ctxt, 'value, 'extra) t = - { - set: Data.t -> ?context:'ctxt -> 'value -> unit; - get: Data.t -> 'value; - sets: Data.t -> ?context:'ctxt -> string -> unit; - gets: Data.t -> string; - help: (unit -> string) option; - extra: 'extra; - } - - let new_id = - let last_id = - ref 0 - in - fun () -> incr last_id; !last_id - - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - (* Default value container *) - let v = - ref None - in - - (* If name is not given, create unique one *) - let nm = - match name with - | Some s -> s - | None -> Printf.sprintf "_anon_%d" (new_id ()) - in - - (* Last chance to get a value: the default *) - let default () = - match default with - | Some d -> d - | None -> raise (Not_set (nm, Some (s_ "no default value"))) - in - - (* Get data *) - let get data = - (* Get value *) - try - (Hashtbl.find data nm) (); - match !v with - | Some x -> x - | None -> default () - with Not_found -> - default () - in - - (* Set data *) - let set data ?context x = - let x = - match update with - | Some f -> - begin - try - f ?context (get data) x - with Not_set _ -> - x - end - | None -> - x - in - Hashtbl.replace - data - nm - (fun () -> v := Some x) - in - - (* Parse string value, if possible *) - let parse = - match parse with - | Some f -> - f - | None -> - fun ?context s -> - failwith - (Printf.sprintf - (f_ "Cannot parse field '%s' when setting value %S") - nm - s) - in - - (* Set data, from string *) - let sets data ?context s = - set ?context data (parse ?context s) - in - - (* Output value as string, if possible *) - let print = - match print with - | Some f -> - f - | None -> - fun _ -> raise (No_printer nm) - in - - (* Get data, as a string *) - let gets data = - print (get data) - in - - begin - match schema with - | Some t -> - Schema.add t nm sets gets extra help - | None -> - () - end; - - { - set = set; - get = get; - sets = sets; - gets = gets; - help = help; - extra = extra; - } - - let fset data t ?context x = - t.set data ?context x - - let fget data t = - t.get data - - let fsets data t ?context s = - t.sets data ?context s - - let fgets data t = - t.gets data - end - - - module FieldRO = - struct - let create ?schema ?name ?parse ?print ?default ?update ?help extra = - let fld = - Field.create ?schema ?name ?parse ?print ?default ?update ?help extra - in - fun data -> Field.fget data fld - end -end - -module OASISMessage = struct -(* # 22 "src/oasis/OASISMessage.ml" *) - - - open OASISGettext - open OASISContext - - - let generic_message ~ctxt lvl fmt = - let cond = - if ctxt.quiet then - false - else - match lvl with - | `Debug -> ctxt.debug - | `Info -> ctxt.info - | _ -> true - in - Printf.ksprintf - (fun str -> - if cond then - begin - ctxt.printf lvl str - end) - fmt - - - let debug ~ctxt fmt = - generic_message ~ctxt `Debug fmt - - - let info ~ctxt fmt = - generic_message ~ctxt `Info fmt - - - let warning ~ctxt fmt = - generic_message ~ctxt `Warning fmt - - - let error ~ctxt fmt = - generic_message ~ctxt `Error fmt - -end - -module OASISVersion = struct -(* # 22 "src/oasis/OASISVersion.ml" *) - - - open OASISGettext - - - - - - type s = string - - - type t = string - - - type comparator = - | VGreater of t - | VGreaterEqual of t - | VEqual of t - | VLesser of t - | VLesserEqual of t - | VOr of comparator * comparator - | VAnd of comparator * comparator - - - - (* Range of allowed characters *) - let is_digit c = - '0' <= c && c <= '9' - - - let is_alpha c = - ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') - - - let is_special = - function - | '.' | '+' | '-' | '~' -> true - | _ -> false - - - let rec version_compare v1 v2 = - if v1 <> "" || v2 <> "" then - begin - (* Compare ascii string, using special meaning for version - * related char - *) - let val_ascii c = - if c = '~' then -1 - else if is_digit c then 0 - else if c = '\000' then 0 - else if is_alpha c then Char.code c - else (Char.code c) + 256 - in - - let len1 = String.length v1 in - let len2 = String.length v2 in - - let p = ref 0 in - - (** Compare ascii part *) - let compare_vascii () = - let cmp = ref 0 in - while !cmp = 0 && - !p < len1 && !p < len2 && - not (is_digit v1.[!p] && is_digit v2.[!p]) do - cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); - incr p - done; - if !cmp = 0 && !p < len1 && !p = len2 then - val_ascii v1.[!p] - else if !cmp = 0 && !p = len1 && !p < len2 then - - (val_ascii v2.[!p]) - else - !cmp - in - - (** Compare digit part *) - let compare_digit () = - let extract_int v p = - let start_p = !p in - while !p < String.length v && is_digit v.[!p] do - incr p - done; - let substr = - String.sub v !p ((String.length v) - !p) - in - let res = - match String.sub v start_p (!p - start_p) with - | "" -> 0 - | s -> int_of_string s - in - res, substr - in - let i1, tl1 = extract_int v1 (ref !p) in - let i2, tl2 = extract_int v2 (ref !p) in - i1 - i2, tl1, tl2 - in - - match compare_vascii () with - | 0 -> - begin - match compare_digit () with - | 0, tl1, tl2 -> - if tl1 <> "" && is_digit tl1.[0] then - 1 - else if tl2 <> "" && is_digit tl2.[0] then - -1 - else - version_compare tl1 tl2 - | n, _, _ -> - n - end - | n -> - n - end - else - begin - 0 - end - - - let version_of_string str = str - - - let string_of_version t = t - - - let version_compare_string s1 s2 = - version_compare (version_of_string s1) (version_of_string s2) - - - let chop t = - try - let pos = - String.rindex t '.' - in - String.sub t 0 pos - with Not_found -> - t - - - let rec comparator_apply v op = - match op with - | VGreater cv -> - (version_compare v cv) > 0 - | VGreaterEqual cv -> - (version_compare v cv) >= 0 - | VLesser cv -> - (version_compare v cv) < 0 - | VLesserEqual cv -> - (version_compare v cv) <= 0 - | VEqual cv -> - (version_compare v cv) = 0 - | VOr (op1, op2) -> - (comparator_apply v op1) || (comparator_apply v op2) - | VAnd (op1, op2) -> - (comparator_apply v op1) && (comparator_apply v op2) - - - let rec string_of_comparator = - function - | VGreater v -> "> "^(string_of_version v) - | VEqual v -> "= "^(string_of_version v) - | VLesser v -> "< "^(string_of_version v) - | VGreaterEqual v -> ">= "^(string_of_version v) - | VLesserEqual v -> "<= "^(string_of_version v) - | VOr (c1, c2) -> - (string_of_comparator c1)^" || "^(string_of_comparator c2) - | VAnd (c1, c2) -> - (string_of_comparator c1)^" && "^(string_of_comparator c2) - - - let rec varname_of_comparator = - let concat p v = - OASISUtils.varname_concat - p - (OASISUtils.varname_of_string - (string_of_version v)) - in - function - | VGreater v -> concat "gt" v - | VLesser v -> concat "lt" v - | VEqual v -> concat "eq" v - | VGreaterEqual v -> concat "ge" v - | VLesserEqual v -> concat "le" v - | VOr (c1, c2) -> - (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) - | VAnd (c1, c2) -> - (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - - - let rec comparator_ge v' = - let cmp v = version_compare v v' >= 0 in - function - | VEqual v - | VGreaterEqual v - | VGreater v -> cmp v - | VLesserEqual _ - | VLesser _ -> false - | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 - | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 - - -end - -module OASISLicense = struct -(* # 22 "src/oasis/OASISLicense.ml" *) - - - (** License for _oasis fields - @author Sylvain Le Gall - *) - - - - - - type license = string - - - type license_exception = string - - - type license_version = - | Version of OASISVersion.t - | VersionOrLater of OASISVersion.t - | NoVersion - - - - type license_dep_5_unit = - { - license: license; - excption: license_exception option; - version: license_version; - } - - - - type license_dep_5 = - | DEP5Unit of license_dep_5_unit - | DEP5Or of license_dep_5 list - | DEP5And of license_dep_5 list - - - type t = - | DEP5License of license_dep_5 - | OtherLicense of string (* URL *) - - - -end - -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) - - - - - - open OASISGettext - - - type test = string - - - type flag = string - - - type t = - | EBool of bool - | ENot of t - | EAnd of t * t - | EOr of t * t - | EFlag of flag - | ETest of test * string - - - - type 'a choices = (t * 'a) list - - - let eval var_get t = - let rec eval' = - function - | EBool b -> - b - - | ENot e -> - not (eval' e) - - | EAnd (e1, e2) -> - (eval' e1) && (eval' e2) - - | EOr (e1, e2) -> - (eval' e1) || (eval' e2) - - | EFlag nm -> - let v = - var_get nm - in - assert(v = "true" || v = "false"); - (v = "true") - - | ETest (nm, vl) -> - let v = - var_get nm - in - (v = vl) - in - eval' t - - - let choose ?printer ?name var_get lst = - let rec choose_aux = - function - | (cond, vl) :: tl -> - if eval var_get cond then - vl - else - choose_aux tl - | [] -> - let str_lst = - if lst = [] then - s_ "" - else - String.concat - (s_ ", ") - (List.map - (fun (cond, vl) -> - match printer with - | Some p -> p vl - | None -> s_ "") - lst) - in - match name with - | Some nm -> - failwith - (Printf.sprintf - (f_ "No result for the choice list '%s': %s") - nm str_lst) - | None -> - failwith - (Printf.sprintf - (f_ "No result for a choice list: %s") - str_lst) - in - choose_aux (List.rev lst) - - -end - -module OASISText = struct -(* # 22 "src/oasis/OASISText.ml" *) - - - - type elt = - | Para of string - | Verbatim of string - | BlankLine - - - type t = elt list - -end - -module OASISTypes = struct -(* # 22 "src/oasis/OASISTypes.ml" *) - - - - - - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) - - - type findlib_name = string - type findlib_full = string - - - type compiled_object = - | Byte - | Native - | Best - - - - type dependency = - | FindlibPackage of findlib_full * OASISVersion.comparator option - | InternalLibrary of name - - - - type tool = - | ExternalTool of name - | InternalExecutable of name - - - - type vcs = - | Darcs - | Git - | Svn - | Cvs - | Hg - | Bzr - | Arch - | Monotone - | OtherVCS of url - - - - type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install - | `Extra - ] - - - type plugin_data_purpose = - [ `Configure - | `Build - | `Install - | `Clean - | `Distclean - | `Install - | `Uninstall - | `Test - | `Doc - | `Extra - | `Other of string - ] - - - type 'a plugin = 'a * name * OASISVersion.t option - - - type all_plugin = plugin_kind plugin - - - type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list - - -(* # 115 "src/oasis/OASISTypes.ml" *) - - - type 'a conditional = 'a OASISExpr.choices - - - type custom = - { - pre_command: (command_line option) conditional; - post_command: (command_line option) conditional; - } - - - - type common_section = - { - cs_name: name; - cs_data: PropList.Data.t; - cs_plugin_data: plugin_data; - } - - - - type build_section = - { - bs_build: bool conditional; - bs_install: bool conditional; - bs_path: unix_dirname; - bs_compiled_object: compiled_object; - bs_build_depends: dependency list; - bs_build_tools: tool list; - bs_c_sources: unix_filename list; - bs_data_files: (unix_filename * unix_filename option) list; - bs_ccopt: args conditional; - bs_cclib: args conditional; - bs_dlllib: args conditional; - bs_dllpath: args conditional; - bs_byteopt: args conditional; - bs_nativeopt: args conditional; - } - - - - type library = - { - lib_modules: string list; - lib_pack: bool; - lib_internal_modules: string list; - lib_findlib_parent: findlib_name option; - lib_findlib_name: findlib_name option; - lib_findlib_containers: findlib_name list; - } - - - type object_ = - { - obj_modules: string list; - obj_findlib_fullname: findlib_name list option; - } - - - type executable = - { - exec_custom: bool; - exec_main_is: unix_filename; - } - - - type flag = - { - flag_description: string option; - flag_default: bool conditional; - } - - - type source_repository = - { - src_repo_type: vcs; - src_repo_location: url; - src_repo_browser: url option; - src_repo_module: string option; - src_repo_branch: string option; - src_repo_tag: string option; - src_repo_subdir: unix_filename option; - } - - - type test = - { - test_type: [`Test] plugin; - test_command: command_line conditional; - test_custom: custom; - test_working_directory: unix_filename option; - test_run: bool conditional; - test_tools: tool list; - } - - - type doc_format = - | HTML of unix_filename - | DocText - | PDF - | PostScript - | Info of unix_filename - | DVI - | OtherDoc - - - - type doc = - { - doc_type: [`Doc] plugin; - doc_custom: custom; - doc_build: bool conditional; - doc_install: bool conditional; - doc_install_dir: unix_filename; - doc_title: string; - doc_authors: string list; - doc_abstract: string option; - doc_format: doc_format; - doc_data_files: (unix_filename * unix_filename option) list; - doc_build_tools: tool list; - } - - - type section = - | Library of common_section * build_section * library - | Object of common_section * build_section * object_ - | Executable of common_section * build_section * executable - | Flag of common_section * flag - | SrcRepo of common_section * source_repository - | Test of common_section * test - | Doc of common_section * doc - - - - type section_kind = - [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] - - - type package = - { - oasis_version: OASISVersion.t; - ocaml_version: OASISVersion.comparator option; - findlib_version: OASISVersion.comparator option; - alpha_features: string list; - beta_features: string list; - name: package_name; - version: OASISVersion.t; - license: OASISLicense.t; - license_file: unix_filename option; - copyrights: string list; - maintainers: string list; - authors: string list; - homepage: url option; - synopsis: string; - description: OASISText.t option; - categories: url list; - - conf_type: [`Configure] plugin; - conf_custom: custom; - - build_type: [`Build] plugin; - build_custom: custom; - - install_type: [`Install] plugin; - install_custom: custom; - uninstall_custom: custom; - - clean_custom: custom; - distclean_custom: custom; - - files_ab: unix_filename list; - sections: section list; - plugins: [`Extra] plugin list; - disable_oasis_section: unix_filename list; - schema_data: PropList.Data.t; - plugin_data: plugin_data; - } - - -end - -module OASISFeatures = struct -(* # 22 "src/oasis/OASISFeatures.ml" *) - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISVersion - - module MapPlugin = - Map.Make - (struct - type t = plugin_kind * name - let compare = Pervasives.compare - end) - - module Data = - struct - type t = - { - oasis_version: OASISVersion.t; - plugin_versions: OASISVersion.t option MapPlugin.t; - alpha_features: string list; - beta_features: string list; - } - - let create oasis_version alpha_features beta_features = - { - oasis_version = oasis_version; - plugin_versions = MapPlugin.empty; - alpha_features = alpha_features; - beta_features = beta_features - } - - let of_package pkg = - create - pkg.OASISTypes.oasis_version - pkg.OASISTypes.alpha_features - pkg.OASISTypes.beta_features - - let add_plugin (plugin_kind, plugin_name, plugin_version) t = - {t with - plugin_versions = MapPlugin.add - (plugin_kind, plugin_name) - plugin_version - t.plugin_versions} - - let plugin_version plugin_kind plugin_name t = - MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions - - let to_string t = - Printf.sprintf - "oasis_version: %s; alpha_features: %s; beta_features: %s; \ - plugins_version: %s" - (OASISVersion.string_of_version t.oasis_version) - (String.concat ", " t.alpha_features) - (String.concat ", " t.beta_features) - (String.concat ", " - (MapPlugin.fold - (fun (_, plg) ver_opt acc -> - (plg^ - (match ver_opt with - | Some v -> - " "^(OASISVersion.string_of_version v) - | None -> "")) - :: acc) - t.plugin_versions [])) - end - - type origin = - | Field of string * string - | Section of string - | NoOrigin - - type stage = Alpha | Beta - - - let string_of_stage = - function - | Alpha -> "alpha" - | Beta -> "beta" - - - let field_of_stage = - function - | Alpha -> "AlphaFeatures" - | Beta -> "BetaFeatures" - - type publication = InDev of stage | SinceVersion of OASISVersion.t - - type t = - { - name: string; - plugin: all_plugin option; - publication: publication; - description: unit -> string; - } - - (* TODO: mutex protect this. *) - let all_features = Hashtbl.create 13 - - - let since_version ver_str = SinceVersion (version_of_string ver_str) - let alpha = InDev Alpha - let beta = InDev Beta - - - let to_string t = - Printf.sprintf - "feature: %s; plugin: %s; publication: %s" - t.name - (match t.plugin with - | None -> "" - | Some (_, nm, _) -> nm) - (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) - - let data_check t data origin = - let no_message = "no message" in - - let check_feature features stage = - let has_feature = List.mem t.name features in - if not has_feature then - match origin with - | Field (fld, where) -> - Some - (Printf.sprintf - (f_ "Field %s in %s is only available when feature %s \ - is in field %s.") - fld where t.name (field_of_stage stage)) - | Section sct -> - Some - (Printf.sprintf - (f_ "Section %s is only available when features %s \ - is in field %s.") - sct t.name (field_of_stage stage)) - | NoOrigin -> - Some no_message - else - None - in - - let version_is_good ~min_version version fmt = - let version_is_good = - OASISVersion.comparator_apply - version (OASISVersion.VGreaterEqual min_version) - in - Printf.ksprintf - (fun str -> - if version_is_good then - None - else - Some str) - fmt - in - - match origin, t.plugin, t.publication with - | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha - | _, _, InDev Beta -> check_feature data.Data.beta_features Beta - | Field(fld, where), None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Field %s in %s is only valid since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking \ - OASIS changelog.") - fld where (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Field(fld, where), Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Field %s in %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - fld where plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Field %s in %s is only valid when the OASIS plugin %s \ - is defined.") - fld where plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Field %s in %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - fld where plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | Section sct, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version - (f_ "Section %s is only valid for since OASIS v%s, update \ - OASISFormat field from '%s' to '%s' after checking OASIS \ - changelog.") - sct (string_of_version min_version) - (string_of_version data.Data.oasis_version) - (string_of_version min_version) - - | Section sct, Some(plugin_knd, plugin_name, _), - SinceVersion min_version -> - begin - try - let plugin_version_current = - try - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> - failwithf - (f_ "Section %s is only valid for the OASIS \ - plugin %s since v%s, but no plugin version is \ - defined in the _oasis file, change '%s' to \ - '%s (%s)' in your _oasis file.") - sct plugin_name (string_of_version min_version) - plugin_name - plugin_name (string_of_version min_version) - with Not_found -> - failwithf - (f_ "Section %s is only valid when the OASIS plugin %s \ - is defined.") - sct plugin_name - in - version_is_good ~min_version plugin_version_current - (f_ "Section %s is only valid for the OASIS plugin %s \ - since v%s, update your plugin from '%s (%s)' to \ - '%s (%s)' after checking the plugin's changelog.") - sct plugin_name (string_of_version min_version) - plugin_name (string_of_version plugin_version_current) - plugin_name (string_of_version min_version) - with Failure msg -> - Some msg - end - - | NoOrigin, None, SinceVersion min_version -> - version_is_good ~min_version data.Data.oasis_version "%s" no_message - - | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> - begin - try - let plugin_version_current = - match Data.plugin_version plugin_knd plugin_name data with - | Some ver -> ver - | None -> raise Not_found - in - version_is_good ~min_version plugin_version_current - "%s" no_message - with Not_found -> - Some no_message - end - - - let data_assert t data origin = - match data_check t data origin with - | None -> () - | Some str -> failwith str - - - let data_test t data = - match data_check t data NoOrigin with - | None -> true - | Some str -> false - - - let package_test t pkg = - data_test t (Data.of_package pkg) - - - let create ?plugin name publication description = - let () = - if Hashtbl.mem all_features name then - failwithf "Feature '%s' is already declared." name - in - let t = - { - name = name; - plugin = plugin; - publication = publication; - description = description; - } - in - Hashtbl.add all_features name t; - t - - - let get_stage name = - try - (Hashtbl.find all_features name).publication - with Not_found -> - failwithf (f_ "Feature %s doesn't exist.") name - - - let list () = - Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] - - (* - * Real flags. - *) - - - let features = - create "features_fields" - (since_version "0.4") - (fun () -> - s_ "Enable to experiment not yet official features.") - - - let flag_docs = - create "flag_docs" - (since_version "0.3") - (fun () -> - s_ "Building docs require '-docs' flag at configure.") - - - let flag_tests = - create "flag_tests" - (since_version "0.3") - (fun () -> - s_ "Running tests require '-tests' flag at configure.") - - - let pack = - create "pack" - (since_version "0.3") - (fun () -> - s_ "Allow to create packed library.") - - - let section_object = - create "section_object" beta - (fun () -> - s_ "Implement an object section.") - - - let dynrun_for_release = - create "dynrun_for_release" alpha - (fun () -> - s_ "Make '-setup-update dynamic' suitable for releasing project.") - - - let compiled_setup_ml = - create "compiled_setup_ml" alpha - (fun () -> - s_ "It compiles the setup.ml and speed-up actions done with it.") - - let disable_oasis_section = - create "disable_oasis_section" alpha - (fun () -> - s_ "Allows the OASIS section comments and digest to be omitted in \ - generated files.") - - let no_automatic_syntax = - create "no_automatic_syntax" alpha - (fun () -> - s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ - that matches the internal heuristic (if a dependency ends with \ - a .syntax or is a well known syntax).") -end - -module OASISUnixPath = struct -(* # 22 "src/oasis/OASISUnixPath.ml" *) - - - type unix_filename = string - type unix_dirname = string - - - type host_filename = string - type host_dirname = string - - - let current_dir_name = "." - - - let parent_dir_name = ".." - - - let is_current_dir fn = - fn = current_dir_name || fn = "" - - - let concat f1 f2 = - if is_current_dir f1 then - f2 - else - let f1' = - try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 - in - f1'^"/"^f2 - - - let make = - function - | hd :: tl -> - List.fold_left - (fun f p -> concat f p) - hd - tl - | [] -> - invalid_arg "OASISUnixPath.make" - - - let dirname f = - try - String.sub f 0 (String.rindex f '/') - with Not_found -> - current_dir_name - - - let basename f = - try - let pos_start = - (String.rindex f '/') + 1 - in - String.sub f pos_start ((String.length f) - pos_start) - with Not_found -> - f - - - let chop_extension f = - try - let last_dot = - String.rindex f '.' - in - let sub = - String.sub f 0 last_dot - in - try - let last_slash = - String.rindex f '/' - in - if last_slash < last_dot then - sub - else - f - with Not_found -> - sub - - with Not_found -> - f - - - let capitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.capitalize base) - - - let uncapitalize_file f = - let dir = dirname f in - let base = basename f in - concat dir (String.uncapitalize base) - - -end - -module OASISHostPath = struct -(* # 22 "src/oasis/OASISHostPath.ml" *) - - - open Filename - - - module Unix = OASISUnixPath - - - let make = - function - | [] -> - invalid_arg "OASISHostPath.make" - | hd :: tl -> - List.fold_left Filename.concat hd tl - - - let of_unix ufn = - if Sys.os_type = "Unix" then - ufn - else - make - (List.map - (fun p -> - if p = Unix.current_dir_name then - current_dir_name - else if p = Unix.parent_dir_name then - parent_dir_name - else - p) - (OASISString.nsplit ufn '/')) - - -end - -module OASISSection = struct -(* # 22 "src/oasis/OASISSection.ml" *) - - - open OASISTypes - - - let section_kind_common = - function - | Library (cs, _, _) -> - `Library, cs - | Object (cs, _, _) -> - `Object, cs - | Executable (cs, _, _) -> - `Executable, cs - | Flag (cs, _) -> - `Flag, cs - | SrcRepo (cs, _) -> - `SrcRepo, cs - | Test (cs, _) -> - `Test, cs - | Doc (cs, _) -> - `Doc, cs - - - let section_common sct = - snd (section_kind_common sct) - - - let section_common_set cs = - function - | Library (_, bs, lib) -> Library (cs, bs, lib) - | Object (_, bs, obj) -> Object (cs, bs, obj) - | Executable (_, bs, exec) -> Executable (cs, bs, exec) - | Flag (_, flg) -> Flag (cs, flg) - | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) - | Test (_, tst) -> Test (cs, tst) - | Doc (_, doc) -> Doc (cs, doc) - - - (** Key used to identify section - *) - let section_id sct = - let k, cs = - section_kind_common sct - in - k, cs.cs_name - - - let string_of_section sct = - let k, nm = - section_id sct - in - (match k with - | `Library -> "library" - | `Object -> "object" - | `Executable -> "executable" - | `Flag -> "flag" - | `SrcRepo -> "src repository" - | `Test -> "test" - | `Doc -> "doc") - ^" "^nm - - - let section_find id scts = - List.find - (fun sct -> id = section_id sct) - scts - - - module CSection = - struct - type t = section - - let id = section_id - - let compare t1 t2 = - compare (id t1) (id t2) - - let equal t1 t2 = - (id t1) = (id t2) - - let hash t = - Hashtbl.hash (id t) - end - - - module MapSection = Map.Make(CSection) - module SetSection = Set.Make(CSection) - - -end - -module OASISBuildSection = struct -(* # 22 "src/oasis/OASISBuildSection.ml" *) - - -end - -module OASISExecutable = struct -(* # 22 "src/oasis/OASISExecutable.ml" *) - - - open OASISTypes - - - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = - OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.dirname exec.exec_main_is) - in - let is_native_exec = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native () - | Byte -> false - in - - OASISUnixPath.concat - dir - (cs.cs_name^(suffix_program ())), - - if not is_native_exec && - not exec.exec_custom && - bs.bs_c_sources <> [] then - Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) - else - None - - -end - -module OASISLibrary = struct -(* # 22 "src/oasis/OASISLibrary.ml" *) - - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISSection - - - (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists bs modul = - let possible_base_fn = - List.map - (OASISUnixPath.concat bs.bs_path) - [modul; - OASISUnixPath.uncapitalize_file modul; - OASISUnixPath.capitalize_file modul] - in - (* TODO: we should be able to be able to determine the source for every - * files. Hence we should introduce a Module(source: fn) for the fields - * Modules and InternalModules - *) - List.fold_left - (fun acc base_fn -> - match acc with - | `No_sources _ -> - begin - let file_found = - List.fold_left - (fun acc ext -> - if source_file_exists (base_fn^ext) then - (base_fn^ext) :: acc - else - acc) - [] - [".ml"; ".mli"; ".mll"; ".mly"] - in - match file_found with - | [] -> - acc - | lst -> - `Sources (base_fn, lst) - end - | `Sources _ -> - acc) - (`No_sources possible_base_fn) - possible_base_fn - - - let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = - List.fold_left - (fun acc modul -> - match find_module source_file_exists bs modul with - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - acc) - [] - (lib.lib_modules @ lib.lib_internal_modules) - - - let generated_unix_files - ~ctxt - ~is_native - ~has_native_dynlink - ~ext_lib - ~ext_dll - ~source_file_exists - (cs, bs, lib) = - - let find_modules lst ext = - let find_module modul = - match find_module source_file_exists bs modul with - | `Sources (base_fn, [fn]) when ext <> "cmi" - && Filename.check_suffix fn ".mli" -> - None (* No implementation files for pure interface. *) - | `Sources (base_fn, _) -> - Some [base_fn] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in library %s") - modul cs.cs_name; - Some lst - in - List.fold_left - (fun acc nm -> - match find_module nm with - | None -> acc - | Some base_fns -> - List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) - [] - lst - in - - (* The .cmx that be compiled along *) - let cmxs = - let should_be_built = - match bs.bs_compiled_object with - | Native -> true - | Best -> is_native - | Byte -> false - in - if should_be_built then - if lib.lib_pack then - find_modules - [cs.cs_name] - "cmx" - else - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" - else - [] - in - - let acc_nopath = - [] - in - - (* The headers and annot/cmt files that should be compiled along *) - let headers = - let sufx = - if lib.lib_pack - then [".cmti"; ".cmt"; ".annot"] - else [".cmi"; ".cmti"; ".cmt"; ".annot"] - in - List.map - begin - List.fold_left - begin fun accu s -> - let dot = String.rindex s '.' in - let base = String.sub s 0 dot in - List.map ((^) base) sufx @ accu - end - [] - end - (find_modules lib.lib_modules "cmi") - in - - (* Compute what libraries should be built *) - let acc_nopath = - (* Add the packed header file if required *) - let add_pack_header acc = - if lib.lib_pack then - [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc - else - acc - in - let byte acc = - add_pack_header ([cs.cs_name^".cma"] :: acc) - in - let native acc = - let acc = - add_pack_header - (if has_native_dynlink then - [cs.cs_name^".cmxs"] :: acc - else acc) - in - [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc - in - match bs.bs_compiled_object with - | Native -> - byte (native acc_nopath) - | Best when is_native -> - byte (native acc_nopath) - | Byte | Best -> - byte acc_nopath - in - - (* Add C library to be built *) - let acc_nopath = - if bs.bs_c_sources <> [] then - begin - ["lib"^cs.cs_name^"_stubs"^ext_lib] - :: - ["dll"^cs.cs_name^"_stubs"^ext_dll] - :: - acc_nopath - end - else - acc_nopath - in - - (* All the files generated *) - List.rev_append - (List.rev_map - (List.rev_map - (OASISUnixPath.concat bs.bs_path)) - acc_nopath) - (headers @ cmxs) - - -end - -module OASISObject = struct -(* # 22 "src/oasis/OASISObject.ml" *) - - - open OASISTypes - open OASISGettext - - - let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = - List.fold_left - (fun acc modul -> - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, lst) -> - (base_fn, lst) :: acc - | `No_sources _ -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name; - acc) - [] - obj.obj_modules - - - let generated_unix_files - ~ctxt - ~is_native - ~source_file_exists - (cs, bs, obj) = - - let find_module ext modul = - match OASISLibrary.find_module source_file_exists bs modul with - | `Sources (base_fn, _) -> [base_fn ^ ext] - | `No_sources lst -> - OASISMessage.warning - ~ctxt - (f_ "Cannot find source file matching \ - module '%s' in object %s") - modul cs.cs_name ; - lst - in - - let header, byte, native, c_object, f = - match obj.obj_modules with - | [ m ] -> (find_module ".cmi" m, - find_module ".cmo" m, - find_module ".cmx" m, - find_module ".o" m, - fun x -> x) - | _ -> ([cs.cs_name ^ ".cmi"], - [cs.cs_name ^ ".cmo"], - [cs.cs_name ^ ".cmx"], - [cs.cs_name ^ ".o"], - OASISUnixPath.concat bs.bs_path) - in - List.map (List.map f) ( - match bs.bs_compiled_object with - | Native -> - native :: c_object :: byte :: header :: [] - | Best when is_native -> - native :: c_object :: byte :: header :: [] - | Byte | Best -> - byte :: header :: []) - - -end - -module OASISFindlib = struct -(* # 22 "src/oasis/OASISFindlib.ml" *) - - - open OASISTypes - open OASISUtils - open OASISGettext - open OASISSection - - - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - [`Library of library | `Object of object_] * - group_t list) - - - type data = common_section * - build_section * - [`Library of library | `Object of object_] - type tree = - | Node of (data option) * (tree MapString.t) - | Leaf of data - - - let findlib_mapping pkg = - (* Map from library name to either full findlib name or parts + parent. *) - let fndlb_parts_of_lib_name = - let fndlb_parts cs lib = - let name = - match lib.lib_findlib_name with - | Some nm -> nm - | None -> cs.cs_name - in - let name = - String.concat "." (lib.lib_findlib_containers @ [name]) - in - name - in - List.fold_left - (fun mp -> - function - | Library (cs, _, lib) -> - begin - let lib_name = cs.cs_name in - let fndlb_parts = fndlb_parts cs lib in - if MapString.mem lib_name mp then - failwithf - (f_ "The library name '%s' is used more than once.") - lib_name; - match lib.lib_findlib_parent with - | Some lib_name_parent -> - MapString.add - lib_name - (`Unsolved (lib_name_parent, fndlb_parts)) - mp - | None -> - MapString.add - lib_name - (`Solved fndlb_parts) - mp - end - - | Object (cs, _, obj) -> - begin - let obj_name = cs.cs_name in - if MapString.mem obj_name mp then - failwithf - (f_ "The object name '%s' is used more than once.") - obj_name; - let findlib_full_name = match obj.obj_findlib_fullname with - | Some ns -> String.concat "." ns - | None -> obj_name - in - MapString.add - obj_name - (`Solved findlib_full_name) - mp - end - - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> - mp) - MapString.empty - pkg.sections - in - - (* Solve the above graph to be only library name to full findlib name. *) - let fndlb_name_of_lib_name = - let rec solve visited mp lib_name lib_name_child = - if SetString.mem lib_name visited then - failwithf - (f_ "Library '%s' is involved in a cycle \ - with regard to findlib naming.") - lib_name; - let visited = SetString.add lib_name visited in - try - match MapString.find lib_name mp with - | `Solved fndlb_nm -> - fndlb_nm, mp - | `Unsolved (lib_nm_parent, post_fndlb_nm) -> - let pre_fndlb_nm, mp = - solve visited mp lib_nm_parent lib_name - in - let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in - fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp - with Not_found -> - failwithf - (f_ "Library '%s', which is defined as the findlib parent of \ - library '%s', doesn't exist.") - lib_name lib_name_child - in - let mp = - MapString.fold - (fun lib_name status mp -> - match status with - | `Solved _ -> - (* Solved initialy, no need to go further *) - mp - | `Unsolved _ -> - let _, mp = solve SetString.empty mp lib_name "" in - mp) - fndlb_parts_of_lib_name - fndlb_parts_of_lib_name - in - MapString.map - (function - | `Solved fndlb_nm -> fndlb_nm - | `Unsolved _ -> assert false) - mp - in - - (* Convert an internal library name to a findlib name. *) - let findlib_name_of_library_name lib_nm = - try - MapString.find lib_nm fndlb_name_of_lib_name - with Not_found -> - raise (InternalLibraryNotFound lib_nm) - in - - (* Add a library to the tree. - *) - let add sct mp = - let fndlb_fullname = - let cs, _, _ = sct in - let lib_name = cs.cs_name in - findlib_name_of_library_name lib_name - in - let rec add_children nm_lst (children: tree MapString.t) = - match nm_lst with - | (hd :: tl) -> - begin - let node = - try - add_node tl (MapString.find hd children) - with Not_found -> - (* New node *) - new_node tl - in - MapString.add hd node children - end - | [] -> - (* Should not have a nameless library. *) - assert false - and add_node tl node = - if tl = [] then - begin - match node with - | Node (None, children) -> - Node (Some sct, children) - | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> - (* TODO: allow to merge Package, i.e. - * archive(byte) = "foo.cma foo_init.cmo" - *) - let cs, _, _ = sct in - failwithf - (f_ "Library '%s' and '%s' have the same findlib name '%s'") - cs.cs_name cs'.cs_name fndlb_fullname - end - else - begin - match node with - | Leaf data -> - Node (Some data, add_children tl MapString.empty) - | Node (data_opt, children) -> - Node (data_opt, add_children tl children) - end - and new_node = - function - | [] -> - Leaf sct - | hd :: tl -> - Node (None, MapString.add hd (new_node tl) MapString.empty) - in - add_children (OASISString.nsplit fndlb_fullname '.') mp - in - - let rec group_of_tree mp = - MapString.fold - (fun nm node acc -> - let cur = - match node with - | Node (Some (cs, bs, lib), children) -> - Package (nm, cs, bs, lib, group_of_tree children) - | Node (None, children) -> - Container (nm, group_of_tree children) - | Leaf (cs, bs, lib) -> - Package (nm, cs, bs, lib, []) - in - cur :: acc) - mp [] - in - - let group_mp = - List.fold_left - (fun mp -> - function - | Library (cs, bs, lib) -> - add (cs, bs, `Library lib) mp - | Object (cs, bs, obj) -> - add (cs, bs, `Object obj) mp - | _ -> - mp) - MapString.empty - pkg.sections - in - - let groups = - group_of_tree group_mp - in - - let library_name_of_findlib_name = - lazy begin - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty - end - in - let library_name_of_findlib_name fndlb_nm = - try - MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) - with Not_found -> - raise (FindlibPackageNotFound fndlb_nm) - in - - groups, - findlib_name_of_library_name, - library_name_of_findlib_name - - - let findlib_of_group = - function - | Container (fndlb_nm, _) - | Package (fndlb_nm, _, _, _, _) -> fndlb_nm - - - let root_of_group grp = - let rec root_lib_aux = - (* We do a DFS in the group. *) - function - | Container (_, children) -> - List.fold_left - (fun res grp -> - if res = None then - root_lib_aux grp - else - res) - None - children - | Package (_, cs, bs, lib, _) -> - Some (cs, bs, lib) - in - match root_lib_aux grp with - | Some res -> - res - | None -> - failwithf - (f_ "Unable to determine root library of findlib library '%s'") - (findlib_of_group grp) - - -end - -module OASISFlag = struct -(* # 22 "src/oasis/OASISFlag.ml" *) - - -end - -module OASISPackage = struct -(* # 22 "src/oasis/OASISPackage.ml" *) - - -end - -module OASISSourceRepository = struct -(* # 22 "src/oasis/OASISSourceRepository.ml" *) - - -end - -module OASISTest = struct -(* # 22 "src/oasis/OASISTest.ml" *) - - -end - -module OASISDocument = struct -(* # 22 "src/oasis/OASISDocument.ml" *) - - -end - -module OASISExec = struct -(* # 22 "src/oasis/OASISExec.ml" *) - - - open OASISGettext - open OASISUtils - open OASISMessage - - - (* TODO: I don't like this quote, it is there because $(rm) foo expands to - * 'rm -f' foo... - *) - let run ~ctxt ?f_exit_code ?(quote=true) cmd args = - let cmd = - if quote then - if Sys.os_type = "Win32" then - if String.contains cmd ' ' then - (* Double the 1st double quote... win32... sigh *) - "\""^(Filename.quote cmd) - else - cmd - else - Filename.quote cmd - else - cmd - in - let cmdline = - String.concat " " (cmd :: args) - in - info ~ctxt (f_ "Running command '%s'") cmdline; - match f_exit_code, Sys.command cmdline with - | None, 0 -> () - | None, i -> - failwithf - (f_ "Command '%s' terminated with error code %d") - cmdline i - | Some f, i -> - f i - - - let run_read_output ~ctxt ?f_exit_code cmd args = - let fn = - Filename.temp_file "oasis-" ".txt" - in - try - begin - let () = - run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) - in - let chn = - open_in fn - in - let routput = - ref [] - in - begin - try - while true do - routput := (input_line chn) :: !routput - done - with End_of_file -> - () - end; - close_in chn; - Sys.remove fn; - List.rev !routput - end - with e -> - (try Sys.remove fn with _ -> ()); - raise e - - - let run_read_one_line ~ctxt ?f_exit_code cmd args = - match run_read_output ~ctxt ?f_exit_code cmd args with - | [fst] -> - fst - | lst -> - failwithf - (f_ "Command return unexpected output %S") - (String.concat "\n" lst) -end - -module OASISFileUtil = struct -(* # 22 "src/oasis/OASISFileUtil.ml" *) - - - open OASISGettext - - - let file_exists_case fn = - let dirname = Filename.dirname fn in - let basename = Filename.basename fn in - if Sys.file_exists dirname then - if basename = Filename.current_dir_name then - true - else - List.mem - basename - (Array.to_list (Sys.readdir dirname)) - else - false - - - let find_file ?(case_sensitive=true) paths exts = - - (* Cardinal product of two list *) - let ( * ) lst1 lst2 = - List.flatten - (List.map - (fun a -> - List.map - (fun b -> a, b) - lst2) - lst1) - in - - let rec combined_paths lst = - match lst with - | p1 :: p2 :: tl -> - let acc = - (List.map - (fun (a, b) -> Filename.concat a b) - (p1 * p2)) - in - combined_paths (acc :: tl) - | [e] -> - e - | [] -> - [] - in - - let alternatives = - List.map - (fun (p, e) -> - if String.length e > 0 && e.[0] <> '.' then - p ^ "." ^ e - else - p ^ e) - ((combined_paths paths) * exts) - in - List.find (fun file -> - (if case_sensitive then - file_exists_case file - else - Sys.file_exists file) - && not (Sys.is_directory file) - ) alternatives - - - let which ~ctxt prg = - let path_sep = - match Sys.os_type with - | "Win32" -> - ';' - | _ -> - ':' - in - let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in - let exec_ext = - match Sys.os_type with - | "Win32" -> - "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) - | _ -> - [""] - in - find_file ~case_sensitive:false [path_lst; [prg]] exec_ext - - - (**/**) - let rec fix_dir dn = - (* Windows hack because Sys.file_exists "src\\" = false when - * Sys.file_exists "src" = true - *) - let ln = - String.length dn - in - if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then - fix_dir (String.sub dn 0 (ln - 1)) - else - dn - - - let q = Filename.quote - (**/**) - - - let cp ~ctxt ?(recurse=false) src tgt = - if recurse then - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt - "xcopy" [q src; q tgt; "/E"] - | _ -> - OASISExec.run ~ctxt - "cp" ["-r"; q src; q tgt] - else - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "copy" - | _ -> "cp") - [q src; q tgt] - - - let mkdir ~ctxt tgt = - OASISExec.run ~ctxt - (match Sys.os_type with - | "Win32" -> "md" - | _ -> "mkdir") - [q tgt] - - - let rec mkdir_parent ~ctxt f tgt = - let tgt = - fix_dir tgt - in - if Sys.file_exists tgt then - begin - if not (Sys.is_directory tgt) then - OASISUtils.failwithf - (f_ "Cannot create directory '%s', a file of the same name already \ - exists") - tgt - end - else - begin - mkdir_parent ~ctxt f (Filename.dirname tgt); - if not (Sys.file_exists tgt) then - begin - f tgt; - mkdir ~ctxt tgt - end - end - - - let rmdir ~ctxt tgt = - if Sys.readdir tgt = [||] then begin - match Sys.os_type with - | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] - | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] - end else begin - OASISMessage.error ~ctxt - (f_ "Cannot remove directory '%s': not empty.") - tgt - end - - - let glob ~ctxt fn = - let basename = - Filename.basename fn - in - if String.length basename >= 2 && - basename.[0] = '*' && - basename.[1] = '.' then - begin - let ext_len = - (String.length basename) - 2 - in - let ext = - String.sub basename 2 ext_len - in - let dirname = - Filename.dirname fn - in - Array.fold_left - (fun acc fn -> - try - let fn_ext = - String.sub - fn - ((String.length fn) - ext_len) - ext_len - in - if fn_ext = ext then - (Filename.concat dirname fn) :: acc - else - acc - with Invalid_argument _ -> - acc) - [] - (Sys.readdir dirname) - end - else - begin - if file_exists_case fn then - [fn] - else - [] - end -end - - -# 2893 "setup.ml" -module BaseEnvLight = struct -(* # 22 "src/base/BaseEnvLight.ml" *) - - - module MapString = Map.Make(String) - - - type t = string MapString.t - - - let default_filename = - Filename.concat - (Sys.getcwd ()) - "setup.data" - - - let load ?(allow_empty=false) ?(filename=default_filename) () = - if Sys.file_exists filename then - begin - let chn = - open_in_bin filename - in - let st = - Stream.of_channel chn - in - let line = - ref 1 - in - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - let lexer = - Genlex.make_lexer ["="] st_line - in - let rec read_file mp = - match Stream.npeek 3 lexer with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lexer; - Stream.junk lexer; - Stream.junk lexer; - read_file (MapString.add nm value mp) - | [] -> - mp - | _ -> - failwith - (Printf.sprintf - "Malformed data file '%s' line %d" - filename !line) - in - let mp = - read_file MapString.empty - in - close_in chn; - mp - end - else if allow_empty then - begin - MapString.empty - end - else - begin - failwith - (Printf.sprintf - "Unable to load environment, the file '%s' doesn't exist." - filename) - end - - - let rec var_expand str env = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = - var_expand (MapString.find name env) env - - - let var_choose lst env = - OASISExpr.choose - (fun nm -> var_get nm env) - lst -end - - -# 2998 "setup.ml" -module BaseContext = struct -(* # 22 "src/base/BaseContext.ml" *) - - (* TODO: get rid of this module. *) - open OASISContext - - - let args () = fst (fspecs ()) - - - let default = default - -end - -module BaseMessage = struct -(* # 22 "src/base/BaseMessage.ml" *) - - - (** Message to user, overrid for Base - @author Sylvain Le Gall - *) - open OASISMessage - open BaseContext - - - let debug fmt = debug ~ctxt:!default fmt - - - let info fmt = info ~ctxt:!default fmt - - - let warning fmt = warning ~ctxt:!default fmt - - - let error fmt = error ~ctxt:!default fmt - -end - -module BaseEnv = struct -(* # 22 "src/base/BaseEnv.ml" *) - - open OASISGettext - open OASISUtils - open PropList - - - module MapString = BaseEnvLight.MapString - - - type origin_t = - | ODefault - | OGetEnv - | OFileLoad - | OCommandLine - - - type cli_handle_t = - | CLINone - | CLIAuto - | CLIWith - | CLIEnable - | CLIUser of (Arg.key * Arg.spec * Arg.doc) list - - - type definition_t = - { - hide: bool; - dump: bool; - cli: cli_handle_t; - arg_help: string option; - group: string option; - } - - - let schema = - Schema.create "environment" - - - (* Environment data *) - let env = - Data.create () - - - (* Environment data from file *) - let env_from_file = - ref MapString.empty - - - (* Lexer for var *) - let var_lxr = - Genlex.make_lexer [] - - - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - (* TODO: this is a quick hack to allow calling Test.Command - * without defining executable name really. I.e. if there is - * an exec Executable toto, then $(toto) should be replace - * by its real name. It is however useful to have this function - * for other variable that depend on the host and should be - * written better than that. - *) - let st = - var_lxr (Stream.of_string var) - in - match Stream.npeek 3 st with - | [Genlex.Ident "utoh"; Genlex.Ident nm] -> - OASISHostPath.of_unix (var_get nm) - | [Genlex.Ident "utoh"; Genlex.String s] -> - OASISHostPath.of_unix s - | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> - String.escaped (var_get nm) - | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> - String.escaped s - | [Genlex.Ident nm] -> - var_get nm - | _ -> - failwithf - (f_ "Unknown expression '%s' in variable expansion of %s.") - var - str - with - | Unknown_field (_, _) -> - failwithf - (f_ "No variable %s defined when trying to expand %S.") - var - str - | Stream.Error e -> - failwithf - (f_ "Syntax error when parsing '%s' when trying to \ - expand %S: %s") - var - str - e) - str; - Buffer.contents buff - - - and var_get name = - let vl = - try - Schema.get schema env name - with Unknown_field _ as e -> - begin - try - MapString.find name !env_from_file - with Not_found -> - raise e - end - in - var_expand vl - - - let var_choose ?printer ?name lst = - OASISExpr.choose - ?printer - ?name - var_get - lst - - - let var_protect vl = - let buff = - Buffer.create (String.length vl) - in - String.iter - (function - | '$' -> Buffer.add_string buff "\\$" - | c -> Buffer.add_char buff c) - vl; - Buffer.contents buff - - - let var_define - ?(hide=false) - ?(dump=true) - ?short_desc - ?(cli=CLINone) - ?arg_help - ?group - name (* TODO: type constraint on the fact that name must be a valid OCaml - id *) - dflt = - - let default = - [ - OFileLoad, (fun () -> MapString.find name !env_from_file); - ODefault, dflt; - OGetEnv, (fun () -> Sys.getenv name); - ] - in - - let extra = - { - hide = hide; - dump = dump; - cli = cli; - arg_help = arg_help; - group = group; - } - in - - (* Try to find a value that can be defined - *) - let var_get_low lst = - let errors, res = - List.fold_left - (fun (errors, res) (o, v) -> - if res = None then - begin - try - errors, Some (v ()) - with - | Not_found -> - errors, res - | Failure rsn -> - (rsn :: errors), res - | e -> - (Printexc.to_string e) :: errors, res - end - else - errors, res) - ([], None) - (List.sort - (fun (o1, _) (o2, _) -> - Pervasives.compare o2 o1) - lst) - in - match res, errors with - | Some v, _ -> - v - | None, [] -> - raise (Not_set (name, None)) - | None, lst -> - raise (Not_set (name, Some (String.concat (s_ ", ") lst))) - in - - let help = - match short_desc with - | Some fs -> Some fs - | None -> None - in - - let var_get_lst = - FieldRO.create - ~schema - ~name - ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) - ~print:var_get_low - ~default - ~update:(fun ?context x old_x -> x @ old_x) - ?help - extra - in - - fun () -> - var_expand (var_get_low (var_get_lst env)) - - - let var_redefine - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt = - if Schema.mem schema name then - begin - (* TODO: look suspsicious, we want to memorize dflt not dflt () *) - Schema.set schema env ~context:ODefault name (dflt ()); - fun () -> var_get name - end - else - begin - var_define - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt - end - - - let var_ignore (e: unit -> string) = () - - - let print_hidden = - var_define - ~hide:true - ~dump:false - ~cli:CLIAuto - ~arg_help:"Print even non-printable variable. (debug)" - "print_hidden" - (fun () -> "false") - - - let var_all () = - List.rev - (Schema.fold - (fun acc nm def _ -> - if not def.hide || bool_of_string (print_hidden ()) then - nm :: acc - else - acc) - [] - schema) - - - let default_filename = - BaseEnvLight.default_filename - - - let load ?allow_empty ?filename () = - env_from_file := BaseEnvLight.load ?allow_empty ?filename () - - - let unload () = - env_from_file := MapString.empty; - Data.clear env - - - let dump ?(filename=default_filename) () = - let chn = - open_out_bin filename - in - let output nm value = - Printf.fprintf chn "%s=%S\n" nm value - in - let mp_todo = - (* Dump data from schema *) - Schema.fold - (fun mp_todo nm def _ -> - if def.dump then - begin - try - let value = - Schema.get - schema - env - nm - in - output nm value - with Not_set _ -> - () - end; - MapString.remove nm mp_todo) - !env_from_file - schema - in - (* Dump data defined outside of schema *) - MapString.iter output mp_todo; - - (* End of the dump *) - close_out chn - - - let print () = - let printable_vars = - Schema.fold - (fun acc nm def short_descr_opt -> - if not def.hide || bool_of_string (print_hidden ()) then - begin - try - let value = - Schema.get - schema - env - nm - in - let txt = - match short_descr_opt with - | Some s -> s () - | None -> nm - in - (txt, value) :: acc - with Not_set _ -> - acc - end - else - acc) - [] - schema - in - let max_length = - List.fold_left max 0 - (List.rev_map String.length - (List.rev_map fst printable_vars)) - in - let dot_pad str = - String.make ((max_length - (String.length str)) + 3) '.' - in - - Printf.printf "\nConfiguration: \n"; - List.iter - (fun (name, value) -> - Printf.printf "%s: %s %s\n" name (dot_pad name) value) - (List.rev printable_vars); - Printf.printf "\n%!" - - - let args () = - let arg_concat = - OASISUtils.varname_concat ~hyphen:'-' - in - [ - "--override", - Arg.Tuple - ( - let rvr = ref "" - in - let rvl = ref "" - in - [ - Arg.Set_string rvr; - Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set - schema - env - ~context:OCommandLine - !rvr - !rvl) - ] - ), - "var+val Override any configuration variable."; - - ] - @ - List.flatten - (Schema.fold - (fun acc name def short_descr_opt -> - let var_set s = - Schema.set - schema - env - ~context:OCommandLine - name - s - in - - let arg_name = - OASISUtils.varname_of_string ~hyphen:'-' name - in - - let hlp = - match short_descr_opt with - | Some txt -> txt () - | None -> "" - in - - let arg_hlp = - match def.arg_help with - | Some s -> s - | None -> "str" - in - - let default_value = - try - Printf.sprintf - (f_ " [%s]") - (Schema.get - schema - env - name) - with Not_set _ -> - "" - in - - let args = - match def.cli with - | CLINone -> - [] - | CLIAuto -> - [ - arg_concat "--" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIWith -> - [ - arg_concat "--with-" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIEnable -> - let dflt = - if default_value = " [true]" then - s_ " [default: enabled]" - else - s_ " [default: disabled]" - in - [ - arg_concat "--enable-" arg_name, - Arg.Unit (fun () -> var_set "true"), - Printf.sprintf (f_ " %s%s") hlp dflt; - - arg_concat "--disable-" arg_name, - Arg.Unit (fun () -> var_set "false"), - Printf.sprintf (f_ " %s%s") hlp dflt - ] - | CLIUser lst -> - lst - in - args :: acc) - [] - schema) -end - -module BaseArgExt = struct -(* # 22 "src/base/BaseArgExt.ml" *) - - - open OASISUtils - open OASISGettext - - - let parse argv args = - (* Simulate command line for Arg *) - let current = - ref 0 - in - - try - Arg.parse_argv - ~current:current - (Array.concat [[|"none"|]; argv]) - (Arg.align args) - (failwithf (f_ "Don't know what to do with arguments: '%s'")) - (s_ "configure options:") - with - | Arg.Help txt -> - print_endline txt; - exit 0 - | Arg.Bad txt -> - prerr_endline txt; - exit 1 -end - -module BaseCheck = struct -(* # 22 "src/base/BaseCheck.ml" *) - - - open BaseEnv - open BaseMessage - open OASISUtils - open OASISGettext - - - let prog_best prg prg_lst = - var_redefine - prg - (fun () -> - let alternate = - List.fold_left - (fun res e -> - match res with - | Some _ -> - res - | None -> - try - Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) - with Not_found -> - None) - None - prg_lst - in - match alternate with - | Some prg -> prg - | None -> raise Not_found) - - - let prog prg = - prog_best prg [prg] - - - let prog_opt prg = - prog_best prg [prg^".opt"; prg] - - - let ocamlfind = - prog "ocamlfind" - - - let version - var_prefix - cmp - fversion - () = - (* Really compare version provided *) - let var = - var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) - in - var_redefine - ~hide:true - var - (fun () -> - let version_str = - match fversion () with - | "[Distributed with OCaml]" -> - begin - try - (var_get "ocaml_version") - with Not_found -> - warning - (f_ "Variable ocaml_version not defined, fallback \ - to default"); - Sys.ocaml_version - end - | res -> - res - in - let version = - OASISVersion.version_of_string version_str - in - if OASISVersion.comparator_apply version cmp then - version_str - else - failwithf - (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") - var_prefix - (OASISVersion.string_of_comparator cmp) - version_str) - () - - - let package_version pkg = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%v"; pkg] - - - let package ?version_comparator pkg () = - let var = - OASISUtils.varname_concat - "pkg_" - (OASISUtils.varname_of_string pkg) - in - let findlib_dir pkg = - let dir = - OASISExec.run_read_one_line ~ctxt:!BaseContext.default - (ocamlfind ()) - ["query"; "-format"; "%d"; pkg] - in - if Sys.file_exists dir && Sys.is_directory dir then - dir - else - failwithf - (f_ "When looking for findlib package %s, \ - directory %s return doesn't exist") - pkg dir - in - let vl = - var_redefine - var - (fun () -> findlib_dir pkg) - () - in - ( - match version_comparator with - | Some ver_cmp -> - ignore - (version - var - ver_cmp - (fun _ -> package_version pkg) - ()) - | None -> - () - ); - vl -end - -module BaseOCamlcConfig = struct -(* # 22 "src/base/BaseOCamlcConfig.ml" *) - - - open BaseEnv - open OASISUtils - open OASISGettext - - - module SMap = Map.Make(String) - - - let ocamlc = - BaseCheck.prog_opt "ocamlc" - - - let ocamlc_config_map = - (* Map name to value for ocamlc -config output - (name ^": "^value) - *) - let rec split_field mp lst = - match lst with - | line :: tl -> - let mp = - try - let pos_semicolon = - String.index line ':' - in - if pos_semicolon > 1 then - ( - let name = - String.sub line 0 pos_semicolon - in - let linelen = - String.length line - in - let value = - if linelen > pos_semicolon + 2 then - String.sub - line - (pos_semicolon + 2) - (linelen - pos_semicolon - 2) - else - "" - in - SMap.add name value mp - ) - else - ( - mp - ) - with Not_found -> - ( - mp - ) - in - split_field mp tl - | [] -> - mp - in - - let cache = - lazy - (var_protect - (Marshal.to_string - (split_field - SMap.empty - (OASISExec.run_read_output - ~ctxt:!BaseContext.default - (ocamlc ()) ["-config"])) - [])) - in - var_redefine - "ocamlc_config_map" - ~hide:true - ~dump:false - (fun () -> - (* TODO: update if ocamlc change !!! *) - Lazy.force cache) - - - let var_define nm = - (* Extract data from ocamlc -config *) - let avlbl_config_get () = - Marshal.from_string - (ocamlc_config_map ()) - 0 - in - let chop_version_suffix s = - try - String.sub s 0 (String.index s '+') - with _ -> - s - in - - let nm_config, value_config = - match nm with - | "ocaml_version" -> - "version", chop_version_suffix - | _ -> nm, (fun x -> x) - in - var_redefine - nm - (fun () -> - try - let map = - avlbl_config_get () - in - let value = - SMap.find nm_config map - in - value_config value - with Not_found -> - failwithf - (f_ "Cannot find field '%s' in '%s -config' output") - nm - (ocamlc ())) - -end - -module BaseStandardVar = struct -(* # 22 "src/base/BaseStandardVar.ml" *) - - - open OASISGettext - open OASISTypes - open OASISExpr - open BaseCheck - open BaseEnv - - - let ocamlfind = BaseCheck.ocamlfind - let ocamlc = BaseOCamlcConfig.ocamlc - let ocamlopt = prog_opt "ocamlopt" - let ocamlbuild = prog "ocamlbuild" - - - (**/**) - let rpkg = - ref None - - - let pkg_get () = - match !rpkg with - | Some pkg -> pkg - | None -> failwith (s_ "OASIS Package is not set") - - - let var_cond = ref [] - - - let var_define_cond ~since_version f dflt = - let holder = ref (fun () -> dflt) in - let since_version = - OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) - in - var_cond := - (fun ver -> - if OASISVersion.comparator_apply ver since_version then - holder := f ()) :: !var_cond; - fun () -> !holder () - - - (**/**) - - - let pkg_name = - var_define - ~short_desc:(fun () -> s_ "Package name") - "pkg_name" - (fun () -> (pkg_get ()).name) - - - let pkg_version = - var_define - ~short_desc:(fun () -> s_ "Package version") - "pkg_version" - (fun () -> - (OASISVersion.string_of_version (pkg_get ()).version)) - - - let c = BaseOCamlcConfig.var_define - - - let os_type = c "os_type" - let system = c "system" - let architecture = c "architecture" - let ccomp_type = c "ccomp_type" - let ocaml_version = c "ocaml_version" - - - (* TODO: Check standard variable presence at runtime *) - - - let standard_library_default = c "standard_library_default" - let standard_library = c "standard_library" - let standard_runtime = c "standard_runtime" - let bytecomp_c_compiler = c "bytecomp_c_compiler" - let native_c_compiler = c "native_c_compiler" - let model = c "model" - let ext_obj = c "ext_obj" - let ext_asm = c "ext_asm" - let ext_lib = c "ext_lib" - let ext_dll = c "ext_dll" - let default_executable_name = c "default_executable_name" - let systhread_supported = c "systhread_supported" - - - let flexlink = - BaseCheck.prog "flexlink" - - - let flexdll_version = - var_define - ~short_desc:(fun () -> "FlexDLL version (Win32)") - "flexdll_version" - (fun () -> - let lst = - OASISExec.run_read_output ~ctxt:!BaseContext.default - (flexlink ()) ["-help"] - in - match lst with - | line :: _ -> - Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) - | [] -> - raise Not_found) - - - (**/**) - let p name hlp dflt = - var_define - ~short_desc:hlp - ~cli:CLIAuto - ~arg_help:"dir" - name - dflt - - - let (/) a b = - if os_type () = Sys.os_type then - Filename.concat a b - else if os_type () = "Unix" then - OASISUnixPath.concat a b - else - OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") - (os_type ()) - (**/**) - - - let prefix = - p "prefix" - (fun () -> s_ "Install architecture-independent files dir") - (fun () -> - match os_type () with - | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) - | _ -> - "/usr/local") - - - let exec_prefix = - p "exec_prefix" - (fun () -> s_ "Install architecture-dependent files in dir") - (fun () -> "$prefix") - - - let bindir = - p "bindir" - (fun () -> s_ "User executables") - (fun () -> "$exec_prefix"/"bin") - - - let sbindir = - p "sbindir" - (fun () -> s_ "System admin executables") - (fun () -> "$exec_prefix"/"sbin") - - - let libexecdir = - p "libexecdir" - (fun () -> s_ "Program executables") - (fun () -> "$exec_prefix"/"libexec") - - - let sysconfdir = - p "sysconfdir" - (fun () -> s_ "Read-only single-machine data") - (fun () -> "$prefix"/"etc") - - - let sharedstatedir = - p "sharedstatedir" - (fun () -> s_ "Modifiable architecture-independent data") - (fun () -> "$prefix"/"com") - - - let localstatedir = - p "localstatedir" - (fun () -> s_ "Modifiable single-machine data") - (fun () -> "$prefix"/"var") - - - let libdir = - p "libdir" - (fun () -> s_ "Object code libraries") - (fun () -> "$exec_prefix"/"lib") - - - let datarootdir = - p "datarootdir" - (fun () -> s_ "Read-only arch-independent data root") - (fun () -> "$prefix"/"share") - - - let datadir = - p "datadir" - (fun () -> s_ "Read-only architecture-independent data") - (fun () -> "$datarootdir") - - - let infodir = - p "infodir" - (fun () -> s_ "Info documentation") - (fun () -> "$datarootdir"/"info") - - - let localedir = - p "localedir" - (fun () -> s_ "Locale-dependent data") - (fun () -> "$datarootdir"/"locale") - - - let mandir = - p "mandir" - (fun () -> s_ "Man documentation") - (fun () -> "$datarootdir"/"man") - - - let docdir = - p "docdir" - (fun () -> s_ "Documentation root") - (fun () -> "$datarootdir"/"doc"/"$pkg_name") - - - let htmldir = - p "htmldir" - (fun () -> s_ "HTML documentation") - (fun () -> "$docdir") - - - let dvidir = - p "dvidir" - (fun () -> s_ "DVI documentation") - (fun () -> "$docdir") - - - let pdfdir = - p "pdfdir" - (fun () -> s_ "PDF documentation") - (fun () -> "$docdir") - - - let psdir = - p "psdir" - (fun () -> s_ "PS documentation") - (fun () -> "$docdir") - - - let destdir = - p "destdir" - (fun () -> s_ "Prepend a path when installing package") - (fun () -> - raise - (PropList.Not_set - ("destdir", - Some (s_ "undefined by construct")))) - - - let findlib_version = - var_define - "findlib_version" - (fun () -> - BaseCheck.package_version "findlib") - - - let is_native = - var_define - "is_native" - (fun () -> - try - let _s: string = - ocamlopt () - in - "true" - with PropList.Not_set _ -> - let _s: string = - ocamlc () - in - "false") - - - let ext_program = - var_define - "suffix_program" - (fun () -> - match os_type () with - | "Win32" | "Cygwin" -> ".exe" - | _ -> "") - - - let rm = - var_define - ~short_desc:(fun () -> s_ "Remove a file.") - "rm" - (fun () -> - match os_type () with - | "Win32" -> "del" - | _ -> "rm -f") - - - let rmdir = - var_define - ~short_desc:(fun () -> s_ "Remove a directory.") - "rmdir" - (fun () -> - match os_type () with - | "Win32" -> "rd" - | _ -> "rm -rf") - - - let debug = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") - ~cli:CLIEnable - "debug" - (fun () -> "true") - - - let profile = - var_define - ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") - ~cli:CLIEnable - "profile" - (fun () -> "false") - - - let tests = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> - s_ "Compile tests executable and library and run them") - ~cli:CLIEnable - "tests" - (fun () -> "false")) - "true" - - - let docs = - var_define_cond ~since_version:"0.3" - (fun () -> - var_define - ~short_desc:(fun () -> s_ "Create documentations") - ~cli:CLIEnable - "docs" - (fun () -> "true")) - "true" - - - let native_dynlink = - var_define - ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") - ~cli:CLINone - "native_dynlink" - (fun () -> - let res = - let ocaml_lt_312 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "3.12.0")) - in - let flexdll_lt_030 () = - OASISVersion.comparator_apply - (OASISVersion.version_of_string (flexdll_version ())) - (OASISVersion.VLesser - (OASISVersion.version_of_string "0.30")) - in - let has_native_dynlink = - let ocamlfind = ocamlfind () in - try - let fn = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ocamlfind - ["query"; "-predicates"; "native"; "dynlink"; - "-format"; "%d/%a"] - in - Sys.file_exists fn - with _ -> - false - in - if not has_native_dynlink then - false - else if ocaml_lt_312 () then - false - else if (os_type () = "Win32" || os_type () = "Cygwin") - && flexdll_lt_030 () then - begin - BaseMessage.warning - (f_ ".cmxs generation disabled because FlexDLL needs to be \ - at least 0.30. Please upgrade FlexDLL from %s to 0.30.") - (flexdll_version ()); - false - end - else - true - in - string_of_bool res) - - - let init pkg = - rpkg := Some pkg; - List.iter (fun f -> f pkg.oasis_version) !var_cond - -end - -module BaseFileAB = struct -(* # 22 "src/base/BaseFileAB.ml" *) - - - open BaseEnv - open OASISGettext - open BaseMessage - - - let to_filename fn = - let fn = - OASISHostPath.of_unix fn - in - if not (Filename.check_suffix fn ".ab") then - warning - (f_ "File '%s' doesn't have '.ab' extension") - fn; - Filename.chop_extension fn - - - let replace fn_lst = - let buff = - Buffer.create 13 - in - List.iter - (fun fn -> - let fn = - OASISHostPath.of_unix fn - in - let chn_in = - open_in fn - in - let chn_out = - open_out (to_filename fn) - in - ( - try - while true do - Buffer.add_string buff (var_expand (input_line chn_in)); - Buffer.add_char buff '\n' - done - with End_of_file -> - () - ); - Buffer.output_buffer chn_out buff; - Buffer.clear buff; - close_in chn_in; - close_out chn_out) - fn_lst -end - -module BaseLog = struct -(* # 22 "src/base/BaseLog.ml" *) - - - open OASISUtils - - - let default_filename = - Filename.concat - (Filename.dirname BaseEnv.default_filename) - "setup.log" - - - module SetTupleString = - Set.Make - (struct - type t = string * string - let compare (s11, s12) (s21, s22) = - match String.compare s11 s21 with - | 0 -> String.compare s12 s22 - | n -> n - end) - - - let load () = - if Sys.file_exists default_filename then - begin - let chn = - open_in default_filename - in - let scbuf = - Scanf.Scanning.from_file default_filename - in - let rec read_aux (st, lst) = - if not (Scanf.Scanning.end_of_input scbuf) then - begin - let acc = - try - Scanf.bscanf scbuf "%S %S\n" - (fun e d -> - let t = - e, d - in - if SetTupleString.mem t st then - st, lst - else - SetTupleString.add t st, - t :: lst) - with Scanf.Scan_failure _ -> - failwith - (Scanf.bscanf scbuf - "%l" - (fun line -> - Printf.sprintf - "Malformed log file '%s' at line %d" - default_filename - line)) - in - read_aux acc - end - else - begin - close_in chn; - List.rev lst - end - in - read_aux (SetTupleString.empty, []) - end - else - begin - [] - end - - - let register event data = - let chn_out = - open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename - in - Printf.fprintf chn_out "%S %S\n" event data; - close_out chn_out - - - let unregister event data = - if Sys.file_exists default_filename then - begin - let lst = - load () - in - let chn_out = - open_out default_filename - in - let write_something = - ref false - in - List.iter - (fun (e, d) -> - if e <> event || d <> data then - begin - write_something := true; - Printf.fprintf chn_out "%S %S\n" e d - end) - lst; - close_out chn_out; - if not !write_something then - Sys.remove default_filename - end - - - let filter events = - let st_events = - List.fold_left - (fun st e -> - SetString.add e st) - SetString.empty - events - in - List.filter - (fun (e, _) -> SetString.mem e st_events) - (load ()) - - - let exists event data = - List.exists - (fun v -> (event, data) = v) - (load ()) -end - -module BaseBuilt = struct -(* # 22 "src/base/BaseBuilt.ml" *) - - - open OASISTypes - open OASISGettext - open BaseStandardVar - open BaseMessage - - - type t = - | BExec (* Executable *) - | BExecLib (* Library coming with executable *) - | BLib (* Library *) - | BObj (* Library *) - | BDoc (* Document *) - - - let to_log_event_file t nm = - "built_"^ - (match t with - | BExec -> "exec" - | BExecLib -> "exec_lib" - | BLib -> "lib" - | BObj -> "obj" - | BDoc -> "doc")^ - "_"^nm - - - let to_log_event_done t nm = - "is_"^(to_log_event_file t nm) - - - let register t nm lst = - BaseLog.register - (to_log_event_done t nm) - "true"; - List.iter - (fun alt -> - let registered = - List.fold_left - (fun registered fn -> - if OASISFileUtil.file_exists_case fn then - begin - BaseLog.register - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end - else - registered) - false - alt - in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) - lst - - - let unregister t nm = - List.iter - (fun (e, d) -> - BaseLog.unregister e d) - (BaseLog.filter - [to_log_event_file t nm; - to_log_event_done t nm]) - - - let fold t nm f acc = - List.fold_left - (fun acc (_, fn) -> - if OASISFileUtil.file_exists_case fn then - begin - f acc fn - end - else - begin - warning - (f_ "File '%s' has been marked as built \ - for %s but doesn't exist") - fn - (Printf.sprintf - (match t with - | BExec | BExecLib -> - (f_ "executable %s") - | BLib -> - (f_ "library %s") - | BObj -> - (f_ "object %s") - | BDoc -> - (f_ "documentation %s")) - nm); - acc - end) - acc - (BaseLog.filter - [to_log_event_file t nm]) - - - let is_built t nm = - List.fold_left - (fun is_built (_, d) -> - (try - bool_of_string d - with _ -> - false)) - false - (BaseLog.filter - [to_log_event_done t nm]) - - - let of_executable ffn (cs, bs, exec) = - let unix_exec_is, unix_dll_opt = - OASISExecutable.unix_exec_is - (cs, bs, exec) - (fun () -> - bool_of_string - (is_native ())) - ext_dll - ext_program - in - let evs = - (BExec, cs.cs_name, [[ffn unix_exec_is]]) - :: - (match unix_dll_opt with - | Some fn -> - [BExecLib, cs.cs_name, [[ffn fn]]] - | None -> - []) - in - evs, - unix_exec_is, - unix_dll_opt - - - let of_library ffn (cs, bs, lib) = - let unix_lst = - OASISLibrary.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - ~has_native_dynlink:(bool_of_string (native_dynlink ())) - ~ext_lib:(ext_lib ()) - ~ext_dll:(ext_dll ()) - (cs, bs, lib) - in - let evs = - [BLib, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - - - let of_object ffn (cs, bs, obj) = - let unix_lst = - OASISObject.generated_unix_files - ~ctxt:!BaseContext.default - ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) - ~is_native:(bool_of_string (is_native ())) - (cs, bs, obj) - in - let evs = - [BObj, - cs.cs_name, - List.map (List.map ffn) unix_lst] - in - evs, unix_lst - -end - -module BaseCustom = struct -(* # 22 "src/base/BaseCustom.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let run cmd args extra_args = - OASISExec.run ~ctxt:!BaseContext.default ~quote:false - (var_expand cmd) - (List.map - var_expand - (args @ (Array.to_list extra_args))) - - - let hook ?(failsafe=false) cstm f e = - let optional_command lst = - let printer = - function - | Some (cmd, args) -> String.concat " " (cmd :: args) - | None -> s_ "No command" - in - match - var_choose - ~name:(s_ "Pre/Post Command") - ~printer - lst with - | Some (cmd, args) -> - begin - try - run cmd args [||] - with e when failsafe -> - warning - (f_ "Command '%s' fail with error: %s") - (String.concat " " (cmd :: args)) - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - end - | None -> - () - in - let res = - optional_command cstm.pre_command; - f e - in - optional_command cstm.post_command; - res -end - -module BaseDynVar = struct -(* # 22 "src/base/BaseDynVar.ml" *) - - - open OASISTypes - open OASISGettext - open BaseEnv - open BaseBuilt - - - let init pkg = - (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) - (* TODO: provide compile option for library libary_byte_args_VARNAME... *) - List.iter - (function - | Executable (cs, bs, exec) -> - if var_choose bs.bs_build then - var_ignore - (var_redefine - (* We don't save this variable *) - ~dump:false - ~short_desc:(fun () -> - Printf.sprintf - (f_ "Filename of executable '%s'") - cs.cs_name) - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - let fn_opt = - fold - BExec cs.cs_name - (fun _ fn -> Some fn) - None - in - match fn_opt with - | Some fn -> fn - | None -> - raise - (PropList.Not_set - (cs.cs_name, - Some (Printf.sprintf - (f_ "Executable '%s' not yet built.") - cs.cs_name))))) - - | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> - ()) - pkg.sections -end - -module BaseTest = struct -(* # 22 "src/base/BaseTest.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISExpr - open OASISGettext - - - let test lst pkg extra_args = - - let one_test (failure, n) (test_plugin, cs, test) = - if var_choose - ~name:(Printf.sprintf - (f_ "test %s run") - cs.cs_name) - ~printer:string_of_bool - test.test_run then - begin - let () = - info (f_ "Running test '%s'") cs.cs_name - in - let back_cwd = - match test.test_working_directory with - | Some dir -> - let cwd = - Sys.getcwd () - in - let chdir d = - info (f_ "Changing directory to '%s'") d; - Sys.chdir d - in - chdir dir; - fun () -> chdir cwd - - | None -> - fun () -> () - in - try - let failure_percent = - BaseCustom.hook - test.test_custom - (test_plugin pkg (cs, test)) - extra_args - in - back_cwd (); - (failure_percent +. failure, n + 1) - with e -> - begin - back_cwd (); - raise e - end - end - else - begin - info (f_ "Skipping test '%s'") cs.cs_name; - (failure, n) - end - in - let failed, n = - List.fold_left - one_test - (0.0, 0) - lst - in - let failure_percent = - if n = 0 then - 0.0 - else - failed /. (float_of_int n) - in - let msg = - Printf.sprintf - (f_ "Tests had a %.2f%% failure rate") - (100. *. failure_percent) - in - if failure_percent > 0.0 then - failwith msg - else - info "%s" msg; - - (* Possible explanation why the tests where not run. *) - if OASISFeatures.package_test OASISFeatures.flag_tests pkg && - not (bool_of_string (BaseStandardVar.tests ())) && - lst <> [] then - BaseMessage.warning - "Tests are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-tests'" -end - -module BaseDoc = struct -(* # 22 "src/base/BaseDoc.ml" *) - - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISGettext - - - let doc lst pkg extra_args = - - let one_doc (doc_plugin, cs, doc) = - if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") - cs.cs_name) - ~printer:string_of_bool - doc.doc_build then - begin - info (f_ "Building documentation '%s'") cs.cs_name; - BaseCustom.hook - doc.doc_custom - (doc_plugin pkg (cs, doc)) - extra_args - end - in - List.iter one_doc lst; - - if OASISFeatures.package_test OASISFeatures.flag_docs pkg && - not (bool_of_string (BaseStandardVar.docs ())) && - lst <> [] then - BaseMessage.warning - "Docs are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-docs'" -end - -module BaseSetup = struct -(* # 22 "src/base/BaseSetup.ml" *) - - open BaseEnv - open BaseMessage - open OASISTypes - open OASISSection - open OASISGettext - open OASISUtils - - - type std_args_fun = - package -> string array -> unit - - - type ('a, 'b) section_args_fun = - name * (package -> (common_section * 'a) -> string array -> 'b) - - - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } - - - (* Associate a plugin function with data from package *) - let join_plugin_sections filter_map lst = - List.rev - (List.fold_left - (fun acc sct -> - match filter_map sct with - | Some e -> - e :: acc - | None -> - acc) - [] - lst) - - - (* Search for plugin data associated with a section name *) - let lookup_plugin_section plugin action nm lst = - try - List.assoc nm lst - with Not_found -> - failwithf - (f_ "Cannot find plugin %s matching section %s for %s action") - plugin - nm - action - - - let configure t args = - (* Run configure *) - BaseCustom.hook - t.package.conf_custom - (fun () -> - (* Reload if preconf has changed it *) - begin - try - unload (); - load (); - with _ -> - () - end; - - (* Run plugin's configure *) - t.configure t.package args; - - (* Dump to allow postconf to change it *) - dump ()) - (); - - (* Reload environment *) - unload (); - load (); - - (* Save environment *) - print (); - - (* Replace data in file *) - BaseFileAB.replace t.package.files_ab - - - let build t args = - BaseCustom.hook - t.package.build_custom - (t.build t.package) - args - - - let doc t args = - BaseDoc.doc - (join_plugin_sections - (function - | Doc (cs, e) -> - Some - (lookup_plugin_section - "documentation" - (s_ "build") - cs.cs_name - t.doc, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let test t args = - BaseTest.test - (join_plugin_sections - (function - | Test (cs, e) -> - Some - (lookup_plugin_section - "test" - (s_ "run") - cs.cs_name - t.test, - cs, - e) - | _ -> - None) - t.package.sections) - t.package - args - - - let all t args = - let rno_doc = - ref false - in - let rno_test = - ref false - in - let arg_rest = - ref [] - in - Arg.parse_argv - ~current:(ref 0) - (Array.of_list - ((Sys.executable_name^" all") :: - (Array.to_list args))) - [ - "-no-doc", - Arg.Set rno_doc, - s_ "Don't run doc target"; - - "-no-test", - Arg.Set rno_test, - s_ "Don't run test target"; - - "--", - Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), - s_ "All arguments for configure."; - ] - (failwithf (f_ "Don't know what to do with '%s'")) - ""; - - info "Running configure step"; - configure t (Array.of_list (List.rev !arg_rest)); - - info "Running build step"; - build t [||]; - - (* Load setup.log dynamic variables *) - BaseDynVar.init t.package; - - if not !rno_doc then - begin - info "Running doc step"; - doc t [||]; - end - else - begin - info "Skipping doc step" - end; - - if not !rno_test then - begin - info "Running test step"; - test t [||] - end - else - begin - info "Skipping test step" - end - - - let install t args = - BaseCustom.hook - t.package.install_custom - (t.install t.package) - args - - - let uninstall t args = - BaseCustom.hook - t.package.uninstall_custom - (t.uninstall t.package) - args - - - let reinstall t args = - uninstall t args; - install t args - - - let clean, distclean = - let failsafe f a = - try - f a - with e -> - warning - (f_ "Action fail with error: %s") - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - in - - let generic_clean t cstm mains docs tests args = - BaseCustom.hook - ~failsafe:true - cstm - (fun () -> - (* Clean section *) - List.iter - (function - | Test (cs, test) -> - let f = - try - List.assoc cs.cs_name tests - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, test)) - args - | Doc (cs, doc) -> - let f = - try - List.assoc cs.cs_name docs - with Not_found -> - fun _ _ _ -> () - in - failsafe - (f t.package (cs, doc)) - args - | Library _ - | Object _ - | Executable _ - | Flag _ - | SrcRepo _ -> - ()) - t.package.sections; - (* Clean whole package *) - List.iter - (fun f -> - failsafe - (f t.package) - args) - mains) - () - in - - let clean t args = - generic_clean - t - t.package.clean_custom - t.clean - t.clean_doc - t.clean_test - args - in - - let distclean t args = - (* Call clean *) - clean t args; - - (* Call distclean code *) - generic_clean - t - t.package.distclean_custom - t.distclean - t.distclean_doc - t.distclean_test - args; - - (* Remove generated file *) - List.iter - (fun fn -> - if Sys.file_exists fn then - begin - info (f_ "Remove '%s'") fn; - Sys.remove fn - end) - (BaseEnv.default_filename - :: - BaseLog.default_filename - :: - (List.rev_map BaseFileAB.to_filename t.package.files_ab)) - in - - clean, distclean - - - let version t _ = - print_endline t.oasis_version - - - let update_setup_ml, no_update_setup_ml_cli = - let b = ref true in - b, - ("-no-update-setup-ml", - Arg.Clear b, - s_ " Don't try to update setup.ml, even if _oasis has changed.") - - - let default_oasis_fn = "_oasis" - - - let update_setup_ml t = - let oasis_fn = - match t.oasis_fn with - | Some fn -> fn - | None -> default_oasis_fn - in - let oasis_exec = - match t.oasis_exec with - | Some fn -> fn - | None -> "oasis" - in - let ocaml = - Sys.executable_name - in - let setup_ml, args = - match Array.to_list Sys.argv with - | setup_ml :: args -> - setup_ml, args - | [] -> - failwith - (s_ "Expecting non-empty command line arguments.") - in - let ocaml, setup_ml = - if Sys.executable_name = Sys.argv.(0) then - (* We are not running in standard mode, probably the script - * is precompiled. - *) - "ocaml", "setup.ml" - else - ocaml, setup_ml - in - let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in - let do_update () = - let oasis_exec_version = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | 1 -> - failwithf - (f_ "Executable '%s' is probably an old version \ - of oasis (< 0.3.0), please update to version \ - v%s.") - oasis_exec t.oasis_version - | 127 -> - failwithf - (f_ "Cannot find executable '%s', please install \ - oasis v%s.") - oasis_exec t.oasis_version - | n -> - failwithf - (f_ "Command '%s version' exited with code %d.") - oasis_exec n) - oasis_exec ["version"] - in - if OASISVersion.comparator_apply - (OASISVersion.version_of_string oasis_exec_version) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string t.oasis_version)) then - begin - (* We have a version >= for the executable oasis, proceed with - * update. - *) - (* TODO: delegate this check to 'oasis setup'. *) - if Sys.os_type = "Win32" then - failwithf - (f_ "It is not possible to update the running script \ - setup.ml on Windows. Please update setup.ml by \ - running '%s'.") - (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) - else - begin - OASISExec.run - ~ctxt:!BaseContext.default - ~f_exit_code: - (function - | 0 -> - () - | n -> - failwithf - (f_ "Unable to update setup.ml using '%s', \ - please fix the problem and retry.") - oasis_exec) - oasis_exec ("setup" :: t.oasis_setup_args); - OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) - end - end - else - failwithf - (f_ "The version of '%s' (v%s) doesn't match the version of \ - oasis used to generate the %s file. Please install at \ - least oasis v%s.") - oasis_exec oasis_exec_version setup_ml t.oasis_version - in - - if !update_setup_ml then - begin - try - match t.oasis_digest with - | Some dgst -> - if Sys.file_exists oasis_fn && - dgst <> Digest.file default_oasis_fn then - begin - do_update (); - true - end - else - false - | None -> - false - with e -> - error - (f_ "Error when updating setup.ml. If you want to avoid this error, \ - you can bypass the update of %s by running '%s %s %s %s'") - setup_ml ocaml setup_ml no_update_setup_ml_cli - (String.concat " " args); - raise e - end - else - false - - - let setup t = - let catch_exn = - ref true - in - try - let act_ref = - ref (fun _ -> - failwithf - (f_ "No action defined, run '%s %s -help'") - Sys.executable_name - Sys.argv.(0)) - - in - let extra_args_ref = - ref [] - in - let allow_empty_env_ref = - ref false - in - let arg_handle ?(allow_empty_env=false) act = - Arg.Tuple - [ - Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); - - Arg.Unit - (fun () -> - allow_empty_env_ref := allow_empty_env; - act_ref := act); - ] - in - - Arg.parse - (Arg.align - ([ - "-configure", - arg_handle ~allow_empty_env:true configure, - s_ "[options*] Configure the whole build process."; - - "-build", - arg_handle build, - s_ "[options*] Build executables and libraries."; - - "-doc", - arg_handle doc, - s_ "[options*] Build documents."; - - "-test", - arg_handle test, - s_ "[options*] Run tests."; - - "-all", - arg_handle ~allow_empty_env:true all, - s_ "[options*] Run configure, build, doc and test targets."; - - "-install", - arg_handle install, - s_ "[options*] Install libraries, data, executables \ - and documents."; - - "-uninstall", - arg_handle uninstall, - s_ "[options*] Uninstall libraries, data, executables \ - and documents."; - - "-reinstall", - arg_handle reinstall, - s_ "[options*] Uninstall and install libraries, data, \ - executables and documents."; - - "-clean", - arg_handle ~allow_empty_env:true clean, - s_ "[options*] Clean files generated by a build."; - - "-distclean", - arg_handle ~allow_empty_env:true distclean, - s_ "[options*] Clean files generated by a build and configure."; - - "-version", - arg_handle ~allow_empty_env:true version, - s_ " Display version of OASIS used to generate this setup.ml."; - - "-no-catch-exn", - Arg.Clear catch_exn, - s_ " Don't catch exception, useful for debugging."; - ] - @ - (if t.setup_update then - [no_update_setup_ml_cli] - else - []) - @ (BaseContext.args ()))) - (failwithf (f_ "Don't know what to do with '%s'")) - (s_ "Setup and run build process current package\n"); - - (* Build initial environment *) - load ~allow_empty:!allow_empty_env_ref (); - - (** Initialize flags *) - List.iter - (function - | Flag (cs, {flag_description = hlp; - flag_default = choices}) -> - begin - let apply ?short_desc () = - var_ignore - (var_define - ~cli:CLIEnable - ?short_desc - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - string_of_bool - (var_choose - ~name:(Printf.sprintf - (f_ "default value of flag %s") - cs.cs_name) - ~printer:string_of_bool - choices))) - in - match hlp with - | Some hlp -> - apply ~short_desc:(fun () -> hlp) () - | None -> - apply () - end - | _ -> - ()) - t.package.sections; - - BaseStandardVar.init t.package; - - BaseDynVar.init t.package; - - if t.setup_update && update_setup_ml t then - () - else - !act_ref t (Array.of_list (List.rev !extra_args_ref)) - - with e when !catch_exn -> - error "%s" (Printexc.to_string e); - exit 1 - - -end - - -# 5409 "setup.ml" -module InternalConfigurePlugin = struct -(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) - - - (** Configure using internal scheme - @author Sylvain Le Gall - *) - - - open BaseEnv - open OASISTypes - open OASISUtils - open OASISGettext - open BaseMessage - - - (** Configure build using provided series of check to be done - * and then output corresponding file. - *) - let configure pkg argv = - let var_ignore_eval var = let _s: string = var () in () in - let errors = ref SetString.empty in - let buff = Buffer.create 13 in - - let add_errors fmt = - Printf.kbprintf - (fun b -> - errors := SetString.add (Buffer.contents b) !errors; - Buffer.clear b) - buff - fmt - in - - let warn_exception e = - warning "%s" (Printexc.to_string e) - in - - (* Check tools *) - let check_tools lst = - List.iter - (function - | ExternalTool tool -> - begin - try - var_ignore_eval (BaseCheck.prog tool) - with e -> - warn_exception e; - add_errors (f_ "Cannot find external tool '%s'") tool - end - | InternalExecutable nm1 -> - (* Check that matching tool is built *) - List.iter - (function - | Executable ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal executable \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - lst - in - - let build_checks sct bs = - if var_choose bs.bs_build then - begin - if bs.bs_compiled_object = Native then - begin - try - var_ignore_eval BaseStandardVar.ocamlopt - with e -> - warn_exception e; - add_errors - (f_ "Section %s requires native compilation") - (OASISSection.string_of_section sct) - end; - - (* Check tools *) - check_tools bs.bs_build_tools; - - (* Check depends *) - List.iter - (function - | FindlibPackage (findlib_pkg, version_comparator) -> - begin - try - var_ignore_eval - (BaseCheck.package ?version_comparator findlib_pkg) - with e -> - warn_exception e; - match version_comparator with - | None -> - add_errors - (f_ "Cannot find findlib package %s") - findlib_pkg - | Some ver_cmp -> - add_errors - (f_ "Cannot find findlib package %s (%s)") - findlib_pkg - (OASISVersion.string_of_comparator ver_cmp) - end - | InternalLibrary nm1 -> - (* Check that matching library is built *) - List.iter - (function - | Library ({cs_name = nm2}, - {bs_build = build}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal library \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) - bs.bs_build_depends - end - in - - (* Parse command line *) - BaseArgExt.parse argv (BaseEnv.args ()); - - (* OCaml version *) - begin - match pkg.ocaml_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "ocaml" - ver_cmp - BaseStandardVar.ocaml_version) - with e -> - warn_exception e; - add_errors - (f_ "OCaml version %s doesn't match version constraint %s") - (BaseStandardVar.ocaml_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - - (* Findlib version *) - begin - match pkg.findlib_version with - | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "findlib" - ver_cmp - BaseStandardVar.findlib_version) - with e -> - warn_exception e; - add_errors - (f_ "Findlib version %s doesn't match version constraint %s") - (BaseStandardVar.findlib_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end - | None -> - () - end; - (* Make sure the findlib version is fine for the OCaml compiler. *) - begin - let ocaml_ge4 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) - (OASISVersion.version_of_string "4.0.0") >= 0 in - if ocaml_ge4 then - let findlib_lt132 = - OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) - (OASISVersion.version_of_string "1.3.2") < 0 in - if findlib_lt132 then - add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" - end; - - (* FlexDLL *) - if BaseStandardVar.os_type () = "Win32" || - BaseStandardVar.os_type () = "Cygwin" then - begin - try - var_ignore_eval BaseStandardVar.flexlink - with e -> - warn_exception e; - add_errors (f_ "Cannot find 'flexlink'") - end; - - (* Check build depends *) - List.iter - (function - | Executable (_, bs, _) - | Library (_, bs, _) as sct -> - build_checks sct bs - | Doc (_, doc) -> - if var_choose doc.doc_build then - check_tools doc.doc_build_tools - | Test (_, test) -> - if var_choose test.test_run then - check_tools test.test_tools - | _ -> - ()) - pkg.sections; - - (* Check if we need native dynlink (presence of libraries that compile to - * native) - *) - begin - let has_cmxa = - List.exists - (function - | Library (_, bs, _) -> - var_choose bs.bs_build && - (bs.bs_compiled_object = Native || - (bs.bs_compiled_object = Best && - bool_of_string (BaseStandardVar.is_native ()))) - | _ -> - false) - pkg.sections - in - if has_cmxa then - var_ignore_eval BaseStandardVar.native_dynlink - end; - - (* Check errors *) - if SetString.empty != !errors then - begin - List.iter - (fun e -> error "%s" e) - (SetString.elements !errors); - failwithf - (fn_ - "%d configuration error" - "%d configuration errors" - (SetString.cardinal !errors)) - (SetString.cardinal !errors) - end - - -end - -module InternalInstallPlugin = struct -(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) - - - (** Install using internal scheme - @author Sylvain Le Gall - *) - - - open BaseEnv - open BaseStandardVar - open BaseMessage - open OASISTypes - open OASISFindlib - open OASISGettext - open OASISUtils - - - let exec_hook = - ref (fun (cs, bs, exec) -> cs, bs, exec) - - - let lib_hook = - ref (fun (cs, bs, lib) -> cs, bs, lib, []) - - - let obj_hook = - ref (fun (cs, bs, obj) -> cs, bs, obj, []) - - - let doc_hook = - ref (fun (cs, doc) -> cs, doc) - - - let install_file_ev = - "install-file" - - - let install_dir_ev = - "install-dir" - - - let install_findlib_ev = - "install-findlib" - - - let win32_max_command_line_length = 8000 - - - let split_install_command ocamlfind findlib_name meta files = - if Sys.os_type = "Win32" then - (* Arguments for the first command: *) - let first_args = ["install"; findlib_name; meta] in - (* Arguments for remaining commands: *) - let other_args = ["install"; findlib_name; "-add"] in - (* Extract as much files as possible from [files], [len] is - the current command line length: *) - let rec get_files len acc files = - match files with - | [] -> - (List.rev acc, []) - | file :: rest -> - let len = len + 1 + String.length file in - if len > win32_max_command_line_length then - (List.rev acc, files) - else - get_files len (file :: acc) rest - in - (* Split the command into several commands. *) - let rec split args files = - match files with - | [] -> - [] - | _ -> - (* Length of "ocamlfind install [META|-add]" *) - let len = - List.fold_left - (fun len arg -> - len + 1 (* for the space *) + String.length arg) - (String.length ocamlfind) - args - in - match get_files len [] files with - | ([], _) -> - failwith (s_ "Command line too long.") - | (firsts, others) -> - let cmd = args @ firsts in - (* Use -add for remaining commands: *) - let () = - let findlib_ge_132 = - OASISVersion.comparator_apply - (OASISVersion.version_of_string - (BaseStandardVar.findlib_version ())) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string "1.3.2")) - in - if not findlib_ge_132 then - failwithf - (f_ "Installing the library %s require to use the \ - flag '-add' of ocamlfind because the command \ - line is too long. This flag is only available \ - for findlib 1.3.2. Please upgrade findlib from \ - %s to 1.3.2") - findlib_name (BaseStandardVar.findlib_version ()) - in - let cmds = split other_args others in - cmd :: cmds - in - (* The first command does not use -add: *) - split first_args files - else - ["install" :: findlib_name :: meta :: files] - - - let install pkg argv = - - let in_destdir = - try - let destdir = - destdir () - in - (* Practically speaking destdir is prepended - * at the beginning of the target filename - *) - fun fn -> destdir^fn - with PropList.Not_set _ -> - fun fn -> fn - in - - let install_file ?tgt_fn src_file envdir = - let tgt_dir = - in_destdir (envdir ()) - in - let tgt_file = - Filename.concat - tgt_dir - (match tgt_fn with - | Some fn -> - fn - | None -> - Filename.basename src_file) - in - (* Create target directory if needed *) - OASISFileUtil.mkdir_parent - ~ctxt:!BaseContext.default - (fun dn -> - info (f_ "Creating directory '%s'") dn; - BaseLog.register install_dir_ev dn) - tgt_dir; - - (* Really install files *) - info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; - BaseLog.register install_file_ev tgt_file - in - - (* Install data into defined directory *) - let install_data srcdir lst tgtdir = - let tgtdir = - OASISHostPath.of_unix (var_expand tgtdir) - in - List.iter - (fun (src, tgt_opt) -> - let real_srcs = - OASISFileUtil.glob - ~ctxt:!BaseContext.default - (Filename.concat srcdir src) - in - if real_srcs = [] then - failwithf - (f_ "Wildcard '%s' doesn't match any files") - src; - List.iter - (fun fn -> - install_file - fn - (fun () -> - match tgt_opt with - | Some s -> - OASISHostPath.of_unix (var_expand s) - | None -> - tgtdir)) - real_srcs) - lst - in - - let make_fnames modul sufx = - List.fold_right - begin fun sufx accu -> - (String.capitalize modul ^ sufx) :: - (String.uncapitalize modul ^ sufx) :: - accu - end - sufx - [] - in - - (** Install all libraries *) - let install_libs pkg = - - let files_of_library (f_data, acc) data_lib = - let cs, bs, lib, lib_extra = - !lib_hook data_lib - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then - begin - let acc = - (* Start with acc + lib_extra *) - List.rev_append lib_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - OASISHostPath.of_unix bs.bs_path - in - List.fold_left - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ acc - end - acc - lib.lib_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the library *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - and files_of_object (f_data, acc) data_obj = - let cs, bs, obj, obj_extra = - !obj_hook data_obj - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then - begin - let acc = - (* Start with acc + obj_extra *) - List.rev_append obj_extra acc - in - let acc = - (* Add uncompiled header from the source tree *) - let path = - OASISHostPath.of_unix bs.bs_path - in - List.fold_left - begin fun acc modul -> - begin - try - [List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".mli"; ".ml"]))] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - [] - end - @ - List.filter - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - (make_fnames modul [".annot";".cmti";".cmt"])) - @ acc - end - acc - obj.obj_modules - in - - let acc = - (* Get generated files *) - BaseBuilt.fold - BaseBuilt.BObj - cs.cs_name - (fun acc fn -> fn :: acc) - acc - in - - let f_data () = - (* Install data associated with the object *) - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in - - (f_data, acc) - end - else - begin - (f_data, acc) - end - - in - - (* Install one group of library *) - let install_group_lib grp = - (* Iterate through all group nodes *) - let rec install_group_lib_aux data_and_files grp = - let data_and_files, children = - match grp with - | Container (_, children) -> - data_and_files, children - | Package (_, cs, bs, `Library lib, children) -> - files_of_library data_and_files (cs, bs, lib), children - | Package (_, cs, bs, `Object obj, children) -> - files_of_object data_and_files (cs, bs, obj), children - in - List.fold_left - install_group_lib_aux - data_and_files - children - in - - (* Findlib name of the root library *) - let findlib_name = - findlib_of_group grp - in - - (* Determine root library *) - let root_lib = - root_of_group grp - in - - (* All files to install for this library *) - let f_data, files = - install_group_lib_aux (ignore, []) grp - in - - (* Really install, if there is something to install *) - if files = [] then - begin - warning - (f_ "Nothing to install for findlib library '%s'") - findlib_name - end - else - begin - let meta = - (* Search META file *) - let _, bs, _ = - root_lib - in - let res = - Filename.concat bs.bs_path "META" - in - if not (OASISFileUtil.file_exists_case res) then - failwithf - (f_ "Cannot find file '%s' for findlib library %s") - res - findlib_name; - res - in - let files = - (* Make filename shorter to avoid hitting command max line length - * too early, esp. on Windows. - *) - let remove_prefix p n = - let plen = String.length p in - let nlen = String.length n in - if plen <= nlen && String.sub n 0 plen = p then - begin - let fn_sep = - if Sys.os_type = "Win32" then - '\\' - else - '/' - in - let cutpoint = plen + - (if plen < nlen && n.[plen] = fn_sep then - 1 - else - 0) - in - String.sub n cutpoint (nlen - cutpoint) - end - else - n - in - List.map (remove_prefix (Sys.getcwd ())) files - in - info - (f_ "Installing findlib library '%s'") - findlib_name; - let ocamlfind = ocamlfind () in - let commands = - split_install_command - ocamlfind - findlib_name - meta - files - in - List.iter - (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) - commands; - BaseLog.register install_findlib_ev findlib_name - end; - - (* Install data files *) - f_data (); - - in - - let group_libs, _, _ = - findlib_mapping pkg - in - - (* We install libraries in groups *) - List.iter install_group_lib group_libs - in - - let install_execs pkg = - let install_exec data_exec = - let cs, bs, exec = - !exec_hook data_exec - in - if var_choose bs.bs_install && - BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then - begin - let exec_libdir () = - Filename.concat - (libdir ()) - pkg.name - in - BaseBuilt.fold - BaseBuilt.BExec - cs.cs_name - (fun () fn -> - install_file - ~tgt_fn:(cs.cs_name ^ ext_program ()) - fn - bindir) - (); - BaseBuilt.fold - BaseBuilt.BExecLib - cs.cs_name - (fun () fn -> - install_file - fn - exec_libdir) - (); - install_data - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name) - end - in - List.iter - (function - | Executable (cs, bs, exec)-> - install_exec (cs, bs, exec) - | _ -> - ()) - pkg.sections - in - - let install_docs pkg = - let install_doc data = - let cs, doc = - !doc_hook data - in - if var_choose doc.doc_install && - BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then - begin - let tgt_dir = - OASISHostPath.of_unix (var_expand doc.doc_install_dir) - in - BaseBuilt.fold - BaseBuilt.BDoc - cs.cs_name - (fun () fn -> - install_file - fn - (fun () -> tgt_dir)) - (); - install_data - Filename.current_dir_name - doc.doc_data_files - doc.doc_install_dir - end - in - List.iter - (function - | Doc (cs, doc) -> - install_doc (cs, doc) - | _ -> - ()) - pkg.sections - in - - install_libs pkg; - install_execs pkg; - install_docs pkg - - - (* Uninstall already installed data *) - let uninstall _ argv = - List.iter - (fun (ev, data) -> - if ev = install_file_ev then - begin - if OASISFileUtil.file_exists_case data then - begin - info - (f_ "Removing file '%s'") - data; - Sys.remove data - end - else - begin - warning - (f_ "File '%s' doesn't exist anymore") - data - end - end - else if ev = install_dir_ev then - begin - if Sys.file_exists data && Sys.is_directory data then - begin - if Sys.readdir data = [||] then - begin - info - (f_ "Removing directory '%s'") - data; - OASISFileUtil.rmdir ~ctxt:!BaseContext.default data - end - else - begin - warning - (f_ "Directory '%s' is not empty (%s)") - data - (String.concat - ", " - (Array.to_list - (Sys.readdir data))) - end - end - else - begin - warning - (f_ "Directory '%s' doesn't exist anymore") - data - end - end - else if ev = install_findlib_ev then - begin - info (f_ "Removing findlib library '%s'") data; - OASISExec.run ~ctxt:!BaseContext.default - (ocamlfind ()) ["remove"; data] - end - else - failwithf (f_ "Unknown log event '%s'") ev; - BaseLog.unregister ev data) - (* We process event in reverse order *) - (List.rev - (BaseLog.filter - [install_file_ev; - install_dir_ev; - install_findlib_ev])) - - -end - - -# 6273 "setup.ml" -module OCamlbuildCommon = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) - - - (** Functions common to OCamlbuild build and doc plugin - *) - - - open OASISGettext - open BaseEnv - open BaseStandardVar - open OASISTypes - - - - - type extra_args = string list - - - let ocamlbuild_clean_ev = "ocamlbuild-clean" - - - let ocamlbuildflags = - var_define - ~short_desc:(fun () -> "OCamlbuild additional flags") - "ocamlbuildflags" - (fun () -> "") - - - (** Fix special arguments depending on environment *) - let fix_args args extra_argv = - List.flatten - [ - if (os_type ()) = "Win32" then - [ - "-classic-display"; - "-no-log"; - "-no-links"; - "-install-lib-dir"; - (Filename.concat (standard_library ()) "ocamlbuild") - ] - else - []; - - if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then - [ - "-byte-plugin" - ] - else - []; - args; - - if bool_of_string (debug ()) then - ["-tag"; "debug"] - else - []; - - if bool_of_string (tests ()) then - ["-tag"; "tests"] - else - []; - - if bool_of_string (profile ()) then - ["-tag"; "profile"] - else - []; - - OASISString.nsplit (ocamlbuildflags ()) ' '; - - Array.to_list extra_argv; - ] - - - (** Run 'ocamlbuild -clean' if not already done *) - let run_clean extra_argv = - let extra_cli = - String.concat " " (Array.to_list extra_argv) - in - (* Run if never called with these args *) - if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then - begin - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args ["-clean"] extra_argv); - BaseLog.register ocamlbuild_clean_ev extra_cli; - at_exit - (fun () -> - try - BaseLog.unregister ocamlbuild_clean_ev extra_cli - with _ -> - ()) - end - - - (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild args extra_argv = - (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - OASISExec.run ~ctxt:!BaseContext.default - (ocamlbuild ()) (fix_args args extra_argv); - (* Remove any clean event, we must run it again *) - List.iter - (fun (e, d) -> BaseLog.unregister e d) - (BaseLog.filter [ocamlbuild_clean_ev]) - - - (** Determine real build directory *) - let build_dir extra_argv = - let rec search_args dir = - function - | "-build-dir" :: dir :: tl -> - search_args dir tl - | _ :: tl -> - search_args dir tl - | [] -> - dir - in - search_args "_build" (fix_args [] extra_argv) - - -end - -module OCamlbuildPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) - - - (** Build using ocamlbuild - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OASISUtils - open OASISString - open BaseEnv - open OCamlbuildCommon - open BaseStandardVar - open BaseMessage - - - - - - let cond_targets_hook = - ref (fun lst -> lst) - - - let build extra_args pkg argv = - (* Return the filename in build directory *) - let in_build_dir fn = - Filename.concat - (build_dir argv) - fn - in - - (* Return the unix filename in host build directory *) - let in_build_dir_of_unix fn = - in_build_dir (OASISHostPath.of_unix fn) - in - - let cond_targets = - List.fold_left - (fun acc -> - function - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_library - in_build_dir_of_unix - (cs, bs, lib) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ~what:".cma" fn - || ends_with ~what:".cmxs" fn - || ends_with ~what:".cmxa" fn - || ends_with ~what:(ext_lib ()) fn - || ends_with ~what:(ext_dll ()) fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for library %s") - cs.cs_name - end - - | Object (cs, bs, obj) when var_choose bs.bs_build -> - begin - let evs, unix_files = - BaseBuilt.of_object - in_build_dir_of_unix - (cs, bs, obj) - in - - let tgts = - List.flatten - (List.filter - (fun l -> l <> []) - (List.map - (List.filter - (fun fn -> - ends_with ".cmo" fn - || ends_with ".cmx" fn)) - unix_files)) - in - - match tgts with - | _ :: _ -> - (evs, tgts) :: acc - | [] -> - failwithf - (f_ "No possible ocamlbuild targets for object %s") - cs.cs_name - end - - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, unix_exec_is, unix_dll_opt = - BaseBuilt.of_executable - in_build_dir_of_unix - (cs, bs, exec) - in - - let target ext = - let unix_tgt = - (OASISUnixPath.concat - bs.bs_path - (OASISUnixPath.chop_extension - exec.exec_main_is))^ext - in - let evs = - (* Fix evs, we want to use the unix_tgt, without copying *) - List.map - (function - | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> - BaseBuilt.BExec, nm, - [[in_build_dir_of_unix unix_tgt]] - | ev -> - ev) - evs - in - evs, [unix_tgt] - in - - (* Add executable *) - let acc = - match bs.bs_compiled_object with - | Native -> - (target ".native") :: acc - | Best when bool_of_string (is_native ()) -> - (target ".native") :: acc - | Byte - | Best -> - (target ".byte") :: acc - in - acc - end - - | Library _ | Object _ | Executable _ | Test _ - | SrcRepo _ | Flag _ | Doc _ -> - acc) - [] - (* Keep the pkg.sections ordered *) - (List.rev pkg.sections); - in - - (* Check and register built files *) - let check_and_register (bt, bnm, lst) = - List.iter - (fun fns -> - if not (List.exists OASISFileUtil.file_exists_case fns) then - failwithf - (fn_ - "Expected built file %s doesn't exist." - "None of expected built files %s exists." - (List.length fns)) - (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) - lst; - (BaseBuilt.register bt bnm lst) - in - - (* Run the hook *) - let cond_targets = !cond_targets_hook cond_targets in - - (* Run a list of target... *) - run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; - (* ... and register events *) - List.iter check_and_register (List.flatten (List.map fst cond_targets)) - - - let clean pkg extra_args = - run_clean extra_args; - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - -end - -module OCamlbuildDocPlugin = struct -(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) - - - (* Create documentation using ocamlbuild .odocl files - @author Sylvain Le Gall - *) - - - open OASISTypes - open OASISGettext - open OASISMessage - open OCamlbuildCommon - open BaseStandardVar - - - - - type run_t = - { - extra_args: string list; - run_path: unix_filename; - } - - - let doc_build run pkg (cs, doc) argv = - let index_html = - OASISUnixPath.make - [ - run.run_path; - cs.cs_name^".docdir"; - "index.html"; - ] - in - let tgt_dir = - OASISHostPath.make - [ - build_dir argv; - OASISHostPath.of_unix run.run_path; - cs.cs_name^".docdir"; - ] - in - run_ocamlbuild (index_html :: run.extra_args) argv; - List.iter - (fun glb -> - BaseBuilt.register - BaseBuilt.BDoc - cs.cs_name - [OASISFileUtil.glob ~ctxt:!BaseContext.default - (Filename.concat tgt_dir glb)]) - ["*.html"; "*.css"] - - - let doc_clean run pkg (cs, doc) argv = - run_clean argv; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - - -end - - -# 6651 "setup.ml" -module CustomPlugin = struct -(* # 22 "src/plugins/custom/CustomPlugin.ml" *) - - - (** Generate custom configure/build/doc/test/install system - @author - *) - - - open BaseEnv - open OASISGettext - open OASISTypes - - - - - - type t = - { - cmd_main: command_line conditional; - cmd_clean: (command_line option) conditional; - cmd_distclean: (command_line option) conditional; - } - - - let run = BaseCustom.run - - - let main t _ extra_args = - let cmd, args = - var_choose - ~name:(s_ "main command") - t.cmd_main - in - run cmd args extra_args - - - let clean t pkg extra_args = - match var_choose t.cmd_clean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - - let distclean t pkg extra_args = - match var_choose t.cmd_distclean with - | Some (cmd, args) -> - run cmd args extra_args - | _ -> - () - - - module Build = - struct - let main t pkg extra_args = - main t pkg extra_args; - List.iter - (fun sct -> - let evs = - match sct with - | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, _ = - BaseBuilt.of_library - OASISHostPath.of_unix - (cs, bs, lib) - in - evs - end - | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, _, _ = - BaseBuilt.of_executable - OASISHostPath.of_unix - (cs, bs, exec) - in - evs - end - | _ -> - [] - in - List.iter - (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) - evs) - pkg.sections - - let clean t pkg extra_args = - clean t pkg extra_args; - (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild - * considering moving this to BaseSetup? - *) - List.iter - (function - | Library (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) - pkg.sections - - let distclean t pkg extra_args = - distclean t pkg extra_args - end - - - module Test = - struct - let main t pkg (cs, test) extra_args = - try - main t pkg extra_args; - 0.0 - with Failure s -> - BaseMessage.warning - (f_ "Test '%s' fails: %s") - cs.cs_name - s; - 1.0 - - let clean t pkg (cs, test) extra_args = - clean t pkg extra_args - - let distclean t pkg (cs, test) extra_args = - distclean t pkg extra_args - end - - - module Doc = - struct - let main t pkg (cs, _) extra_args = - main t pkg extra_args; - BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] - - let clean t pkg (cs, _) extra_args = - clean t pkg extra_args; - BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - - let distclean t pkg (cs, _) extra_args = - distclean t pkg extra_args - end - - -end - - -# 6799 "setup.ml" -open OASISTypes;; - -let setup_t = - { - BaseSetup.configure = InternalConfigurePlugin.configure; - build = OCamlbuildPlugin.build ["-use-ocamlfind"]; - test = - [ - ("all", - CustomPlugin.Test.main - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("./run_qtest.native", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - doc = - [ - ("containers", - OCamlbuildDocPlugin.doc_build - { - OCamlbuildDocPlugin.extra_args = - [ - "-use-ocamlfind"; - "-docflags '-colorize-code -short-functors -charset utf-8'" - ]; - run_path = "." - }) - ]; - install = InternalInstallPlugin.install; - uninstall = InternalInstallPlugin.uninstall; - clean = [OCamlbuildPlugin.clean]; - clean_test = - [ - ("all", - CustomPlugin.Test.clean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("./run_qtest.native", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - clean_doc = - [ - ("containers", - OCamlbuildDocPlugin.doc_clean - { - OCamlbuildDocPlugin.extra_args = - [ - "-use-ocamlfind"; - "-docflags '-colorize-code -short-functors -charset utf-8'" - ]; - run_path = "." - }) - ]; - distclean = []; - distclean_test = - [ - ("all", - CustomPlugin.Test.distclean - { - CustomPlugin.cmd_main = - [(OASISExpr.EBool true, ("./run_qtest.native", []))]; - cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)] - }) - ]; - distclean_doc = []; - package = - { - oasis_version = "0.4"; - ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1"); - findlib_version = None; - alpha_features = ["ocamlbuild_more_args"]; - beta_features = []; - name = "containers"; - version = "0.15"; - 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 optional libraries for dealing with strings, and helpers for unix and threads." - ]; - categories = []; - conf_type = (`Configure, "internal", Some "0.4"); - conf_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - build_type = (`Build, "ocamlbuild", Some "0.4"); - build_custom = - { - pre_command = - [(OASISExpr.EBool true, Some (("make", ["qtest-gen"])))]; - post_command = [(OASISExpr.EBool true, None)] - }; - install_type = (`Install, "internal", Some "0.4"); - install_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - uninstall_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - clean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - distclean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - files_ab = []; - sections = - [ - Flag - ({ - cs_name = "unix"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some - "Build the containers.unix library (depends on Unix)"; - flag_default = [(OASISExpr.EBool true, 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, true)] - }); - Flag - ({ - cs_name = "bench"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = Some "Build and run benchmarks"; - flag_default = [(OASISExpr.EBool true, true)] - }); - Flag - ({ - cs_name = "bigarray"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some "Build modules that depend on bigarrays"; - flag_default = [(OASISExpr.EBool true, true)] - }); - Flag - ({ - cs_name = "advanced"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - flag_description = - Some - "Build advanced combinators, including CCLinq (requires \"sequence\")"; - flag_default = [(OASISExpr.EBool true, true)] - }); - Library - ({ - cs_name = "containers"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/core"; - bs_compiled_object = Best; - bs_build_depends = [FindlibPackage ("bytes", None)]; - 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"; - "CCPrint"; - "CCError"; - "CCHeap"; - "CCList"; - "CCOpt"; - "CCPair"; - "CCFun"; - "CCHash"; - "CCInt"; - "CCBool"; - "CCFloat"; - "CCArray"; - "CCRef"; - "CCSet"; - "CCOrd"; - "CCRandom"; - "CCString"; - "CCHashtbl"; - "CCMap"; - "CCFormat"; - "CCIO"; - "CCInt64"; - "CCChar"; - "Containers" - ]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = None; - lib_findlib_name = None; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_io"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/io"; - bs_compiled_object = Best; - bs_build_depends = [FindlibPackage ("bytes", None)]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["Containers_io_is_deprecated"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "io"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_unix"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/unix"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("bytes", None); - FindlibPackage ("unix", 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 = ["CCUnix"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "unix"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_sexp"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/sexp"; - bs_compiled_object = Best; - bs_build_depends = [FindlibPackage ("bytes", None)]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["CCSexp"; "CCSexpM"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "sexp"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_data"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/data"; - bs_compiled_object = Best; - bs_build_depends = [FindlibPackage ("bytes", None)]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - [ - "CCMultiMap"; - "CCMultiSet"; - "CCTrie"; - "CCFlatHashtbl"; - "CCCache"; - "CCPersistentHashtbl"; - "CCDeque"; - "CCFQueue"; - "CCBV"; - "CCMixtbl"; - "CCMixmap"; - "CCRingBuffer"; - "CCIntMap"; - "CCPersistentArray"; - "CCMixset"; - "CCHashconsedSet"; - "CCGraph"; - "CCHashSet"; - "CCBitField"; - "CCHashTrie"; - "CCBloom"; - "CCWBTree"; - "CCRAL"; - "CCAllocCache" - ]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "data"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_iter"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/iter"; - bs_compiled_object = Best; - bs_build_depends = []; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["CCKTree"; "CCKList"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "iter"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_string"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/string"; - bs_compiled_object = Best; - bs_build_depends = [FindlibPackage ("bytes", None)]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = - [ - "Containers_string"; - "CCKMP"; - "CCLevenshtein"; - "CCApp_parse"; - "CCParse" - ]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "string"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_advanced"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "advanced", true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "advanced", true) - ]; - bs_path = "src/advanced"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("sequence", 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 = - [ - "Containers_advanced"; - "CCLinq"; - "CCBatch"; - "CCCat"; - "CCMonadIO" - ]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "advanced"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_bigarray"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/bigarray"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("bigarray", None); - FindlibPackage ("bytes", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["CCBigstring"; "CCArray1"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "bigarray"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_thread"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "thread", true) - ]; - bs_install = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "thread", true) - ]; - bs_path = "src/threads/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - FindlibPackage ("threads", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_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"; "CCLock"; "CCSemaphore"; "CCThread"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "thread"; - lib_findlib_containers = [] - }); - Library - ({ - cs_name = "containers_top"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "src/top/"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("compiler-libs.common", None); - InternalLibrary "containers"; - InternalLibrary "containers_data"; - InternalLibrary "containers_bigarray"; - InternalLibrary "containers_string"; - InternalLibrary "containers_unix"; - InternalLibrary "containers_sexp"; - InternalLibrary "containers_iter" - ]; - 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 = ["Containers_top"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "containers"; - lib_findlib_name = Some "top"; - lib_findlib_containers = [] - }); - Doc - ({ - cs_name = "containers"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - doc_type = (`Doc, "ocamlbuild", Some "0.3"); - doc_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - doc_build = - [ - (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); - (OASISExpr.EFlag "docs", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EAnd - (OASISExpr.EFlag "docs", - OASISExpr.EAnd - (OASISExpr.EFlag "advanced", - OASISExpr.EAnd - (OASISExpr.EFlag "bigarray", - OASISExpr.EFlag "unix")))), - true) - ]; - doc_install = [(OASISExpr.EBool true, true)]; - doc_install_dir = "$docdir"; - doc_title = "Containers docs"; - doc_authors = []; - doc_abstract = None; - doc_format = OtherDoc; - doc_data_files = []; - doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] - }); - Executable - ({ - cs_name = "run_benchs"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "bench", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "benchs/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_advanced"; - InternalLibrary "containers_data"; - InternalLibrary "containers_string"; - InternalLibrary "containers_iter"; - InternalLibrary "containers_thread"; - FindlibPackage ("sequence", None); - FindlibPackage ("gen", None); - FindlibPackage ("benchmark", None); - FindlibPackage ("hamt", 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_benchs.ml"}); - Executable - ({ - cs_name = "run_bench_hash"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "bench", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "benchs/"; - bs_compiled_object = Best; - bs_build_depends = [InternalLibrary "containers"]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_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_bench_hash.ml"}); - Executable - ({ - cs_name = "run_qtest"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EAnd - (OASISExpr.EFlag "bigarray", - OASISExpr.EAnd - (OASISExpr.EFlag "unix", - OASISExpr.EFlag "advanced"))), - true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "qtest/"; - bs_compiled_object = Best; - bs_build_depends = - [ - InternalLibrary "containers"; - InternalLibrary "containers_string"; - InternalLibrary "containers_iter"; - InternalLibrary "containers_io"; - InternalLibrary "containers_advanced"; - InternalLibrary "containers_sexp"; - InternalLibrary "containers_bigarray"; - InternalLibrary "containers_unix"; - InternalLibrary "containers_thread"; - InternalLibrary "containers_data"; - FindlibPackage ("sequence", None); - FindlibPackage ("gen", None); - FindlibPackage ("unix", None); - FindlibPackage ("oUnit", None); - FindlibPackage ("QTest2Lib", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_c_sources = []; - bs_data_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - {exec_custom = false; exec_main_is = "run_qtest.ml"}); - Test - ({ - cs_name = "all"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - test_type = (`Test, "custom", Some "0.4"); - test_command = - [(OASISExpr.EBool true, ("./run_qtest.native", []))]; - test_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - test_working_directory = None; - test_run = - [ - (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); - (OASISExpr.EFlag "tests", false); - (OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EAnd - (OASISExpr.EFlag "tests", - OASISExpr.EAnd - (OASISExpr.EFlag "unix", - OASISExpr.EAnd - (OASISExpr.EFlag "advanced", - OASISExpr.EFlag "bigarray")))), - true) - ]; - test_tools = - [ - ExternalTool "ocamlbuild"; - InternalExecutable "run_qtest" - ] - }); - Executable - ({ - cs_name = "mem_measure"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = - [ - (OASISExpr.EBool true, false); - (OASISExpr.EFlag "bench", true) - ]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "benchs/"; - bs_compiled_object = Native; - bs_build_depends = - [ - FindlibPackage ("sequence", None); - FindlibPackage ("unix", None); - InternalLibrary "containers"; - InternalLibrary "containers_data"; - FindlibPackage ("hamt", 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 = "mem_measure.ml"}); - Executable - ({ - cs_name = "id_sexp"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, false)]; - bs_path = "examples/"; - bs_compiled_object = Best; - bs_build_depends = [InternalLibrary "containers_sexp"]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_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.5"; - oasis_digest = Some "\183\156\139\200Ys\193\023\212>%\209\180\133\193p"; - oasis_exec = None; - oasis_setup_args = []; - setup_update = false - };; - -let setup () = BaseSetup.setup setup_t;; - -# 7719 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/src/advanced/CCLinq.mli b/src/advanced/CCLinq.mli index cf21c35e..2261af3f 100644 --- a/src/advanced/CCLinq.mli +++ b/src/advanced/CCLinq.mli @@ -56,7 +56,9 @@ CCLinq.( - : `Ok () ]} -{b status: experimental} +{b DEPRECATED, use "OLinq" (standalone library) instead} + +{b status: deprecated} *) @@ -76,8 +78,6 @@ module PMap : sig val to_seq : ('a, 'b) t -> ('a * 'b) sequence - val to_list : ('a, 'b) t -> ('a * 'b) list - val map : ('b -> 'c) -> ('a, 'b) t -> ('a, 'c) t (** Transform values *) diff --git a/src/bigarray/CCArray1.mli b/src/bigarray/CCArray1.mli index ebde558e..4cb6fbea 100644 --- a/src/bigarray/CCArray1.mli +++ b/src/bigarray/CCArray1.mli @@ -25,7 +25,9 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Bigarrays of dimension 1} - {b status: experimental} + {b NOTE this module will be removed soon and should not be depended upon} + + {b status: deprecated} @since 0.12 *) (** {2 used types} *) diff --git a/src/bigarray/CCBigstring.ml b/src/bigarray/CCBigstring.ml index a22fe168..4dcef050 100644 --- a/src/bigarray/CCBigstring.ml +++ b/src/bigarray/CCBigstring.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Interface to 1-dimension Bigarrays of bytes (char)} *) diff --git a/src/bigarray/CCBigstring.mli b/src/bigarray/CCBigstring.mli index 6eb0143b..5c8c6a9a 100644 --- a/src/bigarray/CCBigstring.mli +++ b/src/bigarray/CCBigstring.mli @@ -1,31 +1,13 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Interface to 1-dimension Bigarrays of bytes (char)} -@since 0.7 *) + @deprecated use the package [bigstring] instead. + + {b status: deprecated, do not use anymore} + + @since 0.7 *) type t = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t diff --git a/src/core/CCArray.ml b/src/core/CCArray.ml index 6c1d2098..de3b8b43 100644 --- a/src/core/CCArray.ml +++ b/src/core/CCArray.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Array utils} *) diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index c23ed39e..dd87dd40 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Array utils} *) diff --git a/src/core/CCBool.ml b/src/core/CCBool.ml index 148961ac..c4eab0ed 100644 --- a/src/core/CCBool.ml +++ b/src/core/CCBool.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) type t = bool diff --git a/src/core/CCBool.mli b/src/core/CCBool.mli index 28108f89..743b9c8c 100644 --- a/src/core/CCBool.mli +++ b/src/core/CCBool.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Basic Bool functions} *) diff --git a/src/core/CCError.ml b/src/core/CCError.ml index 3bc727ee..ab9af226 100644 --- a/src/core/CCError.ml +++ b/src/core/CCError.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Error Monad} *) diff --git a/src/core/CCError.mli b/src/core/CCError.mli index f7e5fa34..64bbf525 100644 --- a/src/core/CCError.mli +++ b/src/core/CCError.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Error Monad} diff --git a/src/core/CCFloat.ml b/src/core/CCFloat.ml index 75336d7f..6e4a5b56 100644 --- a/src/core/CCFloat.ml +++ b/src/core/CCFloat.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2014, Carmelo Piccione -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) type t = float type fpclass = Pervasives.fpclass = diff --git a/src/core/CCFloat.mli b/src/core/CCFloat.mli index 1cc33188..4fa7f9ab 100644 --- a/src/core/CCFloat.mli +++ b/src/core/CCFloat.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2014, Carmelo Piccione -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Basic Float functions} @since 0.6.1 *) diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index 51ec4613..8fd37a8e 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Helpers for Format} *) @@ -99,18 +77,38 @@ let opt pp fmt x = match x with | Some x -> Format.fprintf fmt "some %a" pp x let pair ppa ppb fmt (a, b) = - Format.fprintf fmt "(%a, %a)" ppa a ppb b + Format.fprintf fmt "(%a,@ %a)" ppa a ppb b let triple ppa ppb ppc fmt (a, b, c) = - Format.fprintf fmt "(%a, %a, %a)" ppa a ppb b ppc c + Format.fprintf fmt "(%a,@ %a,@ %a)" ppa a ppb b ppc c let quad ppa ppb ppc ppd fmt (a, b, c, d) = - Format.fprintf fmt "(%a, %a, %a, %a)" ppa a ppb b ppc c ppd d + Format.fprintf fmt "(%a,@ %a,@ %a,@ %a)" ppa a ppb b ppc c ppd d let map f pp fmt x = pp fmt (f x); () +let vbox ?(i=0) pp out x = + Format.pp_open_vbox out i; + pp out x; + Format.pp_close_box out () + +let hovbox ?(i=0) pp out x = + Format.pp_open_hovbox out i; + pp out x; + Format.pp_close_box out () + +let hvbox ?(i=0) pp out x = + Format.pp_open_hvbox out i; + pp out x; + Format.pp_close_box out () + +let hbox pp out x = + Format.pp_open_hbox out (); + pp out x; + Format.pp_close_box out () + (** {2 IO} *) let output fmt pp x = pp fmt x @@ -197,7 +195,8 @@ let style_of_tag_ s = match String.trim s with | "magenta" -> [`FG `Magenta] | "cyan" -> [`FG `Cyan] | "white" -> [`FG `White] - | "Black" -> [`FG `Black] + | "bold" -> [`Bold] + | "Black" -> [`FG `Black; `Bold] | "Red" -> [`FG `Red; `Bold] | "Green" -> [`FG `Green; `Bold] | "Yellow" -> [`FG `Yellow; `Bold] @@ -210,25 +209,34 @@ let style_of_tag_ s = match String.trim s with let color_enabled = ref false (* either prints the tag of [s] or delegate to [or_else] *) -let mark_open_tag ~or_else s = +let mark_open_tag st ~or_else s = try let style = style_of_tag_ s in + Stack.push style st; if !color_enabled then ansi_l_to_str_ style else "" with Not_found -> or_else s -let mark_close_tag ~or_else s = +let mark_close_tag st ~or_else s = try let _ = style_of_tag_ s in (* check if it's indeed about color *) - if !color_enabled then ansi_l_to_str_ [`Reset] else "" + let style = + try + ignore (Stack.pop st); (* pop current style (if well-scoped...) *) + Stack.top st (* look at previous style *) + with Stack.Empty -> + [`Reset] + in + if !color_enabled then ansi_l_to_str_ style else "" with Not_found -> or_else s (* add color handling to formatter [ppf] *) let set_color_tag_handling ppf = let open Format in let functions = pp_get_formatter_tag_functions ppf () in + let st = Stack.create () in (* stack of styles *) let functions' = {functions with - mark_open_tag=(mark_open_tag ~or_else:functions.mark_open_tag); - mark_close_tag=(mark_close_tag ~or_else:functions.mark_close_tag); + mark_open_tag=(mark_open_tag st ~or_else:functions.mark_open_tag); + mark_close_tag=(mark_close_tag st ~or_else:functions.mark_close_tag); } in pp_set_mark_tags ppf true; (* enable tags *) pp_set_formatter_tag_functions ppf functions' @@ -255,18 +263,40 @@ let set_color_default = s *) -let sprintf format = +let with_color s pp out x = + Format.pp_open_tag out s; + pp out x; + Format.pp_close_tag out () + +let with_colorf s out fmt = + Format.pp_open_tag out s; + Format.kfprintf + (fun out -> Format.pp_close_tag out ()) + out fmt + +(* c: whether colors are enabled *) +let sprintf_ c format = let buf = Buffer.create 64 in let fmt = Format.formatter_of_buffer buf in - if !color_enabled then set_color_tag_handling fmt; + if c && !color_enabled then set_color_tag_handling fmt; Format.kfprintf (fun _fmt -> Format.pp_print_flush fmt (); Buffer.contents buf) fmt format +let sprintf fmt = sprintf_ true fmt +let sprintf_no_color fmt = sprintf_ false fmt + (*$T sprintf "yolo %s %d" "a b" 42 = "yolo a b 42" sprintf "%d " 0 = "0 " + sprintf_no_color "%d " 0 = "0 " +*) + +(*$R + set_color_default true; + assert_equal "\027[31myolo\027[0m" (sprintf "@{yolo@}"); + assert_equal "yolo" (sprintf_no_color "@{yolo@}"); *) let ksprintf ~f fmt = diff --git a/src/core/CCFormat.mli b/src/core/CCFormat.mli index 8ab2e98f..e678a779 100644 --- a/src/core/CCFormat.mli +++ b/src/core/CCFormat.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Helpers for Format} @@ -66,12 +44,31 @@ val quad : 'a printer -> 'b printer -> 'c printer -> 'd printer -> ('a * 'b * 'c val map : ('a -> 'b) -> 'b printer -> 'a printer -(** {2 ASCII codes} +val vbox : ?i:int -> 'a printer -> 'a printer +(** Wrap the printer in a vertical box + @param i level of indentation within the box (default 0) + @since 0.16 *) + +val hvbox : ?i:int -> 'a printer -> 'a printer +(** Wrap the printer in a horizontal/vertical box + @param i level of indentation within the box (default 0) + @since 0.16 *) + +val hovbox : ?i:int -> 'a printer -> 'a printer +(** Wrap the printer in a horizontal or vertical box + @param i level of indentation within the box (default 0) + @since 0.16 *) + +val hbox : 'a printer -> 'a printer +(** Wrap the printer in an horizontal box + @since 0.16 *) + +(** {2 ANSI codes} Use ANSI escape codes https://en.wikipedia.org/wiki/ANSI_escape_code to put some colors on the terminal. - This uses {b tags} in format strings to specify the style. Current styles + This uses {b tags} in format strings to specify the style. Current styles are the following: {ul @@ -84,6 +81,7 @@ val map : ('a -> 'b) -> 'b printer -> 'a printer {- "magenta" } {- "cyan" } {- "white" } + {- "bold" bold font} {- "Black" bold black} {- "Red" bold red } {- "Green" bold green } @@ -115,6 +113,18 @@ val set_color_default : bool -> unit (stdout, stderr) if [b = true] as well as on {!sprintf} formatters; it disables the color handling if [b = false]. *) +val with_color : string -> 'a printer -> 'a printer +(** [with_color "Blue" pp] behaves like the printer [pp], but with the given + style. + {b status: experimental} + @since 0.16 *) + +val with_colorf : string -> t -> ('a, t, unit, unit) format4 -> 'a +(** [with_colorf "Blue" out "%s %d" "yolo" 42] will behave like {!Format.fprintf}, + but wrapping the content with the given style + {b status: experimental} + @since 0.16 *) + (** {2 IO} *) val output : t -> 'a printer -> 'a -> unit @@ -127,6 +137,10 @@ val sprintf : ('a, t, unit, string) format4 -> 'a (** Print into a string any format string that would usually be compatible with {!fprintf}. Similar to {!Format.asprintf}. *) +val sprintf_no_color : ('a, t, unit, string) format4 -> 'a +(** Similar to {!sprintf} but never prints colors + @since 0.16 *) + val fprintf : t -> ('a, t, unit ) format -> 'a (** Alias to {!Format.fprintf} @since 0.14 *) diff --git a/src/core/CCFun.cppo.ml b/src/core/CCFun.cppo.ml index 77f12094..c14cdb84 100644 --- a/src/core/CCFun.cppo.ml +++ b/src/core/CCFun.cppo.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Basic Functions} *) @@ -64,10 +42,28 @@ let lexicographic f1 f2 x y = let finally ~h ~f = try let x = f () in - h (); + ignore (h ()); x with e -> - h (); + ignore (h ()); + raise e + +let finally1 ~h f x = + try + let res = f x in + ignore (h ()); + res + with e -> + ignore (h ()); + raise e + +let finally2 ~h f x y = + try + let res = f x y in + ignore (h ()); + res + with e -> + ignore (h ()); raise e module Monad(X : sig type t end) = struct diff --git a/src/core/CCFun.mli b/src/core/CCFun.mli index b6abcf08..7d731708 100644 --- a/src/core/CCFun.mli +++ b/src/core/CCFun.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Basic Functions} *) @@ -57,7 +35,7 @@ val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c val uncurry : ('a -> 'b -> 'c) -> ('a * 'b) -> 'c -val tap : ('a -> 'b) -> 'a -> 'a +val tap : ('a -> _) -> 'a -> 'a (** [tap f x] evaluates [f x], discards it, then returns [x]. Useful in a pipeline, for instance: {[CCArray.(1 -- 10) @@ -72,11 +50,21 @@ val (%) : ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c val lexicographic : ('a -> 'a -> int) -> ('a -> 'a -> int) -> 'a -> 'a -> int (** Lexicographic combination of comparison functions *) -val finally : h:(unit -> unit) -> f:(unit -> 'a) -> 'a +val finally : h:(unit -> _) -> f:(unit -> 'a) -> 'a (** [finally h f] calls [f ()] and returns its result. If it raises, the same exception is raised; in {b any} case, [h ()] is called after [f ()] terminates. *) +val finally1 : h:(unit -> _) -> ('a -> 'b) -> 'a -> 'b +(** [finally1 ~h f x] is the same as [f x], but after the computation, + [h ()] is called whether [f x] rose an exception or not. + @since 0.16 *) + +val finally2 : h:(unit -> _) -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c +(** [finally2 ~h f x y] is the same as [f x y], but after the computation, + [h ()] is called whether [f x y] rose an exception or not. + @since 0.16 *) + (** {2 Monad} Functions with a fixed domain are monads in their codomain *) diff --git a/src/core/CCHash.ml b/src/core/CCHash.ml index 9c7cb60c..42d15737 100644 --- a/src/core/CCHash.ml +++ b/src/core/CCHash.ml @@ -1,27 +1,5 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Hash combinators} *) diff --git a/src/core/CCHash.mli b/src/core/CCHash.mli index 09b2d473..3b5620d2 100644 --- a/src/core/CCHash.mli +++ b/src/core/CCHash.mli @@ -1,47 +1,22 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: +(* This file is free software, part of containers. See file "license" for more details. *) -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 Hash combinators} - -Combination of hashes based on the Murmur Hash (64 bits). See -{{: https://sites.google.com/site/murmurhash/MurmurHash2_64.cpp?attredirects=0} this page} -*) +(** {1 Hash combinators} *) (** {2 Definitions} *) type t = int (** A hash value is a positive integer *) -type state = int64 -(** State required by the hash function *) +type state +(** State required by the hash function. + @since 0.16 the state is abstract, for more flexibility *) type 'a hash_fun = 'a -> state -> state (** Hash function for values of type ['a], merging a fingerprint of the value into the state of type [t] *) -(** {2 Applying Murmur Hash} *) +(** {2 Applying Hash} *) val init : state (** Initial value *) @@ -55,11 +30,11 @@ val apply : 'a hash_fun -> 'a -> int (** {2 Basic Combinators} - Those combinators have been renamed in 0.13, so as to - remove the trailing "_". - They are now defined by the application of {!Make} + Those combinators have been renamed in 0.13, so as to + remove the trailing "_". + They are now defined by the application of {!Make} - *) +*) val bool_ : bool hash_fun (** @deprecated use {!bool} *) @@ -108,11 +83,11 @@ val klist : 'a hash_fun -> 'a klist hash_fun (** {2 Generic Hashing} - Parametrize over the state, and some primitives to hash basic types. - This can for instance be used for cryptographic hashing or - checksums such as MD5. + Parametrize over the state, and some primitives to hash basic types. + This can for instance be used for cryptographic hashing or + checksums such as MD5. - @since 0.13 *) + @since 0.13 *) module type HASH = sig type state diff --git a/src/core/CCHashtbl.ml b/src/core/CCHashtbl.ml index 73819dd3..d81c780b 100644 --- a/src/core/CCHashtbl.ml +++ b/src/core/CCHashtbl.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Extension to the standard Hashtbl} *) @@ -36,6 +14,15 @@ let get tbl x = try Some (Hashtbl.find tbl x) with Not_found -> None +let get_or tbl x ~or_ = + try Hashtbl.find tbl x + with Not_found -> or_ + +(*$= + "c" (let tbl = of_list [1,"a"; 2,"b"] in get_or tbl 3 ~or_:"c") + "b" (let tbl = of_list [1,"a"; 2,"b"] in get_or tbl 2 ~or_:"c") +*) + let keys tbl k = Hashtbl.iter (fun key _ -> k key) tbl let values tbl k = Hashtbl.iter (fun _ v -> k v) tbl @@ -43,6 +30,24 @@ let values tbl k = Hashtbl.iter (fun _ v -> k v) tbl let keys_list tbl = Hashtbl.fold (fun k _ a -> k::a) tbl [] let values_list tbl = Hashtbl.fold (fun _ v a -> v::a) tbl [] +let add_list tbl k v = + let l = try Hashtbl.find tbl k with Not_found -> [] in + Hashtbl.replace tbl k (v::l) + +let incr ?(by=1) tbl x = + let n = get_or tbl x ~or_:0 in + if n+by <= 0 + then Hashtbl.remove tbl x + else Hashtbl.replace tbl x (n+by) + +let decr ?(by=1) tbl x = + try + let n = Hashtbl.find tbl x in + if n-by <= 0 + then Hashtbl.remove tbl x + else Hashtbl.replace tbl x (n-by) + with Not_found -> () + let map_list f h = Hashtbl.fold (fun x y acc -> f x y :: acc) @@ -55,9 +60,18 @@ let map_list f h = let to_seq tbl k = Hashtbl.iter (fun key v -> k (key,v)) tbl +let add_seq tbl seq = seq (fun (k,v) -> Hashtbl.add tbl k v) + let of_seq seq = let tbl = Hashtbl.create 32 in - seq (fun (k,v) -> Hashtbl.add tbl k v); + add_seq tbl seq; + tbl + +let add_seq_count tbl seq = seq (fun k -> incr tbl k) + +let of_seq_count seq = + let tbl = Hashtbl.create 32 in + add_seq_count tbl seq; tbl let to_list tbl = @@ -110,18 +124,41 @@ module type S = sig val get : 'a t -> key -> 'a option (** Safe version of {!Hashtbl.find} *) + val get_or : 'a t -> key -> or_:'a -> 'a + (** [get_or tbl k ~or_] returns the value associated to [k] if present, + and returns [or_] otherwise (if [k] doesn't belong in [tbl]) + @since 0.16 *) + + val add_list : 'a list t -> key -> 'a -> unit + (** [add_list tbl x y] adds [y] to the list [x] is bound to. If [x] is + not bound, it becomes bound to [[y]]. + @since 0.16 *) + + val incr : ?by:int -> int t -> key -> unit + (** [incr ?by tbl x] increments or initializes the counter associated with [x]. + If [get tbl x = None], then after update, [get tbl x = Some 1]; + otherwise, if [get tbl x = Some n], now [get tbl x = Some (n+1)]. + @param by if specified, the int value is incremented by [by] rather than 1 + @since 0.16 *) + + val decr : ?by:int -> int t -> key -> unit + (** Same as {!incr} but substract 1 (or the value of [by]). + If the value reaches 0, the key is removed from the table. + This does nothing if the key is not already present in the table. + @since 0.16 *) + val keys : 'a t -> key sequence (** Iterate on keys (similar order as {!Hashtbl.iter}) *) val values : 'a t -> 'a sequence (** Iterate on values in the table *) - val keys_list : ('a, 'b) Hashtbl.t -> 'a list - (** [keys_list t] is the list of keys in [t]. + val keys_list : _ t -> key list + (** [keys t] is the list of keys in [t]. @since 0.8 *) - val values_list : ('a, 'b) Hashtbl.t -> 'b list - (** [values_list t] is the list of values in [t]. + val values_list : 'a t -> 'a list + (** [values t] is the list of values in [t]. @since 0.8 *) val map_list : (key -> 'a -> 'b) -> 'a t -> 'b list @@ -133,6 +170,20 @@ module type S = sig val of_seq : (key * 'a) sequence -> 'a t (** From the given bindings, added in order *) + val add_seq : 'a t -> (key * 'a) sequence -> unit + (** Add the corresponding pairs to the table, using {!Hashtbl.add}. + @since 0.16 *) + + val add_seq_count : int t -> key sequence -> unit + (** [add_seq_count tbl seq] increments the count of each element of [seq] + by calling {!incr}. This is useful for counting how many times each + element of [seq] occurs. + @since 0.16 *) + + val of_seq_count : key sequence -> int t + (** Similar to {!add_seq_count}, but allocates a new table and returns it + @since 0.16 *) + val to_list : 'a t -> (key * 'a) list (** List of bindings (order unspecified) *) @@ -152,6 +203,10 @@ module type S = sig @since 0.13 *) end +(*$inject + module T = Make(CCInt) +*) + module Make(X : Hashtbl.HashedType) : S with type key = X.t and type 'a t = 'a Hashtbl.Make(X).t = struct @@ -161,12 +216,53 @@ module Make(X : Hashtbl.HashedType) try Some (find tbl x) with Not_found -> None + let get_or tbl x ~or_ = + try find tbl x + with Not_found -> or_ + + (*$= + "c" (let tbl = T.of_list [1,"a"; 2,"b"] in T.get_or tbl 3 ~or_:"c") + "b" (let tbl = T.of_list [1,"a"; 2,"b"] in T.get_or tbl 2 ~or_:"c") + *) + + let incr ?(by=1) tbl x = + let n = get_or tbl x ~or_:0 in + if n+by <= 0 + then remove tbl x + else replace tbl x (n+by) + + (*$R + let tbl = T.create 32 in + T.incr tbl 1 ; + T.incr tbl 2; + T.incr tbl 1; + assert_equal 2 (T.find tbl 1); + assert_equal 1 (T.find tbl 2); + assert_equal 2 (T.length tbl); + T.decr tbl 2; + assert_equal 0 (T.get_or tbl 2 ~or_:0); + assert_equal 1 (T.length tbl); + assert_bool "2 removed" (not (T.mem tbl 2)); + *) + + let add_list tbl k v = + let l = try find tbl k with Not_found -> [] in + replace tbl k (v::l) + + let decr ?(by=1) tbl x = + try + let n = find tbl x in + if n-by <= 0 + then remove tbl x + else replace tbl x (n-by) + with Not_found -> () + let keys tbl k = iter (fun key _ -> k key) tbl let values tbl k = iter (fun _ v -> k v) tbl - let keys_list tbl = Hashtbl.fold (fun k _ a -> k::a) tbl [] - let values_list tbl = Hashtbl.fold (fun _ v a -> v::a) tbl [] + let keys_list tbl = fold (fun k _ a -> k::a) tbl [] + let values_list tbl = fold (fun _ v a -> v::a) tbl [] let map_list f h = fold @@ -183,9 +279,18 @@ module Make(X : Hashtbl.HashedType) let to_seq tbl k = iter (fun key v -> k (key,v)) tbl + let add_seq tbl seq = seq (fun (k,v) -> add tbl k v) + let of_seq seq = let tbl = create 32 in - seq (fun (k,v) -> add tbl k v); + add_seq tbl seq; + tbl + + let add_seq_count tbl seq = seq (fun k -> incr tbl k) + + let of_seq_count seq = + let tbl = create 32 in + add_seq_count tbl seq; tbl let to_list tbl = diff --git a/src/core/CCHashtbl.mli b/src/core/CCHashtbl.mli index 826bc636..1016245f 100644 --- a/src/core/CCHashtbl.mli +++ b/src/core/CCHashtbl.mli @@ -1,28 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Extension to the standard Hashtbl} @@ -38,6 +15,11 @@ type 'a printer = Format.formatter -> 'a -> unit val get : ('a,'b) Hashtbl.t -> 'a -> 'b option (** Safe version of {!Hashtbl.find} *) +val get_or : ('a,'b) Hashtbl.t -> 'a -> or_:'b -> 'b +(** [get_or tbl k ~or_] returns the value associated to [k] if present, + and returns [or_] otherwise (if [k] doesn't belong in [tbl]) + @since 0.16 *) + val keys : ('a,'b) Hashtbl.t -> 'a sequence (** Iterate on keys (similar order as {!Hashtbl.iter}) *) @@ -55,12 +37,44 @@ val values_list : ('a, 'b) Hashtbl.t -> 'b list val map_list : ('a -> 'b -> 'c) -> ('a, 'b) Hashtbl.t -> 'c list (** Map on a hashtable's items, collect into a list *) +val incr : ?by:int -> ('a, int) Hashtbl.t -> 'a -> unit +(** [incr ?by tbl x] increments or initializes the counter associated with [x]. + If [get tbl x = None], then after update, [get tbl x = Some 1]; + otherwise, if [get tbl x = Some n], now [get tbl x = Some (n+1)]. + @param by if specified, the int value is incremented by [by] rather than 1 + @since 0.16 *) + +val decr : ?by:int -> ('a, int) Hashtbl.t -> 'a -> unit +(** Same as {!incr} but substract 1 (or the value of [by]). + If the value reaches 0, the key is removed from the table. + This does nothing if the key is not already present in the table. + @since 0.16 *) + val to_seq : ('a,'b) Hashtbl.t -> ('a * 'b) sequence (** Iterate on bindings in the table *) +val add_list : ('a, 'b list) Hashtbl.t -> 'a -> 'b -> unit +(** [add_list tbl x y] adds [y] to the list [x] is bound to. If [x] is + not bound, it becomes bound to [[y]]. + @since 0.16 *) + +val add_seq : ('a,'b) Hashtbl.t -> ('a * 'b) sequence -> unit +(** Add the corresponding pairs to the table, using {!Hashtbl.add}. + @since 0.16 *) + val of_seq : ('a * 'b) sequence -> ('a,'b) Hashtbl.t (** From the given bindings, added in order *) +val add_seq_count : ('a, int) Hashtbl.t -> 'a sequence -> unit +(** [add_seq_count tbl seq] increments the count of each element of [seq] + by calling {!incr}. This is useful for counting how many times each + element of [seq] occurs. + @since 0.16 *) + +val of_seq_count : 'a sequence -> ('a, int) Hashtbl.t +(** Similar to {!add_seq_count}, but allocates a new table and returns it + @since 0.16 *) + val to_list : ('a,'b) Hashtbl.t -> ('a * 'b) list (** List of bindings (order unspecified) *) @@ -87,17 +101,40 @@ module type S = sig val get : 'a t -> key -> 'a option (** Safe version of {!Hashtbl.find} *) + val get_or : 'a t -> key -> or_:'a -> 'a + (** [get_or tbl k ~or_] returns the value associated to [k] if present, + and returns [or_] otherwise (if [k] doesn't belong in [tbl]) + @since 0.16 *) + + val add_list : 'a list t -> key -> 'a -> unit + (** [add_list tbl x y] adds [y] to the list [x] is bound to. If [x] is + not bound, it becomes bound to [[y]]. + @since 0.16 *) + + val incr : ?by:int -> int t -> key -> unit + (** [incr ?by tbl x] increments or initializes the counter associated with [x]. + If [get tbl x = None], then after update, [get tbl x = Some 1]; + otherwise, if [get tbl x = Some n], now [get tbl x = Some (n+1)]. + @param by if specified, the int value is incremented by [by] rather than 1 + @since 0.16 *) + + val decr : ?by:int -> int t -> key -> unit + (** Same as {!incr} but substract 1 (or the value of [by]). + If the value reaches 0, the key is removed from the table. + This does nothing if the key is not already present in the table. + @since 0.16 *) + val keys : 'a t -> key sequence (** Iterate on keys (similar order as {!Hashtbl.iter}) *) val values : 'a t -> 'a sequence (** Iterate on values in the table *) - val keys_list : ('a, 'b) Hashtbl.t -> 'a list + val keys_list : _ t -> key list (** [keys t] is the list of keys in [t]. @since 0.8 *) - val values_list : ('a, 'b) Hashtbl.t -> 'b list + val values_list : 'a t -> 'a list (** [values t] is the list of values in [t]. @since 0.8 *) @@ -110,6 +147,20 @@ module type S = sig val of_seq : (key * 'a) sequence -> 'a t (** From the given bindings, added in order *) + val add_seq : 'a t -> (key * 'a) sequence -> unit + (** Add the corresponding pairs to the table, using {!Hashtbl.add}. + @since 0.16 *) + + val add_seq_count : int t -> key sequence -> unit + (** [add_seq_count tbl seq] increments the count of each element of [seq] + by calling {!incr}. This is useful for counting how many times each + element of [seq] occurs. + @since 0.16 *) + + val of_seq_count : key sequence -> int t + (** Similar to {!add_seq_count}, but allocates a new table and returns it + @since 0.16 *) + val to_list : 'a t -> (key * 'a) list (** List of bindings (order unspecified) *) @@ -134,7 +185,9 @@ module Make(X : Hashtbl.HashedType) : (** {2 Default Table} -A table with a default element for keys that were never added. *) + A table with a default element for keys that were never added. + + @deprecated since 0.16, should be merged into [Make] itself *) module type DEFAULT = sig type key @@ -168,7 +221,9 @@ end module MakeDefault(X : Hashtbl.HashedType) : DEFAULT with type key = X.t -(** {2 Count occurrences using a Hashtbl} *) +(** {2 Count occurrences using a Hashtbl} + + @deprecated since 0.16, should be merged into [Make] itself *) module type COUNTER = sig type elt diff --git a/src/core/CCHeap.ml b/src/core/CCHeap.ml index 97bccb00..3e66c36a 100644 --- a/src/core/CCHeap.ml +++ b/src/core/CCHeap.ml @@ -1,32 +1,11 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Leftist Heaps} *) type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option +type 'a printer = Format.formatter -> 'a -> unit type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] @@ -78,7 +57,7 @@ end (*$QR & ~count:30 Q.(list_of_size Gen.(return 1_000) int) (fun l -> (* put elements into a heap *) - let h = H.of_seq H.empty (Sequence.of_list l) in + let h = H.of_seq (Sequence.of_list l) in OUnit.assert_equal 1_000 (H.size h); let l' = extract_list h in is_sorted l' @@ -134,21 +113,40 @@ module type S = sig val size : t -> int (** Number of elements (linear complexity) *) - (** {2 Conversions} *) + (** {2 Conversions} + + The interface of [of_gen], [of_seq], [of_klist] + has changed @since 0.16 (the old signatures + are now [add_seq], [add_gen], [add_klist]) *) val to_list : t -> elt list + + val add_list : t -> elt list -> t (** @since 0.16 *) + val of_list : elt list -> t - val of_seq : t -> elt sequence -> t + val add_seq : t -> elt sequence -> t (** @since 0.16 *) + + val of_seq : elt sequence -> t + val to_seq : t -> elt sequence - val of_klist : t -> elt klist -> t + val add_klist : t -> elt klist -> t (** @since 0.16 *) + + val of_klist : elt klist -> t + val to_klist : t -> elt klist - val of_gen : t -> elt gen -> t + val add_gen : t -> elt gen -> t (** @since 0.16 *) + + val of_gen : elt gen -> t + val to_gen : t -> elt gen val to_tree : t -> elt ktree + + val print : ?sep:string -> elt printer -> t printer + (** @since 0.16 *) end module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct @@ -240,20 +238,26 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct x::aux (aux acc l) r in aux [] h - let of_list l = List.fold_left add empty l + let add_list h l = List.fold_left add h l - let of_seq h seq = + let of_list l = add_list empty l + + let add_seq h seq = let h = ref h in seq (fun x -> h := insert x !h); !h + let of_seq seq = add_seq empty seq + let to_seq h k = iter k h - let rec of_klist h l = match l() with + let rec add_klist h l = match l() with | `Nil -> h | `Cons (x, l') -> let h' = add h x in - of_klist h' l' + add_klist h' l' + + let of_klist l = add_klist empty l let to_klist h = let rec next stack () = match stack with @@ -264,10 +268,12 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct in next [h] - let rec of_gen h g = match g () with + let rec add_gen h g = match g () with | None -> h | Some x -> - of_gen (add h x) g + add_gen (add h x) g + + let of_gen g = add_gen empty g let to_gen h = let stack = Stack.create () in @@ -285,7 +291,8 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct (*$Q Q.(list int) (fun l -> \ - extract_list (H.of_list l) = extract_list (H.of_gen H.empty (CCList.to_gen l))) + extract_list (H.of_list l) = \ + extract_list (H.of_gen (CCList.to_gen l))) Q.(list int) (fun l -> \ let h = H.of_list l in \ (H.to_gen h |> CCList.of_gen |> List.sort Pervasives.compare) \ @@ -295,4 +302,12 @@ module Make(E : PARTIAL_ORD) : S with type elt = E.t = struct let rec to_tree h () = match h with | E -> `Nil | N (_, x, l, r) -> `Node(x, [to_tree l; to_tree r]) + + let print ?(sep=",") pp_elt out h = + let first=ref true in + iter + (fun x -> + if !first then first := false else Format.fprintf out "%s@," sep; + pp_elt out x) + h end diff --git a/src/core/CCHeap.mli b/src/core/CCHeap.mli index 169b12fd..551f99b5 100644 --- a/src/core/CCHeap.mli +++ b/src/core/CCHeap.mli @@ -1,27 +1,5 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Leftist Heaps} following Okasaki *) @@ -29,6 +7,7 @@ type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option type 'a klist = unit -> [`Nil | `Cons of 'a * 'a klist] type 'a ktree = unit -> [`Nil | `Node of 'a * 'a ktree list] +type 'a printer = Format.formatter -> 'a -> unit module type PARTIAL_ORD = sig type t @@ -85,21 +64,40 @@ module type S = sig val size : t -> int (** Number of elements (linear complexity) *) - (** {2 Conversions} *) + (** {2 Conversions} + + The interface of [of_gen], [of_seq], [of_klist] + has changed @since 0.16 (the old signatures + are now [add_seq], [add_gen], [add_klist]) *) val to_list : t -> elt list + + val add_list : t -> elt list -> t (** @since 0.16 *) + val of_list : elt list -> t - val of_seq : t -> elt sequence -> t + val add_seq : t -> elt sequence -> t (** @since 0.16 *) + + val of_seq : elt sequence -> t + val to_seq : t -> elt sequence - val of_klist : t -> elt klist -> t + val add_klist : t -> elt klist -> t (** @since 0.16 *) + + val of_klist : elt klist -> t + val to_klist : t -> elt klist - val of_gen : t -> elt gen -> t + val add_gen : t -> elt gen -> t (** @since 0.16 *) + + val of_gen : elt gen -> t + val to_gen : t -> elt gen val to_tree : t -> elt ktree + + val print : ?sep:string -> elt printer -> t printer + (** @since 0.16 *) end module Make(E : PARTIAL_ORD) : S with type elt = E.t diff --git a/src/core/CCIO.ml b/src/core/CCIO.ml index d0a7daf4..5de7ed60 100644 --- a/src/core/CCIO.ml +++ b/src/core/CCIO.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 IO Utils} *) @@ -282,6 +260,22 @@ module File = struct with exn -> `Error (Printexc.to_string exn) + let read_exn f = with_in f (read_all_ ~op:Ret_string ~size:4096) + + let read f = try `Ok (read_exn f) with e -> `Error (Printexc.to_string e) + + let append_exn f x = + with_out ~flags:[Open_append; Open_creat; Open_text] f + (fun oc -> output_string oc x; flush oc) + + let append f x = try `Ok (append_exn f x) with e -> `Error (Printexc.to_string e) + + let write_exn f x = + with_out f + (fun oc -> output_string oc x; flush oc) + + let write f x = try `Ok (write_exn f x) with e -> `Error (Printexc.to_string e) + let remove_noerr f = try Sys.remove f with _ -> () let read_dir_base d = diff --git a/src/core/CCIO.mli b/src/core/CCIO.mli index 442b832b..92e6a119 100644 --- a/src/core/CCIO.mli +++ b/src/core/CCIO.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 IO Utils} @@ -184,6 +162,30 @@ module File : sig @param recurse if true (default [false]), sub-directories are also explored *) + val read_exn : t -> string + (** Read the content of the given file, or raises some exception + @since 0.16 *) + + val read : t -> string or_error + (** Read the content of the given file + @since 0.16 *) + + val append_exn : t -> string -> unit + (** Append the given string into the given file, possibly raising + @since 0.16 *) + + val append : t -> string -> unit or_error + (** Append the given string into the given file + @since 0.16 *) + + val write_exn : t -> string -> unit + (** Write the given string into the given file, possibly raising + @since 0.16 *) + + val write : t -> string -> unit or_error + (** Write the given string into the given file + @since 0.16 *) + type walk_item = [`File | `Dir] * t val walk : t -> walk_item gen diff --git a/src/core/CCInt.ml b/src/core/CCInt.ml index bc535eca..506ab79f 100644 --- a/src/core/CCInt.ml +++ b/src/core/CCInt.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) type t = int diff --git a/src/core/CCInt.mli b/src/core/CCInt.mli index f81669f9..a07240c6 100644 --- a/src/core/CCInt.mli +++ b/src/core/CCInt.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Basic Int functions} *) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index 4d697262..76612fee 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -1,30 +1,12 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 complements to list} *) +(*$inject + let lsort l = List.sort Pervasives.compare l +*) + type 'a t = 'a list let empty = [] @@ -170,6 +152,28 @@ let fold_map f acc l = fold_map (fun acc x -> x::acc, x) [] l = (List.rev l, l)) *) +let fold_map2 f acc l1 l2 = + let rec aux f acc map_acc l1 l2 = match l1, l2 with + | [], [] -> acc, List.rev map_acc + | [], _ + | _, [] -> invalid_arg "fold_map2" + | x1 :: l1', x2 :: l2' -> + let acc, y = f acc x1 x2 in + aux f acc (y :: map_acc) l1' l2' + in + aux f acc [] l1 l2 + +(*$= + (310, ["1 10"; "2 0"; "3 100"]) \ + (fold_map2 (fun acc x y->acc+x*y, string_of_int x ^ " " ^ string_of_int y) \ + 0 [1;2;3] [10;0;100]) +*) + +(*$T + (try ignore (fold_map2 (fun _ _ _ -> assert false) 42 [] [1]); false \ + with Invalid_argument _ -> true) +*) + let fold_flat_map f acc l = let rec aux f acc map_acc l = match l with | [] -> acc, List.rev map_acc @@ -450,6 +454,15 @@ let rec drop n l = match l with | _ when n=0 -> l | _::l' -> drop (n-1) l' +let hd_tl = function + | [] -> failwith "hd_tl" + | x :: l -> x, l + +(*$T + try ignore (hd_tl []); false with Failure _ -> true + hd_tl [1;2;3] = (1, [2;3]) +*) + let take_drop n l = take n l, drop n l let split = take_drop @@ -771,15 +784,15 @@ let repeat i l = module Assoc = struct type ('a, 'b) t = ('a*'b) list - let get_exn ?(eq=(=)) l x = - let rec search eq l x = match l with - | [] -> raise Not_found - | (y,z)::l' -> - if eq x y then z else search eq l' x - in search eq l x + let rec search_exn eq l x = match l with + | [] -> raise Not_found + | (y,z)::l' -> + if eq x y then z else search_exn eq l' x - let get ?eq l x = - try Some (get_exn ?eq l x) + let get_exn ?(eq=(=)) l x = search_exn eq l x + + let get ?(eq=(=)) l x = + try Some (search_exn eq l x) with Not_found -> None (*$T @@ -789,14 +802,19 @@ module Assoc = struct Assoc.get [] 42 = None *) + (* search for a binding for [x] in [l], and calls [f x (Some v) rest] + or [f x None rest] depending on whether it finds the binding. + [rest] is the list of the other bindings *) + let rec search_set eq acc l x ~f = match l with + | [] -> f x None acc + | (x',y')::l' -> + if eq x x' + then f x (Some y') (List.rev_append acc l') + else search_set eq ((x',y')::acc) l' x ~f + let set ?(eq=(=)) l x y = - let rec search eq acc l x y = match l with - | [] -> (x,y)::acc - | (x',y')::l' -> - if eq x x' - then (x,y)::List.rev_append acc l' - else search eq ((x',y')::acc) l' x y - in search eq [] l x y + search_set eq [] l x + ~f:(fun x _ l -> (x,y)::l) (*$T Assoc.set [1,"1"; 2, "2"] 2 "two" |> List.sort Pervasives.compare \ @@ -804,6 +822,33 @@ module Assoc = struct Assoc.set [1,"1"; 2, "2"] 3 "3" |> List.sort Pervasives.compare \ = [1, "1"; 2, "2"; 3, "3"] *) + + let mem ?(eq=(=)) l x = + try ignore (search_exn eq l x); true + with Not_found -> false + + (*$T + Assoc.mem [1,"1"; 2,"2"; 3, "3"] 1 + not (Assoc.mem [1,"1"; 2,"2"; 3, "3"] 4) + *) + + let update ?(eq=(=)) l x ~f = + search_set eq [] l x + ~f:(fun x opt_y rest -> + match f opt_y with + | None -> rest (* drop *) + | Some y' -> (x,y') :: rest) + (*$= + [1,"1"; 2,"22"] \ + (Assoc.update [1,"1"; 2,"2"] 2 \ + ~f:(function Some "2" -> Some "22" | _ -> assert false) |> lsort) + [1,"1"; 3,"3"] \ + (Assoc.update [1,"1"; 2,"2"; 3,"3"] 2 \ + ~f:(function Some "2" -> None | _ -> assert false) |> lsort) + [1,"1"; 2,"2"; 3,"3"] \ + (Assoc.update [1,"1"; 2,"2"] 3 \ + ~f:(function None -> Some "3" | _ -> assert false) |> lsort) + *) end (** {2 Zipper} *) @@ -1036,6 +1081,15 @@ let of_klist l = in direct direct_depth_default_ l +module Infix = struct + let (>|=) = (>|=) + let (@) = (@) + let (<*>) = (<*>) + let (<$>) = (<$>) + let (>>=) = (>>=) + let (--) = (--) +end + (** {2 IO} *) let pp ?(start="[") ?(stop="]") ?(sep=", ") pp_item buf l = diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 2f49619f..ee60436a 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -this software is provided by the copyright holders and contributors "as is" and -any express or implied warranties, including, but not limited to, the implied -warranties of merchantability and fitness for a particular purpose are -disclaimed. in no event shall the copyright holder or contributors be liable -for any direct, indirect, incidental, special, exemplary, or consequential -damages (including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) however -caused and on any theory of liability, whether in contract, strict liability, -or tort (including negligence or otherwise) arising in any way out of the use -of this software, even if advised of the possibility of such damage. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 complements to list} *) @@ -70,6 +48,11 @@ val fold_map : ('acc -> 'a -> 'acc * 'b) -> 'acc -> 'a list -> 'acc * 'b list list to another list. @since 0.14 *) +val fold_map2 : ('acc -> 'a -> 'b -> 'acc * 'c) -> 'acc -> 'a list -> 'b list -> 'acc * 'c list +(** [fold_map2] is to [fold_map] what [List.map2] is to [List.map]. + @raise Invalid_argument if the lists do not have the same length + @since 0.16 *) + val fold_flat_map : ('acc -> 'a -> 'acc * 'b list) -> 'acc -> 'a list -> 'acc * 'b list (** [fold_flat_map f acc l] is a [fold_left]-like function, but it also maps the list to a list of lists that is then [flatten]'d.. @@ -123,6 +106,11 @@ val take : int -> 'a t -> 'a t val drop : int -> 'a t -> 'a t (** Drop the [n] first elements, keep the rest *) +val hd_tl : 'a t -> 'a * 'a t +(** [hd_tl (x :: l)] returns [hd, l]. + @raise Failure if the list is empty + @since 0.16 *) + val take_drop : int -> 'a t -> 'a t * 'a t (** [take_drop n l] returns [l1, l2] such that [l1 @ l2 = l] and [length l1 = min (length l) n] *) @@ -295,6 +283,17 @@ module Assoc : sig val set : ?eq:('a->'a->bool) -> ('a,'b) t -> 'a -> 'b -> ('a,'b) t (** Add the binding into the list (erase it if already present) *) + + val mem : ?eq:('a->'a->bool) -> ('a,_) t -> 'a -> bool + (** [mem l x] returns [true] iff [x] is a key in [l] + @since 0.16 *) + + val update : + ?eq:('a->'a->bool) -> ('a,'b) t -> 'a -> f:('b option -> 'b option) -> ('a,'b) t + (** [update l k ~f] updates [l] on the key [k], by calling [f (get l k)] + and removing [k] if it returns [None], mapping [k] to [v'] if it + returns [Some v'] + @since 0.16 *) end (** {2 Zipper} *) @@ -466,6 +465,21 @@ val of_gen : 'a gen -> 'a t val to_klist : 'a t -> 'a klist val of_klist : 'a klist -> 'a t +(** {2 Infix Operators} + It is convenient to {!open CCList.Infix} to access the infix operators + without cluttering the scope too much. + + @since 0.16 *) + +module Infix : sig + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + val (@) : 'a t -> 'a t -> 'a t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + val (<$>) : ('a -> 'b) -> 'a t -> 'b t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (--) : int -> int -> int t +end + (** {2 IO} *) val pp : ?start:string -> ?stop:string -> ?sep:string -> diff --git a/src/core/CCMap.ml b/src/core/CCMap.ml index 2dc4a5df..d8a69a32 100644 --- a/src/core/CCMap.ml +++ b/src/core/CCMap.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Extensions of Standard Map} *) @@ -35,6 +13,11 @@ module type S = sig val get : key -> 'a t -> 'a option (** Safe version of {!find} *) + val get_or : key -> 'a t -> or_:'a -> 'a + (** [get_or k m ~or_] returns the value associated to [k] if present, + and returns [or_] otherwise (if [k] doesn't belong in [m]) + @since 0.16 *) + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t (** [update k f m] calls [f (Some v)] if [find k m = v], otherwise it calls [f None]. In any case, if the result is [None] @@ -63,11 +46,13 @@ module type S = sig val to_list : 'a t -> (key * 'a) list - val pp : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> - key printer -> 'a printer -> 'a t printer + val pp : + ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> + key printer -> 'a printer -> 'a t printer - val print : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> - key formatter -> 'a formatter -> 'a t formatter + val print : + ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> + key formatter -> 'a formatter -> 'a t formatter end module Make(O : Map.OrderedType) = struct @@ -77,14 +62,18 @@ module Make(O : Map.OrderedType) = struct try Some (find k m) with Not_found -> None + let get_or k m ~or_ = + try find k m + with Not_found -> or_ + let update k f m = let x = try f (Some (find k m)) with Not_found -> f None in match x with - | None -> remove k m - | Some v' -> add k v' m + | None -> remove k m + | Some v' -> add k v' m let add_seq m s = let m = ref m in @@ -114,11 +103,11 @@ module Make(O : Map.OrderedType) = struct Buffer.add_string buf start; iter (fun k v -> - if !first then first := false else Buffer.add_string buf sep; - pp_k buf k; - Buffer.add_string buf arrow; - pp_v buf v - ) m; + if !first then first := false else Buffer.add_string buf sep; + pp_k buf k; + Buffer.add_string buf arrow; + pp_v buf v) + m; Buffer.add_string buf stop let print ?(start="[") ?(stop="]") ?(arrow="->") ?(sep=", ") pp_k pp_v fmt m = @@ -126,13 +115,14 @@ module Make(O : Map.OrderedType) = struct let first = ref true in iter (fun k v -> - if !first then first := false else ( - Format.pp_print_string fmt sep; - Format.pp_print_cut fmt () - ); - pp_k fmt k; - Format.pp_print_string fmt arrow; - pp_v fmt v; - ) m; + if !first then first := false + else ( + Format.pp_print_string fmt sep; + Format.pp_print_cut fmt () + ); + pp_k fmt k; + Format.pp_print_string fmt arrow; + pp_v fmt v) + m; Format.pp_print_string fmt stop end diff --git a/src/core/CCMap.mli b/src/core/CCMap.mli index 524e56d2..f03b59ff 100644 --- a/src/core/CCMap.mli +++ b/src/core/CCMap.mli @@ -1,32 +1,10 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Extensions of Standard Map} -Provide useful functions and iterators on [Map.S] -@since 0.5 *) + Provide useful functions and iterators on [Map.S] + @since 0.5 *) type 'a sequence = ('a -> unit) -> unit type 'a printer = Buffer.t -> 'a -> unit @@ -38,6 +16,11 @@ module type S = sig val get : key -> 'a t -> 'a option (** Safe version of {!find} *) + val get_or : key -> 'a t -> or_:'a -> 'a + (** [get_or k m ~or_] returns the value associated to [k] if present, + and returns [or_] otherwise (if [k] doesn't belong in [m]) + @since 0.16 *) + val update : key -> ('a option -> 'a option) -> 'a t -> 'a t (** [update k f m] calls [f (Some v)] if [find k m = v], otherwise it calls [f None]. In any case, if the result is [None] @@ -66,13 +49,15 @@ module type S = sig val to_list : 'a t -> (key * 'a) list - val pp : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> - key printer -> 'a printer -> 'a t printer + val pp : + ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> + key printer -> 'a printer -> 'a t printer - val print : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> - key formatter -> 'a formatter -> 'a t formatter + val print : + ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> + key formatter -> 'a formatter -> 'a t formatter end module Make(O : Map.OrderedType) : S with type 'a t = 'a Map.Make(O).t - and type key = O.t + and type key = O.t diff --git a/src/core/CCOpt.ml b/src/core/CCOpt.ml index 40d87580..4753315d 100644 --- a/src/core/CCOpt.ml +++ b/src/core/CCOpt.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Options} *) @@ -31,10 +9,12 @@ let map f = function | None -> None | Some x -> Some (f x) -let maybe f d = function - | None -> d +let map_or ~default f = function + | None -> default | Some x -> f x +let maybe f default = map_or ~default f + let is_some = function | None -> false | Some _ -> true @@ -143,6 +123,14 @@ let of_list = function | x::_ -> Some x | [] -> None +module Infix = struct + let (>|=) = (>|=) + let (>>=) = (>>=) + let (<*>) = (<*>) + let (<$>) = (<$>) + let (<+>) = (<+>) +end + type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option type 'a printer = Buffer.t -> 'a -> unit diff --git a/src/core/CCOpt.mli b/src/core/CCOpt.mli index 699ea632..2bdbee8e 100644 --- a/src/core/CCOpt.mli +++ b/src/core/CCOpt.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Options} *) @@ -31,7 +9,13 @@ val map : ('a -> 'b) -> 'a t -> 'b t (** Transform the element inside, if any *) val maybe : ('a -> 'b) -> 'b -> 'a t -> 'b -(** [maybe f x o] is [x] if [o] is [None], otherwise it's [f y] if [o = Some y] *) +(** [maybe f x o] is [x] if [o] is [None], + otherwise it's [f y] if [o = Some y] + @deprecated, use {!map_or} *) + +val map_or : default:'b -> ('a -> 'b) -> 'a t -> 'b +(** [map_or ~default f o] is [f x] if [o = Some x], [default otherwise] + @since 0.16 *) val is_some : _ t -> bool @@ -109,6 +93,16 @@ val (<+>) : 'a t -> 'a t -> 'a t val choice : 'a t list -> 'a t (** [choice] returns the first non-[None] element of the list, or [None] *) +(** {2 Infix Operators} + @since 0.16 *) + +module Infix : sig + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + val (<$>) : ('a -> 'b) -> 'a t -> 'b t + val (<+>) : 'a t -> 'a t -> 'a t +end (** {2 Conversion and IO} *) diff --git a/src/core/CCOrd.ml b/src/core/CCOrd.ml index f1c974b3..c8bf3f28 100644 --- a/src/core/CCOrd.ml +++ b/src/core/CCOrd.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Comparisons} *) @@ -52,6 +30,13 @@ let string_ (x:string) y = Pervasives.compare x y let bool_ (x:bool) y = Pervasives.compare x y let float_ (x:float) y = Pervasives.compare x y +(*$T + bool_ true false > 0 + bool_ false true < 0 + bool_ true true = 0 + bool_ false false = 0 +*) + (** {2 Lexicographic Combination} *) let () c (ord,x,y) = diff --git a/src/core/CCOrd.mli b/src/core/CCOrd.mli index 9c9ed76a..9311e87f 100644 --- a/src/core/CCOrd.mli +++ b/src/core/CCOrd.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Comparisons} *) diff --git a/src/core/CCPair.ml b/src/core/CCPair.ml index f377a3f1..b222be6e 100644 --- a/src/core/CCPair.ml +++ b/src/core/CCPair.ml @@ -1,32 +1,12 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Tuple Functions} *) type ('a,'b) t = ('a * 'b) +let make x y = x,y + let map1 f (x,y) = f x,y let map2 f (x,y) = x,f y diff --git a/src/core/CCPair.mli b/src/core/CCPair.mli index 905ecce0..a86c017c 100644 --- a/src/core/CCPair.mli +++ b/src/core/CCPair.mli @@ -1,32 +1,14 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Tuple Functions} *) type ('a,'b) t = ('a * 'b) +val make : 'a -> 'b -> ('a, 'b) t +(** Make a tuple from its components + @since 0.16 *) + val map1 : ('a -> 'b) -> ('a * 'c) -> ('b * 'c) val map2 : ('a -> 'b) -> ('c * 'a) -> ('c * 'b) diff --git a/src/core/CCPrint.ml b/src/core/CCPrint.ml index 22c24e1a..c0f1a4c7 100644 --- a/src/core/CCPrint.ml +++ b/src/core/CCPrint.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Printer Combinators} diff --git a/src/core/CCPrint.mli b/src/core/CCPrint.mli index 3b88617d..bd6f5d85 100644 --- a/src/core/CCPrint.mli +++ b/src/core/CCPrint.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Printer Combinators} diff --git a/src/core/CCRandom.ml b/src/core/CCRandom.ml index 3d762620..9e0ad1fe 100644 --- a/src/core/CCRandom.ml +++ b/src/core/CCRandom.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Random Generators} *) @@ -59,6 +37,24 @@ let choose_exn l = let choose_return l = _choose_array (Array.of_list l) +exception Pick_from_empty + +let pick_list l = + let n = List.length l in + if n=0 then raise Pick_from_empty; + fun st -> + List.nth l (Random.State.int st n) + +(*$Q + Q.(list small_int) (fun l -> \ + l=[] || List.mem (run (pick_list l)) l) +*) + +let pick_array a = + let n = Array.length a in + if n=0 then raise Pick_from_empty; + fun st -> Array.get a (Random.State.int st n) + let int i st = Random.State.int st i let small_int = int 100 diff --git a/src/core/CCRandom.mli b/src/core/CCRandom.mli index c0b8c604..ee6b4237 100644 --- a/src/core/CCRandom.mli +++ b/src/core/CCRandom.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Random Generators} *) @@ -56,8 +34,7 @@ val delay : (unit -> 'a t) -> 'a t small_int >>= fun i -> return (name,i) ) ]} - @since 0.4 -*) + @since 0.4 *) val choose : 'a t list -> 'a option t (** Choose a generator within the list. *) @@ -81,13 +58,25 @@ val sample_without_replacement: (** [sample_without_replacement n g] makes a list of [n] elements which are all generated randomly using [g] with the added constraint that none of the generated random values are equal - @since 0.15 - *) + @since 0.15 *) val list_seq : 'a t list -> 'a list t (** Build random lists from lists of random generators @since 0.4 *) +exception Pick_from_empty +(** @since 0.16 *) + +val pick_list : 'a list -> 'a t +(** Pick an element at random from the list + @raise Pick_from_empty if the list is empty + @since 0.16 *) + +val pick_array : 'a array -> 'a t +(** Pick an element at random from the array + @raise Pick_from_empty if the array is empty + @since 0.16 *) + val small_int : int t val int : int -> int t diff --git a/src/core/CCRef.ml b/src/core/CCRef.ml index 80861110..047b0e92 100644 --- a/src/core/CCRef.ml +++ b/src/core/CCRef.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 References} diff --git a/src/core/CCRef.mli b/src/core/CCRef.mli index 6c6e8cfe..fed1091e 100644 --- a/src/core/CCRef.mli +++ b/src/core/CCRef.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 References} @since 0.9 *) diff --git a/src/core/CCResult.ml b/src/core/CCResult.ml new file mode 100644 index 00000000..57e48752 --- /dev/null +++ b/src/core/CCResult.ml @@ -0,0 +1,256 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Error Monad} *) + +type 'a sequence = ('a -> unit) -> unit +type 'a equal = 'a -> 'a -> bool +type 'a ord = 'a -> 'a -> int +type 'a printer = Buffer.t -> 'a -> unit +type 'a formatter = Format.formatter -> 'a -> unit + +(** {2 Basics} *) + +type (+'good, +'bad) t = ('good, 'bad) Result.result = + | Ok of 'good + | Error of 'bad + +let return x = Ok x + +let fail s = Error s + +let fail_printf format = + let buf = Buffer.create 64 in + Printf.kbprintf + (fun buf -> fail (Buffer.contents buf)) + buf format + +let fail_fprintf format = + let buf = Buffer.create 64 in + let out = Format.formatter_of_buffer buf in + Format.kfprintf + (fun out -> Format.pp_print_flush out (); fail (Buffer.contents buf)) + out format + +let of_exn e = + let msg = Printexc.to_string e in + Error msg + +let of_exn_trace e = + let res = Printf.sprintf "%s\n%s" + (Printexc.to_string e) (Printexc.get_backtrace ()) + in + Error res + +let map f e = match e with + | Ok x -> Ok (f x) + | Error s -> Error s + +let map_err f e = match e with + | Ok _ as res -> res + | Error y -> Error (f y) + +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 _ -> () + +exception Get_error + +let get_exn = function + | Ok x -> x + | Error _ -> raise Get_error + +let get_or e ~default = match e with + | Ok x -> x + | Error _ -> default + +let map_or f e ~default = match e with + | Ok x -> f x + | Error _ -> default + +let catch e ~ok ~err = match e with + | Ok x -> ok x + | Error y -> err y + +let flat_map f e = match e with + | Ok x -> f x + | Error s -> Error s + +let (>|=) e f = map f e + +let (>>=) e f = flat_map f e + +let equal ?(err=Pervasives.(=)) eq a b = match a, b with + | Ok x, Ok y -> eq x y + | Error s, Error s' -> err s s' + | _ -> false + +let compare ?(err=Pervasives.compare) cmp a b = match a, b with + | Ok x, Ok y -> cmp x y + | Ok _, _ -> 1 + | _, Ok _ -> -1 + | Error s, Error s' -> err s s' + +let fold ~ok ~error x = match x with + | Ok x -> ok x + | Error s -> error s + +(** {2 Wrappers} *) + +let guard f = + try Ok (f ()) + with e -> Error e + +let guard_str f = + try Ok (f()) + with e -> of_exn e + +let guard_str_trace f = + try Ok (f()) + with e -> of_exn_trace e + +let wrap1 f x = + try return (f x) + with e -> Error e + +let wrap2 f x y = + try return (f x y) + with e -> Error e + +let wrap3 f x y z = + try return (f x y z) + with e -> Error e + +(** {2 Applicative} *) + +let pure = return + +let (<*>) f x = match f with + | Error s -> fail s + | Ok f -> map f x + +let join t = match t with + | Ok (Ok o) -> Ok o + | Ok (Error e) -> Error e + | (Error _) as e -> e + +let both x y = match x,y with + | Ok o, Ok o' -> Ok (o, o') + | Ok _, Error e -> Error e + | Error e, _ -> Error e + +(** {2 Collections} *) + +let map_l f l = + let rec map acc l = match l with + | [] -> Ok (List.rev acc) + | x::l' -> + match f x with + | Error s -> Error s + | Ok y -> map (y::acc) l' + in map [] l + +exception LocalExit + +let fold_seq f acc seq = + let err = ref None in + try + let acc = ref acc in + seq + (fun x -> match f !acc x with + | Error s -> err := Some s; raise LocalExit + | Ok y -> acc := y); + Ok !acc + with LocalExit -> + match !err with None -> assert false | Some s -> Error s + +let fold_l f acc l = fold_seq f acc (fun k -> List.iter k l) + +(** {2 Misc} *) + +let choose l = + let rec find_ = function + | [] -> raise Not_found + | ((Ok _) as res) :: _ -> res + | (Error _) :: l' -> find_ l' + in + try find_ l + with Not_found -> + let l' = List.map (function Error s -> s | Ok _ -> assert false) l in + Error l' + +let retry n f = + let rec retry n acc = match n with + | 0 -> fail (List.rev acc) + | _ -> + match f () with + | Ok _ as res -> res + | Error e -> retry (n-1) (e::acc) + in retry n [] + +(** {2 Infix} *) + +module Infix = struct + let (>>=) = (>>=) + let (>|=) = (>|=) + let (<*>) = (<*>) +end + +(** {2 Monadic Operations} *) + +module type MONAD = sig + type 'a t + val return : 'a -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +end + +module Traverse(M : MONAD) = struct + let (>>=) = M.(>>=) + + let map_m f e = match e with + | Error s -> M.return (Error s) + | Ok x -> f x >>= fun y -> M.return (Ok y) + + let sequence_m m = map_m (fun x->x) m + + let fold_m f acc e = match e with + | Error _ -> M.return acc + | Ok x -> f acc x >>= fun y -> M.return y + + let retry_m n f = + let rec retry n acc = match n with + | 0 -> M.return (fail (List.rev acc)) + | _ -> + f () >>= function + | Ok x -> M.return (Ok x) + | Error e -> retry (n-1) (e::acc) + in retry n [] +end + +(** {2 Conversions} *) + +let to_opt = function + | Ok x -> Some x + | Error _ -> None + +let of_opt = function + | None -> Error "of_opt" + | Some x -> Ok x + +let to_seq e k = match e with + | Ok x -> k x + | Error _ -> () + +(** {2 IO} *) + +let pp pp_x buf e = match e with + | Ok x -> Printf.bprintf buf "ok(%a)" pp_x x + | Error s -> Printf.bprintf buf "error(%s)" s + +let print pp_x fmt e = match e with + | Ok x -> Format.fprintf fmt "@[ok(@,%a)@]" pp_x x + | Error s -> Format.fprintf fmt "@[error(@,%s)@]" s diff --git a/src/core/CCResult.mli b/src/core/CCResult.mli new file mode 100644 index 00000000..1a72e3a3 --- /dev/null +++ b/src/core/CCResult.mli @@ -0,0 +1,188 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Error Monad} + + Uses the new "result" type from OCaml 4.03. + + @since 0.16 *) + +type 'a sequence = ('a -> unit) -> unit +type 'a equal = 'a -> 'a -> bool +type 'a ord = 'a -> 'a -> int +type 'a printer = Buffer.t -> 'a -> unit +type 'a formatter = Format.formatter -> 'a -> unit + +(** {2 Basics} *) + +type (+'good, +'bad) t = ('good, 'bad) Result.result = + | Ok of 'good + | Error of 'bad + +val return : 'a -> ('a, 'err) t +(** Successfully return a value *) + +val fail : 'err -> ('a, 'err) t +(** Fail with an error *) + +val of_exn : exn -> ('a, string) t +(** [of_exn e] uses {!Printexc} to print the exception as a string *) + +val of_exn_trace : exn -> ('a, string) t +(** [of_exn_trace e] is similar to [of_exn e], but it adds the stacktrace + to the error message. + + Remember to call [Printexc.record_backtrace true] and compile with the + debug flag for this to work. *) + +val fail_printf : ('a, Buffer.t, unit, ('a, string) t) format4 -> 'a +(** [fail_printf format] uses [format] to obtain an error message + and then returns [Error msg] *) + +val fail_fprintf : ('a, Format.formatter, unit, ('a, string) t) format4 -> 'a +(** [fail_printf format] uses [format] to obtain an error message + and then returns [Error msg] *) + +val map : ('a -> 'b) -> ('a, 'err) t -> ('b, 'err) t +(** Map on success *) + +val map_err : ('err1 -> 'err2) -> ('a, 'err1) t -> ('a, 'err2) t +(** Map on the error variant *) + +val map2 : ('a -> 'b) -> ('err1 -> 'err2) -> ('a, 'err1) t -> ('b, 'err2) 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 *) + +exception Get_error + +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 Get_error if the value is an error. *) + +val get_or : ('a, _) t -> default:'a -> 'a +(** [get_or e ~default] returns [x] if [e = Ok x], [default] otherwise *) + +val map_or : ('a -> 'b) -> ('a, 'b) t -> default:'b -> 'b +(** [map_or f e ~default] returns [f x] if [e = Ok x], [default] otherwise *) + +val catch : ('a, 'err) t -> ok:('a -> 'b) -> err:('err -> 'b) -> 'b +(** [catch e ~ok ~err] calls either [ok] or [err] depending on + the value of [e]. *) + +val flat_map : ('a -> ('b, 'err) t) -> ('a, 'err) t -> ('b, 'err) t + +val (>|=) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t + +val (>>=) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t + +val equal : ?err:'err equal -> 'a equal -> ('a, 'err) t equal + +val compare : ?err:'err ord -> 'a ord -> ('a, 'err) t ord + +val fold : ok:('a -> 'b) -> error:('err -> 'b) -> ('a, 'err) t -> 'b +(** [fold ~ok ~error e] opens [e] and, if [e = Ok x], returns + [ok x], otherwise [e = Error s] and it returns [error s]. *) + +(** {2 Wrappers} *) + +val guard : (unit -> 'a) -> ('a, exn) t +(** [guard f] runs [f ()] and returns its result wrapped in [Ok]. If + [f ()] raises some exception [e], then it fails with [Error e] *) + +val guard_str : (unit -> 'a) -> ('a, string) t +(** Same as {!guard} but uses {!of_exn} to print the exception. *) + +val guard_str_trace : (unit -> 'a) -> ('a, string) t +(** Same as {!guard_str} but uses {!of_exn_trace} instead of {!of_exn} so + that the stack trace is printed. *) + +val wrap1 : ('a -> 'b) -> 'a -> ('b, exn) t +(** Same as {!guard} but gives the function one argument. *) + +val wrap2 : ('a -> 'b -> 'c) -> 'a -> 'b -> ('c, exn) t +(** Same as {!guard} but gives the function two arguments. *) + +val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> ('d, exn) t +(** Same as {!guard} but gives the function three arguments. *) + +(** {2 Applicative} *) + +val pure : 'a -> ('a, 'err) t +(** Synonym of {!return} *) + +val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t +(** [a <*> b] evaluates [a] and [b], and, in case of success, returns + [Ok (a b)]. Otherwise, it fails, and the error of [a] is chosen + over the error of [b] if both fail. *) + +val join : (('a, 'err) t, 'err) t -> ('a, 'err) t +(** [join t], in case of success, returns [Ok o] from [Ok (Ok o)]. Otherwise, + it fails with [Error e] where [e] is the unwrapped error of [t]. *) + +val both : ('a, 'err) t -> ('b, 'err) t -> (('a * 'b), 'err) t +(** [both a b], in case of success, returns [Ok (o, o')] with the ok values + of [a] and [b]. Otherwise, it fails, and the error of [a] is chosen over the + error of [b] if both fail. *) + +(** {2 Infix} *) + +module Infix : sig + val (>|=) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t + val (>>=) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t + val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t +end + +(** {2 Collections} *) + +val map_l : ('a -> ('b, 'err) t) -> 'a list -> ('b list, 'err) t + +val fold_l : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a list -> ('b, 'err) t + +val fold_seq : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a sequence -> ('b, 'err) t + +(** {2 Misc} *) + +val choose : ('a, 'err) t list -> ('a, 'err list) t +(** [choose l] selects a member of [l] that is a [Ok _] value, + or returns [Error l] otherwise, where [l] is the list of errors. *) + +val retry : int -> (unit -> ('a, 'err) t) -> ('a, 'err list) t +(** [retry n f] calls [f] at most [n] times, returning the first result + of [f ()] that doesn't fail. If [f] fails [n] times, [retry n f] fails + with the list of successive errors. *) + +(** {2 Monadic Operations} *) +module type MONAD = sig + type 'a t + val return : 'a -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +end + +module Traverse(M : MONAD) : sig + val sequence_m : ('a M.t, 'err) t -> ('a, 'err) t M.t + + val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> ('a, 'err) t -> 'b M.t + + val map_m : ('a -> 'b M.t) -> ('a, 'err) t -> ('b, 'err) t M.t + + val retry_m : int -> (unit -> ('a, 'err) t M.t) -> ('a, 'err list) t M.t +end + +(** {2 Conversions} *) + +val to_opt : ('a, _) t -> 'a option + +val of_opt : 'a option -> ('a, string) t + +val to_seq : ('a, _) t -> 'a sequence + +(** {2 IO} *) + +val pp : 'a printer -> ('a, string) t printer + +val print : 'a formatter -> ('a, string) t formatter diff --git a/src/core/CCSet.ml b/src/core/CCSet.ml index 83d14a10..f11d1981 100644 --- a/src/core/CCSet.ml +++ b/src/core/CCSet.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Wrapper around Set} *) @@ -46,11 +24,13 @@ module type S = sig val to_list : t -> elt list - val pp : ?start:string -> ?stop:string -> ?sep:string -> - elt printer -> t printer + val pp : + ?start:string -> ?stop:string -> ?sep:string -> + elt printer -> t printer - val print : ?start:string -> ?stop:string -> ?sep:string -> - elt formatter -> t formatter + val print : + ?start:string -> ?stop:string -> ?sep:string -> + elt formatter -> t formatter end module Make(O : Map.OrderedType) = struct @@ -76,9 +56,9 @@ module Make(O : Map.OrderedType) = struct Buffer.add_string buf start; iter (fun x -> - if !first then first := false else Buffer.add_string buf sep; - pp_x buf x; - ) m; + if !first then first := false else Buffer.add_string buf sep; + pp_x buf x) + m; Buffer.add_string buf stop let print ?(start="[") ?(stop="]") ?(sep=", ") pp_x fmt m = @@ -86,11 +66,12 @@ module Make(O : Map.OrderedType) = struct let first = ref true in iter (fun x -> - if !first then first := false else ( - Format.pp_print_string fmt sep; - Format.pp_print_cut fmt () - ); - pp_x fmt x; - ) m; + if !first then first := false + else ( + Format.pp_print_string fmt sep; + Format.pp_print_cut fmt () + ); + pp_x fmt x) + m; Format.pp_print_string fmt stop end diff --git a/src/core/CCSet.mli b/src/core/CCSet.mli index 435feb2d..1a8fd4ba 100644 --- a/src/core/CCSet.mli +++ b/src/core/CCSet.mli @@ -1,31 +1,9 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Wrapper around Set} -@since 0.9 *) + @since 0.9 *) type 'a sequence = ('a -> unit) -> unit type 'a printer = Buffer.t -> 'a -> unit @@ -48,13 +26,15 @@ module type S = sig val to_list : t -> elt list - val pp : ?start:string -> ?stop:string -> ?sep:string -> - elt printer -> t printer + val pp : + ?start:string -> ?stop:string -> ?sep:string -> + elt printer -> t printer - val print : ?start:string -> ?stop:string -> ?sep:string -> - elt formatter -> t formatter + val print : + ?start:string -> ?stop:string -> ?sep:string -> + elt formatter -> t formatter end module Make(O : Set.OrderedType) : S with type t = Set.Make(O).t - and type elt = O.t + and type elt = O.t diff --git a/src/core/CCString.cppo.ml b/src/core/CCString.cppo.ml index 738a0c8b..0574eab9 100644 --- a/src/core/CCString.cppo.ml +++ b/src/core/CCString.cppo.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Basic String Utils} *) @@ -221,15 +199,19 @@ module Split = struct let seq ~by s = _mkseq ~by s _tuple3 let seq_cpy ~by s = _mkseq ~by s String.sub - let left ~by s = + let left_exn ~by s = let i = find ~sub:by s in - if i = ~-1 then None - else Some (String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1)) + if i = ~-1 then raise Not_found + else String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1) - let right ~by s = + let left ~by s = try Some (left_exn ~by s) with Not_found -> None + + let right_exn ~by s = let i = rfind ~sub:by s in - if i = ~-1 then None - else Some (String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1)) + if i = ~-1 then raise Not_found + else String.sub s 0 i, String.sub s (i+1) (String.length s - i - 1) + + let right ~by s = try Some (right_exn ~by s) with Not_found -> None end let compare_versions a b = diff --git a/src/core/CCString.mli b/src/core/CCString.mli index ac5ab4ca..c036700e 100644 --- a/src/core/CCString.mli +++ b/src/core/CCString.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Basic String Utils} @@ -321,6 +299,11 @@ module Split : sig the string @since 0.12 *) + val left_exn : by:string -> string -> string * string + (** Split on the first occurrence of [by] from the leftmost part of the string + @raise Not_found if [by] is not part of the string + @since 0.16 *) + (*$T Split.left ~by:" " "ab cde f g " = Some ("ab", "cde f g ") Split.left ~by:"_" "abcde" = None @@ -331,6 +314,11 @@ module Split : sig the string @since 0.12 *) + val right_exn : by:string -> string -> string * string + (** Split on the first occurrence of [by] from the rightmost part of the string + @raise Not_found if [by] is not part of the string + @since 0.16 *) + (*$T Split.right ~by:" " "ab cde f g" = Some ("ab cde f", "g") Split.right ~by:"_" "abcde" = None diff --git a/src/core/CCVector.ml b/src/core/CCVector.ml index 39f53715..6eb571e0 100644 --- a/src/core/CCVector.ml +++ b/src/core/CCVector.ml @@ -1,27 +1,5 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Growable, mutable vector} *) diff --git a/src/core/CCVector.mli b/src/core/CCVector.mli index b2c2a2b5..ea9088d9 100644 --- a/src/core/CCVector.mli +++ b/src/core/CCVector.mli @@ -1,27 +1,5 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Growable, mutable vector} *) diff --git a/src/core/containers.ml b/src/core/containers.ml index 5f5b4b05..d38654de 100644 --- a/src/core/containers.ml +++ b/src/core/containers.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Drop-In replacement to Stdlib} diff --git a/src/data/CCGraph.ml b/src/data/CCGraph.ml index 9db9a9ec..37a9da15 100644 --- a/src/data/CCGraph.ml +++ b/src/data/CCGraph.ml @@ -56,6 +56,16 @@ type ('v, 'e) t = { type ('v, 'e) graph = ('v, 'e) t +let make ~origin ~dest f = {origin; dest; children=f; } + +let make_labelled_tuple f = + make ~origin:(fun (x,_,_) -> x) ~dest:(fun (_,_,x) -> x) + (fun v yield -> f v (fun (l,v') -> yield (v,l,v'))) + +let make_tuple f = + make ~origin:fst ~dest:snd + (fun v yield -> f v (fun v' -> yield (v,v'))) + (** Mutable bitset for values of type ['v] *) type 'v tag_set = { get_tag: 'v -> bool; @@ -519,10 +529,11 @@ module Dot = struct let pp_list pp_x out l = Format.pp_print_string out "["; - List.iteri (fun i x -> + List.iteri + (fun i x -> if i > 0 then Format.fprintf out ",@;"; - pp_x out x - ) l; + pp_x out x) + l; Format.pp_print_string out "]" type vertex_state = { @@ -533,6 +544,7 @@ module Dot = struct (** Print an enum of Full.traverse_event *) let pp_seq ?(tbl=mk_table 128) + ?(eq=(=)) ?(attrs_v=fun _ -> []) ?(attrs_e=fun _ -> []) ?(name="graph") @@ -570,18 +582,18 @@ module Dot = struct get_tag=vertex_explored; set_tag=set_explored; (* allocate new ID *) } in - let events = Traverse.Event.dfs_tag ~tags ~graph seq in + let events = Traverse.Event.dfs_tag ~eq ~tags ~graph seq in Seq.iter (function | `Enter (v, _n, _path) -> let attrs = attrs_v v in - Format.fprintf out " @[%a %a;@]@." pp_vertex v (pp_list pp_attr) attrs + Format.fprintf out "@[%a %a;@]@," pp_vertex v (pp_list pp_attr) attrs | `Exit _ -> () | `Edge (e, _) -> let v1 = graph.origin e in let v2 = graph.dest e in let attrs = attrs_e e in - Format.fprintf out " @[%a -> %a %a;@]@." + Format.fprintf out "@[%a -> %a %a;@]@," pp_vertex v1 pp_vertex v2 (pp_list pp_attr) attrs @@ -590,8 +602,8 @@ module Dot = struct Format.fprintf out "}@]@;@?"; () - let pp ?tbl ?attrs_v ?attrs_e ?name ~graph fmt v = - pp_seq ?tbl ?attrs_v ?attrs_e ?name ~graph fmt (Seq.return v) + let pp ?tbl ?eq ?attrs_v ?attrs_e ?name ~graph fmt v = + pp_seq ?tbl ?eq ?attrs_v ?attrs_e ?name ~graph fmt (Seq.return v) let with_out filename f = let oc = open_out filename in diff --git a/src/data/CCGraph.mli b/src/data/CCGraph.mli index f8710e82..22bc1233 100644 --- a/src/data/CCGraph.mli +++ b/src/data/CCGraph.mli @@ -76,6 +76,23 @@ type ('v, 'e) t = { type ('v, 'e) graph = ('v, 'e) t +val make : + origin:('e -> 'v) -> + dest:('e -> 'v) -> + ('v -> 'e sequence) -> ('v, 'e) t +(** Make a graph by providing its fields + @since 0.16 *) + +val make_labelled_tuple : + ('v -> ('a * 'v) sequence) -> ('v, ('v * 'a * 'v)) t +(** Make a graph with edges being triples [(origin,label,dest)] + @since 0.16 *) + +val make_tuple : + ('v -> 'v sequence) -> ('v, ('v * 'v)) t +(** Make a graph with edges being pairs [(origin,dest)] + @since 0.16 *) + (** Mutable tags from values of type ['v] to tags of type [bool] *) type 'v tag_set = { get_tag: 'v -> bool; @@ -307,6 +324,7 @@ module Dot : sig (** Hidden state associated to a vertex *) val pp : ?tbl:('v,vertex_state) table -> + ?eq:('v -> 'v -> bool) -> ?attrs_v:('v -> attribute list) -> ?attrs_e:('e -> attribute list) -> ?name:string -> @@ -320,6 +338,7 @@ module Dot : sig @param name name of the graph *) val pp_seq : ?tbl:('v,vertex_state) table -> + ?eq:('v -> 'v -> bool) -> ?attrs_v:('v -> attribute list) -> ?attrs_e:('e -> attribute list) -> ?name:string -> diff --git a/src/data/CCMixmap.ml b/src/data/CCMixmap.ml index 39a10501..2373cd75 100644 --- a/src/data/CCMixmap.ml +++ b/src/data/CCMixmap.ml @@ -1,30 +1,30 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Maps with Heterogeneous Values} *) +(*$R + let module M = CCMixmap.Make(CCInt) in + + let inj_int = CCMixmap.create_inj() in + let inj_str = CCMixmap.create_inj() in + let inj_list_int = CCMixmap.create_inj() in + + let m = + M.empty + |> M.add ~inj:inj_int 1 1 + |> M.add ~inj:inj_str 2 "2" + |> M.add ~inj:inj_list_int 3 [3;3;3] + in + + assert_equal (M.get ~inj:inj_int 1 m) (Some 1) ; + assert_equal (M.get ~inj:inj_str 1 m) None ; + assert_equal (M.get ~inj:inj_str 2 m) (Some "2") ; + assert_equal (M.get ~inj:inj_int 2 m) None ; + assert_equal (M.get ~inj:inj_list_int 3 m) (Some [3;3;3]) ; + assert_equal (M.get ~inj:inj_str 3 m) None ; +*) + type 'b injection = { get : (unit -> unit) -> 'b option; set : 'b -> (unit -> unit); @@ -50,14 +50,14 @@ module type S = sig val empty : t (** Empty map *) - val get : inj:'a injection -> t -> key -> 'a option + val get : inj:'a injection -> key -> t -> 'a option (** Get the value corresponding to this key, if it exists and belongs to the same key *) - val add : inj:'a injection -> t -> key -> 'a -> t + val add : inj:'a injection -> key -> 'a -> t -> t (** Bind the key to the value, using [inj] *) - val find : inj:'a injection -> t -> key -> 'a + val find : inj:'a injection -> key -> t -> 'a (** Find the value for the given key, which must be of the right type. @raise Not_found if either the key is not found, or if its value doesn't belong to the right type *) @@ -65,10 +65,10 @@ module type S = sig val cardinal : t -> int (** Number of bindings *) - val remove : t -> key -> t + val remove : key -> t -> t (** Remove the binding for this key *) - val mem : inj:_ injection-> t -> key -> bool + val mem : inj:_ injection-> key -> t -> bool (** Is the given key in the map, with the right type? *) val iter_keys : f:(key -> unit) -> t -> unit @@ -107,23 +107,23 @@ module Make(X : ORD) : S with type key = X.t = struct let empty = M.empty - let find ~inj map x = + let find ~inj x map = match inj.get (M.find x map) with | None -> raise Not_found | Some v -> v - let get ~inj map x = + let get ~inj x map = try inj.get (M.find x map) with Not_found -> None - let add ~inj map x y = + let add ~inj x y map = M.add x (inj.set y) map let cardinal = M.cardinal - let remove map x = M.remove x map + let remove = M.remove - let mem ~inj map x = + let mem ~inj x map = try inj.get (M.find x map) <> None with Not_found -> false diff --git a/src/data/CCMixmap.mli b/src/data/CCMixmap.mli index 6675a877..a238b375 100644 --- a/src/data/CCMixmap.mli +++ b/src/data/CCMixmap.mli @@ -1,33 +1,34 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Maps with Heterogeneous Values} -{b status: experimental} + {b status: experimental} -@since 0.9 *) + {[ + module M = CCMixmap.Make(CCInt) + + let inj_int = CCMixmap.create_inj() + let inj_str = CCMixmap.create_inj() + let inj_list_int = CCMixmap.create_inj() + + let m = + M.empty + |> M.add ~inj:inj_int 1 1 + |> M.add ~inj:inj_str 2 "2" + |> M.add ~inj:inj_list_int 3 [3;3;3] + + assert (M.get ~inj:inj_int 1 m = Some 1) + assert (M.get ~inj:inj_str 1 m = None) + assert (M.get ~inj:inj_str 2 m = Some "2") + assert (M.get ~inj:inj_int 2 m = None) + assert (M.get ~inj:inj_list_int 3 m = Some [3;3;3]) + assert (M.get ~inj:inj_str 3 m = None) + ]} + + @since 0.9 + @since 0.16 change of API, the map is last argument to + make piping with [|>] easier. *) type 'a injection (** An accessor for values of type 'a in any map. Values put @@ -50,14 +51,14 @@ module type S = sig val empty : t (** Empty map *) - val get : inj:'a injection -> t -> key -> 'a option + val get : inj:'a injection -> key -> t -> 'a option (** Get the value corresponding to this key, if it exists and belongs to the same key *) - val add : inj:'a injection -> t -> key -> 'a -> t + val add : inj:'a injection -> key -> 'a -> t -> t (** Bind the key to the value, using [inj] *) - val find : inj:'a injection -> t -> key -> 'a + val find : inj:'a injection -> key -> t -> 'a (** Find the value for the given key, which must be of the right type. @raise Not_found if either the key is not found, or if its value doesn't belong to the right type *) @@ -65,10 +66,10 @@ module type S = sig val cardinal : t -> int (** Number of bindings *) - val remove : t -> key -> t + val remove : key -> t -> t (** Remove the binding for this key *) - val mem : inj:_ injection-> t -> key -> bool + val mem : inj:_ injection-> key -> t -> bool (** Is the given key in the map, with the right type? *) val iter_keys : f:(key -> unit) -> t -> unit diff --git a/src/data/CCMixset.ml b/src/data/CCMixset.ml index ff7320c3..3d049ae4 100644 --- a/src/data/CCMixset.ml +++ b/src/data/CCMixset.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2015, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Set of Heterogeneous Values} *) diff --git a/src/data/CCMixset.mli b/src/data/CCMixset.mli index cfc79d3d..7f7f2619 100644 --- a/src/data/CCMixset.mli +++ b/src/data/CCMixset.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2015, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Set of Heterogeneous Values} diff --git a/src/data/CCMixtbl.ml b/src/data/CCMixtbl.ml index 0ec48c58..84c8e75b 100644 --- a/src/data/CCMixtbl.ml +++ b/src/data/CCMixtbl.ml @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Hash Table with Heterogeneous Keys} *) diff --git a/src/data/CCMixtbl.mli b/src/data/CCMixtbl.mli index 2c6eec78..a778fb4c 100644 --- a/src/data/CCMixtbl.mli +++ b/src/data/CCMixtbl.mli @@ -1,27 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Hash Table with Heterogeneous Keys} diff --git a/src/sexp/CCSexpM.mli b/src/sexp/CCSexpM.mli index 66186e75..b16fe259 100644 --- a/src/sexp/CCSexpM.mli +++ b/src/sexp/CCSexpM.mli @@ -86,9 +86,10 @@ module MakeDecode(M : MONAD) : sig long enough or isn't a proper S-expression *) end -module ID_MONAD : MONAD +module ID_MONAD : MONAD with type 'a t = 'a (** The monad that just uses blocking calls as bind - @since 0.14 *) + @since 0.14 + ['a t = 'a] contraint is @since 0.16 *) module D : module type of MakeDecode(ID_MONAD) (** Decoder that just blocks when input is not available diff --git a/src/threads/CCBlockingQueue.ml b/src/threads/CCBlockingQueue.ml new file mode 100644 index 00000000..d767b4ab --- /dev/null +++ b/src/threads/CCBlockingQueue.ml @@ -0,0 +1,191 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Blocking Queue} *) + +type 'a t = { + q : 'a Queue.t; + lock : Mutex.t; + cond : Condition.t; + capacity : int; + mutable size : int; +} + +let create n = + if n < 1 then invalid_arg "BloquingQueue.create"; + let q = { + q=Queue.create(); + lock=Mutex.create(); + cond=Condition.create(); + capacity=n; + size=0; + } in + q + +let incr_size_ q = assert(q.size < q.capacity); q.size <- q.size + 1 +let decr_size_ q = assert(q.size > 0); q.size <- q.size - 1 + +let finally_ f x ~h = + try + let res = f x in + ignore (h ()); + res + with e -> + ignore (h()); + raise e + +let with_lock_ q f = + Mutex.lock q.lock; + finally_ f () ~h:(fun () -> Mutex.unlock q.lock) + +let push q x = + with_lock_ q + (fun () -> + while q.size = q.capacity do + Condition.wait q.cond q.lock + done; + assert (q.size < q.capacity); + Queue.push x q.q; + (* if there are blocked receivers, awake one of them *) + incr_size_ q; + Condition.broadcast q.cond) + +let take q = + with_lock_ q + (fun () -> + while q.size = 0 do + Condition.wait q.cond q.lock + done; + let x = Queue.take q.q in + (* if there are blocked senders, awake one of them *) + decr_size_ q; + Condition.broadcast q.cond; + x) + +(*$R + let q = create 1 in + let t1 = CCThread.spawn (fun () -> push q 1; push q 2) in + let t2 = CCThread.spawn (fun () -> push q 3; push q 4) in + let l = CCLock.create [] in + let t3 = CCThread.spawn (fun () -> for i = 1 to 4 do + let x = take q in + CCLock.update l (fun l -> x :: l) + done) + in + Thread.join t1; Thread.join t2; Thread.join t3; + assert_equal [1;2;3;4] (List.sort Pervasives.compare (CCLock.get l)) +*) + +let push_list q l = + (* push elements until it's not possible. + Assumes the lock is acquired. *) + let rec push_ q l = match l with + | [] -> l + | _::_ when q.size = q.capacity -> l (* no room remaining *) + | x :: tl -> + Queue.push x q.q; + incr_size_ q; + push_ q tl + in + (* push chunks of [l] in [q] until [l] is empty *) + let rec aux q l = match l with + | [] -> () + | _::_ -> + let l = with_lock_ q + (fun () -> + while q.size = q.capacity do + Condition.wait q.cond q.lock + done; + let l = push_ q l in + Condition.broadcast q.cond; + l) + in + aux q l + in aux q l + +let take_list q n = + (* take at most [n] elements of [q] and prepend them to [acc] *) + let rec pop_ acc q n = + if n=0 || Queue.is_empty q.q then acc, n + else ( (* take next element *) + let x = Queue.take q.q in + decr_size_ q; + pop_ (x::acc) q (n-1) + ) + in + (* call [pop_] until [n] elements have been gathered *) + let rec aux acc q n = + if n=0 then List.rev acc + else + let acc, n = with_lock_ q + (fun () -> + while q.size = 0 do + Condition.wait q.cond q.lock + done; + let acc, n = pop_ acc q n in + Condition.broadcast q.cond; + acc, n + ) + in + aux acc q n + in + aux [] q n + +(*$R + let n = 1000 in + let lists = [| CCList.(1 -- n) ; CCList.(n+1 -- 2*n); CCList.(2*n+1 -- 3*n) |] in + let q = create 2 in + let senders = CCThread.Arr.spawn 3 + (fun i -> + if i=1 + then push_list q lists.(i) (* test push_list *) + else List.iter (push q) lists.(i) + ) + in + let res = CCLock.create [] in + let receivers = CCThread.Arr.spawn 3 + (fun i -> + if i=1 then + let l = take_list q n in + CCLock.update res (fun acc -> l @ acc) + else + for _j = 1 to n do + let x = take q in + CCLock.update res (fun acc -> x::acc) + done + ) + in + CCThread.Arr.join senders; CCThread.Arr.join receivers; + let l = CCLock.get res |> List.sort Pervasives.compare in + assert_equal CCList.(1 -- 3*n) l +*) + +let try_take q = + with_lock_ q + (fun () -> + if q.size = 0 then None + else ( + decr_size_ q; + Some (Queue.take q.q) + )) + +let try_push q x = + with_lock_ q + (fun () -> + if q.size = q.capacity then false + else ( + incr_size_ q; + Queue.push x q.q; + Condition.signal q.cond; + true + )) + +let peek q = + with_lock_ q + (fun () -> + try Some (Queue.peek q.q) + with Queue.Empty -> None) + +let size q = with_lock_ q (fun () -> q.size) + +let capacity q = q.capacity diff --git a/src/threads/CCBlockingQueue.mli b/src/threads/CCBlockingQueue.mli new file mode 100644 index 00000000..003110b1 --- /dev/null +++ b/src/threads/CCBlockingQueue.mli @@ -0,0 +1,50 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Blocking Queue} + + This queue has a limited size. Pushing a value on the queue when it + is full will block. + + @since 0.16 *) + +type 'a t +(** Safe-thread queue for values of type ['a] *) + +val create : int -> 'a t +(** Create a new queue of size [n]. Using [n=max_int] amounts to using + an infinite queue (2^61 items is a lot to fit in memory); using [n=1] + amounts to using a box with 0 or 1 elements inside. + @raise Invalid_argument if [n < 1] *) + +val push : 'a t -> 'a -> unit +(** [push q x] pushes [x] into [q], blocking if the queue is full *) + +val take : 'a t -> 'a +(** Take the first element, blocking if needed *) + +val push_list : 'a t -> 'a list -> unit +(** Push items of the list, one by one *) + +val take_list : 'a t -> int -> 'a list +(** [take_list n q] takes [n] elements out of [q] *) + +val try_take : 'a t -> 'a option +(** Take the first element if the queue is not empty, return [None] + otherwise *) + +val try_push : 'a t -> 'a -> bool +(** [try_push q x] pushes [x] into [q] if [q] is not full, in which + case it returns [true]. + If it fails because [q] is full, it returns [false] *) + +val peek : 'a t -> 'a option +(** [peek q] returns [Some x] if [x] is the first element of [q], + otherwise it returns [None] *) + +val size : _ t -> int +(** Number of elements currently in the queue *) + +val capacity : _ t -> int +(** Number of values the queue can hold *) + diff --git a/src/threads/CCFuture.ml b/src/threads/CCFuture.ml deleted file mode 100644 index 438b46a0..00000000 --- a/src/threads/CCFuture.ml +++ /dev/null @@ -1,617 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Futures for concurrency} *) - -type 'a state = - | Done of 'a - | Waiting - | Failed of exn - -(** {2 Thread pool} *) -module Pool = struct - type job = - | Job : ('a -> unit) * 'a -> job - - type t = { - mutable stop : bool; (* indicate that threads should stop *) - mutex : Mutex.t; - jobs : job Queue.t; (* waiting jobs *) - mutable cur_size : int; (* total number of threads *) - max_size : int; - } (** Dynamic, growable thread pool *) - - let with_lock_ t f = - Mutex.lock t.mutex; - try - let x = f t in - Mutex.unlock t.mutex; - x - with e -> - Mutex.unlock t.mutex; - raise e - - type command = - | Process of job - | Die (* thread has no work to do *) - - let die pool = - assert (pool.cur_size > 0); - pool.cur_size <- pool.cur_size - 1; - Die - - (** Thread: entry point. They seek jobs in the queue *) - let rec serve pool = - match with_lock_ pool get_next with - | Die -> () - | Process (Job (f, x)) -> - f x; - serve pool - - (* thread: seek what to do next (including dying) *) - and get_next pool = - if pool.stop then die pool - else if Queue.is_empty pool.jobs then die pool - else ( - let job = Queue.pop pool.jobs in - Process job - ) - - (** Create a pool with at most the given number of threads. [timeout] - is the time after which idle threads are killed. *) - let create ~max_size () = - let pool = { - stop = false; - cur_size = 0; - max_size; - jobs = Queue.create (); - mutex = Mutex.create (); - } in - pool - - exception PoolStopped - - let run_job pool job = - (* heuristic criterion for starting a new thread. We try to assess - whether there are many busy threads and many waiting tasks. - If there are many threads, it's less likely to start a new one *) - let should_start_thread p = - let num_q = Queue.length p.jobs in - let num_busy = p.cur_size in - let reached_max = p.cur_size = p.max_size in - num_q > 0 && not reached_max && (num_q > 2 * num_busy) - in - (* acquire lock and push job in queue *) - with_lock_ pool - (fun pool -> - if pool.stop then raise PoolStopped; - Queue.push job pool.jobs; - (* maybe start a thread *) - if should_start_thread pool then ( - pool.cur_size <- pool.cur_size + 1; - ignore (Thread.create serve pool) - ) - ) - - (* run the function on the argument in the given pool *) - let run pool f x = run_job pool (Job (f, x)) - - (* kill threads in the pool *) - let stop pool = - with_lock_ pool - (fun p -> - p.stop <- true; - Queue.clear p.jobs - ) -end - -(*$inject - open Infix -*) - -let pool = Pool.create ~max_size:50 () -(** Default pool of threads, should be ok for most uses. *) - -(** {2 Futures} *) - -type 'a handler = 'a state -> unit - -(** A proper future, with a delayed computation *) -type 'a cell = { - mutable state : 'a state; - mutable handlers : 'a handler list; (* handlers *) - mutex : Mutex.t; - condition : Condition.t; -} - -(** A future value of type 'a *) -type 'a t = - | Return of 'a - | FailNow of exn - | Run of 'a cell - -type 'a future = 'a t - -(** {2 Basic Future functions} *) - -let return x = Return x - -let fail e = FailNow e - -let create_cell () = { - state = Waiting; - handlers = []; - mutex = Mutex.create (); - condition = Condition.create (); -} - -let with_lock_ cell f = - Mutex.lock cell.mutex; - try - let x = f cell in - Mutex.unlock cell.mutex; - x - with e -> - Mutex.unlock cell.mutex; - raise e - -let set_done_ cell x = - with_lock_ cell - (fun cell -> match cell.state with - | Waiting -> (* set state and signal *) - cell.state <- Done x; - Condition.broadcast cell.condition; - List.iter (fun f -> f cell.state) cell.handlers - | _ -> assert false - ) - -let set_fail_ cell e = - with_lock_ cell - (fun cell -> match cell.state with - | Waiting -> - cell.state <- Failed e; - Condition.broadcast cell.condition; - List.iter (fun f -> f cell.state) cell.handlers - | _ -> assert false - ) - -let run_and_set1 cell f x = - try - let y = f x in - set_done_ cell y - with e -> - set_fail_ cell e - -let run_and_set2 cell f x y = - try - let z = f x y in - set_done_ cell z - with e -> - set_fail_ cell e - -let make1 f x = - let cell = create_cell() in - Pool.run pool (run_and_set1 cell f) x; - Run cell - -let make f = make1 f () - -(*$R - List.iter - (fun n -> - let l = Sequence.(1 -- n) |> Sequence.to_list in - let l = List.map (fun i -> - make - (fun () -> - Thread.delay 0.1; - 1 - )) l in - let l' = List.map get l in - OUnit.assert_equal n (List.fold_left (+) 0 l'); - ) - [ 10; 300 ] -*) - -let make2 f x y = - let cell = create_cell() in - Pool.run pool (run_and_set2 cell f x) y; - Run cell - -let get = function - | Return x -> x - | FailNow e -> raise e - | Run cell -> - let rec get_cell cell = match cell.state with - | Waiting -> - Condition.wait cell.condition cell.mutex; (* wait *) - get_cell cell - | Done x -> Mutex.unlock cell.mutex; x - | Failed e -> Mutex.unlock cell.mutex; raise e - in - Mutex.lock cell.mutex; - get_cell cell - -let state = function - | Return x -> Done x - | FailNow e -> Failed e - | Run cell -> - with_lock_ cell (fun cell -> cell.state) - -let is_done = function - | Return _ - | FailNow _ -> true - | Run cell -> - with_lock_ cell (fun c -> c.state <> Waiting) - -(** {2 Combinators *) - -let add_handler_ cell f = - with_lock_ cell - (fun cell -> match cell.state with - | Waiting -> cell.handlers <- f :: cell.handlers - | Done _ | Failed _ -> f cell.state - ) - -let on_finish fut k = match fut with - | Return x -> k (Done x) - | FailNow e -> k (Failed e) - | Run cell -> add_handler_ cell k - -let on_success fut k = - on_finish fut - (function - | Done x -> k x - | _ -> () - ) - -let on_failure fut k = - on_finish fut - (function - | Failed e -> k e - | _ -> () - ) - -let map f fut = match fut with - | Return x -> make1 f x - | FailNow e -> FailNow e - | Run cell -> - let cell' = create_cell() in - add_handler_ cell - (function - | Done x -> run_and_set1 cell' f x - | Failed e -> set_fail_ cell' e - | Waiting -> assert false - ); - Run cell' - -(*$R - let a = make (fun () -> 1) in - let b = map (fun x -> x+1) a in - let c = map (fun x -> x-1) b in - OUnit.assert_equal 1 (get c) -*) - -let flat_map f fut = match fut with - | Return x -> f x - | FailNow e -> FailNow e - | Run cell -> - let cell' = create_cell() in - add_handler_ cell - (function - | Done x -> - let fut' = f x in - on_finish fut' - (function - | Done y -> set_done_ cell' y - | Failed e -> set_fail_ cell' e - | Waiting -> assert false - ) - | Failed e -> set_fail_ cell' e - | Waiting -> assert false - ); - Run cell' - -let and_then fut f = flat_map (fun _ -> f ()) fut - -let sequence futures = - let n = List.length futures in - let state = CCLock.create (`WaitFor n) in - let results = Array.make n None in - let cell = create_cell() in - (* when all futures returned, collect results for future' *) - let send_result () = - let l = Array.map - (function - | None -> assert false - | Some x -> x - ) results - in - set_done_ cell (Array.to_list l) - in - (* wait for all to succeed or fail *) - List.iteri - (fun i fut -> - on_finish fut - (fun res -> - CCLock.update state - (fun st -> match res, st with - | Done _, `Failed -> st - | Done x, `WaitFor 1 -> results.(i) <- Some x; send_result (); `Done - | Done x, `WaitFor n -> results.(i) <- Some x; `WaitFor (n-1) - | Failed _, `Failed -> st - | Failed e, `WaitFor _ -> set_fail_ cell e; `Failed - | _, `Done -> assert false - | Waiting, _ -> assert false - ) - ) - ) futures; - Run cell - -(*$R - let l = CCList.(1 -- 10) in - let l' = l - |> List.map - (fun x -> make (fun () -> Thread.delay 0.2; x*10)) - |> sequence - |> map (List.fold_left (+) 0) - in - let expected = List.fold_left (fun acc x -> acc + 10 * x) 0 l in - OUnit.assert_equal expected (get l') -*) - -(*$R - let l = CCList.(1 -- 10) in - let l' = l - |> List.map - (fun x -> make (fun () -> Thread.delay 0.2; if x = 5 then raise Exit; x)) - |> sequence - |> map (List.fold_left (+) 0) - in - OUnit.assert_raises Exit (fun () -> get l') -*) - -let choose futures = - let cell = create_cell() in - let state = ref `Waiting in - (* add handlers to all futures *) - List.iter - (fun fut -> - on_finish fut - (fun res -> match res, !state with - | Done x, `Waiting -> state := `Done; set_done_ cell x - | Failed e, `Waiting -> state := `Done; set_fail_ cell e - | Waiting, _ -> assert false - | _, `Done -> () - ) - ) futures; - Run cell - -(** slurp the entire state of the file_descr into a string *) -let slurp ic = CCIO.read_all_bytes ic - -let read_chan ic = make1 slurp ic - -type subprocess_res = < - errcode : int; - stdout : Bytes.t; - stderr : Bytes.t; -> - -(** Spawn a sub-process with the given command [cmd] (and possibly input); - returns a future containing (returncode, stdout, stderr) *) -let spawn_process ?(stdin="") cmd : subprocess_res t = - make - (fun () -> - (* spawn subprocess *) - let out, inp, err = Unix.open_process_full cmd (Unix.environment ()) in - output_string inp stdin; - (* send stdin to command *) - flush inp; - close_out inp; - (* read output of process *) - let out' = slurp out in - let err' = slurp err in - (* wait for termination *) - let status = Unix.close_process_full (out,inp,err) in - (* get return code *) - let returncode = match status with - | Unix.WEXITED i -> i - | Unix.WSIGNALED i -> i - | Unix.WSTOPPED i -> i in - object - method errcode = returncode - method stdout = out' - method stderr = err' - end - ) - -let sleep time = make (fun () -> Thread.delay time) - -(*$R - let start = Unix.gettimeofday () in - let pause = 0.2 and n = 10 in - let l = CCList.(1 -- n) - |> List.map (fun _ -> make (fun () -> Thread.delay pause)) - in - List.iter get l; - let stop = Unix.gettimeofday () in - OUnit.assert_bool "some_parallelism" (stop -. start < float_of_int n *. pause); -*) - -(** {2 Event timer} *) - -module Timer = struct - module TaskHeap = CCHeap.Make(struct - type t = (float * unit cell) - let leq (f1,_)(f2,_) = f1 <= f2 - end) - - type t = { - mutable stop : bool; - mutable thread : Thread.t option; (* thread dedicated to the timer *) - mutable tasks : TaskHeap.t; - t_mutex : Mutex.t; - fifo_in : Unix.file_descr; - fifo_out : Unix.file_descr; - } (** A timer for events *) - - let standby_wait = 10. (* when no task is scheduled *) - let epsilon = 0.0001 (* accepted time diff for actions *) - - let with_lock_ t f = - Mutex.lock t.t_mutex; - try - let x = f t in - Mutex.unlock t.t_mutex; - x - with e -> - Mutex.unlock t.t_mutex; - raise e - - type command = - | Loop - | Wait of float - - let pop_task_ t = - let tasks, _ = TaskHeap.take_exn t.tasks in - t.tasks <- tasks - - (** Wait for next event, run it, and loop *) - let serve timer = - let buf = Bytes.make 1 '_' in - (* acquire lock, call [process_task] and do as it commands *) - let rec next () = match with_lock_ timer process_task with - | Loop -> next () - | Wait delay -> wait delay - (* check next task *) - and process_task timer = match TaskHeap.find_min timer.tasks with - | None -> Wait standby_wait - | Some (time, cell) -> - let now = Unix.gettimeofday () in - if now +. epsilon > time then ( - (* now! *) - pop_task_ timer; - set_done_ cell (); - Loop - ) else Wait (time -. now) - (* wait for [delay] seconds, or until something happens on fifo_in *) - and wait delay = - let read = Thread.wait_timed_read timer.fifo_in delay in - if read - then ignore (Unix.read timer.fifo_in buf 0 1); (* remove char *) - next () - in - next () - - (** A timer that runs in the given thread pool *) - let create () = - let fifo_in, fifo_out = Unix.pipe () in - let timer = { - stop = false; - thread = None; - tasks = TaskHeap.empty; - t_mutex = Mutex.create (); - fifo_in; - fifo_out; - } in - (* start a thread to process tasks *) - let t = Thread.create serve timer in - timer.thread <- Some t; - timer - - let underscore_ = Bytes.make 1 '_' - - (** [timerule_at s t act] will run [act] at the Unix echo [t] *) - let at timer time = - let now = Unix.gettimeofday () in - if now >= time - then return () - else ( - let cell = create_cell() in - with_lock_ timer - (fun timer -> - (* time of the next scheduled event *) - let next_time = match TaskHeap.find_min timer.tasks with - | None -> max_float - | Some (f, _) -> f - in - (* insert task *) - timer.tasks <- TaskHeap.insert (time, cell) timer.tasks; - (* see if the timer thread needs to be awaken earlier *) - if time < next_time - then ignore (Unix.single_write timer.fifo_out underscore_ 0 1) - ); - Run cell - ) - - let after timer delay = - assert (delay >= 0.); - let now = Unix.gettimeofday () in - at timer (now +. delay) - - (** Stop the given timer, cancelling pending tasks *) - let stop timer = - with_lock_ timer - (fun timer -> - if not timer.stop then ( - timer.stop <- true; - (* empty heap of tasks *) - timer.tasks <- TaskHeap.empty; - (* kill the thread *) - match timer.thread with - | None -> () - | Some t -> - Thread.kill t; - timer.thread <- None - ) - ) -end - -(*$R - let timer = Timer.create () in - let n = CCLock.create 1 in - let getter = make (fun () -> Thread.delay 0.8; CCLock.get n) in - let _ = - Timer.after timer 0.6 - >>= fun () -> CCLock.update n (fun x -> x+2); return() - in - let _ = - Timer.after timer 0.4 - >>= fun () -> CCLock.update n (fun x -> x * 4); return() - in - OUnit.assert_equal 6 (get getter); -*) - -module Infix = struct - let (>>=) x f = flat_map f x - let (>>) a f = and_then a f - let (>|=) a f = map f a -end - -include Infix - -(** {2 Low Level } *) - -let stop_pool () = Pool.stop pool diff --git a/src/threads/CCFuture.mli b/src/threads/CCFuture.mli deleted file mode 100644 index c42a5785..00000000 --- a/src/threads/CCFuture.mli +++ /dev/null @@ -1,148 +0,0 @@ -(* -Copyright (c) 2013, Simon Cruanes -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. Redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Futures for concurrency} *) - -type 'a state = - | Done of 'a - | Waiting - | Failed of exn - -type 'a t -(** A future value of type 'a *) - -type 'a future = 'a t - -(** {2 Constructors} *) - -val return : 'a -> 'a t -(** Future that is already computed *) - -val fail : exn -> 'a t -(** Future that fails immediately *) - -val make : (unit -> 'a) -> 'a t -(** Create a future, representing a value that will be computed by - the function. If the function raises, the future will fail. *) - -val make1 : ('a -> 'b) -> 'a -> 'b t -val make2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t - -(** {2 Basics} *) - -val get : 'a t -> 'a -(** Blocking get: wait for the future to be evaluated, and get the value, - or the exception that failed the future is returned. - raise e if the future failed with e *) - -val state : 'a t -> 'a state -(** State of the future *) - -val is_done : 'a t -> bool -(** Is the future evaluated (success/failure)? *) - -(** {2 Combinators} *) - -val on_success : 'a t -> ('a -> unit) -> unit -(** Attach a handler to be called upon success *) - -val on_failure : _ t -> (exn -> unit) -> unit -(** Attach a handler to be called upon failure *) - -val on_finish : 'a t -> ('a state -> unit) -> unit -(** Attach a handler to be called when the future is evaluated *) - -val flat_map : ('a -> 'b t) -> 'a t -> 'b t -(** Monadic combination of futures *) - -val and_then : 'a t -> (unit -> 'b t) -> 'b t -(** Wait for the first future to succeed, then launch the second *) - -val sequence : 'a t list -> 'a list t -(** Future that waits for all previous sequences to terminate. If any future - in the list fails, [sequence l] fails too. *) - -val choose : 'a t list -> 'a t -(** Choose among those futures (the first to terminate). Behaves like - the first future that terminates, by failing if the future fails *) - -val map : ('a -> 'b) -> 'a t -> 'b t -(** Maps the value inside the future. The function doesn't run in its - own task; if it can take time, use {!flat_map} *) - -(** {2 Helpers} *) - -val read_chan : in_channel -> Bytes.t t -(** Read the whole channel *) - -type subprocess_res = < - errcode : int; - stdout : Bytes.t; - stderr : Bytes.t; -> - -val spawn_process : ?stdin:string -> string -> subprocess_res t -(** Spawn a sub-process with the given command (and possibly input); - returns a future containing [(returncode, stdout, stderr)] *) - -val sleep : float -> unit t -(** Future that returns with success in the given amount of seconds. Blocks - the thread! If you need to wait on many events, consider - using {!Timer} *) - -(** {2 Event timer} *) - -module Timer : sig - type t - (** A scheduler for events. It runs in its own thread. *) - - val create : unit -> t - (** A new timer. *) - - val after : t -> float -> unit future - (** Create a future that waits for the given number of seconds, then - awakens with [()] *) - - val at : t -> float -> unit future - (** Create a future that evaluates to [()] at the given Unix timestamp *) - - val stop : t -> unit - (** Stop the given timer, cancelling pending tasks *) -end - -module Infix : sig - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val (>>) : 'a t -> (unit -> 'b t) -> 'b t - val (>|=) : 'a t -> ('a -> 'b) -> 'b t -end - -val (>>=) : 'a t -> ('a -> 'b t) -> 'b t -val (>>) : 'a t -> (unit -> 'b t) -> 'b t -val (>|=) : 'a t -> ('a -> 'b) -> 'b t - -(** {2 Low level} *) - -val stop_pool : unit -> unit -(** Stop the thread pool *) diff --git a/src/threads/CCLock.ml b/src/threads/CCLock.ml index d7aaac7b..cd9aa456 100644 --- a/src/threads/CCLock.ml +++ b/src/threads/CCLock.ml @@ -1,28 +1,5 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Utils around Mutex} *) @@ -80,11 +57,14 @@ let with_lock_as_ref l ~f = let test_it l = with_lock_as_ref l ~f:(fun r -> - let x = LockRef.get r in - LockRef.set r (x+10); - Thread.yield (); - let y = LockRef.get r in - LockRef.set r (y - 10); + (* increment and decrement *) + for j = 0 to 100 do + let x = LockRef.get r in + LockRef.set r (x+10); + if j mod 5=0 then Thread.yield (); + let y = LockRef.get r in + LockRef.set r (y - 10); + done ) in for i = 1 to 100 do ignore (Thread.create test_it l) done; @@ -101,6 +81,17 @@ let update l f = let l = create 5 in update l (fun x->x+1); get l = 6 *) +let update_map l f = + with_lock l + (fun x -> + let x', y = f x in + l.content <- x'; + y) + +(*$T + let l = create 5 in update_map l (fun x->x+1, string_of_int x) = "5" && get l = 6 + *) + let get l = Mutex.lock l.mutex; let x = l.content in @@ -117,9 +108,9 @@ let set l x = let l = create 0 in set l 4; set l 5; get l = 5 *) -let incr l = update l (fun x -> x+1) +let incr l = update l Pervasives.succ -let decr l = update l (fun x -> x-1) +let decr l = update l Pervasives.pred (*$R @@ -133,3 +124,53 @@ let decr l = update l (fun x -> x-1) let l = create 0 in incr l ; get l = 1 let l = create 0 in decr l ; get l = ~-1 *) + +let incr_then_get l = + Mutex.lock l.mutex; + l.content <- l.content + 1; + let x = l.content in + Mutex.unlock l.mutex; + x + +let get_then_incr l = + Mutex.lock l.mutex; + let x = l.content in + l.content <- l.content + 1; + Mutex.unlock l.mutex; + x + +let decr_then_get l = + Mutex.lock l.mutex; + l.content <- l.content - 1; + let x = l.content in + Mutex.unlock l.mutex; + x + +let get_then_decr l = + Mutex.lock l.mutex; + let x = l.content in + l.content <- l.content - 1; + Mutex.unlock l.mutex; + x + +(*$T + let l = create 0 in 1 = incr_then_get l && 1 = get l + let l = create 0 in 0 = get_then_incr l && 1 = get l + let l = create 10 in 9 = decr_then_get l && 9 = get l + let l = create 10 in 10 = get_then_decr l && 9 = get l +*) + +let get_then_set l = + Mutex.lock l.mutex; + let x = l.content in + l.content <- true; + Mutex.unlock l.mutex; + x + +let get_then_clear l = + Mutex.lock l.mutex; + let x = l.content in + l.content <- false; + Mutex.unlock l.mutex; + x + diff --git a/src/threads/CCLock.mli b/src/threads/CCLock.mli index f1b248d4..75e4b07c 100644 --- a/src/threads/CCLock.mli +++ b/src/threads/CCLock.mli @@ -1,32 +1,11 @@ -(* -copyright (c) 2013-2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) +(* This file is free software, part of containers. See file "license" for more details. *) (** {1 Utils around Mutex} -@since 0.8 *) + A value wrapped into a Mutex, for more safety. + + @since 0.8 *) type 'a t (** A value surrounded with a lock *) @@ -60,6 +39,11 @@ val with_lock_as_ref : 'a t -> f:('a LockRef.t -> 'b) -> 'b val update : 'a t -> ('a -> 'a) -> unit (** [update l f] replaces the content [x] of [l] with [f x], atomically *) +val update_map : 'a t -> ('a -> 'a * 'b) -> 'b +(** [update_map l f] computes [x', y = f (get l)], then puts [x'] in [l] + and returns [y] + @since 0.16 *) + val mutex : _ t -> Mutex.t (** Underlying mutex *) @@ -77,3 +61,27 @@ val incr : int t -> unit val decr : int t -> unit (** Atomically decrement the value @since 0.13 *) + +val incr_then_get : int t -> int +(** [incr_then_get x] increments [x], and return its new value + @since 0.16 *) + +val get_then_incr : int t -> int +(** [get_then_incr x] increments [x], and return its previous value + @since 0.16 *) + +val decr_then_get : int t -> int +(** [decr_then_get x] decrements [x], and return its new value + @since 0.16 *) + +val get_then_decr : int t -> int +(** [get_then_decr x] decrements [x], and return its previous value + @since 0.16 *) + +val get_then_set : bool t -> bool +(** [get_then_set b] sets [b] to [true], and return the old value + @since 0.16 *) + +val get_then_clear : bool t -> bool +(** [get_then_clear b] sets [b] to [false], and return the old value + @since 0.16 *) diff --git a/src/threads/CCPool.ml b/src/threads/CCPool.ml new file mode 100644 index 00000000..86ea2bf5 --- /dev/null +++ b/src/threads/CCPool.ml @@ -0,0 +1,545 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Thread Pool, and Futures} *) + +type +'a state = + | Done of 'a + | Waiting + | Failed of exn + +module type PARAM = sig + val min_size : int + (** Minimum number of threads in the pool *) + + val max_size : int + (** Maximum number of threads in the pool *) +end + +exception Stopped + +(*$inject + module P = Make(struct let min_size = 0 let max_size = 30 end) + module Fut = P.Fut + open Fut.Infix +*) + +(** {2 Thread pool} *) +module Make(P : PARAM) = struct + type job = + | Job1 : ('a -> _) * 'a -> job + | Job2 : ('a -> 'b -> _) * 'a * 'b -> job + | Job3 : ('a -> 'b -> 'c -> _) * 'a * 'b * 'c -> job + | Job4 : ('a -> 'b -> 'c -> 'd -> _) * 'a * 'b * 'c * 'd -> job + + type t = { + mutable stop : bool; (* indicate that threads should stop *) + mutable exn_handler: (exn -> unit); + mutex : Mutex.t; + cond : Condition.t; + jobs : job Queue.t; (* waiting jobs *) + mutable cur_size : int; (* total number of threads *) + mutable cur_idle : int; (* number of idle threads *) + } (** Dynamic, growable thread pool *) + + let nop_ _ = () + + (* singleton pool *) + let pool = { + stop = false; + exn_handler = nop_; + cond = Condition.create(); + cur_size = 0; + cur_idle = 0; + jobs = Queue.create (); + mutex = Mutex.create (); + } + + let set_exn_handler f = pool.exn_handler <- f + + let with_lock_ t f = + Mutex.lock t.mutex; + try + let x = f t in + Mutex.unlock t.mutex; + x + with e -> + Mutex.unlock t.mutex; + raise e + + let incr_size_ p = p.cur_size <- p.cur_size + 1 + let decr_size_ p = p.cur_size <- p.cur_size - 1 + + (* next thing a thread should do *) + type command = + | Process of job + | Wait (* wait on condition *) + | Die (* thread has no work to do *) + + (* thread: seek what to do next (including dying). + Assumes the pool is locked. *) + let get_next_ pool = + if pool.stop + || (Queue.is_empty pool.jobs && pool.cur_size > P.min_size) then ( + (* die: the thread would be idle otherwise *) + assert (pool.cur_size > 0); + decr_size_ pool; + Die + ) + else if Queue.is_empty pool.jobs then Wait + else ( + let job = Queue.pop pool.jobs in + Process job + ) + + (* Thread: entry point. They seek jobs in the queue *) + let rec serve pool = + let cmd = with_lock_ pool get_next_ in + run_cmd cmd + + (* run a command *) + and run_cmd = function + | Die -> () + | Wait -> + with_lock_ pool (fun p -> Condition.wait p.cond p.mutex) + | Process (Job1 (f, x)) -> + begin try ignore (f x) with e -> pool.exn_handler e end; serve pool + | Process (Job2 (f, x, y)) -> + begin try ignore (f x y) with e -> pool.exn_handler e end; serve pool + | Process (Job3 (f, x, y, z)) -> + begin try ignore (f x y z) with e -> pool.exn_handler e end; serve pool + | Process (Job4 (f, x, y, z, w)) -> + begin try ignore (f x y z w) with e -> pool.exn_handler e end; serve pool + + (* create a new worker thread *) + let launch_worker_ pool = ignore (Thread.create serve pool) + + (* launch the minimum required number of threads *) + let () = + for _i = 1 to P.min_size do launch_worker_ pool done + + (* heuristic criterion for starting a new thread. *) + let can_start_thread_ p = p.cur_size < P.max_size + + let run_job job = + (* acquire lock and push job in queue, or start thread directly + if the queue is empty *) + with_lock_ pool + (fun pool -> + if pool.stop then raise Stopped; + if Queue.is_empty pool.jobs && can_start_thread_ pool && pool.cur_idle = 0 + then ( + (* create the thread now, on [job], as it will not break order of + jobs. We do not want to wait for the busy threads to do our task + if we are allowed to spawn a new thread. *) + incr_size_ pool; + ignore (Thread.create run_cmd (Process job)) + ) else ( + (* cannot start thread, push and wait for some worker to pick it up *) + Queue.push job pool.jobs; + Condition.signal pool.cond; (* wake up *) + (* might want to process in the background, if all threads are busy *) + if pool.cur_idle = 0 && can_start_thread_ pool then ( + incr_size_ pool; + launch_worker_ pool; + ) + )) + + (* run the function on the argument in the given pool *) + let run1 f x = run_job (Job1 (f, x)) + + let run f = run1 f () + + let run2 f x y = run_job (Job2 (f, x, y)) + + let run3 f x y z = run_job (Job3 (f, x, y, z)) + + let run4 f x y z w = run_job (Job4 (f, x, y, z, w)) + + let active () = not pool.stop + + (* kill threads in the pool *) + let stop () = + with_lock_ pool + (fun p -> + p.stop <- true; + Queue.clear p.jobs) + + (* stop threads if pool is GC'd *) + let () = Gc.finalise (fun _ -> stop ()) pool + + (** {6 Futures} *) + module Fut = struct + type 'a handler = 'a state -> unit + + (** A proper future, with a delayed computation *) + type 'a cell = { + mutable state : 'a state; + mutable handlers : 'a handler list; (* handlers *) + f_mutex : Mutex.t; + condition : Condition.t; + } + + (** A future value of type 'a *) + type 'a t = + | Return of 'a + | FailNow of exn + | Run of 'a cell + + type 'a future = 'a t + + (** {2 Basic Future functions} *) + + let return x = Return x + + let fail e = FailNow e + + let create_cell () = { + state = Waiting; + handlers = []; + f_mutex = Mutex.create (); + condition = Condition.create (); + } + + let with_lock_ cell f = + Mutex.lock cell.f_mutex; + try + let x = f cell in + Mutex.unlock cell.f_mutex; + x + with e -> + Mutex.unlock cell.f_mutex; + raise e + + (* TODO: exception handler for handler errors *) + + let set_done_ cell x = + with_lock_ cell + (fun cell -> match cell.state with + | Waiting -> (* set state and signal *) + cell.state <- Done x; + Condition.broadcast cell.condition; + List.iter + (fun f -> try f cell.state with e -> pool.exn_handler e) + cell.handlers + | _ -> assert false) + + let set_fail_ cell e = + with_lock_ cell + (fun cell -> match cell.state with + | Waiting -> + cell.state <- Failed e; + Condition.broadcast cell.condition; + List.iter + (fun f -> try f cell.state with e -> pool.exn_handler e) + cell.handlers + | _ -> assert false) + + (* calls [f x], and put result or exception in [cell] *) + let run_and_set1 cell f x = + try + let y = f x in + set_done_ cell y + with e -> + set_fail_ cell e + + let run_and_set2 cell f x y = + try + let z = f x y in + set_done_ cell z + with e -> + set_fail_ cell e + + let make1 f x = + let cell = create_cell() in + run3 run_and_set1 cell f x; + Run cell + + let make f = make1 f () + + (*$R + List.iter + (fun n -> + let l = Sequence.(1 -- n) |> Sequence.to_list in + let l = List.rev_map (fun i -> + Fut.make + (fun () -> + Thread.delay 0.1; + 1 + )) l in + let l' = List.map Fut.get l in + OUnit.assert_equal n (List.fold_left (+) 0 l'); + ) + [ 10; 300; ] + *) + + let make2 f x y = + let cell = create_cell() in + run4 run_and_set2 cell f x y; + Run cell + + let get = function + | Return x -> x + | FailNow e -> raise e + | Run cell -> + let rec get_ cell = match cell.state with + | Waiting -> + Condition.wait cell.condition cell.f_mutex; (* wait *) + get_ cell + | Done x -> x + | Failed e -> raise e + in + with_lock_ cell get_ + + (* access the result without locking *) + let get_nolock_ = function + | Return x + | Run {state=Done x; _} -> x + | FailNow _ + | Run {state=(Failed _ | Waiting); _} -> assert false + + let state = function + | Return x -> Done x + | FailNow e -> Failed e + | Run cell -> + with_lock_ cell (fun cell -> cell.state) + + let is_done = function + | Return _ + | FailNow _ -> true + | Run cell -> + with_lock_ cell (fun c -> c.state <> Waiting) + + (** {2 Combinators *) + + let add_handler_ cell f = + with_lock_ cell + (fun cell -> match cell.state with + | Waiting -> cell.handlers <- f :: cell.handlers + | Done _ | Failed _ -> f cell.state) + + let on_finish fut k = match fut with + | Return x -> k (Done x) + | FailNow e -> k (Failed e) + | Run cell -> add_handler_ cell k + + let on_success fut k = + on_finish fut + (function + | Done x -> k x + | _ -> ()) + + let on_failure fut k = + on_finish fut + (function + | Failed e -> k e + | _ -> ()) + + let map_cell_ ~async f cell ~into:cell' = + add_handler_ cell + (function + | Done x -> + if async + then run3 run_and_set1 cell' f x + else run_and_set1 cell' f x + | Failed e -> set_fail_ cell' e + | Waiting -> assert false); + Run cell' + + let map_ ~async f fut = match fut with + | Return x -> + if async + then make1 f x + else Return (f x) + | FailNow e -> FailNow e + | Run cell -> map_cell_ ~async f cell ~into:(create_cell()) + + let map f fut = map_ ~async:false f fut + + let map_async f fut = map_ ~async:true f fut + + (*$R + let a = Fut.make (fun () -> 1) in + let b = Fut.map (fun x -> x+1) a in + let c = Fut.map (fun x -> x-1) b in + OUnit.assert_equal 1 (Fut.get c) + *) + + let app_ ~async f x = match f, x with + | Return f, Return x -> + if async + then make1 f x + else Return (f x) + | FailNow e, _ + | _, FailNow e -> FailNow e + | Return f, Run x -> + map_cell_ ~async (fun x -> f x) x ~into:(create_cell()) + | Run f, Return x -> + map_cell_ ~async (fun f -> f x) f ~into:(create_cell()) + | Run f, Run x -> + let cell' = create_cell () in + add_handler_ f + (function + | Done f -> ignore (map_cell_ ~async f x ~into:cell') + | Failed e -> set_fail_ cell' e + | Waiting -> assert false); + Run cell' + + let app f x = app_ ~async:false f x + + let app_async f x = app_ ~async:true f x + + let flat_map f fut = match fut with + | Return x -> f x + | FailNow e -> FailNow e + | Run cell -> + let cell' = create_cell() in + add_handler_ cell + (function + | Done x -> + let fut' = f x in + on_finish fut' + (function + | Done y -> set_done_ cell' y + | Failed e -> set_fail_ cell' e + | Waiting -> assert false + ) + | Failed e -> set_fail_ cell' e + | Waiting -> assert false + ); + Run cell' + + let and_then fut f = flat_map (fun _ -> f ()) fut + + type _ array_or_list = + | A_ : 'a array -> 'a array_or_list + | L_ : 'a list -> 'a array_or_list + + let iter_aol + : type a. a array_or_list -> (a -> unit) -> unit + = fun aol f -> match aol with + | A_ a -> Array.iter f a + | L_ l -> List.iter f l + + (* [sequence_ l f] returns a future that waits for every element of [l] + to return of fail, and call [f ()] to obtain the result (as a closure) + in case every element succeeded (otherwise a failure is + returned automatically) *) + let sequence_ + : type a res. a t array_or_list -> (unit -> res) -> res t + = fun aol f -> + let n = match aol with + | A_ a -> Array.length a + | L_ l -> List.length l + in + assert (n>0); + let cell = create_cell() in + let n_err = CCLock.create 0 in (* number of failed threads *) + let n_ok = CCLock.create 0 in (* number of succeeding threads *) + iter_aol aol + (fun fut -> + on_finish fut + (function + | Failed e -> + let x = CCLock.incr_then_get n_err in + (* if first failure, then seal [cell]'s fate now *) + if x=1 then set_fail_ cell e + | Done _ -> + let x = CCLock.incr_then_get n_ok in + (* if [n] successes, then [cell] succeeds. Otherwise, some + job has not finished or some job has failed. *) + if x = n then ( + let res = f () in + set_done_ cell res + ) + | Waiting -> assert false)); + Run cell + + (* map an array of futures to a future array *) + let sequence_a a = match a with + | [||] -> return [||] + | _ -> + sequence_ (A_ a) + (fun () -> Array.map get_nolock_ a) + + let map_a f a = sequence_a (Array.map f a) + + let sequence_l l = match l with + | [] -> return [] + | _ :: _ -> + sequence_ (L_ l) (fun () -> List.map get_nolock_ l) + + (* reverse twice *) + let map_l f l = + let l = List.rev_map f l in + sequence_ (L_ l) + (fun () -> List.rev_map get_nolock_ l) + + (*$R + let l = CCList.(1 -- 50) in + let l' = l + |> List.map + (fun x -> Fut.make (fun () -> Thread.delay 0.1; x*10)) + |> Fut.sequence_l + |> Fut.map (List.fold_left (+) 0) + in + let expected = List.fold_left (fun acc x -> acc + 10 * x) 0 l in + OUnit.assert_equal expected (Fut.get l') + *) + + (*$R + let l = CCList.(1 -- 50) in + let l' = l + |> List.map + (fun x -> Fut.make (fun () -> Thread.delay 0.1; if x = 5 then raise Exit; x)) + |> Fut.sequence_l + |> Fut.map (List.fold_left (+) 0) + in + OUnit.assert_raises Exit (fun () -> Fut.get l') + *) + + let choose_ + : type a. a t array_or_list -> a t + = fun aol -> + let cell = create_cell() in + let is_done = CCLock.create false in + iter_aol aol + (fun fut -> + on_finish fut + (fun res -> match res with + | Waiting -> assert false + | Done x -> + let was_done = CCLock.get_then_clear is_done in + if not was_done then set_done_ cell x + | Failed e -> + let was_done = CCLock.get_then_clear is_done in + if not was_done then set_fail_ cell e)); + Run cell + + let choose_a a = choose_ (A_ a) + + let choose_l l = choose_ (L_ l) + + let sleep time = make1 Thread.delay time + + (*$R + let start = Unix.gettimeofday () in + let pause = 0.2 and n = 10 in + let l = CCList.(1 -- n) + |> List.map (fun _ -> Fut.make (fun () -> Thread.delay pause)) + in + List.iter Fut.get l; + let stop = Unix.gettimeofday () in + OUnit.assert_bool "some_parallelism" (stop -. start < float_of_int n *. pause); + *) + + module Infix = struct + let (>>=) x f = flat_map f x + let (>>) a f = and_then a f + let (>|=) a f = map f a + let (<*>) = app + end + + include Infix + end +end diff --git a/src/threads/CCPool.mli b/src/threads/CCPool.mli new file mode 100644 index 00000000..9697c6d1 --- /dev/null +++ b/src/threads/CCPool.mli @@ -0,0 +1,167 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Thread Pool, and Futures} + + Renamed and heavily updated from [CCFuture] + @since 0.16 *) + +type +'a state = + | Done of 'a + | Waiting + | Failed of exn + +module type PARAM = sig + val min_size : int + (** Minimum number of threads in the pool *) + + val max_size : int + (** Maximum number of threads in the pool *) +end + +exception Stopped + +(** {2 Create a new Pool} *) +module Make(P : PARAM) : sig + val run : (unit -> _) -> unit + (** [run f] schedules [f] for being executed in the thread pool *) + + val run1 : ('a -> _) -> 'a -> unit + (** [run1 f x] is similar to [run (fun () -> f x)] *) + + val run2 : ('a -> 'b -> _) -> 'a -> 'b -> unit + + val run3 : ('a -> 'b -> 'c -> _) -> 'a -> 'b -> 'c -> unit + + val set_exn_handler : (exn -> unit) -> unit + + val active : unit -> bool + (** [active ()] is true as long as [stop()] has not been called yet *) + + val stop : unit -> unit + (** After calling [stop ()], Most functions will raise Stopped. + This has the effect of preventing new tasks from being executed. *) + + (** {6 Futures} + + The futures are registration points for callbacks, storing a {!state}, + that are executed in the pool using {!run}. *) + module Fut : sig + type 'a t + (** A future value of type 'a *) + + type 'a future = 'a t + + (** {2 Constructors} *) + + val return : 'a -> 'a t + (** Future that is already computed *) + + val fail : exn -> 'a t + (** Future that fails immediately *) + + val make : (unit -> 'a) -> 'a t + (** Create a future, representing a value that will be computed by + the function. If the function raises, the future will fail. *) + + val make1 : ('a -> 'b) -> 'a -> 'b t + + val make2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c t + + (** {2 Basics} *) + + val get : 'a t -> 'a + (** Blocking get: wait for the future to be evaluated, and get the value, + or the exception that failed the future is returned. + raise e if the future failed with e *) + + val state : 'a t -> 'a state + (** State of the future *) + + val is_done : 'a t -> bool + (** Is the future evaluated (success/failure)? *) + + (** {2 Combinators} *) + + val on_success : 'a t -> ('a -> unit) -> unit + (** Attach a handler to be called upon success. + The handler should not call functions on the future. + Might be evaluated now if the future is already done. *) + + val on_failure : _ t -> (exn -> unit) -> unit + (** Attach a handler to be called upon failure. + The handler should not call any function on the future. + Might be evaluated now if the future is already done. *) + + val on_finish : 'a t -> ('a state -> unit) -> unit + (** Attach a handler to be called when the future is evaluated. + The handler should not call functions on the future. + Might be evaluated now if the future is already done. *) + + val flat_map : ('a -> 'b t) -> 'a t -> 'b t + (** Monadic combination of futures *) + + val and_then : 'a t -> (unit -> 'b t) -> 'b t + (** Wait for the first future to succeed, then launch the second *) + + val sequence_a : 'a t array -> 'a array t + (** Future that waits for all previous futures to terminate. If any future + in the array fails, [sequence_a l] fails too. *) + + val map_a : ('a -> 'b t) -> 'a array -> 'b array t + (** [map_l f a] maps [f] on every element of [a], and will return + the array of every result if all calls succeed, or an error otherwise. *) + + val sequence_l : 'a t list -> 'a list t + (** Future that waits for all previous futures to terminate. If any future + in the list fails, [sequence_l l] fails too. *) + + val map_l : ('a -> 'b t) -> 'a list -> 'b list t + (** [map_l f l] maps [f] on every element of [l], and will return + the list of every result if all calls succeed, or an error otherwise. *) + + val choose_a : 'a t array -> 'a t + (** Choose among those futures (the first to terminate). Behaves like + the first future that terminates, by failing if the future fails *) + + val choose_l : 'a t list -> 'a t + (** Choose among those futures (the first to terminate). Behaves like + the first future that terminates, by failing if the future fails *) + + val map : ('a -> 'b) -> 'a t -> 'b t + (** Maps the value inside the future. The function doesn't run in its + own task; if it can take time, use {!flat_map} or {!map_async} *) + + val map_async : ('a -> 'b) -> 'a t -> 'b t + (** Maps the value inside the future, to be computed in a separated job. *) + + val app : ('a -> 'b) t -> 'a t -> 'b t + (** [app f x] applies the result of [f] to the result of [x] *) + + val app_async : ('a -> 'b) t -> 'a t -> 'b t + (** [app f x] applies the result of [f] to the result of [x], in + a separated job scheduled in the pool *) + + val sleep : float -> unit t + (** Future that returns with success in the given amount of seconds. Blocks + the thread! If you need to wait on many events, consider + using {!CCTimer}. *) + + module Infix : sig + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + val (>>) : 'a t -> (unit -> 'b t) -> 'b t + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + end + + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + + val (>>) : 'a t -> (unit -> 'b t) -> 'b t + + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + (** Alias to {!map} *) + + val (<*>): ('a -> 'b) t -> 'a t -> 'b t + (** Alias to {!app} *) + end +end diff --git a/src/threads/CCSemaphore.ml b/src/threads/CCSemaphore.ml index 22673dfd..17d0b6de 100644 --- a/src/threads/CCSemaphore.ml +++ b/src/threads/CCSemaphore.ml @@ -6,11 +6,12 @@ type t = { cond : Condition.t; } -let create n = { - n; - mutex=Mutex.create(); - cond=Condition.create(); -} +let create n = + if n <= 0 then invalid_arg "Semaphore.create"; + { n; + mutex=Mutex.create(); + cond=Condition.create(); + } let get t = t.n diff --git a/src/threads/CCSemaphore.mli b/src/threads/CCSemaphore.mli index 7f8c9ad6..5734d31c 100644 --- a/src/threads/CCSemaphore.mli +++ b/src/threads/CCSemaphore.mli @@ -9,13 +9,13 @@ type t val create : int -> t (** [create n] creates a semaphore with initial value [n] - @raise Invalid_argument if [n < 0] *) + @raise Invalid_argument if [n <= 0] *) val get : t -> int (** Current value *) val acquire : int -> t -> unit -(** [acquire n s] blocks until [get s > n], then atomically +(** [acquire n s] blocks until [get s >= n], then atomically sets [s := !s - n] *) val release : int -> t -> unit diff --git a/src/threads/CCThread.ml b/src/threads/CCThread.ml index b43104cd..eb274097 100644 --- a/src/threads/CCThread.ml +++ b/src/threads/CCThread.ml @@ -6,8 +6,21 @@ type t = Thread.t let spawn f = Thread.create f () +let spawn1 f x = Thread.create f x + +let spawn2 f x y = Thread.create (fun () -> f x y) () + let detach f = ignore (Thread.create f ()) +let finally_ f x ~h = + try + let res = f x in + ignore (h ()); + res + with e -> + ignore (h()); + raise e + module Arr = struct let spawn n f = Array.init n (fun i -> Thread.create f i) @@ -38,13 +51,7 @@ module Barrier = struct let with_lock_ b f = Mutex.lock b.lock; - try - let x = f () in - Mutex.unlock b.lock; - x - with e -> - Mutex.unlock b.lock; - raise e + finally_ f () ~h:(fun () -> Mutex.unlock b.lock) let reset b = with_lock_ b (fun () -> b.activated <- false) @@ -53,17 +60,14 @@ module Barrier = struct (fun () -> while not b.activated do Condition.wait b.cond b.lock - done - ) + done) let activate b = with_lock_ b (fun () -> if not b.activated then ( b.activated <- true; - Condition.broadcast b.cond - ) - ) + Condition.broadcast b.cond)) let activated b = with_lock_ b (fun () -> b.activated) end @@ -79,194 +83,3 @@ end Thread.join t1; Thread.join t2; assert_equal 2 (CCLock.get res) *) - -module Queue = struct - type 'a t = { - q : 'a Queue.t; - lock : Mutex.t; - cond : Condition.t; - capacity : int; - mutable size : int; - } - - let create n = - if n < 1 then invalid_arg "CCThread.Queue.create"; - let q = { - q=Queue.create(); - lock=Mutex.create(); - cond=Condition.create(); - capacity=n; - size=0; - } in - q - - let incr_size_ q = assert(q.size < q.capacity); q.size <- q.size + 1 - let decr_size_ q = assert(q.size > 0); q.size <- q.size - 1 - - let with_lock_ q f = - Mutex.lock q.lock; - try - let x = f () in - Mutex.unlock q.lock; - x - with e -> - Mutex.unlock q.lock; - raise e - - let push q x = - with_lock_ q - (fun () -> - while q.size = q.capacity do - Condition.wait q.cond q.lock - done; - assert (q.size < q.capacity); - Queue.push x q.q; - (* if there are blocked receivers, awake one of them *) - incr_size_ q; - Condition.broadcast q.cond; - ) - - let take q = - with_lock_ q - (fun () -> - while q.size = 0 do - Condition.wait q.cond q.lock - done; - let x = Queue.take q.q in - (* if there are blocked senders, awake one of them *) - decr_size_ q; - Condition.broadcast q.cond; - x - ) - - (*$R - let q = Queue.create 1 in - let t1 = spawn (fun () -> Queue.push q 1; Queue.push q 2) in - let t2 = spawn (fun () -> Queue.push q 3; Queue.push q 4) in - let l = CCLock.create [] in - let t3 = spawn (fun () -> for i = 1 to 4 do - let x = Queue.take q in - CCLock.update l (fun l -> x :: l) - done) - in - Thread.join t1; Thread.join t2; Thread.join t3; - assert_equal [1;2;3;4] (List.sort Pervasives.compare (CCLock.get l)) - *) - - let push_list q l = - let is_empty_ = function [] -> true | _::_ -> false in - (* push elements until it's not possible *) - let rec push_ q l = match l with - | [] -> l - | _::_ when q.size = q.capacity -> l (* no room remaining *) - | x :: tl -> - Queue.push x q.q; - incr_size_ q; - push_ q tl - in - (* push chunks of [l] in [q] until [l] is empty *) - let rec aux q l = - if not (is_empty_ l) - then - let l = with_lock_ q - (fun () -> - while q.size = q.capacity do - Condition.wait q.cond q.lock - done; - let l = push_ q l in - Condition.broadcast q.cond; - l - ) - in - aux q l - in aux q l - - let take_list q n = - (* take at most [n] elements of [q] and prepend them to [acc] *) - let rec pop_ acc q n = - if n=0 || Queue.is_empty q.q then acc, n - else ( (* take next element *) - let x = Queue.take q.q in - decr_size_ q; - pop_ (x::acc) q (n-1) - ) - in - (* call [pop_] until [n] elements have been gathered *) - let rec aux acc q n = - if n=0 then List.rev acc - else - let acc, n = with_lock_ q - (fun () -> - while q.size = 0 do - Condition.wait q.cond q.lock - done; - let acc, n = pop_ acc q n in - Condition.broadcast q.cond; - acc, n - ) - in - aux acc q n - in - aux [] q n - - (*$R - let n = 1000 in - let lists = [| CCList.(1 -- n) ; CCList.(n+1 -- 2*n); CCList.(2*n+1 -- 3*n) |] in - let q = Queue.create 2 in - let senders = Arr.spawn 3 - (fun i -> - if i=1 - then Queue.push_list q lists.(i) (* test push_list *) - else List.iter (Queue.push q) lists.(i) - ) - in - let res = CCLock.create [] in - let receivers = Arr.spawn 3 - (fun i -> - if i=1 then - let l = Queue.take_list q n in - CCLock.update res (fun acc -> l @ acc) - else - for _j = 1 to n do - let x = Queue.take q in - CCLock.update res (fun acc -> x::acc) - done - ) - in - Arr.join senders; Arr.join receivers; - let l = CCLock.get res |> List.sort Pervasives.compare in - assert_equal CCList.(1 -- 3*n) l - *) - - let try_take q = - with_lock_ q - (fun () -> - if q.size > 0 - then ( - decr_size_ q; - Some (Queue.take q.q) - ) else None - ) - - let try_push q x = - with_lock_ q - (fun () -> - if q.size < q.capacity - then ( - incr_size_ q; - Queue.push x q.q; - Condition.signal q.cond; - true - ) else false - ) - - let peek q = - with_lock_ q - (fun () -> - try Some (Queue.peek q.q) with Queue.Empty -> None - ) - - let size q = with_lock_ q (fun () -> q.size) - - let capacity q = q.capacity -end diff --git a/src/threads/CCThread.mli b/src/threads/CCThread.mli index 7c38e9a7..fe54e6f8 100644 --- a/src/threads/CCThread.mli +++ b/src/threads/CCThread.mli @@ -7,9 +7,17 @@ type t = Thread.t -val spawn : (unit -> 'a) -> t +val spawn : (unit -> _) -> t (** [spawn f] creates a new thread that runs [f ()] *) +val spawn1 : ('a -> _) -> 'a -> t +(** [spawn1 f x] is like [spawn (fun () -> f x)]. + @since 0.16 *) + +val spawn2 : ('a -> 'b -> _) -> 'a -> 'b -> t +(** [spawn2 f x y] is like [spawn (fun () -> f x y)]. + @since 0.16 *) + val detach : (unit -> 'a) -> unit (** [detach f] is the same as [ignore (spawn f)] *) @@ -48,48 +56,3 @@ module Barrier : sig was not called since. In other words, [activated b = true] means [wait b] will not block. *) end - -(** {2 Blocking Queue} - - This queue has a limited size. Pushing a value on the queue when it - is full will block *) -module Queue : sig - type 'a t - (** Safe-thread queue for values of type ['a] *) - - val create : int -> 'a t - (** Create a new queue of size [n]. Using [n=max_int] amounts to using - an infinite queue (2^61 items is a lot to fit in memory). - @raise Invalid_argument if [n < 1] *) - - val push : 'a t -> 'a -> unit - (** [push q x] pushes [x] into [q], blocking if the queue is full *) - - val take : 'a t -> 'a - (** Take the first element, blocking if needed *) - - val push_list : 'a t -> 'a list -> unit - (** Push items of the list, one by one *) - - val take_list : 'a t -> int -> 'a list - (** [take_list n q] takes [n] elements out of [q] *) - - val try_take : 'a t -> 'a option - (** Take the first element if the queue is not empty, return [None] - otherwise *) - - val try_push : 'a t -> 'a -> bool - (** [try_push q x] pushes [x] into [q] if [q] is not full, in which - case it returns [true]. - If it fails because [q] is full, it returns [false] *) - - val peek : 'a t -> 'a option - (** [peek q] returns [Some x] if [x] is the first element of [q], - otherwise it returns [None] *) - - val size : _ t -> int - (** Number of elements currently in the queue *) - - val capacity : _ t -> int - (** Number of values the queue can hold *) -end diff --git a/src/threads/CCTimer.ml b/src/threads/CCTimer.ml new file mode 100644 index 00000000..cb4739dd --- /dev/null +++ b/src/threads/CCTimer.ml @@ -0,0 +1,195 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Event timer} *) + +type job = + | Job : float * (unit -> 'a) -> job + +module TaskHeap = CCHeap.Make(struct + type t = job + let leq (Job(f1,_)) (Job (f2,_)) = f1 <= f2 +end) + +exception Stopped + +type t = { + mutable stop : bool; + mutable tasks : TaskHeap.t; + mutable exn_handler : (exn -> unit); + t_mutex : Mutex.t; + fifo_in : Unix.file_descr; + fifo_out : Unix.file_descr; +} + +let set_exn_handler timer f = timer.exn_handler <- f + +let standby_wait = 10. +(* when no task is scheduled, this is the amount of time that is waited + in a row for something to happen. This is also the maximal delay + between the call to {!stop} and the actual termination of the + thread. *) + +let epsilon = 0.0001 +(* accepted time diff for actions. *) + +let with_lock_ t f = + Mutex.lock t.t_mutex; + try + let x = f t in + Mutex.unlock t.t_mutex; + x + with e -> + Mutex.unlock t.t_mutex; + raise e + +type command = + | Quit + | Run : (unit -> _) -> command + | Wait of float + +let pop_task_ t = + let tasks, _ = TaskHeap.take_exn t.tasks in + t.tasks <- tasks + +let call_ timer f = + try ignore (f ()) + with e -> timer.exn_handler e + +(* check next task *) +let next_task_ timer = match TaskHeap.find_min timer.tasks with + | _ when timer.stop -> Quit + | None -> Wait standby_wait + | Some Job (time, f) -> + let now = Unix.gettimeofday () in + if now +. epsilon > time then ( + (* now! *) + pop_task_ timer; + Run f + ) else Wait (time -. now) + +(* The main thread function: wait for next event, run it, and loop *) +let serve timer = + let buf = Bytes.make 1 '_' in + (* acquire lock, call [process_task] and do as it commands *) + let rec next () = match with_lock_ timer next_task_ with + | Quit -> () + | Run f -> + call_ timer f; (* call outside of any lock *) + next () + | Wait delay -> wait delay + (* wait for [delay] seconds, or until something happens on [fifo_in] *) + and wait delay = + let read = Thread.wait_timed_read timer.fifo_in delay in + (* remove char from fifo, so that next write can happen *) + if read then ignore (Unix.read timer.fifo_in buf 0 1); + next () + in + next () + +let nop_handler_ _ = () + +let create () = + let fifo_in, fifo_out = Unix.pipe () in + let timer = { + stop = false; + tasks = TaskHeap.empty; + exn_handler = nop_handler_; + t_mutex = Mutex.create (); + fifo_in; + fifo_out; + } in + (* start a thread to process tasks *) + let _t = Thread.create serve timer in + timer + +let underscore_ = Bytes.make 1 '_' + +(* awake the thread *) +let awaken_ timer = + ignore (Unix.single_write timer.fifo_out underscore_ 0 1) + +(** [at s t ~f] will run [f ()] at the Unix echo [t] *) +let at timer time ~f = + if timer.stop then raise Stopped; + let now = Unix.gettimeofday () in + if now >= time + then call_ timer f + else + with_lock_ timer + (fun timer -> + if timer.stop then raise Stopped; + (* time of the next scheduled event *) + let next_time = match TaskHeap.find_min timer.tasks with + | None -> max_float + | Some Job (d, _) -> d + in + (* insert task *) + timer.tasks <- TaskHeap.insert (Job (time, f)) timer.tasks; + (* see if the timer thread needs to be awaken earlier *) + if time < next_time then awaken_ timer + ) + +let after timer delay ~f = + assert (delay >= 0.); + let now = Unix.gettimeofday () in + at timer (now +. delay) ~f + +exception ExitEvery + +let every ?delay timer d ~f = + let rec run () = + try + ignore (f ()); + schedule() + with ExitEvery -> () (* stop *) + and schedule () = after timer d ~f:run in + match delay with + | None -> run() + | Some d -> after timer d ~f:run + +(*$R + let start = Unix.gettimeofday() in + let timer = create() in + let res = CCLock.create 0 in + let stop = ref 0. in + every timer 0.1 + ~f:(fun () -> + if CCLock.incr_then_get res > 5 then ( + stop := Unix.gettimeofday(); + raise ExitEvery + )); + Thread.delay 0.7; + OUnit.assert_equal ~printer:CCInt.to_string 6 (CCLock.get res); + OUnit.assert_bool "estimate delay" (abs_float (!stop -. start -. 0.5) < 0.1); +*) + +let active timer = not timer.stop + +(** Stop the given timer, cancelling pending tasks *) +let stop timer = + with_lock_ timer + (fun timer -> + if not timer.stop then ( + timer.stop <- true; + (* empty heap of tasks *) + timer.tasks <- TaskHeap.empty; + (* tell the thread to stop *) + awaken_ timer; + ) + ) + +(*$R + (* scenario: n := 1; n := n*4 ; n := n+2; res := n *) + let timer = create () in + let n = CCLock.create 1 in + let res = CCLock.create 0 in + after timer 0.6 + ~f:(fun () -> CCLock.update n (fun x -> x+2)); + ignore (Thread.create + (fun _ -> Thread.delay 0.8; CCLock.set res (CCLock.get n)) ()); + after timer 0.4 + ~f:(fun () -> CCLock.update n (fun x -> x * 4)); + Thread.delay 1. ; + OUnit.assert_equal 6 (CCLock.get res); +*) diff --git a/src/threads/CCTimer.mli b/src/threads/CCTimer.mli new file mode 100644 index 00000000..f0068cf8 --- /dev/null +++ b/src/threads/CCTimer.mli @@ -0,0 +1,43 @@ + +(* This file is free software, part of containers. See file "license" for more details. *) + +(** {1 Event timer} + + Used to be part of [CCFuture] + @since 0.16 *) + +type t +(** A scheduler for events. It runs in its own thread. *) + +val create : unit -> t +(** A new timer. *) + +val set_exn_handler : t -> (exn -> unit) -> unit +(** [set_exn_handler timer f] registers [f] so that any exception + raised by a task scheduled in [timer] is given to [f] *) + +exception Stopped + +val after : t -> float -> f:(unit -> _) -> unit +(** Call the callback [f] after the given number of seconds. + @raise Stopped if the timer was stopped *) + +val at : t -> float -> f:(unit -> _) -> unit +(** Create a future that evaluates to [()] at the given Unix timestamp + @raise Stopped if the timer was stopped *) + +exception ExitEvery + +val every : ?delay:float -> t -> float -> f:(unit -> _) -> unit +(** [every timer n ~f] calls [f ()] every [n] seconds. + [f()] can raise ExitEvery to stop the cycle. + @param delay if provided, the first call to [f ()] is delayed by + that many seconds. + @raise Stopped if the timer was stopped *) + +val stop : t -> unit +(** Stop the given timer, cancelling pending tasks. Idempotent. + From now on, calling most other operations on the timer will raise Stopped. *) + +val active : t -> bool +(** Returns [true] until [stop t] has been called. *) diff --git a/src/unix/CCUnix.ml b/src/unix/CCUnix.ml index 7e38efd3..09ee3022 100644 --- a/src/unix/CCUnix.ml +++ b/src/unix/CCUnix.ml @@ -46,6 +46,15 @@ let rec iter_gen f g = match g() with | None -> () | Some x -> f x; iter_gen f g +let finally_ f x ~h = + try + let y = f x in + ignore (h()); + y + with e -> + ignore (h ()); + raise e + (* print a string, but escaped if required *) let escape_str buf s = if str_exists s @@ -155,6 +164,72 @@ let stderr x = x#stderr let status x = x#status let errcode x = x#errcode +let with_in ?(mode=0o644) ?(flags=[]) file ~f = + let fd = Unix.openfile file (Unix.O_RDONLY::flags) mode in + let ic = Unix.in_channel_of_descr fd in + finally_ f ic + ~h:(fun () -> Unix.close fd) + +let with_out ?(mode=0o644) ?(flags=[Unix.O_CREAT; Unix.O_TRUNC]) file ~f = + let fd = Unix.openfile file (Unix.O_WRONLY::flags) mode in + let oc = Unix.out_channel_of_descr fd in + finally_ f oc + ~h:(fun () -> flush oc; Unix.close fd) + +let with_process_in cmd ~f = + let ic = Unix.open_process_in cmd in + finally_ f ic + ~h:(fun () -> ignore (Unix.close_process_in ic)) + +let with_process_out cmd ~f = + let oc = Unix.open_process_out cmd in + finally_ f oc + ~h:(fun () -> ignore (Unix.close_process_out oc)) + +type process_full = < + stdin: out_channel; + stdout: in_channel; + stderr: in_channel; + close: Unix.process_status; +> + +let with_process_full ?env cmd ~f = + let env = match env with None -> Unix.environment () | Some e -> e in + let oc, ic, err = Unix.open_process_full cmd env in + let close = lazy (Unix.close_process_full (oc,ic,err)) in + let p = object + method stdin = ic + method stdout = oc + method stderr = err + method close = Lazy.force close + end in + finally_ f p ~h:(fun () -> p#close) + +let with_connection addr ~f = + let ic, oc = Unix.open_connection addr in + finally_ (fun () -> f ic oc) () + ~h:(fun () -> Unix.shutdown_connection ic) + +exception ExitServer + +(* version of {!Unix.establish_server} that doesn't fork *) +let establish_server sockaddr ~f = + let sock = + Unix.socket (Unix.domain_of_sockaddr sockaddr) Unix.SOCK_STREAM 0 in + Unix.setsockopt sock Unix.SO_REUSEADDR true; + Unix.bind sock sockaddr; + Unix.listen sock 5; + let continue = ref true in + while !continue do + try + let s, _ = Unix.accept sock in + let ic = Unix.in_channel_of_descr s in + let oc = Unix.out_channel_of_descr s in + ignore (f ic oc) + with ExitServer -> + continue := false + done + module Infix = struct let (?|) fmt = call fmt diff --git a/src/unix/CCUnix.mli b/src/unix/CCUnix.mli index 779979e7..82b29502 100644 --- a/src/unix/CCUnix.mli +++ b/src/unix/CCUnix.mli @@ -36,8 +36,7 @@ type 'a gen = unit -> 'a option (** {2 Calling Commands} *) val escape_str : Buffer.t -> string -> unit -(** Escape a string so it can be a shell argument. -*) +(** Escape a string so it can be a shell argument. *) (*$T CCPrint.sprintf "%a" escape_str "foo" = "foo" @@ -107,6 +106,57 @@ val stderr : < stderr : 'a; .. > -> 'a val status : < status : 'a; .. > -> 'a val errcode : < errcode : 'a; .. > -> 'a +(** {2 Simple IO} *) + +val with_in : ?mode:int -> ?flags:Unix.open_flag list -> + string -> f:(in_channel -> 'a) -> 'a +(** Open an input file with the given optional flag list, calls the function + on the input channel. When the function raises or returns, the + channel is closed. + @param flags opening flags. [Unix.O_RDONLY] is used in any cases + @since 0.16 *) + +val with_out : ?mode:int -> ?flags:Unix.open_flag list -> + string -> f:(out_channel -> 'a) -> 'a +(** Same as {!with_in} but for an output channel + @param flags opening flags (default [[Unix.O_CREAT; Unix.O_TRUNC]]) + [Unix.O_WRONLY] is used in any cases. + @since 0.16 *) + +val with_process_in : string -> f:(in_channel -> 'a) -> 'a +(** Open a subprocess and obtain a handle to its stdout + @since 0.16 *) + +val with_process_out : string -> f:(out_channel -> 'a) -> 'a +(** Open a subprocess and obtain a handle to its stdin + @since 0.16 *) + +(** Handle to a subprocess. + @since 0.16 *) +type process_full = < + stdin: out_channel; + stdout: in_channel; + stderr: in_channel; + close: Unix.process_status; +> + +val with_process_full : ?env:string array -> string -> f:(process_full -> 'a) -> 'a +(** Open a subprocess and obtain a handle to its channels. + @param env environment to pass to the subprocess. + @since 0.16 *) + +val with_connection : Unix.sockaddr -> f:(in_channel -> out_channel -> 'a) -> 'a +(** Wrap {!Unix.open_connection} with a handler + @since 0.16 *) + +exception ExitServer + +val establish_server : Unix.sockaddr -> f:(in_channel -> out_channel -> _) -> unit +(** Listen on the address and calls the handler in a blocking fashion. + Using {!Thread} is recommended if handlers might take time. + The callback should raise {!ExitServer} to stop the loop. + @since 0.16 *) + (** {2 Infix Functions} *) module Infix : sig