From ccb05344e28d5f11ff4115ae29ea063a5bf32f97 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 19 Oct 2014 22:40:43 +0200 Subject: [PATCH 01/29] readme --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 13ef7ed8..3d5af8d4 100644 --- a/README.md +++ b/README.md @@ -23,7 +23,7 @@ ocaml-containers least) are unfinished or don't really work. Some of the modules have been moved to their own repository (e.g. `sequence`, -`gen`, `qcheck` and are on opam for great fun and profit (or not)). +`gen`, `qcheck`) and are on opam for great fun and profit. [![Build Status](http://ci.cedeela.fr/buildStatus/icon?job=containers)](http://ci.cedeela.fr/job/containers/) From 92ba6b34a6fb512dc9ad8b5ee7197ec17970dba0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 20 Oct 2014 11:37:36 +0200 Subject: [PATCH 02/29] CCPervasives.Opt -> CCPervasives.Option --- pervasives/CCPervasives.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/pervasives/CCPervasives.ml b/pervasives/CCPervasives.ml index 833faedb..b87db046 100644 --- a/pervasives/CCPervasives.ml +++ b/pervasives/CCPervasives.ml @@ -35,6 +35,11 @@ This module is meant to be opened if one doesn't want to use both, say, ]} @since 0.4 + +Changed [Opt] to [Option] to better reflect that this module is about the +['a option] type, with [module Option = CCOpt]. + +@since NEXT_RELEASE *) module Array = struct include Array include CCArray end @@ -43,7 +48,7 @@ module Error = CCError module Fun = CCFun module Int = CCInt module List = struct include List include CCList end -module Opt = CCOpt +module Option = CCOpt module Pair = CCPair module String = struct include String include CCString end module Vector = CCVector From 565f17fb5b47d3d7f99c8419c60aee836e22de31 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 20 Oct 2014 14:07:51 +0200 Subject: [PATCH 03/29] authors file --- AUTHORS.md | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 AUTHORS.md diff --git a/AUTHORS.md b/AUTHORS.md new file mode 100644 index 00000000..0e5a2e95 --- /dev/null +++ b/AUTHORS.md @@ -0,0 +1,7 @@ +# Authors and contributors + +- Simon Cruanes +- Drup (Gabriel Radanne) +- Jacques-Pascal Deplaix +- Nicolas Braud-Santoni + From 7b2ffdc0b95b32c31a6e913d109ef77eab6f5f1c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 20 Oct 2014 14:47:51 +0200 Subject: [PATCH 04/29] stub for CCMap (extension of the standard Map module) --- _oasis | 2 +- core/CCMap.ml | 41 +++++++++++++++++++++++++++++++++++++++++ core/CCMap.mli | 40 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 82 insertions(+), 1 deletion(-) create mode 100644 core/CCMap.ml create mode 100644 core/CCMap.mli diff --git a/_oasis b/_oasis index ed297ebf..23032165 100644 --- a/_oasis +++ b/_oasis @@ -48,7 +48,7 @@ Library "containers" CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCKList, CCInt, CCBool, CCArray, CCOrd, CCIO, CCRandom, CCKTree, CCTrie, CCString, CCHashtbl, - CCFlatHashtbl, CCSexp + CCFlatHashtbl, CCSexp, CCMap FindlibName: containers Library "containers_string" diff --git a/core/CCMap.ml b/core/CCMap.ml new file mode 100644 index 00000000..bb92ab80 --- /dev/null +++ b/core/CCMap.ml @@ -0,0 +1,41 @@ + +(* +copyright (c) 2013-2014, simon cruanes +all rights reserved. + +redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Extensions of Standard Map} *) + +module type S = sig + include Map.S + + val to_list : 'a t -> (key * 'a) list +end + +module Make(O : Map.OrderedType) = struct + include Map.Make(O) + + let to_list m = + fold (fun k v acc -> (k,v)::acc) m [] +end + diff --git a/core/CCMap.mli b/core/CCMap.mli new file mode 100644 index 00000000..25493a22 --- /dev/null +++ b/core/CCMap.mli @@ -0,0 +1,40 @@ + +(* +copyright (c) 2013-2014, simon cruanes +all rights reserved. + +redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Extensions of Standard Map} + +Provide useful functions and iterators on [Map.S] +@since NEXT_RELEASE *) + +module type S = sig + include Map.S + + val to_list : 'a t -> (key * 'a) list +end + +module Make(O : Map.OrderedType) : S + with type 'a t = 'a Map.Make(O).t + and type key = O.t From de494e9667eba7e263a7e67d2f038ffbe2421741 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 20 Oct 2014 18:28:44 +0200 Subject: [PATCH 05/29] a bunch of useful functions in CCMap --- core/CCMap.ml | 79 ++++++++++++++++++++++++++++++++++++++++++++++++++ core/CCMap.mli | 25 ++++++++++++++++ 2 files changed, 104 insertions(+) diff --git a/core/CCMap.ml b/core/CCMap.ml index bb92ab80..f2b7c50b 100644 --- a/core/CCMap.ml +++ b/core/CCMap.ml @@ -26,16 +26,95 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Extensions of Standard Map} *) +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Buffer.t -> 'a -> unit +type 'a formatter = Format.formatter -> 'a -> unit + module type S = sig include Map.S + val get : key -> 'a t -> 'a option + (** Safe version of {!find} *) + + 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] + [k] is removed from [m], and if the result is [Some v'] then + [add k v' m] is returned. *) + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + val of_list : (key * 'a) list -> 'a t + 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 print : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> + key formatter -> 'a formatter -> 'a t formatter end module Make(O : Map.OrderedType) = struct include Map.Make(O) + let get k m = + try Some (find k m) + with Not_found -> None + + 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 + + let of_seq s = + let m = ref empty in + s (fun (k,v) -> m := add k v !m); + !m + + let to_seq m yield = + iter (fun k v -> yield (k,v)) m + + let of_list l = + List.fold_left + (fun m (k,v) -> add k v m) empty l + let to_list m = fold (fun k v acc -> (k,v)::acc) m [] + + let pp ?(start="{") ?(stop="}") ?(arrow="->") ?(sep=", ") pp_k pp_v buf m = + let first = ref true in + 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; + Buffer.add_string buf stop + + (*$T + CCPrint.to_string (pp CCPrint.int) [1;2;3] = "[1, 2, 3]" + *) + + let print ?(start="[") ?(stop="]") ?(arrow="->") ?(sep=", ") pp_k pp_v fmt m = + Format.pp_print_string fmt start; + let first = ref true in + iter + (fun k v -> + if !first then first := false else Format.pp_print_string fmt sep; + pp_k fmt k; + Format.pp_print_string fmt arrow; + pp_v fmt v; + Format.pp_print_cut fmt () + ) m; + Format.pp_print_string fmt stop end diff --git a/core/CCMap.mli b/core/CCMap.mli index 25493a22..385c714a 100644 --- a/core/CCMap.mli +++ b/core/CCMap.mli @@ -29,10 +29,35 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Provide useful functions and iterators on [Map.S] @since NEXT_RELEASE *) +type 'a sequence = ('a -> unit) -> unit +type 'a printer = Buffer.t -> 'a -> unit +type 'a formatter = Format.formatter -> 'a -> unit + module type S = sig include Map.S + val get : key -> 'a t -> 'a option + (** Safe version of {!find} *) + + 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] + [k] is removed from [m], and if the result is [Some v'] then + [add k v' m] is returned. *) + + val of_seq : (key * 'a) sequence -> 'a t + + val to_seq : 'a t -> (key * 'a) sequence + + val of_list : (key * 'a) list -> 'a t + 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 print : ?start:string -> ?stop:string -> ?arrow:string -> ?sep:string -> + key formatter -> 'a formatter -> 'a t formatter end module Make(O : Map.OrderedType) : S From 56132eacad86e43444a36bbdf30d4e6c64ac70fb Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 20 Oct 2014 23:03:59 +0200 Subject: [PATCH 06/29] removed useless comment --- core/CCMap.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/core/CCMap.ml b/core/CCMap.ml index f2b7c50b..0ae3cb3f 100644 --- a/core/CCMap.ml +++ b/core/CCMap.ml @@ -100,10 +100,6 @@ module Make(O : Map.OrderedType) = struct ) m; Buffer.add_string buf stop - (*$T - CCPrint.to_string (pp CCPrint.int) [1;2;3] = "[1, 2, 3]" - *) - let print ?(start="[") ?(stop="]") ?(arrow="->") ?(sep=", ") pp_k pp_v fmt m = Format.pp_print_string fmt start; let first = ref true in From 1374a2741c0ae61e2d95c3e60c62086786f842d5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 28 Oct 2014 16:38:56 +0100 Subject: [PATCH 07/29] CCInt.neg --- core/CCInt.ml | 2 ++ core/CCInt.mli | 4 ++++ 2 files changed, 6 insertions(+) diff --git a/core/CCInt.ml b/core/CCInt.ml index 29a898e3..4a7bbf1f 100644 --- a/core/CCInt.ml +++ b/core/CCInt.ml @@ -37,6 +37,8 @@ let sign i = else if i>0 then 1 else 0 +let neg i = -i + type 'a printer = Buffer.t -> 'a -> unit type 'a formatter = Format.formatter -> 'a -> unit type 'a random_gen = Random.State.t -> 'a diff --git a/core/CCInt.mli b/core/CCInt.mli index e62291a1..3fcd33ac 100644 --- a/core/CCInt.mli +++ b/core/CCInt.mli @@ -37,6 +37,10 @@ val hash : t -> int val sign : t -> int (** [sign i] is one of [-1, 0, 1] *) +val neg : t -> t +(** [neg i = - i] + @since NEXT_RELEASE *) + type 'a printer = Buffer.t -> 'a -> unit type 'a formatter = Format.formatter -> 'a -> unit type 'a random_gen = Random.State.t -> 'a From ad705fd75823e5374ba2b89f8cd1298891a69fd3 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 20 Oct 2014 23:29:17 +0200 Subject: [PATCH 08/29] add Format printers to CCString --- core/CCString.ml | 7 +++++++ core/CCString.mli | 1 + 2 files changed, 8 insertions(+) diff --git a/core/CCString.ml b/core/CCString.ml index 6d926f43..f1a6ee14 100644 --- a/core/CCString.ml +++ b/core/CCString.ml @@ -46,6 +46,7 @@ module type S = sig val to_list : t -> char list val pp : Buffer.t -> t -> unit + val print : Format.formatter -> t -> unit end let equal (a:string) b = a=b @@ -251,6 +252,9 @@ let pp buf s = Buffer.add_string buf s; Buffer.add_char buf '"' +let print fmt s = + Format.fprintf fmt "\"%s\"" s + module Sub = struct type t = string * int * int @@ -284,4 +288,7 @@ module Sub = struct Buffer.add_char buf '"'; Buffer.add_substring buf s i len; Buffer.add_char buf '"' + + let print fmt s = + Format.fprintf fmt "\"%s\"" (copy s) end diff --git a/core/CCString.mli b/core/CCString.mli index 78059fff..8945e525 100644 --- a/core/CCString.mli +++ b/core/CCString.mli @@ -50,6 +50,7 @@ module type S = sig val to_list : t -> char list val pp : Buffer.t -> t -> unit + val print : Format.formatter -> t -> unit end (** {2 Strings} *) From 786334dcce3db3ea7d441228d44221309fdbf019 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 30 Oct 2014 01:48:16 +0100 Subject: [PATCH 09/29] use Buffer whenever string mutation is needed --- core/CCString.ml | 39 +++++++++++++++------------------------ core/CCTrie.ml | 6 +++--- string/levenshtein.ml | 6 +++--- 3 files changed, 21 insertions(+), 30 deletions(-) diff --git a/core/CCString.ml b/core/CCString.ml index f1a6ee14..a35c8c3f 100644 --- a/core/CCString.ml +++ b/core/CCString.ml @@ -56,9 +56,9 @@ let compare = String.compare let hash s = Hashtbl.hash s let init n f = - let s = String.make n ' ' in - for i = 0 to n-1 do s.[i] <- f i done; - s + let buf = Buffer.create n in + for i = 0 to n-1 do Buffer.add_char buf (f i) done; + Buffer.contents buf let length = String.length @@ -168,11 +168,7 @@ let repeat s n = assert (n>=0); let len = String.length s in assert(len > 0); - let buf = String.create (len * n) in - for i = 0 to n-1 do - String.blit s 0 buf (i * len) len; - done; - buf + init (len * n) (fun i -> s.[i mod len]) let prefix ~pre s = String.length pre <= String.length s && @@ -213,26 +209,23 @@ let rec _to_klist s i len () = else `Cons (s.[i], _to_klist s (i+1)(len-1)) let of_klist l = - let rec aux acc n l = match l() with + let b = Buffer.create 15 in + let rec aux l = match l() with | `Nil -> - let s = String.create n in - let acc = ref acc in - for i=n-1 downto 0 do - s.[i] <- List.hd !acc; - acc := List.tl !acc - done; - s - | `Cons (x,l') -> aux (x::acc) (n+1) l' - in aux [] 0 l + Buffer.contents b + | `Cons (x,l') -> + Buffer.add_char b x; + aux l' + in aux l let to_klist s = _to_klist s 0 (String.length s) let to_list s = _to_list s [] 0 (String.length s) let of_list l = - let s = String.make (List.length l) ' ' in - List.iteri (fun i c -> s.[i] <- c) l; - s + let buf = Buffer.create (List.length l) in + List.iter (Buffer.add_char buf) l; + Buffer.contents buf (*$T of_list ['a'; 'b'; 'c'] = "abc" @@ -240,9 +233,7 @@ let of_list l = *) let of_array a = - let s = String.make (Array.length a) ' ' in - Array.iteri (fun i c -> s.[i] <- c) a; - s + init (Array.length a) (fun i -> a.(i)) let to_array s = Array.init (String.length s) (fun i -> s.[i]) diff --git a/core/CCTrie.ml b/core/CCTrie.ml index de04ec32..c4900000 100644 --- a/core/CCTrie.ml +++ b/core/CCTrie.ml @@ -535,9 +535,9 @@ module String = Make(struct let compare = Char.compare let to_seq s k = String.iter k s let of_list l = - let s = String.create (List.length l) in - List.iteri (fun i c -> s.[i] <- c) l; - s + let buf = Buffer.create (List.length l) in + List.iter (fun c -> Buffer.add_char buf c) l; + Buffer.contents buf end) (*$T diff --git a/string/levenshtein.ml b/string/levenshtein.ml index cf9b4f9d..04e65dcc 100644 --- a/string/levenshtein.ml +++ b/string/levenshtein.ml @@ -643,9 +643,9 @@ include Make(struct let length = String.length let get = String.get let of_list l = - let s = String.make (List.length l) ' ' in - List.iteri (fun i c -> s.[i] <- c) l; - s + let buf = Buffer.create (List.length l) in + List.iter (fun c -> Buffer.add_char buf c) l; + Buffer.contents buf end) let debug_print = debug_print output_char From 76c9254dec599df2394de33f49a726901dec60f5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 4 Nov 2014 15:21:09 +0100 Subject: [PATCH 10/29] thanks to @whitequark, could use cppo for preprocessing files --- AUTHORS.md | 2 +- _oasis | 2 +- configure | 4 ++-- myocamlbuild.ml | 47 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 51 insertions(+), 4 deletions(-) create mode 100644 myocamlbuild.ml diff --git a/AUTHORS.md b/AUTHORS.md index 0e5a2e95..61fe076f 100644 --- a/AUTHORS.md +++ b/AUTHORS.md @@ -4,4 +4,4 @@ - Drup (Gabriel Radanne) - Jacques-Pascal Deplaix - Nicolas Braud-Santoni - +- Whitequark (Peter Zotov) diff --git a/_oasis b/_oasis index 23032165..ff9b90c0 100644 --- a/_oasis +++ b/_oasis @@ -8,7 +8,7 @@ LicenseFile: LICENSE Plugins: META (0.3), DevFiles (0.3) OCamlVersion: >= 4.00.1 BuildTools: ocamlbuild -AlphaFeatures: compiled_setup_ml +AlphaFeatures: ocamlbuild_more_args, compiled_setup_ml Synopsis: A modular standard library focused on data structures. Description: diff --git a/configure b/configure index 42fb4c31..d2a26d17 100755 --- a/configure +++ b/configure @@ -1,7 +1,7 @@ #!/bin/sh # OASIS_START -# DO NOT EDIT (digest: 82230d61386befb40bc7377608e1f16e) +# DO NOT EDIT (digest: 6f7b8221311e800a7093dc3b793f67ca) set -e FST=true @@ -23,5 +23,5 @@ for i in "$@"; do esac done -make configure CONFIGUREFLAGS="$@" +make configure CONFIGUREFLAGS="$*" # OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 00000000..06976423 --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,47 @@ +(* OASIS_START *) +(* OASIS_STOP *) + +open Ocamlbuild_plugin;; + +dispatch + (MyOCamlbuildBase.dispatch_combine [ + begin function + | After_rules -> + (* replace with Ocamlbuild_cppo.dispatch when 4.00 is not supported + anymore *) + let dep = "%(name).cppo.ml" in + let prod1 = "%(name: <*> and not <*.cppo>).ml" in + let prod2 = "%(name: <**/*> and not <**/*.cppo>).ml" in + let f prod env _build = + let dep = env dep in + let prod = env prod in + let tags = tags_of_pathname prod ++ "cppo" in + Cmd (S[A "cppo"; T tags; S [A "-o"; P prod]; P dep ]) + in + rule "cppo1" ~dep ~prod:prod1 (f prod1) ; + rule "cppo2" ~dep ~prod:prod2 (f prod2) ; + pflag ["cppo"] "cppo_D" (fun s -> S [A "-D"; A s]) ; + pflag ["cppo"] "cppo_U" (fun s -> S [A "-U"; A s]) ; + pflag ["cppo"] "cppo_I" (fun s -> + if Pathname.is_directory s then S [A "-I"; P s] + else S [A "-I"; P (Pathname.dirname s)] + ) ; + pdep ["cppo"] "cppo_I" (fun s -> + if Pathname.is_directory s then [] else [s]) ; + flag ["cppo"; "cppo_q"] (A "-q") ; + flag ["cppo"; "cppo_s"] (A "-s") ; + flag ["cppo"; "cppo_n"] (A "-n") ; + pflag ["cppo"] "cppo_x" (fun s -> S [A "-x"; A s]); + (* end replace *) + + let major, minor = Scanf.sscanf Sys.ocaml_version "%d.%d.%d" + (fun major minor patchlevel -> major, minor) + in + let ocaml_major = "OCAML_MAJOR " ^ string_of_int major in + let ocaml_minor = "OCAML_MINOR " ^ string_of_int minor in + + flag ["cppo"] & S[A"-D"; A ocaml_major; A"-D"; A ocaml_minor] + | _ -> () + end; + dispatch_default + ]) From 5c559c2099022b642e6df0b9dc6513323b56ba41 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 4 Nov 2014 15:27:24 +0100 Subject: [PATCH 11/29] containers now depends on cppo --- _oasis | 1 + 1 file changed, 1 insertion(+) diff --git a/_oasis b/_oasis index ff9b90c0..354e71f8 100644 --- a/_oasis +++ b/_oasis @@ -49,6 +49,7 @@ Library "containers" CCKList, CCInt, CCBool, CCArray, CCOrd, CCIO, CCRandom, CCKTree, CCTrie, CCString, CCHashtbl, CCFlatHashtbl, CCSexp, CCMap + BuildDepends: cppo FindlibName: containers Library "containers_string" From 611086e6ab4cb52bfa9578eb4167c7df0740653a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 4 Nov 2014 15:48:14 +0100 Subject: [PATCH 12/29] make some functions in CCFun and CCString depend on ocaml version --- _oasis | 4 ++-- core/{CCFun.ml => CCFun.cppo.ml} | 10 ++++++++++ core/CCFun.mli | 6 +++++- core/{CCString.ml => CCString.cppo.ml} | 8 ++++++++ 4 files changed, 25 insertions(+), 3 deletions(-) rename core/{CCFun.ml => CCFun.cppo.ml} (91%) rename core/{CCString.ml => CCString.cppo.ml} (98%) diff --git a/_oasis b/_oasis index 354e71f8..38f5e31b 100644 --- a/_oasis +++ b/_oasis @@ -8,7 +8,7 @@ LicenseFile: LICENSE Plugins: META (0.3), DevFiles (0.3) OCamlVersion: >= 4.00.1 BuildTools: ocamlbuild -AlphaFeatures: ocamlbuild_more_args, compiled_setup_ml +AlphaFeatures: compiled_setup_ml Synopsis: A modular standard library focused on data structures. Description: @@ -49,7 +49,7 @@ Library "containers" CCKList, CCInt, CCBool, CCArray, CCOrd, CCIO, CCRandom, CCKTree, CCTrie, CCString, CCHashtbl, CCFlatHashtbl, CCSexp, CCMap - BuildDepends: cppo + XMETARequires: cppo FindlibName: containers Library "containers_string" diff --git a/core/CCFun.ml b/core/CCFun.cppo.ml similarity index 91% rename from core/CCFun.ml rename to core/CCFun.cppo.ml index 55f1a337..49e2fada 100644 --- a/core/CCFun.ml +++ b/core/CCFun.cppo.ml @@ -26,7 +26,17 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Basic Functions} *) +#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 2 + +external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply" +external (@@) : ('a -> 'b) -> 'a -> 'b = "%apply" + +#else + let (|>) x f = f x +let (@@) f x = f x + +#endif let compose f g x = g (f x) diff --git a/core/CCFun.mli b/core/CCFun.mli index 40aed09e..59af0e40 100644 --- a/core/CCFun.mli +++ b/core/CCFun.mli @@ -27,7 +27,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (** {1 Basic Functions} *) val (|>) : 'a -> ('a -> 'b) -> 'b -(** Pipeline (naive implementation) *) +(** Pipeline. [x |> f] is the same as [f x]. *) val compose : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c (** Composition *) @@ -35,6 +35,10 @@ val compose : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c val (%>) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c (** Alias to [compose] *) +val (@@) : ('a -> 'b) -> 'a -> 'b +(** [f @@ x] is the same as [f x], but right-associative. + @since NEXT_RELEASE *) + val id : 'a -> 'a (** Identity function *) diff --git a/core/CCString.ml b/core/CCString.cppo.ml similarity index 98% rename from core/CCString.ml rename to core/CCString.cppo.ml index a35c8c3f..3948c8a2 100644 --- a/core/CCString.ml +++ b/core/CCString.cppo.ml @@ -55,11 +55,19 @@ let compare = String.compare let hash s = Hashtbl.hash s +#if OCAML_MAJOR >= 4 && OCAML_MINOR >= 2 + +let init = String.init + +#else + let init n f = let buf = Buffer.create n in for i = 0 to n-1 do Buffer.add_char buf (f i) done; Buffer.contents buf +#endif + let length = String.length let rec _to_list s acc i len = From d3af230de90659cd2f146663979819a2320825e1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 4 Nov 2014 16:44:15 +0100 Subject: [PATCH 13/29] fix tests by making oasis build qtest itself --- Makefile | 28 ++++++++++++++-------------- _oasis | 21 ++++++++++++++++----- 2 files changed, 30 insertions(+), 19 deletions(-) diff --git a/Makefile b/Makefile index b5127b33..40955067 100644 --- a/Makefile +++ b/Makefile @@ -47,7 +47,7 @@ setup.exe: setup.ml EXAMPLES = examples/mem_size.native examples/collatz.native \ examples/bencode_write.native # examples/crawl.native -OPTIONS = -use-ocamlfind +OPTIONS = -use-ocamlfind -I _build examples: all ocamlbuild $(OPTIONS) -package unix -I . $(EXAMPLES) @@ -58,7 +58,7 @@ push_doc: doc scp -r containers_advanced.docdir/* cedeela.fr:~/simon/root/software/containers/advanced scp -r containers_misc.docdir/* cedeela.fr:~/simon/root/software/containers/misc/ -DONTTEST=myocamlbuild.ml setup.ml +DONTTEST=myocamlbuild.ml setup.ml $(wildcard **/*.cppo*) QTESTABLE=$(filter-out $(DONTTEST), \ $(wildcard core/*.ml) $(wildcard core/*.mli) \ $(wildcard misc/*.ml) $(wildcard misc/*.mli) \ @@ -70,16 +70,16 @@ qtest-clean: QTEST_PREAMBLE='open CCFun;; ' -qtest-build: qtest-clean build - @mkdir -p qtest - @qtest extract --preamble $(QTEST_PREAMBLE) -o qtest/qtest_all.ml $(QTESTABLE) 2> /dev/null - @ocamlbuild $(OPTIONS) -pkg oUnit,QTest2Lib \ - -I core -I misc -I string \ - qtest/qtest_all.native +#qtest-build: qtest-clean build +# @mkdir -p qtest +# @qtest extract --preamble $(QTEST_PREAMBLE) -o qtest/qtest_all.ml $(QTESTABLE) 2> /dev/null +# @ocamlbuild $(OPTIONS) -pkg oUnit,QTest2Lib,ocamlbuildlib \ +# -I core -I misc -I string \ +# qtest/qtest_all.native -qtest: qtest-build - @echo - ./qtest_all.native +qtest-gen: qtest-clean + @mkdir -p qtest + @qtest extract --preamble $(QTEST_PREAMBLE) -o qtest/run_qtest.ml $(QTESTABLE) 2> /dev/null push-stable: git checkout stable @@ -92,11 +92,11 @@ push-stable: clean-generated: rm **/*.{mldylib,mlpack,mllib} myocamlbuild.ml -f -run-test: build qtest-build - ./qtest_all.native +run-test: build + ./run_qtest.native ./run_tests.native -test-all: run-test qtest +test-all: run-test tags: otags *.ml *.mli diff --git a/_oasis b/_oasis index 38f5e31b..c289206a 100644 --- a/_oasis +++ b/_oasis @@ -208,10 +208,16 @@ Executable test_threads MainIs: test_Future.ml BuildDepends: containers,threads,oUnit,containers.lwt -Test all - Command: make test-all - TestTools: run_tests - Run$: flag(tests) +PreBuildCommand: make qtest-gen + +Executable run_qtest + Path: qtest/ + Install: false + CompiledObject: native + MainIs: run_qtest.ml + Build$: flag(tests) + BuildDepends: containers, containers.misc, containers.string, + oUnit, QTest2Lib Executable run_tests Path: tests/ @@ -219,7 +225,12 @@ Executable run_tests CompiledObject: native MainIs: run_tests.ml Build$: flag(tests) && flag(misc) - BuildDepends: containers,oUnit,qcheck,containers.misc + BuildDepends: containers, oUnit, qcheck, containers.misc + +Test all + Command: make test-all + TestTools: run_tests, run_qtest + Run$: flag(tests) && flag(misc) Executable web_pwd Path: examples/cgi/ From d75317253d202f44f3d84c8d0a5a57450e7b797f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 4 Nov 2014 20:56:38 +0100 Subject: [PATCH 14/29] remove some junk from misc/ --- _oasis | 8 +- misc/actionMan.ml | 159 ----------------- misc/actionMan.mli | 94 ---------- misc/bencode.ml | 363 -------------------------------------- misc/bencode.mli | 130 -------------- misc/bencodeOnDisk.ml | 136 -------------- misc/bencodeOnDisk.mli | 60 ------- misc/bencodeStream.ml | 156 ---------------- misc/bencodeStream.mli | 65 ------- misc/bencode_write_par.sh | 13 -- misc/bij.ml | 136 -------------- misc/bij.mli | 22 --- misc/tell.ml | 111 ------------ misc/tell.mli | 73 -------- tests/run_tests.ml | 3 - tests/test_bencode.ml | 71 -------- tests/test_bij.ml | 91 ---------- 17 files changed, 3 insertions(+), 1688 deletions(-) delete mode 100644 misc/actionMan.ml delete mode 100644 misc/actionMan.mli delete mode 100644 misc/bencode.ml delete mode 100644 misc/bencode.mli delete mode 100644 misc/bencodeOnDisk.ml delete mode 100644 misc/bencodeOnDisk.mli delete mode 100644 misc/bencodeStream.ml delete mode 100644 misc/bencodeStream.mli delete mode 100755 misc/bencode_write_par.sh delete mode 100644 misc/tell.ml delete mode 100644 misc/tell.mli delete mode 100644 tests/test_bencode.ml delete mode 100644 tests/test_bij.ml diff --git a/_oasis b/_oasis index c289206a..73a75682 100644 --- a/_oasis +++ b/_oasis @@ -80,11 +80,9 @@ Library "containers_misc" Modules: Cache, FHashtbl, FlatHashtbl, Hashset, Heap, LazyGraph, PersistentGraph, PHashtbl, SkipList, SplayTree, SplayMap, Univ, - Bij, PiCalculus, Bencode, RAL, - UnionFind, SmallSet, AbsSet, CSM, - ActionMan, BencodeOnDisk, TTree, PrintBox, - HGraph, Automaton, Conv, Bidir, Iteratee, BTree, - Ty, Tell, BencodeStream, RatTerm, Cause, AVL, ParseReact + Bij, PiCalculus, RAL, UnionFind, SmallSet, AbsSet, CSM, + TTree, PrintBox, HGraph, Automaton, Conv, Bidir, Iteratee, + BTree, Ty, Cause, AVL, ParseReact BuildDepends: unix,containers FindlibName: misc FindlibParent: containers diff --git a/misc/actionMan.ml b/misc/actionMan.ml deleted file mode 100644 index 025df2a6..00000000 --- a/misc/actionMan.ml +++ /dev/null @@ -1,159 +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. -*) - -(** {6 Action Language for command line} *) - -module Action = struct - type trigger = string - - type _ t = - | Return : 'a -> 'a t - | Bind : 'a t * ('a -> 'b t) -> 'b t - | Ignore : ('a t * 'b t) -> 'b t - | Any : string t - | ReadInt : (int -> 'a t) -> 'a t - | ReadString : (string -> 'a t) -> 'a t - | ReadBool : (bool -> 'a t) -> 'a t - | Choice : 'a t list -> 'a t - | Fail : string -> 'a t - - let return x = Return x - - let (>>=) x f = Bind (x, f) - - let (>>) x f = Bind (x, (fun _ -> f ())) - - let ( *>) a b = Ignore (a, b) - - let ignore x = x *> return () - - let any = Any - - let accept trigger = - Any >>= fun x -> - if x = trigger - then return () - else Fail ("expected trigger \"" ^ trigger ^ "\"") - - let with_string ?trigger f = - match trigger with - | None -> ReadString f - | Some t -> accept t *> ReadString f - - let with_int ?trigger f = - match trigger with - | None -> ReadInt f - | Some t -> accept t *> ReadInt f - - let with_bool ?trigger f = - match trigger with - | None -> ReadBool f - | Some t -> accept t *> ReadBool f - - let choice l = Choice l - - let repeat act = - let rec try_next acc = - choice - [ act >>= (fun x -> try_next (x::acc)) - ; return acc - ] - in - (try_next []) >>= (fun l -> return (List.rev l)) - - let opt act = - choice [ act >>= (fun x -> return (Some x)); return None ] - - let fail msg = Fail msg -end - -type 'a result = - | Ok of 'a - | Error of string - -type 'a partial_result = - | POk of 'a * int (* value and position in args *) - | PError of string (* error message *) - -let parse_args args (act : 'a Action.t) : 'a result = - let module A = Action in - (* interpret recursively, with backtracking. Returns partial result *) - let rec interpret : type a. string array -> int -> a Action.t -> a partial_result - = fun args i act -> - let n = Array.length args in - match act with - | A.Return x -> POk (x, i) - | A.Bind (x, f) -> - begin match interpret args i x with - | POk (x, i') -> interpret args i' (f x) - | PError msg -> PError msg - end - | A.Ignore (a, b) -> - begin match interpret args i a with - | POk (_, i') -> interpret args i' b - | PError msg -> PError msg - end - | A.Any when i >= n -> mk_error i "expected [any], reached end" - | A.Any -> POk (args.(i), i+1) - | A.ReadInt f when i >= n -> mk_error i "expected [int], reached end" - | A.ReadInt f -> - begin try - let j = int_of_string args.(i) in - interpret args (i+1) (f j) - with Failure _ -> mk_error i "expected [int]" - end - | A.ReadString _ when i >= n -> mk_error i "expected [string], reached end" - | A.ReadString f -> interpret args (i+1) (f args.(i)) - | A.ReadBool _ -> failwith "not implemented: read bool" (* TODO *) - | A.Fail msg -> mk_error i msg - | A.Choice l -> try_choices args i [] l - (* try the actions remaining in [l], whenre [errors] is the list - of errors in already tried branches *) - and try_choices : type a. string array -> int -> string list -> a Action.t list -> a partial_result - = fun args i errors l -> - match l with - | [] -> - let msg = Printf.sprintf "choice failed: [%s]" (String.concat " | " errors) in - mk_error i msg - | act::l' -> - begin match interpret args i act with - | POk _ as res -> res (* success! *) - | PError msg -> - try_choices args i (msg :: errors) l' - end - (* report error *) - and mk_error : type a. int -> string -> a partial_result - = fun i msg -> - PError (Printf.sprintf "at arg %d: %s" i msg) - in - match interpret args 1 act with - | POk (x,_) -> Ok x - | PError msg -> Error msg - -let parse act = parse_args Sys.argv act - -let print_doc oc act = - failwith "print_doc: not implemented" diff --git a/misc/actionMan.mli b/misc/actionMan.mli deleted file mode 100644 index bcced976..00000000 --- a/misc/actionMan.mli +++ /dev/null @@ -1,94 +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. -*) - -(** {6 Action Language for command line} *) - -(** {2 Command-line Actions} *) - -module Action : sig - type 'a t - (** Action returning a 'a *) - - type trigger = string - (** Trigger a given action, based on the next token *) - - val return : 'a -> 'a t - (** Return a pure value *) - - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - (** CCSequence of arguments *) - - val (>>) : 'a t -> (unit -> 'b t) -> 'b t - (** Same as {! (>>=)}, but ignores the result of left side *) - - val ( *>) : 'a t -> 'b t -> 'b t - (** Accept left, then returns right *) - - val accept : trigger -> unit t - (** Accept the given trigger, fails otherwise *) - - val any : string t - (** Any token *) - - val with_string : ?trigger:trigger -> (string -> 'a t) -> 'a t - (** Command that takes a string *) - - val with_int : ?trigger:trigger -> (int -> 'a t) -> 'a t - (** Command that takes an integer *) - - val with_bool : ?trigger:trigger -> (bool -> 'a t) -> 'a t - - val opt : 'a t -> 'a option t - (** Optional action *) - - val repeat : 'a t -> 'a list t - (** Repeated action *) - - val choice : 'a t list -> 'a t - (** Choice between options. The first option of the list that - does not fail will be the result (backtracking is used!) *) - - val ignore : 'a t -> unit t - (** Ignore result *) - - val fail : string -> 'a t - (** Fail with given message *) -end - -(** {2 Main interface} *) - -type 'a result = - | Ok of 'a - | Error of string - -val parse_args : string array -> 'a Action.t -> 'a result - (** Parse given command line *) - -val parse : 'a Action.t -> 'a result - (** Parse Sys.argv *) - -val print_doc : out_channel -> 'a Action.t -> unit - (** Print documentation on given channel *) diff --git a/misc/bencode.ml b/misc/bencode.ml deleted file mode 100644 index 04e64656..00000000 --- a/misc/bencode.ml +++ /dev/null @@ -1,363 +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. -*) - -(** {6 B-encoding} *) - - -module SMap = Map.Make(String) - -type t = - | I of int - | S of string - | L of t list - | D of t SMap.t - -let rec eq t1 t2 = match t1, t2 with - | I i1, I i2 -> i1 = i2 - | S s1, S s2 -> s1 = s2 - | L l1, L l2 -> - (try List.for_all2 eq l1 l2 with Invalid_argument _ -> false) - | D d1, D d2 -> - SMap.equal eq d1 d2 - | _ -> false - -let hash t = Hashtbl.hash t - -let dict_of_list l = - let d = List.fold_left - (fun d (k, v) -> SMap.add k v d) - SMap.empty l - in - D d - -(** {2 Serialization (encoding)} *) - -(* length of an encoded int, in bytes *) -let _len_int i = - match i with - | 0 -> 1 - | _ when i < 0 -> 2 + int_of_float (log10 (float_of_int ~-i)) - | _ -> 1 + int_of_float (log10 (float_of_int i)) - -(* length of an encoded string, in bytes *) -let _len_str s = - _len_int (String.length s) + 1 + String.length s - -let rec size t = match t with - | I i -> 2 + _len_int i - | S s -> _len_str s - | L l -> List.fold_left (fun acc i -> acc + size i) 2 l - | D map -> SMap.fold (fun k v acc -> acc + _len_str k + size v) map 2 - -let write_in_string t buf o = - let pos = ref o in - let rec append t = match t with - | I i -> write_char 'i'; write_int i; write_char 'e' - | S s -> write_str s - | L l -> - write_char 'l'; - List.iter append l; - write_char 'e'; - | D m -> - write_char 'd'; - SMap.iter (fun key t' -> write_str key; append t') m; - write_char 'e' - and write_int i = - let s = string_of_int i in - String.blit s 0 buf !pos (String.length s); - pos := !pos + String.length s - and write_str s = - write_int (String.length s); - write_char ':'; - String.blit s 0 buf !pos (String.length s); - pos := !pos + String.length s - and write_char c = - buf.[!pos] <- c; - incr pos - in - append t - -let to_string t = - let len = size t in - let s = String.create len in - write_in_string t s 0; - s - -let to_buf buf t = - Buffer.add_string buf (to_string t) - -let to_chan ch t = - let b = Buffer.create 25 in - to_buf b t; - Buffer.output_buffer ch b - -let fmt formatter t = - let b = Buffer.create 25 in - to_buf b t; - Format.pp_print_string formatter (Buffer.contents b) - -let rec pretty fmt t = match t with - | I i -> Format.fprintf fmt "%d" i - | S s -> Format.fprintf fmt "@[\"%s\"@]" s - | L l -> - Format.fprintf fmt "@[[@,"; - List.iteri (fun i t' -> (if i > 0 then Format.pp_print_char fmt ' '); pretty fmt t') l; - Format.fprintf fmt "]@]"; - | D d -> - Format.fprintf fmt "@[{@,"; - SMap.iter - (fun k t' -> Format.fprintf fmt "%a -> %a@ " pretty (S k) pretty t') - d; - Format.fprintf fmt "}@]"; - () - -let pretty_to_str t = - let b = Buffer.create 15 in - Format.fprintf (Format.formatter_of_buffer b) "%a@?" pretty t; - Buffer.contents b - -(** {2 Deserialization (decoding)} *) - -(** Deserialization is based on the {! decoder} type. Parsing can be - incremental, in which case the input is provided chunk by chunk and - the decoder contains the parsing state. Once a B-encoded value - has been parsed, other values can still be read. *) - -type decoder = { - mutable buf : string; (* buffer *) - mutable i : int; (* index in buf *) - mutable len : int; (* length of substring to read *) - mutable c : int; (* line *) - mutable l : int; (* column *) - mutable state : parse_result; - mutable stack : partial_state list; -} - -(** Result of parsing *) -and parse_result = - | ParseOk of t - | ParseError of string - | ParsePartial - -(** Partial state of the parser *) -and partial_state = - | PS_I of bool * int (* sign and integer *) - | PS_S of int ref * string (* index in string, plus string *) - | PS_L of t list - | PS_D of t SMap.t (* in dictionary *) - | PS_D_key of string * t SMap.t (* parsed key, wait for value *) - | PS_return of t (* bottom of stack *) - | PS_error of string (* error *) - -let mk_decoder () = - let dec = { - buf = ""; - i = 0; - len = 0; - c = 0; - l = 0; - state = ParsePartial; - stack = []; - } in - dec - -let is_empty dec = dec.len = 0 -let cur dec = dec.buf.[dec.i] - -let junk dec = - (* update line/column *) - (if cur dec = '\n' - then (dec.c <- 0; dec.l <- dec.l + 1) - else dec.c <- dec.c + 1); - dec.i <- dec.i + 1; - dec.len <- dec.len - 1 - -let next dec = - let c = cur dec in - junk dec; - c - -(* parse value *) -let rec parse_rec dec = - match dec.stack with - | [PS_return v] -> (* return value *) - dec.stack <- []; - dec.state <- ParseOk v; - dec.state - | [PS_error s] -> (* failure *) - dec.stack <- []; - dec.state <- ParseError s; - dec.state - | _ -> - if is_empty dec then ParsePartial (* wait *) - else begin - let c = next dec in - (match dec.stack, c with - | (PS_I (sign, i)) :: stack, '0' .. '9' -> - dec.stack <- PS_I (sign, (Char.code c - Char.code '0') + 10 * i) :: stack; - | (PS_I (_, 0)) :: stack, '-' -> - dec.stack <- PS_I (false, 0) :: stack (* negative number *) - | (PS_I (sign, i)) :: stack, 'e' -> - dec.stack <- stack; - push_value dec (I (if sign then i else ~- i)) - | ((PS_D _ | PS_D_key _ | PS_L _) :: _ | []), '0' .. '9' -> - (* initial length of string *) - dec.stack <- (PS_I (true, Char.code c - Char.code '0')) :: dec.stack - | (PS_I (sign, i)) :: stack, ':' -> - if i < 0 - then error dec "string length cannot be negative" - else if i = 0 then (* empty string *) - let _ = dec.stack <- stack in - push_value dec (S "") - else (* prepare to parse a string *) - dec.stack <- (PS_S (ref 0, String.create i)) :: stack; - | (PS_S (n, s)) :: stack, _ -> - s.[!n] <- c; - incr n; - (* value completed *) - (if !n = String.length s - then - let _ = dec.stack <- stack in - push_value dec (S s)); - | stack, 'i' -> - dec.stack <- (PS_I (true, 0)) :: stack - | stack, 'l' -> - dec.stack <- PS_L [] :: stack; - | stack, 'd' -> - dec.stack <- PS_D SMap.empty :: stack - | (PS_L l) :: stack, 'e' -> (* end of list *) - dec.stack <- stack; - push_value dec (L (List.rev l)) - | (PS_D d) :: stack, 'e' -> (* end of dict *) - dec.stack <- stack; - push_value dec (D d) - | (PS_D_key _) :: _, 'e' -> (* error *) - error dec "missing value in dict" - | _ -> (* generic error *) - error dec (Printf.sprintf "expected value, got %c" c)); - parse_rec dec - end -(* When a value is parsed, push it on the stack (possibly collapsing it) *) -and push_value dec v = - match v, dec.stack with - | _, [] -> - dec.stack <- [PS_return v] (* finished *) - | _, (PS_L l) :: stack -> - (* add to list *) - dec.stack <- (PS_L (v :: l)) :: stack; - | S key, ((PS_D d) :: stack) -> - (* new key for the map *) - dec.stack <- (PS_D_key (key, d)) :: stack; - | _, ((PS_D d) :: _) -> - (* error: key must be string *) - error dec "dict keys must be strings" - | _, (PS_D_key (key, d)) :: stack -> - (* new binding for the map *) - dec.stack <- (PS_D (SMap.add key v d)) :: stack; - | _ -> assert false -(* signal error *) -and error dec msg = - let msg = Printf.sprintf "Bencode: error at line %d, column %d: %s" - dec.l dec.c msg in - dec.stack <- [PS_error msg] - -(* exported parse function *) -let parse dec s i len = - (if i < 0 || i+len > String.length s - then invalid_arg "Bencode.parse: not a valid substring"); - (* add the input to [dec] *) - if dec.len = 0 - then begin - dec.buf <- String.copy s; - dec.i <- i; - dec.len <- len; - end else begin - (* use a buffer to merge the stored input and the new input *) - let buf' = String.create (dec.len + len - dec.i) in - String.blit dec.buf dec.i buf' 0 dec.len; - String.blit s i buf' dec.len len; - dec.buf <- buf'; - dec.i <- 0; - dec.len <- dec.len + len - dec.i; - end; - (* state machine *) - parse_rec dec - -let parse_resume d = parse_rec d - -let reset dec = - dec.l <- 0; - dec.c <- 0; - dec.i <- 0; - dec.len <- 0; - dec.state <- ParsePartial; - dec.stack <- []; - () - -let state dec = dec.state - -let rest dec = - String.sub dec.buf dec.i dec.len - -let rest_size dec = - dec.len - -let parse_string s = - let dec = mk_decoder () in - parse dec s 0 (String.length s) - -let of_string s = - match parse_string s with - | ParseOk t -> t - | ParsePartial -> invalid_arg "Bencode: partial parse" - | ParseError msg -> invalid_arg msg - -(** {2 Iterator} *) - -type 'a sequence = ('a -> unit) -> unit - -let of_seq seq = - fun k -> - let decoder = mk_decoder () in - (* read a string *) - let rec read_chunk str = - match parse decoder str 0 (String.length str) with - | ParseOk v -> - k v; (* yield, and parse the rest of the string *) - resume () - | ParseError e -> raise (Invalid_argument e) - | ParsePartial -> () (* wait for next chunk *) - and resume () = match parse_resume decoder with - | ParseOk v -> - k v; - resume () - | ParseError e -> raise (Invalid_argument e) - | ParsePartial -> () (* wait for next chunk *) - in - seq read_chunk - -let to_seq seq = - fun k -> seq (fun b -> k (to_string b)) - diff --git a/misc/bencode.mli b/misc/bencode.mli deleted file mode 100644 index 5af81b98..00000000 --- a/misc/bencode.mli +++ /dev/null @@ -1,130 +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. -*) - -(** {6 B-encoding} *) - -(** This implements encoding and decoding using the {i B-encode} format. - See {{: http://en.wikipedia.org/wiki/Bencode} wikipedia} for more details - *) - -module SMap : Map.S with type key = string - -type t = - | I of int - | S of string - | L of t list - | D of t SMap.t - -val eq : t -> t -> bool -val hash : t -> int - -val dict_of_list : (string * t) list -> t - -(** {2 Serialization (encoding)} *) - -val size : t -> int - (** Size needed for serialization *) - -val write_in_string : t -> string -> int -> unit - (** [write_in_string v buf o] writes the value [v] in the string, - starting at offset [o]. The portion of the string starting from [o] - must be big enough (ie >= [size v]) *) - -val to_buf : Buffer.t -> t -> unit -val to_string : t -> string -val to_chan : out_channel -> t -> unit -val fmt : Format.formatter -> t -> unit - -val pretty : Format.formatter -> t -> unit - (** Print the tree itself, not its encoding *) - -val pretty_to_str : t -> string - (** Print the tree into a string *) - -(** {2 Deserialization (decoding)} *) - -(** Deserialization is based on the {! decoder} type. Parsing can be - incremental, in which case the input is provided chunk by chunk and - the decoder contains the parsing state. Once a B-encoded value - has been parsed, other values can still be read. - - This implementation does accept leading zeros, because it simplifies - the code. *) - -type decoder - (** Decoding state *) - -val mk_decoder : unit -> decoder - (** Create a new decoder *) - -type parse_result = - | ParseOk of t - | ParseError of string - | ParsePartial - -val parse : decoder -> string -> int -> int -> parse_result - (** [parse dec s i len] uses the partial state stored in [dec] and - the substring of [s] starting at index [i] with length [len]. - It can return an error, a value or just [ParsePartial] if - more input is needed *) - -val parse_resume : decoder -> parse_result - (** Resume where the previous call to {!parse} stopped (may have - returned a value while some input is not processed) *) - -val reset : decoder -> unit - (** Reset the decoder to its pristine state, ready to parse something - different. Before that, {! rest} and {! rest_size} can be used - to recover the part of the input that has not been consumed yet. *) - -val state : decoder -> parse_result - (** Current state of the decoder *) - -val rest : decoder -> string - (** What remains after parsing (the additional, unused input) *) - -val rest_size : decoder -> int - (** Length of [rest d]. 0 indicates that the whole input has been consumed. *) - -val parse_string : string -> parse_result - (** Parse a full value from this string. *) - -val of_string : string -> t - (** Parse the string. @raise Invalid_argument if it fails to parse. *) - -(** {2 Iterator} *) - -type 'a sequence = ('a -> unit) -> unit - -val of_seq : string sequence -> t sequence - (** Given a sequence of strings into Bencode values. Strings can be - the result of {!Unix.read}, for instance, they don't need to be - valid bencode individually; Only their concatenation should - be a valid stream of Bencode values. - - @raise Invalid_argument if a parsing error occurs. *) - -val to_seq : t sequence -> string sequence - (** Serialize each value in the sequence of Bencode values *) diff --git a/misc/bencodeOnDisk.ml b/misc/bencodeOnDisk.ml deleted file mode 100644 index 4fc55882..00000000 --- a/misc/bencodeOnDisk.ml +++ /dev/null @@ -1,136 +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 Serialize Bencode on disk with persistency guarantees} - - This module provides an append-only interface to some file, with - synchronized access and fsync() called after every write. - - It currently uses [Unix.O_SYNC] to guarantee that writes are saved to - the disk, so {b WRITES ARE SLOW}. On the other hand, several - processes can access the same file and append data without risks of - losing written values or race conditions. - - Similarly, reads are atomic (require locking) and provide only - a fold interface. - *) - -type t = { - file : Unix.file_descr; - lock_file : Unix.file_descr; -} - -let open_out ?lock filename = - let lock = match lock with - | None -> filename - | Some l -> l - in - let lock_file = Unix.openfile lock [Unix.O_CREAT; Unix.O_WRONLY] 0o644 in - let file = Unix.openfile filename - [Unix.O_CREAT; Unix.O_APPEND; Unix.O_WRONLY; Unix.O_SYNC] 0o644 - in - { file; lock_file; } - -let close_out out = - Unix.close out.file - -let write_string out s = - Unix.lockf out.lock_file Unix.F_LOCK 0; - try - (* go to the end of the file *) - ignore (Unix.lseek out.file 0 Unix.SEEK_END); - (* call write() until everything is written *) - let rec write_all n = - if n >= String.length s - then () - else - let n' = n + Unix.write out.file s n (String.length s - n) in - write_all n' - in - write_all 0; - Unix.lockf out.lock_file Unix.F_ULOCK 0; - with e -> - (* unlock in any case *) - Unix.lockf out.lock_file Unix.F_ULOCK 0; - raise e - -let write out b = - let s = Bencode.to_string b in - write_string out s - -let write_batch out l = - let buf = Buffer.create 255 in - List.iter (fun b -> Bencode.to_buf buf b) l; - let s = Buffer.contents buf in - write_string out s - -type 'a result = - | Ok of 'a - | Error of string - -let read ?lock filename acc f = - let lock = match lock with - | None -> filename - | Some l -> l - in - (* lock file before reading, to observe a consistent state *) - let lock_file = Unix.openfile lock [Unix.O_CREAT; Unix.O_RDONLY] 0o644 in - Unix.lockf lock_file Unix.F_RLOCK 0; - try - let file = Unix.openfile filename [Unix.O_RDONLY] 0o644 in - (* read bencode values *) - let decoder = Bencode.mk_decoder () in - let len = 256 in - let buf = String.create len in - (* read a chunk of input and parse it *) - let rec next_val acc = - let n = Unix.read file buf 0 len in - if n = 0 - then Ok acc (* finished *) - else match Bencode.parse decoder buf 0 n with - | Bencode.ParseOk v -> - let acc = f acc v in - resume acc - | Bencode.ParseError e -> Error e - | Bencode.ParsePartial -> next_val acc - (* consume what remains of input *) - and resume acc = match Bencode.parse_resume decoder with - | Bencode.ParseOk v -> - let acc = f acc v in - resume acc - | Bencode.ParseError e -> Error e - | Bencode.ParsePartial -> next_val acc - in - let res = next_val acc in - (* cleanup *) - Unix.close file; - Unix.lockf lock_file Unix.F_ULOCK 0; - Unix.close lock_file; - res - with e -> - Unix.lockf lock_file Unix.F_ULOCK 0; - Unix.close lock_file; - raise e diff --git a/misc/bencodeOnDisk.mli b/misc/bencodeOnDisk.mli deleted file mode 100644 index b55c1ef5..00000000 --- a/misc/bencodeOnDisk.mli +++ /dev/null @@ -1,60 +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 Serialize Bencode on disk with persistency guarantees} - - This module provides an append-only interface to some file, with - synchronized access and fsync() called after every write. - It needs {b Extunix} to compile (needs fsync). - *) - -type t - (** Handle to a file on which we can append values atomically *) - -val open_out : ?lock:string -> string -> t - (** Open the given file for appending values. Creates the file - if it doesn't exist. - @param lock, if provided, is the name of the lock file used. By default, - the file that is provided for writing is also used for locking. - @raise Unix.Unix_error if some IO error occurs. *) - -val close_out : t -> unit - (** Close the file descriptor *) - -val write : t -> Bencode.t -> unit - (** Write "atomically" a value to the end of the file *) - -val write_batch : t -> Bencode.t list -> unit - (** Write several values at once, at the end of the file *) - -type 'a result = - | Ok of 'a - | Error of string - -val read : ?lock:string -> string -> 'a -> ('a -> Bencode.t -> 'a) -> 'a result - (** Fold on values serialized in the given file. - @param lock see {!open_out}. - @raise Unix.Unix_error if some IO error occurs. *) diff --git a/misc/bencodeStream.ml b/misc/bencodeStream.ml deleted file mode 100644 index 5d2fa2fa..00000000 --- a/misc/bencodeStream.ml +++ /dev/null @@ -1,156 +0,0 @@ - -(* -copyright (c) 2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Full-Streaming API of Bencode} *) - -type token = - | Int of int - | String of string - | BeginDict - | BeginList - | End - -module Encode = struct - type sink = - [ `File of string - | `Out of out_channel - | `Buf of Buffer.t - ] - - type t = { - write_string : string -> unit; - write_char : char -> unit; - on_close : unit -> unit; - } - - let nop() = () - - let create = function - | `Out o -> - { write_string=output_string o - ; write_char=output_char o - ; on_close = nop - } - | `File f -> - let o = open_out f in - { write_string=output_string o - ; write_char=output_char o - ; on_close = (fun () -> close_out o) - } - | `Buf b -> - { write_string=Buffer.add_string b - ; write_char=Buffer.add_char b - ; on_close =nop - } - - let push out tok = match tok with - | Int i -> - out.write_char 'i'; - out.write_string (string_of_int i); - out.write_char 'e' - | String s -> - out.write_string (string_of_int (String.length s)); - out.write_char ':'; - out.write_string s - | BeginDict -> - out.write_char 'd' - | End -> - out.write_char 'e' - | BeginList -> - out.write_char 'l' -end - -module Decode = struct - type result = - | Yield of token - | Error of string - | Await (** The user needs to call {!feed} with some input *) - - type state = - | Start - | ParsingInt of int - | ParsingString of string - - type t = { - mutable buf : string; (* buffer *) - mutable i : int; (* index in buf *) - mutable len : int; (* length of substring to read *) - mutable c : int; (* line *) - mutable l : int; (* column *) - mutable state : state; - } - - let create () = { - buf = ""; - i = 0; - len = 0; - c = 0; - l = 0; - state = Start; - } - - let is_empty dec = dec.len = 0 - let cur dec = dec.buf.[dec.i] - - let junk dec = - (* update line/column *) - (if cur dec = '\n' - then (dec.c <- 0; dec.l <- dec.l + 1) - else dec.c <- dec.c + 1); - dec.i <- dec.i + 1; - dec.len <- dec.len - 1 - - let next dec = - let c = cur dec in - junk dec; - c - - (* - (* parse value *) - let rec parse_rec dec = - if is_empty dec then Await (* wait *) - else begin - let c = next dec in - match dec.state, c with - | Start, 'l' -> - Yield StartList - | Start, 'd' -> - Yield StartDict - | Start, 'e' -> - Yield End - | Start, 'i' -> - dec.state <- ParsingInt 0 - | ParsingString i, 'e' -> - dec.state <- Start; - Yield (Int i) - | - *) - - let feed dec = assert false - - let next dec = assert false -end - diff --git a/misc/bencodeStream.mli b/misc/bencodeStream.mli deleted file mode 100644 index bb5f2d87..00000000 --- a/misc/bencodeStream.mli +++ /dev/null @@ -1,65 +0,0 @@ - -(* -copyright (c) 2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Full-Streaming API of Bencode} *) - -type token = - | Int of int - | String of string - | BeginDict - | BeginList - | End - -module Encode : sig - type t - - type sink = - [ `File of string - | `Out of out_channel - | `Buf of Buffer.t - ] - - val create : sink -> t - - val push : t -> token -> unit -end - -module Decode : sig - type t - - val create : unit -> t - (** Create a new decoder with the given source. *) - - val feed : t -> string -> unit - (** For manual mode, provide some input *) - - type result = - | Yield of token - | Error of string (** Invalid B-encode *) - | Await (** The user needs to call {!feed} with some input *) - - val next : t -> result -end diff --git a/misc/bencode_write_par.sh b/misc/bencode_write_par.sh deleted file mode 100755 index a441a5aa..00000000 --- a/misc/bencode_write_par.sh +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/sh - -# call n instances of ./bencode_write.native on the same file - -N=$1 -FILE=$2 - -echo "call script $N times on file $FILE" -for i in `seq $N` ; do - ./bencode_write.native "$FILE" & -done - -wait diff --git a/misc/bij.ml b/misc/bij.ml index 0147e072..2831e017 100644 --- a/misc/bij.ml +++ b/misc/bij.ml @@ -105,139 +105,3 @@ let hashtbl ma mb = List.iter (fun (k,v) -> Hashtbl.add h k v) l; h) (list_ (pair ma mb)) - -(** {2 Translations} *) - -module TrBencode = struct - module B = Bencode - - let rec encode: type a. bij:a t -> a -> B.t = - fun ~bij x -> match bij, x with - | Unit, () -> B.I 0 - | String, s -> B.S s - | Int, i -> B.I i - | Float, f -> B.S (string_of_float f) - | Bool, b -> B.I (if b then 1 else 0) - | List bij', l -> - let l' = List.map (fun x -> encode ~bij:bij' x) l in - B.L l' - | Many bij', [] -> raise (EncodingError "many: got empty list") - | Many bij', l -> - let l' = List.map (fun x -> encode ~bij:bij' x) l in - B.L l' - | Opt bij', None -> B.L [] - | Opt bij', Some x -> B.L [encode ~bij:bij' x] - | Pair (bija, bijb), (a, b) -> - B.L [encode ~bij:bija a; encode ~bij:bijb b] - | Triple (bija, bijb, bijc), (a, b, c) -> - B.L [encode ~bij:bija a; encode ~bij:bijb b; encode ~bij:bijc c] - | Quad (bija, bijb, bijc, bijd), (a, b, c, d) -> - B.L [encode ~bij:bija a; encode ~bij:bijb b; - encode ~bij:bijc c; encode ~bij:bijd d] - | Quint (bija, bijb, bijc, bijd, bije), (a, b, c, d, e) -> - B.L [encode ~bij:bija a; encode ~bij:bijb b; - encode ~bij:bijc c; encode ~bij:bijd d; - encode ~bij:bije e] - | Guard (check, bij'), x -> - if not (check x) then raise (EncodingError "check failed"); - encode ~bij:bij' x - | Map (inject, _, bij'), x -> - encode ~bij:bij' (inject x) - | Switch (inject, _), x -> - let key, BranchTo (bij',y) = inject x in - B.D (B.SMap.singleton key (encode ~bij:bij' y)) - - let rec decode: type a. bij:a t -> B.t -> a - = fun ~bij b -> match bij, b with - | Unit, B.I 0 -> () - | String, B.S s -> s - | Int, B.I i -> i - | Float, B.S s -> - begin try - let f = float_of_string s in - f - with Failure _ -> - raise (DecodingError "expected float") - end - | Bool, B.I 0 -> false - | Bool, B.I _ -> true - | List bij', B.L l -> - List.map (fun b -> decode ~bij:bij' b) l - | Many bij', B.L [] -> - raise (DecodingError "expected nonempty list") - | Many bij', B.L l -> - List.map (fun b -> decode ~bij:bij' b) l - | Opt bij', B.L [] -> None - | Opt bij', B.L [x] -> Some (decode ~bij:bij' x) - | Opt bij', B.L _ -> - raise (DecodingError "expected [] or [_]") - | Pair (bija, bijb), B.L [a; b] -> - decode ~bij:bija a, decode ~bij:bijb b - | Triple (bija, bijb, bijc), B.L [a; b; c] -> - decode ~bij:bija a, decode ~bij:bijb b, decode ~bij:bijc c - | Quad (bija, bijb, bijc, bijd), B.L [a; b; c; d] -> - decode ~bij:bija a, decode ~bij:bijb b, - decode ~bij:bijc c, decode ~bij:bijd d - | Quint (bija, bijb, bijc, bijd, bije), B.L [a; b; c; d; e] -> - decode ~bij:bija a, decode ~bij:bijb b, - decode ~bij:bijc c, decode ~bij:bijd d, - decode ~bij:bije e - | Guard (check, bij'), x -> - let y = decode ~bij:bij' x in - if not (check y) then raise (DecodingError "check failed"); - y - | Map (_, extract, bij'), b -> - let x = decode ~bij:bij' b in - extract x - | Switch (_, extract), B.D d when B.SMap.cardinal d = 1 -> - let key, value = B.SMap.choose d in - let BranchFrom (bij', convert) = extract key in - convert (decode ~bij:bij' value) - | _ -> raise (DecodingError "bad case") - - let to_string ~bij x = B.to_string (encode ~bij x) - - let of_string ~bij s = - let b = B.of_string s in - decode ~bij b - - let read ~bij ic = - let d = B.mk_decoder () in - let buf = String.create 256 in - let rec read_chunk() = - let n = input ic buf 0 (String.length buf) in - if n = 0 - then raise (DecodingError "unexpected EOF") - else match B.parse d buf 0 n with - | B.ParsePartial -> read_chunk() - | B.ParseError s -> raise (DecodingError s) - | B.ParseOk b -> decode ~bij b - in - read_chunk() - - let read_stream ~bij ic = - let d = B.mk_decoder () in - let buf = String.create 256 in - let rec try_parse n = match B.parse d buf 0 n with - | B.ParsePartial -> read_chunk() - | B.ParseError s -> raise (DecodingError s) - | B.ParseOk b -> Some (decode ~bij b) - and read_chunk() = - let n = input ic buf 0 (String.length buf) in - if n = 0 - then match B.parse_resume d with - | B.ParsePartial -> None - | B.ParseError s -> raise (DecodingError s) - | B.ParseOk b -> Some (decode ~bij b) - else try_parse n - in - Stream.from (fun _ -> read_chunk()) - - let write ~bij oc x = - let b = encode ~bij x in - B.to_chan oc b; - flush oc - - let write_stream ~bij oc str = - Stream.iter (fun x -> write ~bij oc x) str -end diff --git a/misc/bij.mli b/misc/bij.mli index 9448ea63..4bbc8756 100644 --- a/misc/bij.mli +++ b/misc/bij.mli @@ -163,25 +163,3 @@ exception EncodingError of string exception DecodingError of string (** Raised when decoding is impossible *) - -(** {2 Translations} *) - -module TrBencode : sig - val encode : bij:'a t -> 'a -> Bencode.t - - val decode : bij:'a t -> Bencode.t -> 'a - - val to_string : bij:'a t -> 'a -> string - - val of_string : bij:'a t -> string -> 'a - - val read : bij:'a t -> in_channel -> 'a - (** Read a single value from the channel *) - - val read_stream : bij:'a t -> in_channel -> 'a Stream.t - - val write : bij:'a t -> out_channel -> 'a -> unit - - val write_stream : bij:'a t -> out_channel -> 'a Stream.t -> unit -end - diff --git a/misc/tell.ml b/misc/tell.ml deleted file mode 100644 index 530a4bcc..00000000 --- a/misc/tell.ml +++ /dev/null @@ -1,111 +0,0 @@ - -(* -copyright (c) 2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Hierarchic logging} *) - -module BS = BencodeStream - -type t = { - name : string; - out : out_channel; - encoder : BS.Encode.t; - cleanup : bool; - mutable context : string list; -} - -let __new_name = - let r = ref 0 in - fun () -> - let name = Printf.sprintf "Tell.log_%d" !r in - incr r; - name - -let to_chan ?(cleanup=false) o = { - name = __new_name (); - out = o; - encoder = BS.Encode.create (`Out o); - cleanup; - context = []; -} - -let to_file filename = - let o = open_out filename in - to_chan ~cleanup:true o - -let close log = - if log.cleanup - then close_out log.out - -let step log msg = - BS.Encode.push log.encoder BS.BeginDict; - BS.Encode.push log.encoder (BS.String "step"); - BS.Encode.push log.encoder (BS.String msg); - BS.Encode.push log.encoder BS.End - -let enter log = - BS.Encode.push log.encoder BS.BeginList - -let exit log = - BS.Encode.push log.encoder BS.End - -let within ~log f = - BS.Encode.push log.encoder BS.BeginDict; - BS.Encode.push log.encoder (BS.String "section"); - try - let x = f () in - BS.Encode.push log.encoder BS.End; - x - with e -> - BS.Encode.push log.encoder BS.End; - raise e - -module B = struct - let step ~log format = - exit log; - let b = Buffer.create 24 in - Printf.kbprintf - (fun b -> - BS.Encode.push log.encoder (BS.String (Buffer.contents b))) - b format - - let enter ~log format = - let b = Buffer.create 24 in - let x = Printf.kbprintf - (fun b -> - BS.Encode.push log.encoder (BS.String (Buffer.contents b))) - b format - in - enter log; - x - - let exit ~log format = - exit log; - let b = Buffer.create 24 in - Printf.kbprintf - (fun b -> - BS.Encode.push log.encoder (BS.String (Buffer.contents b))) - b format -end diff --git a/misc/tell.mli b/misc/tell.mli deleted file mode 100644 index 6f17ffc6..00000000 --- a/misc/tell.mli +++ /dev/null @@ -1,73 +0,0 @@ - -(* -copyright (c) 2014, simon cruanes -all rights reserved. - -redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. redistributions in binary -form must reproduce the above copyright notice, this list of conditions and the -following disclaimer in the documentation and/or other materials provided with -the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*) - -(** {1 Hierarchic logging} *) - -type t - -val to_file : string -> t -(** Create a logger that outputs to the given file *) - -val to_chan : ?cleanup:bool -> out_channel -> t -(** Obtain a logger that outputs to the given channel. - @param cleanup if true, will close the channel on exit; - if false or not explicited, won't do anything. *) - -(** {2 Raw functions} *) - -val step : t -> string -> unit - -val close : t -> unit -(** Close the logger. It will be unusable afterwards. *) - -(** {2 Hierarchy} *) - -val enter : t -> unit -(** Enter a new subsection *) - -val exit : t -> unit -(** Exit the current subsection *) - -val within : log:t -> (unit -> 'a) -> 'a -(** Enter a new subsection, evaluate the given function, - exit the subsection and return the function's result. - Also protects against exceptions. *) - -(** {2 Buffer-formatting output} -The following functions use a {!Buffer.t} to create the message, -then send it to their logger. *) - -module B : sig - val enter : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a - (** Enter a new (sub-)section with the given message *) - - val exit : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a - (** Exit (close) the current sub-section. *) - - val step : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a - (** Unit step within the current section *) -end - diff --git a/tests/run_tests.ml b/tests/run_tests.ml index 858df690..631379e5 100644 --- a/tests/run_tests.ml +++ b/tests/run_tests.ml @@ -6,11 +6,9 @@ let suite = "all_tests" >::: [ Test_pHashtbl.suite; Test_PersistentHashtbl.suite; - Test_bencode.suite; Test_bv.suite; Test_PiCalculus.suite; Test_splayMap.suite; - Test_bij.suite; Test_CCHeap.suite; Test_cc.suite; Test_puf.suite; @@ -29,7 +27,6 @@ let props = QCheck.flatten [ Test_PersistentHashtbl.props ; Test_bv.props - ; Test_bencode.props ; Test_vector.props ] diff --git a/tests/test_bencode.ml b/tests/test_bencode.ml deleted file mode 100644 index 3bfb5c6f..00000000 --- a/tests/test_bencode.ml +++ /dev/null @@ -1,71 +0,0 @@ - -open OUnit -open Containers_misc - -module B = Bencode - -let test1 () = - let s = "li42ei0ei-200ee" in - match B.parse_string s with - | B.ParseError msg -> - OUnit.assert_failure (Printf.sprintf "should parse, got %s" msg) - | B.ParsePartial -> - OUnit.assert_failure "should parse, got partial" - | B.ParseOk b -> - OUnit.assert_equal (B.L [B.I 42; B.I 0; B.I ~-200]) b - -let test2 () = - let b = - B.dict_of_list [ - "foo", B.I 42; - "bar", B.L [B.I 0; B.S "caramba si"]; - "", B.S ""; - ] - in - let s = B.to_string b in - (* Printf.printf "serialized to %s\n" s; *) - let b' = B.of_string s in - OUnit.assert_equal ~cmp:B.eq ~printer:B.to_string b b' - -let test3 () = - let b = B.dict_of_list [ - "a", B.I 1; - "b", B.S "bbbb"; - "l", B.L [B.I 0; B.I 0; B.S "zero\n\t \x00"]; - "d", B.dict_of_list ["foo", B.S "bar"]; - ] in - let s = B.to_string b in - (* Printf.printf "serialized to %s\n" s; *) - let b' = B.of_string s in - OUnit.assert_equal ~cmp:B.eq ~printer:B.to_string b b' - -let suite = - "test_bencode" >::: - [ "test1" >:: test1; - "test2" >:: test2; - "test3" >:: test3; - ] - -open QCheck - -let check_decode_encode = - let gen = Arbitrary.( - let base = choose - [ lift (fun i -> B.I i) small_int - ; lift (fun s -> B.S s) string - ] - in - fix ~max:3 ~base (fun sub -> - choose - [ lift B.dict_of_list (list (pair string sub)) - ; lift (fun l -> B.L l) (list sub) - ; sub - ])) - in - let prop b = B.eq (B.of_string (B.to_string b)) b in - let name = "bencode_decode_encode_bij" in - mk_test ~name gen prop - -let props = - [ check_decode_encode - ] diff --git a/tests/test_bij.ml b/tests/test_bij.ml deleted file mode 100644 index 869bd9b1..00000000 --- a/tests/test_bij.ml +++ /dev/null @@ -1,91 +0,0 @@ - -open OUnit -open Containers_misc - -module Sequence = CCSequence - -let pp_int_list l = - let b = Buffer.create 4 in - CCList.pp CCInt.pp b l; - Buffer.contents b - -let test_intlist n () = - let bij = Bij.(list_ int_) in - let l = Sequence.to_list (Sequence.int_range ~start:0 ~stop:n) in - let s = Bij.TrBencode.to_string ~bij l in - let l' = Bij.TrBencode.of_string ~bij s in - OUnit.assert_equal ~printer:pp_int_list l l' - -type term = - | Const of string - | Int of int - | App of term list - -let bij_term = - let bij = Bij.fix - (fun bij -> - Bij.switch - ~inject:(function - | Const s -> "const", Bij.(BranchTo (string_, s)) - | Int i -> "int", Bij.(BranchTo (int_, i)) - | App l -> "app", Bij.(BranchTo (list_ (Lazy.force bij), l))) - ~extract:(function - | "const" -> Bij.(BranchFrom (string_, fun x -> Const x)) - | "int" -> Bij.BranchFrom (Bij.int_, fun x -> Int x) - | "app" -> Bij.(BranchFrom (list_ (Lazy.force bij), fun l -> App l)) - | _ -> raise Bij.(DecodingError "unexpected case switch")) - ) - in - bij - -let test_rec () = - let t = App [Const "foo"; App [Const "bar"; Int 1; Int 2]; Int 3; Const "hello"] in - let s = Bij.TrBencode.to_string ~bij:bij_term t in - (* Printf.printf "to: %s\n" s; *) - let t' = Bij.TrBencode.of_string ~bij:bij_term s in - OUnit.assert_equal t t' - -let random_str len = - let s = String.make len ' ' in - for i = 0 to len - 1 do - s.[i] <- "abcdefghijklmnopqrstuvwxyz".[Random.int 26] - done; - s - -let rec random_term depth = - if depth = 0 - then if Random.bool () - then Const (random_str (1 + Random.int 5)) - else Int (Random.int 20) - else - let len = Random.int (1 + Random.int 10) in - let seq = Sequence.map (fun _ -> random_term (depth-1)) - (Sequence.int_range ~start:1 ~stop:len) in - App (Sequence.to_list seq) - -let test_term_random ?(depth=5) n () = - for i = 0 to n - 1 do - let t = random_term depth in - let s = Bij.TrBencode.to_string ~bij:bij_term t in - let t' = Bij.TrBencode.of_string ~bij:bij_term s in - OUnit.assert_equal t t' - done - -let test_complicated () = - let bij = Bij.(triple int_ (pair bool_ (many float_)) - (map ~inject:(fun (a,b) -> (b,a)) ~extract:(fun (b,a) -> a,b) (pair int_ bool_))) in - let x = (1, (true, [1.; 2.; 3.]), (false, 42)) in - let s = Bij.TrBencode.to_string ~bij x in - let x' = Bij.TrBencode.of_string ~bij s in - OUnit.assert_equal x x' - -let suite = - "test_bij" >::: - [ "test_intlist10" >:: test_intlist 10 - ; "test_intlist100" >:: test_intlist 100 - ; "test_intlist10_000" >:: test_intlist 10_000 - ; "test_rec" >:: test_rec - ; "test_term_random100" >:: test_term_random 100 - ; "test_term_random100_depth10" >:: test_term_random ~depth:10 100 - ; "test_complicated" >:: test_complicated - ] From 36423c01d2ab8881c9f8ac6d43fb7c945b0add59 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 4 Nov 2014 22:19:26 +0100 Subject: [PATCH 15/29] Squashed 'sequence/' changes from 2691bee..efeb0fc efeb0fc merge from master; version 0.5.4 0de04d0 depend on bytes; compliant with -safe-string d95495d sequence.bigarray 15a0b9d fix release numbers git-subtree-dir: sequence git-subtree-split: efeb0fc99751bc8260f10da96fa26aac70585208 --- .merlin | 1 + .ocamlinit | 8 +- CHANGELOG.md | 8 +- META | 18 ++- Makefile | 6 +- _oasis | 16 ++- _tags | 28 +++- bigarray/bigarray.mldylib | 4 + bigarray/bigarray.mllib | 4 + bigarray/sequenceBigarray.ml | 45 +++++++ bigarray/sequenceBigarray.mli | 34 +++++ myocamlbuild.ml | 94 +++++++------ sequence.ml | 17 ++- sequence.mli | 18 ++- setup.ml | 244 +++++++++++++++++++++++----------- 15 files changed, 406 insertions(+), 139 deletions(-) create mode 100644 bigarray/bigarray.mldylib create mode 100644 bigarray/bigarray.mllib create mode 100644 bigarray/sequenceBigarray.ml create mode 100644 bigarray/sequenceBigarray.mli diff --git a/.merlin b/.merlin index 385d4698..d9043276 100644 --- a/.merlin +++ b/.merlin @@ -6,3 +6,4 @@ B _build/tests/ B _build/bench/ PKG oUnit PKG benchmark +FLAG -safe-string diff --git a/.ocamlinit b/.ocamlinit index b54780c5..7123b8dc 100644 --- a/.ocamlinit +++ b/.ocamlinit @@ -1,5 +1,9 @@ #directory "_build";; #load "sequence.cma";; + open Sequence.Infix;; -(* vim:syntax=ocaml -*) + +#directory "_build/bigarray/";; +#load "bigarray.cma";; + +(* vim:syntax=ocaml *) diff --git a/CHANGELOG.md b/CHANGELOG.md index c21ef641..d293db2d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog +## 0.5.4 + +- depend on `bytes` +- compliance with `-safe-string` +- `sequence.bigarray` + ## 0.5.3 - bugfix: interaction between `take` and `is_empty` @@ -76,4 +82,4 @@ - `zip`, `unzip` and `zip_i` to convert between `t` and `t2` - added `scan` combinator -note: git log --no-merges previous_version..HEAD --pretty=%s +note: git log --no-merges --pretty=%s previous_version..HEAD diff --git a/META b/META index 246e94fa..d7b95ba5 100644 --- a/META +++ b/META @@ -1,14 +1,15 @@ # OASIS_START -# DO NOT EDIT (digest: 99194977427ba82f5912e81125f6cac0) -version = "0.5.3" +# DO NOT EDIT (digest: 0c501104bbf1dfc40db58200fdbfdd57) +version = "0.5.4" description = "Simple sequence (iterator) datatype and combinators" +requires = "bytes" archive(byte) = "sequence.cma" archive(byte, plugin) = "sequence.cma" archive(native) = "sequence.cmxa" archive(native, plugin) = "sequence.cmxs" exists_if = "sequence.cma" package "invert" ( - version = "0.5.3" + version = "0.5.4" description = "Simple sequence (iterator) datatype and combinators" requires = "sequence delimcc" archive(byte) = "invert.cma" @@ -17,5 +18,16 @@ package "invert" ( archive(native, plugin) = "invert.cmxs" exists_if = "invert.cma" ) + +package "bigarray" ( + version = "0.5.4" + description = "Simple sequence (iterator) datatype and combinators" + requires = "sequence bigarray" + archive(byte) = "bigarray.cma" + archive(byte, plugin) = "bigarray.cma" + archive(native) = "bigarray.cmxa" + archive(native, plugin) = "bigarray.cmxs" + exists_if = "bigarray.cma" +) # OASIS_STOP diff --git a/Makefile b/Makefile index cdc0e22e..bc5e0da5 100644 --- a/Makefile +++ b/Makefile @@ -59,9 +59,11 @@ push_stable: all VERSION=$(shell awk '/^Version:/ {print $$2}' _oasis) +SOURCE=*.ml *.mli invert/*.ml invert/*.mli bigarray/*.ml bigarray/*.mli + update_next_tag: @echo "update version to $(VERSION)..." - sed -i "s/NEXT_VERSION/$(VERSION)/g" *.ml *.mli - sed -i "s/NEXT_RELEASE/$(VERSION)/g" *.ml *.mli + sed -i "s/NEXT_VERSION/$(VERSION)/g" $(SOURCE) + sed -i "s/NEXT_RELEASE/$(VERSION)/g" $(SOURCE) .PHONY: benchs tests examples update_next_tag push_doc push_stable diff --git a/_oasis b/_oasis index 39a59224..b0b92be5 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: sequence -Version: 0.5.3 +Version: 0.5.4 Homepage: https://github.com/c-cube/sequence Authors: Simon Cruanes License: BSD-2-clause @@ -23,9 +23,14 @@ Flag invert Description: build sequence.invert (requires Delimcc) Default: false +Flag bigarray + Description: build sequence.bigarray (requires bigarray) + Default: true + Library "sequence" Path: . Modules: Sequence + BuildDepends: bytes Library "invert" Path: invert @@ -36,6 +41,15 @@ Library "invert" FindlibParent: sequence BuildDepends: sequence,delimcc +Library "bigarray" + Path: bigarray + Build$: flag(bigarray) + Install$: flag(bigarray) + Modules: SequenceBigarray + FindlibName: bigarray + FindlibParent: sequence + BuildDepends: sequence,bigarray + Document sequence Title: Sequence docs Type: ocamlbuild (0.3) diff --git a/_tags b/_tags index 699130f7..9825df02 100644 --- a/_tags +++ b/_tags @@ -1,8 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: e8d5fe31ff471d3c0ec54943fe50d011) +# DO NOT EDIT (digest: 29e0c9fc65daf16caa16466d6ff32bac) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process +true: annot, bin_annot <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse @@ -15,25 +16,38 @@ "_darcs": not_hygienic # Library sequence "sequence.cmxs": use_sequence +<*.ml{,i,y}>: pkg_bytes # Library invert "invert/invert.cmxs": use_invert -: pkg_delimcc -: use_sequence +: pkg_bytes +: pkg_delimcc +: use_sequence +# Library bigarray +"bigarray/bigarray.cmxs": use_bigarray +: pkg_bigarray +: pkg_bytes +: use_sequence # Executable run_tests +"tests/run_tests.native": pkg_bytes "tests/run_tests.native": pkg_oUnit "tests/run_tests.native": use_sequence -: pkg_oUnit -: use_sequence +: pkg_bytes +: pkg_oUnit +: use_sequence # Executable benchs "bench/benchs.native": pkg_benchmark +"bench/benchs.native": pkg_bytes "bench/benchs.native": use_sequence # Executable bench_persistent "bench/bench_persistent.native": pkg_benchmark +"bench/bench_persistent.native": pkg_bytes "bench/bench_persistent.native": use_sequence # Executable bench_persistent_read "bench/bench_persistent_read.native": pkg_benchmark +"bench/bench_persistent_read.native": pkg_bytes "bench/bench_persistent_read.native": use_sequence -: pkg_benchmark -: use_sequence +: pkg_benchmark +: pkg_bytes +: use_sequence # OASIS_STOP true: bin_annot diff --git a/bigarray/bigarray.mldylib b/bigarray/bigarray.mldylib new file mode 100644 index 00000000..f817c41e --- /dev/null +++ b/bigarray/bigarray.mldylib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: dca476c3b57e859aa3b1c75ec0959ed9) +SequenceBigarray +# OASIS_STOP diff --git a/bigarray/bigarray.mllib b/bigarray/bigarray.mllib new file mode 100644 index 00000000..f817c41e --- /dev/null +++ b/bigarray/bigarray.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: dca476c3b57e859aa3b1c75ec0959ed9) +SequenceBigarray +# OASIS_STOP diff --git a/bigarray/sequenceBigarray.ml b/bigarray/sequenceBigarray.ml new file mode 100644 index 00000000..fd61b86b --- /dev/null +++ b/bigarray/sequenceBigarray.ml @@ -0,0 +1,45 @@ +(* +Copyright (c) 2014, Simon Cruanes +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. Redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Interface and Helpers for bigarrays} *) + +let of_bigarray b yield = + let len = Bigarray.Array1.dim b in + for i=0 to len-1 do + yield b.{i} + done + +let mmap filename = + fun yield -> + let fd = Unix.openfile filename [Unix.O_RDONLY] 0 in + let len = Unix.lseek fd 0 Unix.SEEK_END in + let _ = Unix.lseek fd 0 Unix.SEEK_SET in + let b = Bigarray.Array1.map_file fd Bigarray.Char Bigarray.C_layout false len in + try + of_bigarray b yield; + Unix.close fd + with e -> + Unix.close fd; + raise e diff --git a/bigarray/sequenceBigarray.mli b/bigarray/sequenceBigarray.mli new file mode 100644 index 00000000..a9c78808 --- /dev/null +++ b/bigarray/sequenceBigarray.mli @@ -0,0 +1,34 @@ +(* +Copyright (c) 2014, Simon Cruanes +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. Redistributions in binary +form must reproduce the above copyright notice, this list of conditions and the +following disclaimer in the documentation and/or other materials provided with +the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) + +(** {1 Interface and Helpers for bigarrays} + +@since 0.5.4 *) + +val of_bigarray : ('a, _, _) Bigarray.Array1.t -> 'a Sequence.t +(** Iterate on the elements of a 1-D array *) + +val mmap : string -> char Sequence.t +(** Map the file into memory, and read the characters. *) diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 0d9d2514..1cfd88ec 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: c4bb6d2ca42efb069d5612eb2bbcf244) *) +(* DO NOT EDIT (digest: 2ea21bad023bcdcb9626e204d039d0d2) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -249,6 +249,9 @@ module MyOCamlbuildFindlib = struct *) open Ocamlbuild_plugin + type conf = + { no_automatic_syntax: bool; + } (* these functions are not really officially exported *) let run_and_read = @@ -315,7 +318,7 @@ module MyOCamlbuildFindlib = struct (* This lists all supported packages. *) let find_packages () = - List.map before_space (split_nl & run_and_read "ocamlfind list") + List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) (* Mock to list available syntaxes. *) @@ -338,7 +341,7 @@ module MyOCamlbuildFindlib = struct ] - let dispatch = + let dispatch conf = function | After_options -> (* By using Before_options one let command line options have an higher @@ -357,31 +360,39 @@ module MyOCamlbuildFindlib = struct * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - let base_args = [A"-package"; A pkg] in - (* TODO: consider how to really choose camlp4o or camlp4r. *) - let syn_args = [A"-syntax"; A "camlp4o"] in - let args = - (* Heuristic to identify syntax extensions: whether they end in - ".syntax"; some might not. - *) - if Filename.check_suffix pkg "syntax" || - List.mem pkg well_known_syntax then - syn_args @ base_args - else - base_args - in - flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; - flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; - end - (find_packages ()); + if not (conf.no_automatic_syntax) then begin + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + let base_args = [A"-package"; A pkg] in + (* TODO: consider how to really choose camlp4o or camlp4r. *) + let syn_args = [A"-syntax"; A "camlp4o"] in + let (args, pargs) = + (* Heuristic to identify syntax extensions: whether they end in + ".syntax"; some might not. + *) + if Filename.check_suffix pkg "syntax" || + List.mem pkg well_known_syntax then + (syn_args @ base_args, syn_args) + else + (base_args, []) + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + + (* TODO: Check if this is allowed for OCaml < 3.12.1 *) + flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; + end + (find_packages ()); + end; (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) @@ -546,12 +557,13 @@ module MyOCamlbuildBase = struct (* When ocaml link something that use the C library, then one need that file to be up to date. + This holds both for programs and for libraries. *) - dep ["link"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["link"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - dep ["compile"; "ocaml"; "program"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["compile"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) @@ -580,31 +592,37 @@ module MyOCamlbuildBase = struct () - let dispatch_default t = + let dispatch_default conf t = dispatch_combine [ dispatch t; - MyOCamlbuildFindlib.dispatch; + MyOCamlbuildFindlib.dispatch conf; ] end -# 594 "myocamlbuild.ml" +# 606 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = - [("sequence", [], []); ("invert", ["invert"], [])]; + [ + ("sequence", [], []); + ("invert", ["invert"], []); + ("bigarray", ["bigarray"], []) + ]; lib_c = []; flags = []; includes = [] } ;; -let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; +let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} -# 609 "myocamlbuild.ml" +let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; + +# 627 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/sequence.ml b/sequence.ml index 00dd7cd0..531a90d0 100644 --- a/sequence.ml +++ b/sequence.ml @@ -751,7 +751,7 @@ module IO = struct fun k -> let ic = open_in_gen flags mode filename in try - let buf = String.create size in + let buf = Bytes.create size in let n = ref 0 in let stop = ref false in while not !stop do @@ -763,22 +763,29 @@ module IO = struct if n' = 0 then stop := true else n := !n + n'; done; if !n > 0 - then k (String.sub buf 0 !n) + then k (Bytes.sub_string buf 0 !n) done; close_in ic with e -> close_in_noerr ic; raise e - let write_to ?(mode=0o644) ?(flags=[Open_creat;Open_wronly]) filename seq = + let write_bytes_to ?(mode=0o644) ?(flags=[Open_creat;Open_wronly]) filename seq = let oc = open_out_gen flags mode filename in try - seq (fun s -> output oc s 0 (String.length s)); + seq (fun s -> output oc s 0 (Bytes.length s)); close_out oc with e -> close_out oc; raise e + let write_to ?mode ?flags filename seq = + write_bytes_to ?mode ?flags filename (map Bytes.unsafe_of_string seq) + + let write_bytes_lines ?mode ?flags filename seq = + let ret = Bytes.unsafe_of_string "\n" in + write_bytes_to ?mode ?flags filename (snoc (intersperse ret seq) ret) + let write_lines ?mode ?flags filename seq = - write_to ?mode ?flags filename (snoc (intersperse "\n" seq) "\n") + write_bytes_lines ?mode ?flags filename (map Bytes.unsafe_of_string seq) end diff --git a/sequence.mli b/sequence.mli index 449b3f77..677f79ce 100644 --- a/sequence.mli +++ b/sequence.mli @@ -558,6 +558,12 @@ By chunks of [4096] bytes: Sequence.IO.(chunks_of ~size:4096 "a" |> write_to "b");; ]} +Read the lines of a file into a list: + +{[ + Sequence.IO.lines "a" |> Sequence.to_list +]} + @since 0.5.1 *) module IO : sig @@ -580,13 +586,21 @@ module IO : sig different iterations might return different results *) val write_to : ?mode:int -> ?flags:open_flag list -> - string -> string t -> unit + string -> string t -> unit (** [write_to filename seq] writes all strings from [seq] into the given file. It takes care of opening and closing the file. @param mode default [0o644] @param flags used by [open_out_gen]. Default: [[Open_creat;Open_wronly]]. *) + val write_bytes_to : ?mode:int -> ?flags:open_flag list -> + string -> Bytes.t t -> unit + (** @since 0.5.4 *) + val write_lines : ?mode:int -> ?flags:open_flag list -> - string -> string t -> unit + string -> string t -> unit (** Same as {!write_to}, but intercales ['\n'] between each string *) + + val write_bytes_lines : ?mode:int -> ?flags:open_flag list -> + string -> Bytes.t t -> unit + (** @since 0.5.4 *) end diff --git a/setup.ml b/setup.ml index 51aae2fc..e9622939 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 1c260750474eb19b8e9212954217b6fd) *) +(* DO NOT EDIT (digest: 99b277a969b94ce64e720af9e5ba6929) *) (* - Regenerated by OASIS v0.4.4 + Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -242,11 +242,9 @@ module OASISString = struct let replace_chars f s = - let buf = String.make (String.length s) 'X' in - for i = 0 to String.length s - 1 do - buf.[i] <- f s.[i] - done; - buf + let buf = Buffer.create (String.length s) in + String.iter (fun c -> Buffer.add_char buf (f c)) s; + Buffer.contents buf end @@ -1729,6 +1727,13 @@ module OASISFeatures = struct (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 @@ -2099,16 +2104,6 @@ module OASISLibrary = struct lst in - (* The headers that should be compiled along *) - let headers = - if lib.lib_pack then - [] - else - find_modules - lib.lib_modules - "cmi" - in - (* The .cmx that be compiled along *) let cmxs = let should_be_built = @@ -2134,12 +2129,32 @@ module OASISLibrary = struct [] 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"] :: acc + [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in @@ -2499,13 +2514,13 @@ module OASISFindlib = struct in let library_name_of_findlib_name = - Lazy.lazy_from_fun - (fun () -> - (* Revert findlib_name_of_library_name. *) - MapString.fold - (fun k v mp -> MapString.add v k mp) - fndlb_name_of_lib_name - MapString.empty) + 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 @@ -2875,7 +2890,7 @@ module OASISFileUtil = struct end -# 2878 "setup.ml" +# 2893 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -2980,7 +2995,7 @@ module BaseEnvLight = struct end -# 2983 "setup.ml" +# 2998 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -5391,7 +5406,7 @@ module BaseSetup = struct end -# 5394 "setup.ml" +# 5409 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) @@ -5827,6 +5842,17 @@ module InternalInstallPlugin = struct 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 = @@ -5847,27 +5873,29 @@ module InternalInstallPlugin = struct OASISHostPath.of_unix bs.bs_path in List.fold_left - (fun acc modul -> - try - List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - String.uncapitalize modul^".mli"; - String.capitalize modul^".mli"; - String.uncapitalize modul^".ml"; - String.capitalize modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in library %s") - modul cs.cs_name; - acc - end) + 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 @@ -5915,27 +5943,29 @@ module InternalInstallPlugin = struct OASISHostPath.of_unix bs.bs_path in List.fold_left - (fun acc modul -> - try - List.find - OASISFileUtil.file_exists_case - (List.map - (Filename.concat path) - [modul^".mli"; - modul^".ml"; - String.uncapitalize modul^".mli"; - String.capitalize modul^".mli"; - String.uncapitalize modul^".ml"; - String.capitalize modul^".ml"]) - :: acc - with Not_found -> - begin - warning - (f_ "Cannot find source header for module %s \ - in object %s") - modul cs.cs_name; - acc - end) + 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 @@ -6240,7 +6270,7 @@ module InternalInstallPlugin = struct end -# 6243 "setup.ml" +# 6273 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) @@ -6298,6 +6328,11 @@ module OCamlbuildCommon = struct else []; + if bool_of_string (tests ()) then + ["-tag"; "tests"] + else + []; + if bool_of_string (profile ()) then ["-tag"; "profile"] else @@ -6613,7 +6648,7 @@ module OCamlbuildDocPlugin = struct end -# 6616 "setup.ml" +# 6651 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) @@ -6761,7 +6796,7 @@ module CustomPlugin = struct end -# 6764 "setup.ml" +# 6799 "setup.ml" open OASISTypes;; let setup_t = @@ -6826,7 +6861,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "sequence"; - version = "0.5.3"; + version = "0.5.4"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -6906,6 +6941,17 @@ let setup_t = Some "build sequence.invert (requires Delimcc)"; flag_default = [(OASISExpr.EBool true, false)] }); + Flag + ({ + cs_name = "bigarray"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + flag_description = + Some "build sequence.bigarray (requires bigarray)"; + flag_default = [(OASISExpr.EBool true, true)] + }); Library ({ cs_name = "sequence"; @@ -6917,7 +6963,7 @@ let setup_t = bs_install = [(OASISExpr.EBool true, true)]; bs_path = "."; bs_compiled_object = Best; - bs_build_depends = []; + bs_build_depends = [FindlibPackage ("bytes", None)]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; bs_data_files = []; @@ -6978,6 +7024,48 @@ let setup_t = lib_findlib_name = Some "invert"; lib_findlib_containers = [] }); + Library + ({ + cs_name = "bigarray"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "bigarray", true) + ]; + bs_install = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "bigarray", true) + ]; + bs_path = "bigarray"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "sequence"; + FindlibPackage ("bigarray", 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 = ["SequenceBigarray"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "sequence"; + lib_findlib_name = Some "bigarray"; + lib_findlib_containers = [] + }); Doc ({ cs_name = "sequence"; @@ -7191,8 +7279,8 @@ let setup_t = plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.4"; - oasis_digest = Some "\214\tqh\b\169>\243\237\213\012\180\162\155`L"; + oasis_version = "0.4.5"; + oasis_digest = Some "\143pX\233\t\217\232\\d\023B\027\020*\019W"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7200,6 +7288,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7204 "setup.ml" +# 7292 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 73201a4e6714f1ebf55e79238f15abe667061379 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 6 Nov 2014 13:48:03 +0100 Subject: [PATCH 16/29] add some warnings (to be fixed) --- _tags | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/_tags b/_tags index e89e7e22..5a3bb15a 100644 --- a/_tags +++ b/_tags @@ -160,4 +160,4 @@ : thread : thread : -traverse -<{string,core}/**/*.ml>: warn_K, warn_Y, warn_X +<{string,core}/**/*.ml>: warn_A, warn(-4) From ed3bf4ba267d9e7756faf93b886b7ba2ff549efc Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 6 Nov 2014 16:08:36 +0100 Subject: [PATCH 17/29] CCList.(>|=) infix map --- core/CCList.ml | 4 +++- core/CCList.mli | 4 ++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/core/CCList.ml b/core/CCList.ml index cddb1911..03713d62 100644 --- a/core/CCList.ml +++ b/core/CCList.ml @@ -51,6 +51,8 @@ let map f l = List.rev (List.rev_map f l) = map f l) *) +let (>|=) l f = map f l + let append l1 l2 = let rec direct i l1 l2 = match l1 with | [] -> l2 @@ -550,7 +552,7 @@ module type MONAD = sig end module Traverse(M : MONAD) = struct - open M + open! M let map_m f l = let rec aux f acc l = match l with diff --git a/core/CCList.mli b/core/CCList.mli index 65356855..939888c4 100644 --- a/core/CCList.mli +++ b/core/CCList.mli @@ -33,6 +33,10 @@ val empty : 'a t val map : ('a -> 'b) -> 'a t -> 'b t (** Safe version of map *) +val (>|=) : 'a t -> ('a -> 'b) -> 'b t +(** Infix version of [map] with reversed arguments + @since NEXT_RELEASE *) + val append : 'a t -> 'a t -> 'a t (** Safe version of append *) From 443850588511186723298f316933a6780935138d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 6 Nov 2014 16:30:08 +0100 Subject: [PATCH 18/29] disable warning 44 --- .merlin | 2 +- _tags | 2 +- core/CCList.ml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.merlin b/.merlin index 728816da..933075fd 100644 --- a/.merlin +++ b/.merlin @@ -15,4 +15,4 @@ PKG benchmark PKG threads PKG threads.posix PKG lwt -FLG -w +K,+Y,+X +FLG -w +a -w -4 -w -44 diff --git a/_tags b/_tags index 5a3bb15a..37a53b13 100644 --- a/_tags +++ b/_tags @@ -160,4 +160,4 @@ : thread : thread : -traverse -<{string,core}/**/*.ml>: warn_A, warn(-4) +<{string,core}/**/*.ml>: warn_A, warn(-4), warn(-44) diff --git a/core/CCList.ml b/core/CCList.ml index 03713d62..64cd4b9e 100644 --- a/core/CCList.ml +++ b/core/CCList.ml @@ -552,7 +552,7 @@ module type MONAD = sig end module Traverse(M : MONAD) = struct - open! M + open M let map_m f l = let rec aux f acc l = match l with From fcf950e9455b969092249eee99d9fe7e5c18083d Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 7 Nov 2014 08:48:19 +0100 Subject: [PATCH 19/29] Add CCOpt.filter. --- core/CCOpt.ml | 4 ++++ core/CCOpt.mli | 5 +++++ 2 files changed, 9 insertions(+) diff --git a/core/CCOpt.ml b/core/CCOpt.ml index 40bd8e58..b99176de 100644 --- a/core/CCOpt.ml +++ b/core/CCOpt.ml @@ -84,6 +84,10 @@ let map2 f o1 o2 = match o1, o2 with | _, None -> None | Some x, Some y -> Some (f x y) +let filter p = function + | Some x as o when p x -> o + | o -> o + let iter f o = match o with | None -> () | Some x -> f x diff --git a/core/CCOpt.mli b/core/CCOpt.mli index 48b7ec4a..838f04e7 100644 --- a/core/CCOpt.mli +++ b/core/CCOpt.mli @@ -60,6 +60,11 @@ val iter : ('a -> unit) -> 'a t -> unit val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a (** Fold on 0 or 1 elements *) +val filter : ('a -> bool) -> 'a t -> 'a t +(** Filter on 0 or 1 elements + + @since NEXT_RELEASE *) + val get : 'a -> 'a t -> 'a (** [get default x] unwraps [x], but if [x = None] it returns [default] instead. @since NEXT_RELEASE *) From dc7b774120beeaa906d9f1c3ed62c477f8130ede Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 8 Nov 2014 01:00:05 +0100 Subject: [PATCH 20/29] CCList.(>|=) map operator --- core/CCList.ml | 10 ++++++---- core/CCList.mli | 4 ++++ 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/core/CCList.ml b/core/CCList.ml index cddb1911..961d1fd8 100644 --- a/core/CCList.ml +++ b/core/CCList.ml @@ -51,6 +51,8 @@ let map f l = List.rev (List.rev_map f l) = map f l) *) +let (>|=) l f = map f l + let append l1 l2 = let rec direct i l1 l2 = match l1 with | [] -> l2 @@ -448,7 +450,7 @@ module Assoc = struct let rec search eq acc l x y = match l with | [] -> (x,y)::acc | (x',y')::l' -> - if eq x x' + 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 @@ -497,7 +499,7 @@ module Zipper = struct | l, x::r -> begin match f (Some x) with | None -> l,r - | Some x' -> l, x::r + | Some _ -> l, x::r end let focused = function @@ -661,7 +663,7 @@ let of_klist l = let pp ?(start="[") ?(stop="]") ?(sep=", ") pp_item buf l = let rec print l = match l with - | x::((y::xs) as l) -> + | x::((_::_) as l) -> pp_item buf x; Buffer.add_string buf sep; print l @@ -675,7 +677,7 @@ let pp ?(start="[") ?(stop="]") ?(sep=", ") pp_item buf l = let print ?(start="[") ?(stop="]") ?(sep=", ") pp_item fmt l = let rec print fmt l = match l with - | x::((y::xs) as l) -> + | x::((_::_) as l) -> pp_item fmt x; Format.pp_print_string fmt sep; Format.pp_print_cut fmt (); diff --git a/core/CCList.mli b/core/CCList.mli index 65356855..939888c4 100644 --- a/core/CCList.mli +++ b/core/CCList.mli @@ -33,6 +33,10 @@ val empty : 'a t val map : ('a -> 'b) -> 'a t -> 'b t (** Safe version of map *) +val (>|=) : 'a t -> ('a -> 'b) -> 'b t +(** Infix version of [map] with reversed arguments + @since NEXT_RELEASE *) + val append : 'a t -> 'a t -> 'a t (** Safe version of append *) From 259644edf18e849d356b2f27522be3f7a9486360 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 8 Nov 2014 01:00:33 +0100 Subject: [PATCH 21/29] more warnings --- .merlin | 2 +- _tags | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.merlin b/.merlin index 728816da..933075fd 100644 --- a/.merlin +++ b/.merlin @@ -15,4 +15,4 @@ PKG benchmark PKG threads PKG threads.posix PKG lwt -FLG -w +K,+Y,+X +FLG -w +a -w -4 -w -44 diff --git a/_tags b/_tags index e89e7e22..37a53b13 100644 --- a/_tags +++ b/_tags @@ -160,4 +160,4 @@ : thread : thread : -traverse -<{string,core}/**/*.ml>: warn_K, warn_Y, warn_X +<{string,core}/**/*.ml>: warn_A, warn(-4), warn(-44) From 6ff9c1116728ebc3201e7b25422eeca1476c7a09 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 8 Nov 2014 01:01:03 +0100 Subject: [PATCH 22/29] CCSequence now provides some bytes-dependent operations (so containers depends on bytes) --- _oasis | 1 + core/CCSequence.mli | 8 ++++++++ 2 files changed, 9 insertions(+) diff --git a/_oasis b/_oasis index 73a75682..1bf48bc4 100644 --- a/_oasis +++ b/_oasis @@ -49,6 +49,7 @@ Library "containers" CCKList, CCInt, CCBool, CCArray, CCOrd, CCIO, CCRandom, CCKTree, CCTrie, CCString, CCHashtbl, CCFlatHashtbl, CCSexp, CCMap + BuildDepends: bytes XMETARequires: cppo FindlibName: containers diff --git a/core/CCSequence.mli b/core/CCSequence.mli index e036693b..7e3b6a63 100644 --- a/core/CCSequence.mli +++ b/core/CCSequence.mli @@ -604,7 +604,15 @@ module IO : sig @param mode default [0o644] @param flags used by [open_out_gen]. Default: [[Open_creat;Open_wronly]]. *) + val write_bytes_to : ?mode:int -> ?flags:open_flag list -> + string -> Bytes.t t -> unit + (** @since NEXT_RELEASE *) + val write_lines : ?mode:int -> ?flags:open_flag list -> string -> string t -> unit (** Same as {!write_to}, but intercales ['\n'] between each string *) + + val write_bytes_lines : ?mode:int -> ?flags:open_flag list -> + string -> Bytes.t t -> unit + (** @since NEXT_RELEASE *) end From af58399ca75d427a57c01914a84c3b8408096a3f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 8 Nov 2014 01:24:39 +0100 Subject: [PATCH 23/29] Levenshtein.Index.remove changed signature (useless param removed) --- string/levenshtein.ml | 6 +++--- string/levenshtein.mli | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/string/levenshtein.ml b/string/levenshtein.ml index 04e65dcc..cc4f9ade 100644 --- a/string/levenshtein.ml +++ b/string/levenshtein.ml @@ -98,7 +98,7 @@ module type S = sig (** Add a pair string/value to the index. If a value was already present for this string it is replaced. *) - val remove : 'b t -> string_ -> 'b -> 'b t + val remove : 'b t -> string_ -> 'b t (** Remove a string (and its associated value, if any) from the index. *) val retrieve : limit:int -> 'b t -> string_ -> 'b klist @@ -338,7 +338,7 @@ module Make(Str : STRING) = struct let rec get_transitions_for_any nda acc transitions = match transitions with - | NDA.Upon (NDA.Char _, i, j) :: transitions' -> + | NDA.Upon (NDA.Char _, _, _) :: transitions' -> get_transitions_for_any nda acc transitions' | NDA.Upon (NDA.Any, i, j) :: transitions' -> let acc = NDAStateSet.add (i,j) acc in @@ -558,7 +558,7 @@ module Make(Str : STRING) = struct (function | Node (_, m) -> Node (Some value, m)) - let remove trie s value = + let remove trie s = goto_leaf s trie (function | Node (_, m) -> Node (None, m)) diff --git a/string/levenshtein.mli b/string/levenshtein.mli index 9affac48..8db9fa5e 100644 --- a/string/levenshtein.mli +++ b/string/levenshtein.mli @@ -142,7 +142,7 @@ module type S = sig (** Add a pair string/value to the index. If a value was already present for this string it is replaced. *) - val remove : 'b t -> string_ -> 'b -> 'b t + val remove : 'b t -> string_ -> 'b t (** Remove a string (and its associated value, if any) from the index. *) val retrieve : limit:int -> 'b t -> string_ -> 'b klist From 24b441579cfdee4644363da5071bce5107bd73e1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 8 Nov 2014 01:28:42 +0100 Subject: [PATCH 24/29] removed many warnings --- core/CCArray.ml | 6 +++--- core/CCError.ml | 4 ++-- core/CCFQueue.ml | 8 ++++---- core/CCFlatHashtbl.ml | 2 +- core/CCGen.ml | 20 ++++++++++---------- core/CCIO.ml | 2 +- core/CCKTree.ml | 6 +++--- core/CCMultiMap.ml | 6 +++--- core/CCMultiSet.ml | 8 ++++---- core/CCPersistentHashtbl.ml | 2 +- core/CCPrint.ml | 8 ++++---- core/CCTrie.ml | 4 ++-- core/CCVector.ml | 2 +- misc/json.ml | 4 ++-- misc/printBox.ml | 28 ++++++++++++++-------------- misc/printBox.mli | 2 +- tests/test_levenshtein.ml | 6 +++--- 17 files changed, 59 insertions(+), 59 deletions(-) diff --git a/core/CCArray.ml b/core/CCArray.ml index d91f555b..c10a9ee2 100644 --- a/core/CCArray.ml +++ b/core/CCArray.ml @@ -225,7 +225,7 @@ let _shuffle _rand_int a i j = let _choose a i j st = if i>=j then raise Not_found; - a.(i+Random.int (j-i)) + a.(i+Random.State.int st (j-i)) let _pp ~sep pp_item buf a i j = for k = i to j - 1 do @@ -283,7 +283,7 @@ let iteri = Array.iteri let blit = Array.blit let reverse_in_place a = - _reverse_in_place a 0 (Array.length a) + _reverse_in_place a 0 ~len:(Array.length a) (*$T reverse_in_place [| |]; true @@ -464,7 +464,7 @@ module Sub = struct let copy a = Array.sub a.arr a.i (length a) - let sub a i len = make a.arr (a.i + i) len + let sub a i len = make a.arr ~len:(a.i + i) len let equal eq a b = length a = length b && _equal eq a.arr a.i a.j b.arr b.i b.j diff --git a/core/CCError.ml b/core/CCError.ml index abe716f7..79c555e1 100644 --- a/core/CCError.ml +++ b/core/CCError.ml @@ -170,7 +170,7 @@ let choose l = (* print errors on the buffer *) let rec print buf l = match l with | `Ok _ :: _ -> assert false - | (`Error x)::((y::xs) as l) -> + | (`Error x)::((_::_) as l) -> Buffer.add_string buf x; Buffer.add_string buf ", "; print buf l @@ -205,7 +205,7 @@ module Traverse(M : MONAD) = struct let sequence_m m = map_m (fun x->x) m let fold_m f acc e = match e with - | `Error s -> M.return acc + | `Error _ -> M.return acc | `Ok x -> f acc x >>= fun y -> M.return y let rec retry_m n f = match n with diff --git a/core/CCFQueue.ml b/core/CCFQueue.ml index 41df1639..04122478 100644 --- a/core/CCFQueue.ml +++ b/core/CCFQueue.ml @@ -68,7 +68,7 @@ let rec cons : 'a. 'a -> 'a t -> 'a t | Shallow (Two (y,z)) -> Shallow (Three (x,y,z)) | Shallow (Three (y,z,z')) -> _deep 4 (Two (x,y)) _empty (Two (z,z')) - | Deep (_, Zero, middle, tl) -> assert false + | Deep (_, Zero, _middle, _tl) -> assert false | Deep (n,One y, middle, tl) -> _deep (n+1) (Two (x,y)) middle tl | Deep (n,Two (y,z), middle, tl) -> _deep (n+1)(Three (x,y,z)) middle tl | Deep (n,Three (y,z,z'), lazy q', tail) -> @@ -81,7 +81,7 @@ let rec snoc : 'a. 'a t -> 'a -> 'a t | Shallow (Two (y,z)) -> Shallow (Three (y,z,x)) | Shallow (Three (y,z,z')) -> _deep 4 (Two (y,z)) _empty (Two (z',x)) - | Deep (_,hd, middle, Zero) -> assert false + | Deep (_,_hd, _middle, Zero) -> assert false | Deep (n,hd, middle, One y) -> _deep (n+1) hd middle (Two(y,x)) | Deep (n,hd, middle, Two (y,z)) -> _deep (n+1) hd middle (Three(y,z,x)) | Deep (n,hd, lazy q', Three (y,z,z')) -> @@ -131,7 +131,7 @@ let rec take_back_exn : 'a. 'a t -> 'a t * 'a | Shallow (One x) -> empty, x | Shallow (Two (x,y)) -> _single x, y | Shallow (Three (x,y,z)) -> Shallow (Two(x,y)), z - | Deep (_, hd, middle, Zero) -> assert false + | Deep (_, _hd, _middle, Zero) -> assert false | Deep (n, hd, lazy q', One x) -> if is_empty q' then Shallow hd, x @@ -206,7 +206,7 @@ let rec nth_exn : 'a. int -> 'a t -> 'a | 1, Shallow (Three (_,x,_)) -> x | 2, Shallow (Three (_,_,x)) -> x | _, Shallow _ -> raise Not_found - | _, Deep (n, l, q, r) -> + | _, Deep (_, l, q, r) -> if i<_size_digit l then _nth_digit i l else diff --git a/core/CCFlatHashtbl.ml b/core/CCFlatHashtbl.ml index 5de3a2a2..904c482c 100644 --- a/core/CCFlatHashtbl.ml +++ b/core/CCFlatHashtbl.ml @@ -170,7 +170,7 @@ module Make(X : HASHABLE) = struct | Empty -> () | Key (_, _, h_k) when _dib tbl h_k i = 0 -> () (* stop *) - | Key (k, v, h_k) as bucket -> + | Key (_k, _v, h_k) as bucket -> assert (_dib tbl h_k i > 0); (* shift backward *) tbl.arr.(_pred tbl i) <- bucket; diff --git a/core/CCGen.ml b/core/CCGen.ml index a2db99d7..533e016f 100644 --- a/core/CCGen.ml +++ b/core/CCGen.ml @@ -201,7 +201,7 @@ module type S = sig [e1, e2, ... ] picks elements in [e1], [e2], in [e3], [e1], [e2] .... Once a generator is empty, it is skipped; when they are all empty, and none remains in the input, - their merge is also empty. + their merge is also empty. For instance, [merge [1;3;5] [2;4;6]] will be, in disorder, [1;2;3;4;5;6]. *) val intersection : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t @@ -384,7 +384,7 @@ let reduce f g = let acc = match g () with | None -> raise (Invalid_argument "reduce") | Some x -> x - in + in fold f acc g (* Dual of {!fold}, with a deconstructing operation *) @@ -671,7 +671,7 @@ let drop_while p gen = | Yield -> begin match gen () with | None -> state := Stop; None - | (Some x) as res -> res + | Some _ as res -> res end in next @@ -1088,7 +1088,7 @@ let sorted_merge_n ?(cmp=Pervasives.compare) l = let round_robin ?(n=2) gen = (* array of queues, together with their index *) - let qs = Array.init n (fun i -> Queue.create ()) in + let qs = Array.init n (fun _ -> Queue.create ()) in let cur = ref 0 in (* get next element for the i-th queue *) let rec next i = @@ -1128,7 +1128,7 @@ let round_robin ?(n=2) gen = when they are consumed evenly *) let tee ?(n=2) gen = (* array of queues, together with their index *) - let qs = Array.init n (fun i -> Queue.create ()) in + let qs = Array.init n (fun _ -> Queue.create ()) in let finished = ref false in (* is [gen] exhausted? *) (* get next element for the i-th queue *) let rec next i = @@ -1139,7 +1139,7 @@ let tee ?(n=2) gen = else Queue.pop qs.(i) (* consume one more element *) and get_next i = match gen() with - | (Some x) as res -> + | Some _ as res -> for j = 0 to n-1 do if j <> i then Queue.push res qs.(j) done; @@ -1158,7 +1158,7 @@ let tee ?(n=2) gen = module InterleaveState = struct type 'a t = - | Only of 'a gen + | Only of 'a gen | Both of 'a gen * 'a gen * bool ref | Stop end @@ -1487,7 +1487,7 @@ module Restart = struct let repeat x () = repeat x - let unfold f acc () = unfold f acc + let unfold f acc () = unfold f acc let init ?limit f () = init ?limit f @@ -1625,7 +1625,7 @@ module Restart = struct let of_list l () = of_list l let to_rev_list e = to_rev_list (e ()) - + let to_list e = to_list (e ()) let to_array e = to_array (e ()) @@ -1678,7 +1678,7 @@ module MList = struct then begin prev := cur; fill next Nil - end else fill prev cur + end else fill prev cur in fill start !start ; !start diff --git a/core/CCIO.ml b/core/CCIO.ml index 07d36922..26645d5c 100644 --- a/core/CCIO.ml +++ b/core/CCIO.ml @@ -415,7 +415,7 @@ module Seq = struct try _yield (input_line ic) with End_of_file -> _stop() - let words g = + let words _g = failwith "words: not implemented yet" (* TODO: state machine that goes: - 0: read input chunk diff --git a/core/CCKTree.ml b/core/CCKTree.ml index b6cff1e4..e18c89c7 100644 --- a/core/CCKTree.ml +++ b/core/CCKTree.ml @@ -199,14 +199,14 @@ module Dot = struct let mk_id format = let buf = Buffer.create 64 in Printf.kbprintf - (fun fmt -> `Id (Buffer.contents buf)) + (fun _ -> `Id (Buffer.contents buf)) buf format let mk_label format = let buf = Buffer.create 64 in Printf.kbprintf - (fun fmt -> `Label(Buffer.contents buf)) + (fun _ -> `Label(Buffer.contents buf)) buf format @@ -287,6 +287,6 @@ module Dot = struct Printf.bprintf buf "}\n"; () - let pp_single name buf t = pp buf (singleton name t) + let pp_single name buf t = pp buf (singleton ~name t) end diff --git a/core/CCMultiMap.ml b/core/CCMultiMap.ml index 29be19a8..83d19d24 100644 --- a/core/CCMultiMap.ml +++ b/core/CCMultiMap.ml @@ -167,7 +167,7 @@ module Make(K : OrderedType)(V : OrderedType) = struct let union m1 m2 = M.merge - (fun k v1 v2 -> match v1, v2 with + (fun _k v1 v2 -> match v1, v2 with | None, None -> None | Some set1, Some set2 -> Some (S.union set1 set2) | Some set, None @@ -176,7 +176,7 @@ module Make(K : OrderedType)(V : OrderedType) = struct let inter m1 m2 = M.merge - (fun k v1 v2 -> match v1, v2 with + (fun _k v1 v2 -> match v1, v2 with | None, _ | _, None -> None | Some set1, Some set2 -> @@ -188,7 +188,7 @@ module Make(K : OrderedType)(V : OrderedType) = struct let diff m1 m2 = M.merge - (fun k v1 v2 -> match v1, v2 with + (fun _k v1 v2 -> match v1, v2 with | None, _ -> None | Some set, None -> Some set | Some set1, Some set2 -> diff --git a/core/CCMultiSet.ml b/core/CCMultiSet.ml index 2a0b2747..8e840586 100644 --- a/core/CCMultiSet.ml +++ b/core/CCMultiSet.ml @@ -117,7 +117,7 @@ module Make(O : Set.OrderedType) = struct let union m1 m2 = M.merge - (fun x n1 n2 -> match n1, n2 with + (fun _x n1 n2 -> match n1, n2 with | None, None -> assert false | Some n, None | None, Some n -> Some n @@ -134,7 +134,7 @@ module Make(O : Set.OrderedType) = struct let intersection m1 m2 = M.merge - (fun x n1 n2 -> match n1, n2 with + (fun _x n1 n2 -> match n1, n2 with | None, None -> assert false | Some _, None | None, Some _ -> None @@ -143,10 +143,10 @@ module Make(O : Set.OrderedType) = struct let diff m1 m2 = M.merge - (fun x n1 n2 -> match n1, n2 with + (fun _x n1 n2 -> match n1, n2 with | None, None -> assert false | Some n1, None -> Some n1 - | None, Some n2 -> None + | None, Some _n2 -> None | Some n1, Some n2 -> if n1 > n2 then Some (n1 - n2) diff --git a/core/CCPersistentHashtbl.ml b/core/CCPersistentHashtbl.ml index 70c4df91..878f76ba 100644 --- a/core/CCPersistentHashtbl.ml +++ b/core/CCPersistentHashtbl.ml @@ -294,7 +294,7 @@ module Make(H : HashedType) : S with type key = H.t = struct (fun k v2 -> if not (mem t1 k) then match f k None (Some v2) with | None -> () - | Some v' -> Table.replace tbl k v2); + | Some _ -> Table.replace tbl k v2); ref (Table tbl) let add_seq init seq = diff --git a/core/CCPrint.ml b/core/CCPrint.ml index b8e8851f..8ccde136 100644 --- a/core/CCPrint.ml +++ b/core/CCPrint.ml @@ -38,7 +38,7 @@ type 'a t = Buffer.t -> 'a -> unit (** {2 Combinators} *) -let silent buf _ = () +let silent _buf _ = () let unit buf () = Buffer.add_string buf "()" let int buf i = Buffer.add_string buf (string_of_int i) @@ -49,7 +49,7 @@ let float buf f = Buffer.add_string buf (string_of_float f) let list ?(start="[") ?(stop="]") ?(sep=", ") pp buf l = let rec pp_list l = match l with - | x::((y::xs) as l) -> + | x::((_::_) as l) -> pp buf x; Buffer.add_string buf sep; pp_list l @@ -116,14 +116,14 @@ let to_string pp x = let sprintf format = let buffer = Buffer.create 64 in Printf.kbprintf - (fun fmt -> Buffer.contents buffer) + (fun _fmt -> Buffer.contents buffer) buffer format let fprintf oc format = let buffer = Buffer.create 64 in Printf.kbprintf - (fun fmt -> Buffer.output_buffer oc buffer) + (fun _fmt -> Buffer.output_buffer oc buffer) buffer format diff --git a/core/CCTrie.ml b/core/CCTrie.ml index c4900000..2956fe2f 100644 --- a/core/CCTrie.ml +++ b/core/CCTrie.ml @@ -211,7 +211,7 @@ module Make(W : WORD) = struct let _remove_sub c t = match t with | Empty -> t | Path ([], _) -> assert false - | Path (c'::l, t') -> + | Path (c'::_, _) -> if W.compare c c' = 0 then Empty else t @@ -357,7 +357,7 @@ module Make(W : WORD) = struct | Some v -> f acc v in M.fold - (fun c t' acc -> fold_values f acc t') + (fun _c t' acc -> fold_values f acc t') map acc let iter_values f t = fold_values (fun () x -> f x) () t diff --git a/core/CCVector.ml b/core/CCVector.ml index c7f4b9f2..b4f3c4f7 100644 --- a/core/CCVector.ml +++ b/core/CCVector.ml @@ -437,7 +437,7 @@ let of_array a = let of_list l = match l with | [] -> create() - | x::l' -> + | x::_ -> let v = create_with ~capacity:(List.length l + 5) x in List.iter (push v) l; v diff --git a/misc/json.ml b/misc/json.ml index e0893414..051434ff 100644 --- a/misc/json.ml +++ b/misc/json.ml @@ -79,7 +79,6 @@ let parse chars = read_list (t::acc) (* next *) | Some (Genlex.Kwd "]") -> read_list (t::acc) (* next *) - | Some (Genlex.Kwd "]") -> List.rev acc (* yield *) | _ -> raise (Stream.Error "expected ','")) and read_pairs acc = match peek tokens with @@ -163,7 +162,8 @@ let rec pp fmt t = let to_string t = let buf = Buffer.create 16 in - Format.bprintf buf "%a@?" pp t; + let fmt = Format.formatter_of_buffer buf in + Format.fprintf fmt "%a@?" pp t; Buffer.contents buf (** {2 Utils *) diff --git a/misc/printBox.ml b/misc/printBox.ml index 6d0feca4..34141af2 100644 --- a/misc/printBox.ml +++ b/misc/printBox.ml @@ -36,7 +36,7 @@ let _minus pos1 pos2 = _move pos1 (- pos2.x) (- pos2.y) let _move_x pos x = _move pos x 0 let _move_y pos y = _move pos 0 y -let _string_len = ref String.length +let _string_len = ref Bytes.length let set_string_len f = _string_len := f @@ -61,11 +61,11 @@ module Output = struct mutable buf_len : int; } and buf_line = { - mutable bl_str : string; + mutable bl_str : Bytes.t; mutable bl_len : int; } - let _make_line _ = {bl_str=""; bl_len=0} + let _make_line _ = {bl_str=Bytes.empty; bl_len=0} let _ensure_lines buf i = if i >= Array.length buf.buf_lines @@ -78,8 +78,8 @@ module Output = struct let _ensure_line line i = if i >= !_string_len line.bl_str then ( - let str' = String.make (2 * i + 5) ' ' in - String.blit line.bl_str 0 str' 0 line.bl_len; + let str' = Bytes.make (2 * i + 5) ' ' in + Bytes.blit line.bl_str 0 str' 0 line.bl_len; line.bl_str <- str'; ) @@ -88,7 +88,7 @@ module Output = struct _ensure_line buf.buf_lines.(pos.y) pos.x; buf.buf_len <- max buf.buf_len (pos.y+1); let line = buf.buf_lines.(pos.y) in - line.bl_str.[pos.x] <- c; + Bytes.set line.bl_str pos.x c; line.bl_len <- max line.bl_len (pos.x+1) let _buf_put_sub_string buf pos s s_i s_len = @@ -100,7 +100,7 @@ module Output = struct line.bl_len <- max line.bl_len (pos.x+s_len) let _buf_put_string buf pos s = - _buf_put_sub_string buf pos s 0 (!_string_len s) + _buf_put_sub_string buf pos s 0 (!_string_len (Bytes.unsafe_of_string s)) (* create a new buffer *) let make_buffer () = @@ -121,7 +121,7 @@ module Output = struct for i = 0 to buf.buf_len - 1 do for k = 1 to indent do Buffer.add_char buffer ' ' done; let line = buf.buf_lines.(i) in - Buffer.add_substring buffer line.bl_str 0 line.bl_len; + Buffer.add_substring buffer (Bytes.unsafe_to_string line.bl_str) 0 line.bl_len; Buffer.add_char buffer '\n'; done; Buffer.contents buffer @@ -238,7 +238,7 @@ module Box = struct | Empty -> origin | Text l -> let width = List.fold_left - (fun acc line -> max acc (!_string_len line)) 0 l + (fun acc line -> max acc (!_string_len (Bytes.unsafe_of_string line))) 0 l in { x=width; y=List.length l; } | Frame t -> @@ -337,7 +337,7 @@ let tree ?(indent=1) node children = let children = List.filter (function - | {Box.shape=Box.Empty} -> false + | {Box.shape=Box.Empty; _} -> false | _ -> true ) children in @@ -384,10 +384,10 @@ let rec _render ?(offset=origin) ?expected_size ~out b pos = Output.put_char out (_move pos (x+1) (y+1)) '+'; Output.put_char out (_move pos 0 (y+1)) '+'; Output.put_char out (_move pos (x+1) 0) '+'; - _write_hline out (_move_x pos 1) x; - _write_hline out (_move pos 1 (y+1)) x; - _write_vline out (_move_y pos 1) y; - _write_vline out (_move pos (x+1) 1) y; + _write_hline ~out (_move_x pos 1) x; + _write_hline ~out (_move pos 1 (y+1)) x; + _write_vline ~out (_move_y pos 1) y; + _write_vline ~out (_move pos (x+1) 1) y; _render ~out b' (_move pos 1 1) | Box.Pad (dim, b') -> let expected_size = Box.size b in diff --git a/misc/printBox.mli b/misc/printBox.mli index ca325fca..30cb3d4f 100644 --- a/misc/printBox.mli +++ b/misc/printBox.mli @@ -72,7 +72,7 @@ we go toward the bottom (same order as a printer) *) val origin : position (** Initial position *) -val set_string_len : (string -> int) -> unit +val set_string_len : (Bytes.t -> int) -> unit (** Set which function is used to compute string length. Typically to be used with a unicode-sensitive length function *) diff --git a/tests/test_levenshtein.ml b/tests/test_levenshtein.ml index ff6aed45..52ecd20a 100644 --- a/tests/test_levenshtein.ml +++ b/tests/test_levenshtein.ml @@ -26,10 +26,10 @@ let test_mutation = return (s,i,c) ) in let test (s,i,c) = - let s' = String.copy s in - s'.[i] <- c; + let s' = Bytes.of_string s in + Bytes.set s' i c; let a = Levenshtein.of_string ~limit:1 s in - Levenshtein.match_with a s' + Levenshtein.match_with a (Bytes.to_string s') in let name = "mutating s.[i] into s' still accepted by automaton(s)" in QCheck.mk_test ~name ~size:(fun (s,_,_)->String.length s) gen test From be08237d61273e5cdce07161fa980a59bc4199f6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 10 Nov 2014 00:11:08 +0100 Subject: [PATCH 25/29] re-enable qtests for .cppo.ml files --- Makefile | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/Makefile b/Makefile index 40955067..bc534202 100644 --- a/Makefile +++ b/Makefile @@ -61,6 +61,7 @@ push_doc: doc DONTTEST=myocamlbuild.ml setup.ml $(wildcard **/*.cppo*) QTESTABLE=$(filter-out $(DONTTEST), \ $(wildcard core/*.ml) $(wildcard core/*.mli) \ + $(wildcard core/*.cppo.ml) $(wildcard core/*.cppo.mli) \ $(wildcard misc/*.ml) $(wildcard misc/*.mli) \ $(wildcard string/*.ml) $(wildcard string/*.mli) \ ) @@ -72,14 +73,18 @@ QTEST_PREAMBLE='open CCFun;; ' #qtest-build: qtest-clean build # @mkdir -p qtest -# @qtest extract --preamble $(QTEST_PREAMBLE) -o qtest/qtest_all.ml $(QTESTABLE) 2> /dev/null +# @qtest extract --preamble $(QTEST_PREAMBLE) \ +# -o qtest/qtest_all.ml \ +# $(QTESTABLE) 2> /dev/null # @ocamlbuild $(OPTIONS) -pkg oUnit,QTest2Lib,ocamlbuildlib \ # -I core -I misc -I string \ # qtest/qtest_all.native qtest-gen: qtest-clean @mkdir -p qtest - @qtest extract --preamble $(QTEST_PREAMBLE) -o qtest/run_qtest.ml $(QTESTABLE) 2> /dev/null + @qtest extract --preamble $(QTEST_PREAMBLE) \ + -o qtest/run_qtest.cppo.ml \ + $(QTESTABLE) 2> /dev/null push-stable: git checkout stable From 1debe08645941f811c65ce2d062f7f99c47e60e5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 10 Nov 2014 00:49:29 +0100 Subject: [PATCH 26/29] more tests for CCVector --- core/CCVector.ml | 36 ++++++++++++++++++++++++++++++++---- core/CCVector.mli | 2 +- 2 files changed, 33 insertions(+), 5 deletions(-) diff --git a/core/CCVector.ml b/core/CCVector.ml index b4f3c4f7..8f948dc3 100644 --- a/core/CCVector.ml +++ b/core/CCVector.ml @@ -139,6 +139,11 @@ let append a b = a.size <- a.size + b.size ) +(*$T + let v1 = init 5 (fun i->i) and v2 = init 5 (fun i->i+5) in \ + append v1 v2; to_list v1 = CCList.(0--9) +*) + let get v i = if i < 0 || i >= v.size then failwith "Vector.get"; Array.unsafe_get v.vec i @@ -159,8 +164,14 @@ let append_seq a seq = seq (fun x -> push a x) let append_array a b = + ensure a (a.size + Array.length b); Array.iter (push a) b +(*$T + let v1 = init 5 (fun i->i) and v2 = Array.init 5 (fun i->i+5) in \ + append_array v1 v2; to_list v1 = CCList.(0--9) +*) + let equal eq v1 v2 = let n = min v1.size v2.size in let rec check i = @@ -243,6 +254,11 @@ let uniq_sort cmp v = then traverse v.vec.(0) 1 1 (* start at 1, to get the first element in hand *) +(*$T + let v = of_list [1;4;5;3;2;4;1] in \ + uniq_sort Pervasives.compare v; to_list v = [1;2;3;4;5] +*) + let iter k v = for i = 0 to v.size -1 do k (Array.unsafe_get v.vec i) @@ -256,10 +272,18 @@ let iteri k v = let map f v = if _empty_array v then create () - else { - size=v.size; - vec=Array.map f v.vec - } + else ( + let vec = Array.init v.size (fun i -> f (Array.unsafe_get v.vec i)) in + { + size=v.size; + vec; + } + ) + +(*$T + let v = create() in push v 1; push v 2; push v 3; \ + to_list (map string_of_int v) = ["1"; "2"; "3"] + *) let filter' p v = let i = ref (v.size - 1) in @@ -464,6 +488,10 @@ let to_gen v = Some x ) else None +(*$T + let v = (1--10) in to_list v = CCGen.to_list (to_gen v) + *) + let of_klist ?(init=create ()) l = let rec aux l = match l() with | `Nil -> init diff --git a/core/CCVector.mli b/core/CCVector.mli index d3b7a7d3..37cb0677 100644 --- a/core/CCVector.mli +++ b/core/CCVector.mli @@ -90,7 +90,7 @@ val append_seq : ('a, rw) t -> 'a sequence -> unit val equal : 'a equal -> ('a,_) t equal val compare : 'a ord -> ('a,_) t ord -(** Lexicographic comparison *) +(** Total ordering on vectors: Lexicographic comparison. *) val pop : ('a, rw) t -> 'a option (** Remove last element, or [None] *) From 9b3419055e9eb7253b6618699e185d06f566cc87 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 10 Nov 2014 00:49:45 +0100 Subject: [PATCH 27/29] stronger inlining for CCVector (so that e.g. push is inline) --- _tags | 1 + 1 file changed, 1 insertion(+) diff --git a/_tags b/_tags index 37a53b13..2026ea27 100644 --- a/_tags +++ b/_tags @@ -160,4 +160,5 @@ : thread : thread : -traverse +: inline(25) <{string,core}/**/*.ml>: warn_A, warn(-4), warn(-44) From 21fba9effa2c9a7822cc7c7119d8571648f063d8 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 10 Nov 2014 12:17:59 +0100 Subject: [PATCH 28/29] more documentation in CCGen --- core/CCGen.mli | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/core/CCGen.mli b/core/CCGen.mli index c61670f6..fab98dc6 100644 --- a/core/CCGen.mli +++ b/core/CCGen.mli @@ -28,7 +28,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Values of type ['a Gen.t] represent a possibly infinite sequence of values of type 'a. One can only iterate once on the sequence, as it is consumed by iteration/deconstruction/access. [None] is returned when the generator -is exhausted. +is exhausted. Most functions consume elements. The submodule {!Restart} provides utilities to work with {b restartable generators}, that is, functions [unit -> 'a Gen.t] that @@ -78,25 +78,27 @@ module type S = sig (** {2 Basic combinators} *) val is_empty : _ t -> bool - (** Check whether the enum is empty. *) + (** Check whether the genertor is empty. Consumes one element if the + generator isn't empty. *) val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b - (** Fold on the generator, tail-recursively *) + (** Fold on the generator, tail-recursively; consumes it *) val reduce : ('a -> 'a -> 'a) -> 'a t -> 'a - (** Fold on non-empty sequences (otherwise raise Invalid_argument) *) + (** Fold on non-empty sequences + @raise Invalid_argument if the generator is empty *) val scan : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b t (** Like {!fold}, but keeping successive values of the accumulator *) val iter : ('a -> unit) -> 'a t -> unit - (** Iterate on the enum *) + (** Iterate on the generator, consuming it *) val iteri : (int -> 'a -> unit) -> 'a t -> unit - (** Iterate on elements with their index in the enum, from 0 *) + (** Iterate on elements with their index in the enum, from 0. Consumes it. *) val length : _ t -> int - (** Length of an enum (linear time) *) + (** Length of a generator (linear time, consumes its input) *) val map : ('a -> 'b) -> 'a t -> 'b t (** Lazy map. No iteration is performed now, the function will be called @@ -217,7 +219,7 @@ module type S = sig [e1, e2, ... ] picks elements in [e1], [e2], in [e3], [e1], [e2] .... Once a generator is empty, it is skipped; when they are all empty, and none remains in the input, - their merge is also empty. + their merge is also empty. For instance, [merge [1;3;5] [2;4;6]] will be, in disorder, [1;2;3;4;5;6]. *) val intersection : ?cmp:('a -> 'a -> int) -> 'a t -> 'a t -> 'a t From c69dc8b0095a08bb47754a3cfc5114f88aa6cefe Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 11 Nov 2014 15:51:55 +0100 Subject: [PATCH 29/29] CCError: now polymorphic on the error type; some retro-incompatibilies (wrap,guard) --- core/CCError.ml | 75 ++++++++++++++++----------------- core/CCError.mli | 106 +++++++++++++++++++++++++++-------------------- 2 files changed, 99 insertions(+), 82 deletions(-) diff --git a/core/CCError.ml b/core/CCError.ml index 79c555e1..053de05d 100644 --- a/core/CCError.ml +++ b/core/CCError.ml @@ -34,9 +34,9 @@ type 'a formatter = Format.formatter -> 'a -> unit (** {2 Basics} *) -type +'a t = - [ `Ok of 'a - | `Error of string +type (+'good, +'bad) t = + [ `Ok of 'good + | `Error of 'bad ] let return x = `Ok x @@ -68,6 +68,10 @@ 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) @@ -88,16 +92,16 @@ let (>|=) e f = map f e let (>>=) e f = flat_map f e -let equal eq a b = match a, b with +let equal ?(err=Pervasives.(=)) eq a b = match a, b with | `Ok x, `Ok y -> eq x y - | `Error s, `Error s' -> s = s' + | `Error s, `Error s' -> err s s' | _ -> false -let compare cmp a b = match a, b with +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' -> String.compare s s' + | `Error s, `Error s' -> err s s' let fold ~success ~failure x = match x with | `Ok x -> success x @@ -106,21 +110,24 @@ let fold ~success ~failure x = match x with (** {2 Wrappers} *) let guard f = - try - return (f ()) + try `Ok (f ()) + with e -> `Error e + +let guard_str f = + try `Ok (f()) with e -> of_exn e let wrap1 f x = try return (f x) - with e -> of_exn e + with e -> `Error e let wrap2 f x y = try return (f x y) - with e -> of_exn e + with e -> `Error e let wrap3 f x y z = try return (f x y z) - with e -> of_exn e + with e -> `Error e (** {2 Applicative} *) @@ -141,18 +148,20 @@ let map_l f l = | `Ok y -> map (y::acc) l' in map [] l -exception LocalExit of string +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 -> raise (LocalExit s) + | `Error s -> err := Some s; raise LocalExit | `Ok y -> acc := y ); `Ok !acc - with LocalExit s -> `Error s + 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) @@ -166,26 +175,17 @@ let choose l = in try _find l with Not_found -> - let buf = Buffer.create 32 in - (* print errors on the buffer *) - let rec print buf l = match l with - | `Ok _ :: _ -> assert false - | (`Error x)::((_::_) as l) -> - Buffer.add_string buf x; - Buffer.add_string buf ", "; - print buf l - | `Error x::[] -> Buffer.add_string buf x - | [] -> () - in - Printf.bprintf buf "CCError.choice failed: [%a]" print l; - fail (Buffer.contents buf) + let l' = List.map (function `Error s -> s | `Ok _ -> assert false) l in + `Error l' -let rec retry n f = match n with - | 0 -> fail "retry failed" +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 _ -> retry (n-1) f + | `Error e -> retry (n-1) (e::acc) + in retry n [] (** {2 Monadic Operations} *) @@ -208,13 +208,14 @@ module Traverse(M : MONAD) = struct | `Error _ -> M.return acc | `Ok x -> f acc x >>= fun y -> M.return y - let rec retry_m n f = match n with - | 0 -> M.return (fail "retry failed") + let retry_m n f = + let rec retry n acc = match n with + | 0 -> M.return (fail (List.rev acc)) | _ -> - let x = f () in - x >>= function - | `Ok _ -> x - | `Error _ -> retry_m (n-1) f + f () >>= function + | `Ok x -> M.return (`Ok x) + | `Error e -> retry (n-1) (e::acc) + in retry n [] end (** {2 Conversions} *) diff --git a/core/CCError.mli b/core/CCError.mli index ee2368dd..17297bb6 100644 --- a/core/CCError.mli +++ b/core/CCError.mli @@ -24,7 +24,9 @@ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -(** {1 Error Monad} *) +(** {1 Error Monad} + +The variant is polymorphic in the error type since NEXT_RELEASE *) type 'a sequence = ('a -> unit) -> unit type 'a equal = 'a -> 'a -> bool @@ -34,90 +36,104 @@ type 'a formatter = Format.formatter -> 'a -> unit (** {2 Basics} *) -type +'a t = - [ `Ok of 'a - | `Error of string +type (+'good, +'bad) t = + [ `Ok of 'good + | `Error of 'bad ] -val return : 'a -> 'a t +val return : 'a -> ('a,'err) t +(** Successfully return a value *) -val fail : string -> 'a t +val fail : 'err -> ('a,'err) t +(** Fail with an error *) -val of_exn : exn -> 'a t +val of_exn : exn -> ('a, string) t +(** [of_exn e] uses {!Printexc} to print the exception as a string *) -val fail_printf : ('a, Buffer.t, unit, 'a t) format4 -> 'a +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] @since 0.3.3 *) -val map : ('a -> 'b) -> 'a t -> 'b t +val map : ('a -> 'b) -> ('a, 'err) t -> ('b, 'err) t +(** Map on success *) -val map2 : ('a -> 'b) -> (string -> string) -> 'a t -> 'b t +val map_err : ('err1 -> 'err2) -> ('a, 'err1) t -> ('a, 'err2) t +(** Map on error. + @since NEXT_RELEASE *) + +val map2 : ('a -> 'b) -> ('err -> 'err) -> ('a, 'err) t -> ('b, 'err) 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 +val iter : ('a -> unit) -> ('a, _) t -> unit (** Apply the function only in case of `Ok *) -val get_exn : 'a t -> 'a +val get_exn : ('a, _) t -> 'a (** Extract the value [x] from [`Ok x], fails otherwise. You should be careful with this function, and favor other combinators whenever possible. @raise Invalid_argument if the value is an error. *) -val flat_map : ('a -> 'b t) -> 'a t -> 'b t +val flat_map : ('a -> ('b, 'err) t) -> ('a, 'err) t -> ('b, 'err) t -val (>|=) : 'a t -> ('a -> 'b) -> 'b t +val (>|=) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t -val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +val (>>=) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t -val equal : 'a equal -> 'a t equal +val equal : ?err:'err equal -> 'a equal -> ('a, 'err) t equal -val compare : 'a ord -> 'a t ord +val compare : ?err:'err ord -> 'a ord -> ('a, 'err) t ord -val fold : success:('a -> 'b) -> failure:(string -> 'b) -> 'a t -> 'b +val fold : success:('a -> 'b) -> failure:('err -> 'b) -> ('a, 'err) t -> 'b (** [fold ~success ~failure e] opens [e] and, if [e = `Ok x], returns [success x], otherwise [e = `Error s] and it returns [failure s]. *) -(** {2 Wrappers} *) +(** {2 Wrappers} -val guard : (unit -> 'a) -> 'a t +The functions {!guard}, {!wrap1}, {!wrap2} and {!wrap3} now return +exceptions in case of failure, @since NEXT_RELEASE *) + +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 msg] - where [msg] is some printing of [e] (see {!register_printer}). *) + [f ()] raises some exception [e], then it fails with [`Error e] *) -val wrap1 : ('a -> 'b) -> 'a -> 'b t +val guard_str : (unit -> 'a) -> ('a, string) t +(** Same as {!guard} but uses {!of_exn} to print the exception. + See {!register_printer} *) + +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 t +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 t +val wrap3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> ('d, exn) t (** {2 Applicative} *) -val pure : 'a -> 'a t +val pure : 'a -> ('a, 'err) t -val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +val (<*>) : ('a -> 'b, 'err) t -> ('a, 'err) t -> ('b, 'err) t (** {2 Collections} *) -val map_l : ('a -> 'b t) -> 'a list -> 'b list t +val map_l : ('a -> ('b, 'err) t) -> 'a list -> ('b list, 'err) t -val fold_l : ('b -> 'a -> 'b t) -> 'b -> 'a list -> 'b t +val fold_l : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a list -> ('b, 'err) t -val fold_seq : ('b -> 'a -> 'b t) -> 'b -> 'a sequence -> 'b t +val fold_seq : ('b -> 'a -> ('b, 'err) t) -> 'b -> 'a sequence -> ('b, 'err) t (** {2 Misc} *) -val choose : 'a t list -> 'a t +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 msg] otherwise, where [msg] is obtained by - combining the error messages of all elements of [l] *) + or returns [`Error l] otherwise, where [l] is the list of errors. *) -val retry : int -> (unit -> 'a t) -> 'a t +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. *) + 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 @@ -127,28 +143,28 @@ module type MONAD = sig end module Traverse(M : MONAD) : sig - val sequence_m : 'a M.t t -> 'a t M.t + val sequence_m : ('a M.t, 'err) t -> ('a, 'err) t M.t - val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b 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 t -> 'b t M.t + val map_m : ('a -> 'b M.t) -> ('a, 'err) t -> ('b, 'err) t M.t - val retry_m : int -> (unit -> 'a t M.t) -> 'a 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 to_opt : ('a, _) t -> 'a option -val of_opt : 'a option -> 'a t +val of_opt : 'a option -> ('a, string) t -val to_seq : 'a t -> 'a sequence +val to_seq : ('a, _) t -> 'a sequence (** {2 IO} *) -val pp : 'a printer -> 'a t printer +val pp : 'a printer -> ('a, string) t printer -val print : 'a formatter -> 'a t formatter +val print : 'a formatter -> ('a, string) t formatter (** {2 Global Exception Printers} @@ -156,7 +172,7 @@ One can register exception printers here, so they will be used by {!guard}, {!wrap1}, etc. The printers should succeed (print) on exceptions they can deal with, and re-raise the exception otherwise. For instance if I register a printer for [Not_found], it could look like: - + {[CCError.register_printer (fun buf exn -> match exn with | Not_found -> Buffer.add_string buf "Not_found"