From 4ca1295c44ff6f617e6250210277fdbe00ba0596 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Jul 2014 23:05:13 +0200 Subject: [PATCH 01/30] CCError.fail_printf --- core/CCError.ml | 6 ++++++ core/CCError.mli | 5 +++++ 2 files changed, 11 insertions(+) diff --git a/core/CCError.ml b/core/CCError.ml index fe1fdd86..851cd5c1 100644 --- a/core/CCError.ml +++ b/core/CCError.ml @@ -43,6 +43,12 @@ let return x = `Ok x let fail s = `Error s +let fail_printf format = + let buf = Buffer.create 16 in + Printf.kbprintf + (fun buf -> fail (Buffer.contents buf)) + buf format + let _printers = ref [] let register_printer p = _printers := p :: !_printers diff --git a/core/CCError.mli b/core/CCError.mli index ab850d9a..d054296d 100644 --- a/core/CCError.mli +++ b/core/CCError.mli @@ -45,6 +45,11 @@ val fail : string -> 'a t val of_exn : exn -> 'a t +val fail_printf : ('a, Buffer.t, unit, 'a t) format4 -> 'a +(** [fail_printf format] uses [format] to obtain an error message + and then returns [`Error msg] + @since NEXT_VERSION *) + val map : ('a -> 'b) -> 'a t -> 'b t val map2 : ('a -> 'b) -> (string -> string) -> 'a t -> 'b t From 783331b03773ac8f165ad8773efd5dc12db99b2f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 11 Jul 2014 23:07:26 +0200 Subject: [PATCH 02/30] CCString.init --- core/CCString.ml | 5 +++++ core/CCString.mli | 4 ++++ 2 files changed, 9 insertions(+) diff --git a/core/CCString.ml b/core/CCString.ml index 9c46b93c..1128093a 100644 --- a/core/CCString.ml +++ b/core/CCString.ml @@ -56,6 +56,11 @@ 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 length = String.length let rec _to_list s acc i len = diff --git a/core/CCString.mli b/core/CCString.mli index 19fbe9fc..547ed083 100644 --- a/core/CCString.mli +++ b/core/CCString.mli @@ -62,6 +62,10 @@ val compare : t -> t -> int val hash : t -> int +val init : int -> (int -> char) -> t +(** Analog to [Array.init]. + @since NEXT_VERSION *) + val of_gen : char gen -> t val of_seq : char sequence -> t val of_klist : char klist -> t From 9488ff51c6beff87e9044c65620b606145acd2a9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Jul 2014 13:26:31 +0200 Subject: [PATCH 03/30] some unrolling in CCHashtbl --- core/CCHashtbl.ml | 23 ++++++++++++++++++----- tests/benchs.ml | 2 +- 2 files changed, 19 insertions(+), 6 deletions(-) diff --git a/core/CCHashtbl.ml b/core/CCHashtbl.ml index bc08e480..5de3a2a2 100644 --- a/core/CCHashtbl.ml +++ b/core/CCHashtbl.ml @@ -107,7 +107,8 @@ module Make(X : HASHABLE) = struct h mod Array.length tbl.arr let _succ tbl i = - if i = Array.length tbl.arr-1 then 0 else i+1 + let i' = i+1 in + if i' = Array.length tbl.arr then 0 else i' let _pred tbl i = if i = 0 then Array.length tbl.arr - 1 else i-1 @@ -198,7 +199,7 @@ module Make(X : HASHABLE) = struct | Empty -> raise Not_found | Key (k', v', _) when X.equal k k' -> v' | Key (_, _, h_k') -> - if (dib > 3 && _dib tbl h_k' i < dib) + if _dib tbl h_k' i < dib then raise Not_found (* [k] would be here otherwise *) else _get_exn tbl k h_k (_succ tbl i) (dib+1) @@ -206,9 +207,21 @@ module Make(X : HASHABLE) = struct let h_k = X.hash k in let i0 = _initial_idx tbl h_k in match tbl.arr.(i0) with - | Empty -> raise Not_found - | Key (k', v, _) when X.equal k k' -> v - | Key _ -> _get_exn tbl k h_k (_succ tbl i0) 1 + | Empty -> raise Not_found + | Key (k', v, _) -> + if X.equal k k' then v + else let i1 = _succ tbl i0 in + match tbl.arr.(i1) with + | Empty -> raise Not_found + | Key (k', v, _) -> + if X.equal k k' then v + else + let i2 = _succ tbl i1 in + match tbl.arr.(i2) with + | Empty -> raise Not_found + | Key (k', v, _) -> + if X.equal k k' then v + else _get_exn tbl k h_k (_succ tbl i2) 3 let get k tbl = try Some (get_exn k tbl) diff --git a/tests/benchs.ml b/tests/benchs.ml index 93f48fd2..a6553124 100644 --- a/tests/benchs.ml +++ b/tests/benchs.ml @@ -281,7 +281,7 @@ let imap_find m = let icchashtbl_find m = fun n -> for i = 0 to n-1 do - ignore (ICCHashtbl.find_exn m i); + ignore (ICCHashtbl.get_exn i m); done let bench_maps3 () = From 633ded75c29970ed8aaaab3bfc6a648303058fc4 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Jul 2014 18:08:57 +0200 Subject: [PATCH 04/30] make CCList an applicative instance --- core/CCList.ml | 2 ++ core/CCList.mli | 2 ++ 2 files changed, 4 insertions(+) diff --git a/core/CCList.ml b/core/CCList.ml index 2fca2327..b95942ed 100644 --- a/core/CCList.ml +++ b/core/CCList.ml @@ -160,6 +160,8 @@ let (>>=) l f = flat_map f l let (<$>) = map +let pure f = [f] + let (<*>) funs l = product (fun f x -> f x) funs l let sorted_merge ?(cmp=Pervasives.compare) l1 l2 = diff --git a/core/CCList.mli b/core/CCList.mli index 6a72b547..a94820f5 100644 --- a/core/CCList.mli +++ b/core/CCList.mli @@ -64,6 +64,8 @@ val diagonal : 'a t -> ('a * 'a) t (** All pairs of distinct positions of the list. [list_diagonal l] will return the list of [List.nth i l, List.nth j l] if [i < j]. *) +val pure : 'a -> 'a t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t val (<$>) : ('a -> 'b) -> 'a t -> 'b t From 8c5c462c51ea3201ad6c0973d4a55683486a4547 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 16 Jul 2014 18:09:08 +0200 Subject: [PATCH 05/30] CCCat for crazy category concepts --- _oasis | 2 +- core/CCCat.ml | 130 +++++++++++++++++++++++++++++++++++++++++++++++++ core/CCCat.mli | 107 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 238 insertions(+), 1 deletion(-) create mode 100644 core/CCCat.ml create mode 100644 core/CCCat.mli diff --git a/_oasis b/_oasis index 914bd639..c9a02e07 100644 --- a/_oasis +++ b/_oasis @@ -45,7 +45,7 @@ Library "containers" Path: core Modules: CCVector, CCDeque, CCGen, CCSequence, CCFQueue, CCMultiMap, CCMultiSet, CCBV, CCPrint, CCPersistentHashtbl, CCError, - CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, + CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCCat, CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, CCRandom, CCLinq, CCKTree, CCTrie, CCString, CCHashtbl FindlibName: containers diff --git a/core/CCCat.ml b/core/CCCat.ml new file mode 100644 index 00000000..fe9d6f6f --- /dev/null +++ b/core/CCCat.ml @@ -0,0 +1,130 @@ + +(* +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 Categorical Constructs} *) + +(** {2 Signatures} *) + +module type MONOID = sig + type t + val empty : t + val append : t -> t -> t +end + +module type FUNCTOR = sig + type +'a t + val map : ('a -> 'b) -> 'a t -> 'b t +end + +module type APPLICATIVE = sig + type +'a t + include FUNCTOR with type 'a t := 'a t + val pure : 'a -> 'a t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +end + +module type MONAD = sig + type +'a t + include APPLICATIVE with type 'a t := 'a t + val return : 'a -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +end + +module type MONAD_TRANSFORMER = sig + include MONAD + module M : MONAD + val lift : 'a M.t -> 'a t +end + +type 'a sequence = ('a -> unit) -> unit + +module type FOLDABLE = sig + type 'a t + val to_seq : 'a t -> 'a sequence +end + +module type TRAVERSE = functor(M : MONAD) -> sig + type +'a t + + val sequence_m : 'a M.t t -> 'a t M.t + + val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t + + val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t +end + +(** {2 Some Implementations} *) + +module type FREE_MONAD = sig + module F : FUNCTOR + + type +'a t = + | Return of 'a + | Roll of 'a t F.t + + include MONAD with type 'a t := 'a t + val inj : 'a F.t -> 'a t +end + +module MakeFree(F : FUNCTOR) = struct + module F = F + + type 'a t = Return of 'a | Roll of ('a t F.t) + + let return x = Return x + let pure = return + + let rec map : type a b. (a -> b) -> a t -> b t + = fun f x -> match x with + | Return x -> Return (f x) + | Roll xs -> Roll (F.map (map f) xs) + + let rec _bind : type a b. (a -> b t) -> a t -> b t + = fun f x -> match x with + | Return x -> f x + | Roll y -> Roll (F.map (_bind f) y) + + let (>>=) x f = _bind f x + + let rec _app : type a b. (a -> b) t -> a t -> b t + = fun f x -> match f, x with + | Return f, Return x -> Return (f x) + | Return f, Roll xs -> Roll (F.map (map f) xs) + | Roll fs, _ -> Roll (F.map (fun f -> _app f x) fs) + + let (<*>) = _app + + let inj x = Roll (F.map return x) +end + +module MakeFreeFold(FM : FREE_MONAD)(Fold : FOLDABLE with type 'a t = 'a FM.F.t) = struct + type 'a t = 'a FM.t + + let rec to_seq : type a. a FM.t -> a sequence + = fun x k -> match x with + | FM.Return x -> k x + | FM.Roll xs -> Fold.to_seq xs (fun x -> to_seq x k) +end diff --git a/core/CCCat.mli b/core/CCCat.mli new file mode 100644 index 00000000..62b2ed76 --- /dev/null +++ b/core/CCCat.mli @@ -0,0 +1,107 @@ +(* +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 Categorical Constructs} + +Attempt to copy some structures from Haskell and the likes. Disclaimer: +I don't know much about category theory, only about type signatures ;). *) + +(** {2 Signatures} *) + +module type MONOID = sig + type t + val empty : t + val append : t -> t -> t +end + +module type FUNCTOR = sig + type +'a t + val map : ('a -> 'b) -> 'a t -> 'b t +end + +module type APPLICATIVE = sig + type +'a t + include FUNCTOR with type 'a t := 'a t + val pure : 'a -> 'a t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +end + +module type MONAD = sig + type +'a t + include APPLICATIVE with type 'a t := 'a t + val return : 'a -> 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +end + +module type MONAD_TRANSFORMER = sig + include MONAD + module M : MONAD + val lift : 'a M.t -> 'a t +end + +(** Cheating: use an equivalent of "to List" with a sequence *) +type 'a sequence = ('a -> unit) -> unit + +module type FOLDABLE = sig + type 'a t + val to_seq : 'a t -> 'a sequence +end + +module type TRAVERSE = functor(M : MONAD) -> sig + type +'a t + + val sequence_m : 'a M.t t -> 'a t M.t + + val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t + + val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t +end + +(** {2 Some Implementations} *) + +(** The free monad is built by nesting applications of a functor [F]. + +For instance, Lisp-like nested lists can be built and dealt with like this: +{[ + module Lisp = CCCat.FreeMonad(CCList);; + + let l = Lisp.(inj [1;2;3] >>= fun x -> inj [x; x*2; x+100]);; +]} *) +module type FREE_MONAD = sig + module F : FUNCTOR + + type +'a t = + | Return of 'a + | Roll of 'a t F.t + + include MONAD with type 'a t := 'a t + val inj : 'a F.t -> 'a t +end + +module MakeFree(F : FUNCTOR) : FREE_MONAD with module F = F + +module MakeFreeFold(FM : FREE_MONAD)(Fold : FOLDABLE with type 'a t = 'a FM.F.t) + : FOLDABLE with type 'a t = 'a FM.t + From b6168ca7f6a953a08a03f9dd86b86bec7bee945e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 17 Jul 2014 10:11:02 +0200 Subject: [PATCH 06/30] details in CCCat --- core/CCCat.ml | 23 +++++++++++++++++++---- core/CCCat.mli | 15 +++++++++++---- 2 files changed, 30 insertions(+), 8 deletions(-) diff --git a/core/CCCat.ml b/core/CCCat.ml index fe9d6f6f..cb9ab343 100644 --- a/core/CCCat.ml +++ b/core/CCCat.ml @@ -46,13 +46,17 @@ module type APPLICATIVE = sig val (<*>) : ('a -> 'b) t -> 'a t -> 'b t end -module type MONAD = sig +module type MONAD_BARE = sig type +'a t - include APPLICATIVE with type 'a t := 'a t val return : 'a -> 'a t val (>>=) : 'a t -> ('a -> 'b t) -> 'b t end +module type MONAD = sig + include MONAD_BARE + include APPLICATIVE with type 'a t := 'a t +end + module type MONAD_TRANSFORMER = sig include MONAD module M : MONAD @@ -76,8 +80,6 @@ module type TRAVERSE = functor(M : MONAD) -> sig val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t end -(** {2 Some Implementations} *) - module type FREE_MONAD = sig module F : FUNCTOR @@ -89,6 +91,19 @@ module type FREE_MONAD = sig val inj : 'a F.t -> 'a t end +(** {2 Some Implementations} *) + +module WrapMonad(M : MONAD_BARE) = struct + include M + + let map f x = x >>= (fun x -> return (f x)) + + let pure = return + + let (<*>) f x = f >>= fun f -> x >>= fun x -> return (f x) +end + + module MakeFree(F : FUNCTOR) = struct module F = F diff --git a/core/CCCat.mli b/core/CCCat.mli index 62b2ed76..1f136322 100644 --- a/core/CCCat.mli +++ b/core/CCCat.mli @@ -48,13 +48,17 @@ module type APPLICATIVE = sig val (<*>) : ('a -> 'b) t -> 'a t -> 'b t end -module type MONAD = sig +module type MONAD_BARE = sig type +'a t - include APPLICATIVE with type 'a t := 'a t val return : 'a -> 'a t val (>>=) : 'a t -> ('a -> 'b t) -> 'b t end +module type MONAD = sig + include MONAD_BARE + include APPLICATIVE with type 'a t := 'a t +end + module type MONAD_TRANSFORMER = sig include MONAD module M : MONAD @@ -79,8 +83,6 @@ module type TRAVERSE = functor(M : MONAD) -> sig val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t end -(** {2 Some Implementations} *) - (** The free monad is built by nesting applications of a functor [F]. For instance, Lisp-like nested lists can be built and dealt with like this: @@ -100,6 +102,11 @@ module type FREE_MONAD = sig val inj : 'a F.t -> 'a t end +(** {2 Some Implementations} *) + +(** Implement the applicative and functor modules from only return and bind *) +module WrapMonad(M : MONAD_BARE) : MONAD with type 'a t = 'a M.t + module MakeFree(F : FUNCTOR) : FREE_MONAD with module F = F module MakeFreeFold(FM : FREE_MONAD)(Fold : FOLDABLE with type 'a t = 'a FM.F.t) From 462ac72b2e09cbe78c11241d0790f7482496bc2f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 17 Jul 2014 10:37:53 +0200 Subject: [PATCH 07/30] detail --- tests/test_graph.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/test_graph.ml b/tests/test_graph.ml index bbedd709..2899b232 100644 --- a/tests/test_graph.ml +++ b/tests/test_graph.ml @@ -65,7 +65,6 @@ let test_bfs () = () let rec pp_path p = - let buf = Buffer.create 10 in CCPrint.to_string (CCList.pp ~sep:"; " pp_edge) p and pp_edge b (v1,e,v2) = Printf.bprintf b "%d -> %d" v1 v2 From 5dc0155ab00dd8466df2c8df16b67713f69fac11 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 17 Jul 2014 10:37:58 +0200 Subject: [PATCH 08/30] more functions in CCPair --- core/CCPair.ml | 9 +++++++++ core/CCPair.mli | 23 +++++++++++++++++++++++ 2 files changed, 32 insertions(+) diff --git a/core/CCPair.ml b/core/CCPair.ml index 136bc567..fa15d4c9 100644 --- a/core/CCPair.ml +++ b/core/CCPair.ml @@ -36,6 +36,11 @@ let map f g (x,y) = f x, g y let map_same f (x,y) = f x, f y +let map_fst f (x,_) = f x +let map_snd f (_,x) = f x + +let iter f (x,y) = f x y + let swap (x,y) = y, x let (<<<) = map1 @@ -47,6 +52,10 @@ let ( *** ) = map let ( &&& ) f g x = f x, g x let merge f (x,y) = f x y +let fold = merge + +let dup x = x,x +let dup_map f x = x, f x let equal f g (x1,y1) (x2,y2) = f x1 x2 && g y1 y2 diff --git a/core/CCPair.mli b/core/CCPair.mli index 45748dab..ba532242 100644 --- a/core/CCPair.mli +++ b/core/CCPair.mli @@ -36,6 +36,16 @@ val map : ('a -> 'c) -> ('b -> 'd) -> ('a * 'b) -> ('c * 'd) val map_same : ('a -> 'b) -> ('a*'a) -> ('b*'b) +val map_fst : ('a -> 'b) -> ('a * _) -> 'b +(** Compose the given function with [fst]. + @since NEXT_RELEASE *) + +val map_snd : ('a -> 'b) -> (_ * 'a) -> 'b +(** Compose the given function with [snd]. + @since NEXT_RELEASE *) + +val iter : ('a -> 'b -> unit) -> ('a * 'b) -> unit + val swap : ('a * 'b) -> ('b * 'a) (** Swap the components of the tuple *) @@ -55,6 +65,19 @@ val ( &&& ) : ('a -> 'b) -> ('a -> 'c) -> 'a -> ('b * 'c) val merge : ('a -> 'b -> 'c) -> ('a * 'b) -> 'c (** Uncurrying (merges the two components of a tuple) *) +val fold : ('a -> 'b -> 'c) -> ('a * 'b) -> 'c +(** Synonym to {!merge} + @since NEXT_RELEASE *) + +val dup : 'a -> ('a * 'a) +(** [dup x = (x,x)] (duplicate the value) + @since NEXT_RELEASE *) + +val dup_map : ('a -> 'b) -> 'a -> ('a * 'b) +(** [dup_map f x = (x, f x)]. Duplicates the value and applies the function + to the second copy. + @since NEXT_RELEASE *) + val equal : ('a -> 'a -> bool) -> ('b -> 'b -> bool) -> ('a * 'b) -> ('a * 'b) -> bool val compare : ('a -> 'a -> int) -> ('b -> 'b -> int) -> ('a * 'b) -> ('a * 'b) -> int From be7d94fac44e155b3da6d711d8dcc7040d56c57b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 18 Jul 2014 01:18:23 +0200 Subject: [PATCH 09/30] CCTrie.MakeList/MakeArray --- core/CCTrie.ml | 21 +++++++++++++++++++++ core/CCTrie.mli | 9 +++++++++ 2 files changed, 30 insertions(+) diff --git a/core/CCTrie.ml b/core/CCTrie.ml index 00926bce..7d762557 100644 --- a/core/CCTrie.ml +++ b/core/CCTrie.ml @@ -417,6 +417,27 @@ module Make(W : WORD) = struct `Node(x, List.map (fun (c,t') -> _tree_node (`Char c) [to_tree t']) l) end +module type ORDERED = sig + type t + val compare : t -> t -> int +end + +module MakeArray(X : ORDERED) = Make(struct + type t = X.t array + type char_ = X.t + let compare = X.compare + let to_seq a k = Array.iter k a + let of_list = Array.of_list +end) + +module MakeList(X : ORDERED) = Make(struct + type t = X.t list + type char_ = X.t + let compare = X.compare + let to_seq a k = List.iter k a + let of_list l = l +end) + module String = Make(struct type t = string type char_ = char diff --git a/core/CCTrie.mli b/core/CCTrie.mli index 38c4a479..de635de2 100644 --- a/core/CCTrie.mli +++ b/core/CCTrie.mli @@ -110,4 +110,13 @@ end module Make(W : WORD) : S with type key = W.t and type char_ = W.char_ +module type ORDERED = sig + type t + val compare : t -> t -> int +end + +module MakeArray(X : ORDERED) : S with type key = X.t array and type char_ = X.t + +module MakeList(X : ORDERED) : S with type key = X.t list and type char_ = X.t + module String : S with type key = string and type char_ = char From 89b2e525bccce12276995da333d927fc494447f6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 18 Jul 2014 02:05:37 +0200 Subject: [PATCH 10/30] CCTrie.above/below: ranges of items --- core/CCTrie.ml | 124 +++++++++++++++++++++++++++++++++++++++++------- core/CCTrie.mli | 8 ++++ 2 files changed, 115 insertions(+), 17 deletions(-) diff --git a/core/CCTrie.ml b/core/CCTrie.ml index 7d762557..47b4b9ce 100644 --- a/core/CCTrie.ml +++ b/core/CCTrie.ml @@ -104,6 +104,14 @@ module type S = sig val to_seq_values : 'a t -> 'a sequence val to_tree : 'a t -> [`Char of char_ | `Val of 'a | `Switch] ktree + + (** {6 Ranges} *) + + val above : key -> 'a t -> (key * 'a) sequence + (** All bindings whose key is bigger than (or equal to) the given key *) + + val below : key -> 'a t -> (key * 'a) sequence + (** All bindings whose key is smaller or equal to the given key *) end module Make(W : WORD) = struct @@ -143,6 +151,19 @@ module Make(W : WORD) = struct seq (fun x -> acc := f !acc x); finish !acc + let _filter_map_seq f seq k = + seq (fun x -> match f x with + | None -> () + | Some y -> k y) + + let _seq_append_list l seq = + let l = ref l in + seq (fun x -> l := x :: !l); + !l + + let _seq_map map k = + M.iter (fun key v -> k (key,v)) map + let _is_path = function | Path _ -> true | _ -> false @@ -293,24 +314,39 @@ module Make(W : WORD) = struct let _difflist_append f l = fun l' -> f (l @ l') let _difflist_add f x = fun l' -> f (x :: l') - let fold f acc t = - (* also keep the path from the root, so as to provide the list - of chars that lead to a value. The path is a difference list, ie - a function that prepends a list to some suffix *) - let rec aux path t acc = match t with - | Empty -> acc - | Path (l, t') -> aux (_difflist_append path l) t' acc - | Node (v, map) -> - let acc = match v with - | None -> acc - | Some v -> f acc (W.of_list (path [])) v - in - M.fold - (fun c t' acc -> aux (_difflist_add path c) t' acc) - map acc - in aux _id t acc + (* fold that also keeps the path from the root, so as to provide the list + of chars that lead to a value. The path is a difference list, ie + a function that prepends a list to some suffix *) + let rec _fold f path t acc = match t with + | Empty -> acc + | Path (l, t') -> _fold f (_difflist_append path l) t' acc + | Node (v, map) -> + let acc = match v with + | None -> acc + | Some v -> f acc path v + in + M.fold + (fun c t' acc -> _fold f (_difflist_add path c) t' acc) + map acc - let iter f t = fold (fun _ x y -> f x y) () t + let fold f acc t = + _fold + (fun acc path v -> + let key = W.of_list (path []) in + f acc key v + ) _id t acc + + let iter f t = + _fold + (fun () path y -> f (W.of_list (path [])) y) + _id t () + + let _iter_prefix ~prefix f t = + _fold + (fun () path y -> + let key = W.of_list (prefix (path [])) in + f key y) + _id t () let rec fold_values f acc t = match t with | Empty -> acc @@ -415,6 +451,60 @@ module Make(W : WORD) = struct in let l = M.bindings map in `Node(x, List.map (fun (c,t') -> _tree_node (`Char c) [to_tree t']) l) + + (** {6 Ranges} *) + + (* range above or below a threshold. + [p c c'] must return [true] if [c'], in the tree, meets some criterion + w.r.t [c] which is a part of the key. *) + let _half_range ~p key t k = + (* at subtree [cur = Some (t,trail)] or [None], alternatives above + [alternatives], and char [c] in [key]. *) + let on_char (cur, alternatives) c = + match cur with + | None -> (None, alternatives) + | Some (Empty,_) -> (None, alternatives) + | Some (Path ([], _),_) -> assert false + | Some (Path (c'::l, t'), trail) -> + if W.compare c c' = 0 + then Some (_mk_path l t', _difflist_add trail c), alternatives + else None, alternatives + | Some (Node (_, map), trail) -> + let alternatives = + _seq_map map + |> _filter_map_seq + (fun (c', t') -> if p c c' + then Some (t', _difflist_add trail c') + else None + ) + |> _seq_append_list alternatives + in + begin try + let t' = M.find c map in + Some (t', _difflist_add trail c), alternatives + with Not_found -> + None, alternatives + end + + (* run through the current path (if any) and alternatives *) + and finish (cur,alternatives) = + begin match cur with + | Some (t, prefix) -> + _iter_prefix ~prefix (fun key' v -> k (key', v)) t + | None -> () + end; + List.iter + (fun (t,prefix) -> _iter_prefix ~prefix (fun key' v -> k (key', v)) t) + alternatives + in + let word = W.to_seq key in + _fold_seq on_char ~finish (Some(t,_id), []) word + + let above key t = + _half_range ~p:(fun c c' -> W.compare c c' < 0) key t + + let below key t = + _half_range ~p:(fun c c' -> W.compare c c' > 0) key t end module type ORDERED = sig diff --git a/core/CCTrie.mli b/core/CCTrie.mli index de635de2..b7afccd7 100644 --- a/core/CCTrie.mli +++ b/core/CCTrie.mli @@ -104,6 +104,14 @@ module type S = sig val to_seq_values : 'a t -> 'a sequence val to_tree : 'a t -> [`Char of char_ | `Val of 'a | `Switch] ktree + + (** {6 Ranges} *) + + val above : key -> 'a t -> (key * 'a) sequence + (** All bindings whose key is bigger than (or equal to) the given key *) + + val below : key -> 'a t -> (key * 'a) sequence + (** All bindings whose key is smaller or equal to the given key *) end (** {2 Implementation} *) From ff2ab244f5ec7f3f4ee2715619d5dcc444d2d981 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 18 Jul 2014 02:14:02 +0200 Subject: [PATCH 11/30] sequence and CCMultiSet --- core/CCMultiSet.ml | 14 ++++++++++++++ core/CCMultiSet.mli | 6 ++++++ 2 files changed, 20 insertions(+) diff --git a/core/CCMultiSet.ml b/core/CCMultiSet.ml index 41d147f8..60640411 100644 --- a/core/CCMultiSet.ml +++ b/core/CCMultiSet.ml @@ -25,6 +25,8 @@ for any direct, indirect, incidental, special, exemplary, or consequential (** {1 Multiset} *) +type 'a sequence = ('a -> unit) -> unit + module type S = sig type elt type t @@ -69,6 +71,10 @@ module type S = sig val of_list : elt list -> t val to_list : t -> elt list + + val to_seq : t -> elt sequence + + val of_seq : elt sequence -> t end module Make(O : Set.OrderedType) = struct @@ -172,4 +178,12 @@ module Make(O : Set.OrderedType) = struct | _ -> n_cons (n-1) x (x::l) in fold m [] (fun acc n x -> n_cons n x acc) + + let to_seq m k = + M.iter (fun x n -> for _i = 1 to n do k x done) m + + let of_seq seq = + let m = ref empty in + seq (fun x -> m := add !m x); + !m end diff --git a/core/CCMultiSet.mli b/core/CCMultiSet.mli index 99e0521f..4c994901 100644 --- a/core/CCMultiSet.mli +++ b/core/CCMultiSet.mli @@ -25,6 +25,8 @@ for any direct, indirect, incidental, special, exemplary, or consequential (** {1 Multiset} *) +type 'a sequence = ('a -> unit) -> unit + module type S = sig type elt type t @@ -69,6 +71,10 @@ module type S = sig val of_list : elt list -> t val to_list : t -> elt list + + val to_seq : t -> elt sequence + + val of_seq : elt sequence -> t end module Make(O : Set.OrderedType) : S with type elt = O.t From 05453c3ce8ed72a27bb38ee28b9c5c0861ddef42 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 18 Jul 2014 02:34:40 +0200 Subject: [PATCH 12/30] CCKlist.product and product_with (fair cartesian product) --- core/CCKList.ml | 28 ++++++++++++++++++++++++++++ core/CCKList.mli | 9 +++++++++ 2 files changed, 37 insertions(+) diff --git a/core/CCKList.ml b/core/CCKList.ml index 9dd606e6..964bdb1f 100644 --- a/core/CCKList.ml +++ b/core/CCKList.ml @@ -139,6 +139,34 @@ and _flat_map_app f l l' () = match l () with | `Cons (x, tl) -> `Cons (x, _flat_map_app f tl l') +let product_with f l1 l2 = + let rec _next_left h1 tl1 h2 tl2 () = + match tl1() with + | `Nil -> _next_right ~die:true h1 tl1 h2 tl2 () + | `Cons (x, tl1') -> + _map_list_left x h2 + (_next_right ~die:false (x::h1) tl1' h2 tl2) + () + and _next_right ~die h1 tl1 h2 tl2 () = + match tl2() with + | `Nil when die -> `Nil + | `Nil -> _next_left h1 tl1 h2 tl2 () + | `Cons (y, tl2') -> + _map_list_right h1 y + (_next_left h1 tl1 (y::h2) tl2') + () + and _map_list_left x l kont () = match l with + | [] -> kont() + | y::l' -> `Cons (f x y, _map_list_left x l' kont) + and _map_list_right l y kont () = match l with + | [] -> kont() + | x::l' -> `Cons (f x y, _map_list_right l' y kont) + in + _next_left [] l1 [] l2 + +let product l1 l2 = + product_with (fun x y -> x,y) l1 l2 + let rec filter_map f l () = match l() with | `Nil -> `Nil | `Cons (x, l') -> diff --git a/core/CCKList.mli b/core/CCKList.mli index 0997a7f2..2e244712 100644 --- a/core/CCKList.mli +++ b/core/CCKList.mli @@ -78,6 +78,15 @@ val filter : ('a -> bool) -> 'a t -> 'a t val append : 'a t -> 'a t -> 'a t +val product_with : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t +(** Fair product of two (possibly infinite) lists into a new list. Lazy. + The first parameter is used to combine each pair of elements + @since NEXT_RELEASE *) + +val product : 'a t -> 'b t -> ('a * 'b) t +(** Specialization of {!product_with} producing tuples + @since NEXT_RELEASE *) + val flat_map : ('a -> 'b t) -> 'a t -> 'b t val filter_map : ('a -> 'b option) -> 'a t -> 'b t From a27e252cf1e3c0283fe99ab2d996335ecf48e450 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 18 Jul 2014 02:34:52 +0200 Subject: [PATCH 13/30] CCKlist infix operators for monad, applicative... --- core/CCKList.ml | 9 +++++++++ core/CCKList.mli | 9 +++++++++ 2 files changed, 18 insertions(+) diff --git a/core/CCKList.ml b/core/CCKList.ml index 964bdb1f..161ef36f 100644 --- a/core/CCKList.ml +++ b/core/CCKList.ml @@ -230,6 +230,15 @@ let rec merge cmp l1 l2 () = match l1(), l2() with then `Cons (x1, merge cmp l1' l2) else `Cons (x2, merge cmp l1 l2') +(** {2 Implementations} *) + +let return x () = `Cons (x, nil) +let pure = return +let (>>=) xs f = flat_map f xs +let (>|=) xs f = map f xs + +let (<*>) fs xs = product_with (fun f x -> f x) fs xs + (** {2 Conversions} *) let rec _to_rev_list acc l = match l() with diff --git a/core/CCKList.mli b/core/CCKList.mli index 2e244712..bd420ea4 100644 --- a/core/CCKList.mli +++ b/core/CCKList.mli @@ -115,6 +115,15 @@ val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool val merge : 'a ord -> 'a t -> 'a t -> 'a t (** Merge two sorted iterators into a sorted iterator *) +(** {2 Implementations} + @since NEXT_RELEASE *) + +val return : 'a -> 'a t +val pure : 'a -> 'a t +val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +val (>|=) : 'a t -> ('a -> 'b) -> 'b t +val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + (** {2 Monadic Operations} *) module type MONAD = sig type 'a t From 556d10a0d401bd034937bb20743336bed75a4509 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 18 Jul 2014 02:51:23 +0200 Subject: [PATCH 14/30] CCKList: group,uniq,sort,sort_uniq,repeat and cycle --- core/CCKList.ml | 36 ++++++++++++++++++++++++++++++++++++ core/CCKList.mli | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 68 insertions(+) diff --git a/core/CCKList.ml b/core/CCKList.ml index 161ef36f..99a56459 100644 --- a/core/CCKList.ml +++ b/core/CCKList.ml @@ -43,6 +43,15 @@ let empty = nil let singleton x () = `Cons (x, nil) +let rec _forever x () = `Cons (x, _forever x) + +let rec _repeat n x () = + if n<=0 then `Nil else `Cons (x, _repeat (n-1) x) + +let repeat ?n x = match n with + | None -> _forever x + | Some n -> _repeat n x + let is_empty l = match l () with | `Nil -> true | `Cons _ -> false @@ -130,6 +139,8 @@ let rec append l1 l2 () = match l1 () with | `Nil -> l2 () | `Cons (x, l1') -> `Cons (x, append l1' l2) +let rec cycle l () = append l (cycle l) () + let rec flat_map f l () = match l () with | `Nil -> `Nil | `Cons (x, l') -> @@ -167,6 +178,22 @@ let product_with f l1 l2 = let product l1 l2 = product_with (fun x y -> x,y) l1 l2 +let rec group eq l () = match l() with + | `Nil -> `Nil + | `Cons (x, l') -> + `Cons (cons x (take_while (eq x) l'), group eq (drop_while (eq x) l')) + +let rec _uniq eq prev l () = match prev, l() with + | _, `Nil -> `Nil + | None, `Cons (x, l') -> + `Cons (x, _uniq eq (Some x) l') + | Some y, `Cons (x, l') -> + if eq x y + then _uniq eq prev l' () + else `Cons (x, _uniq eq (Some x) l') + +let uniq eq l = _uniq eq None l + let rec filter_map f l () = match l() with | `Nil -> `Nil | `Cons (x, l') -> @@ -274,6 +301,15 @@ let to_gen l = l := l'; Some x +let sort ?(cmp=Pervasives.compare) l = + let l = to_list l in + of_list (List.sort cmp l) + +let sort_uniq ?(cmp=Pervasives.compare) l = + let l = to_list l in + uniq (fun x y -> cmp x y = 0) (of_list (List.sort cmp l)) + + (** {2 Monadic Operations} *) module type MONAD = sig type 'a t diff --git a/core/CCKList.mli b/core/CCKList.mli index bd420ea4..003a5892 100644 --- a/core/CCKList.mli +++ b/core/CCKList.mli @@ -47,6 +47,16 @@ val cons : 'a -> 'a t -> 'a t val singleton : 'a -> 'a t +val repeat : ?n:int -> 'a -> 'a t +(** [repeat ~n x] repeats [x] [n] times then stops. If [n] is omitted, + then [x] is repeated forever. + @since NEXT_RELEASE *) + +val cycle : 'a t -> 'a t +(** Cycle through the iterator infinitely. The iterator shouldn't be empty. + @since NEXT_RELEASE *) + + val is_empty : 'a t -> bool val equal : 'a equal -> 'a t equal @@ -87,6 +97,18 @@ val product : 'a t -> 'b t -> ('a * 'b) t (** Specialization of {!product_with} producing tuples @since NEXT_RELEASE *) +val group : 'a equal -> 'a t -> 'a t t +(** [group eq l] groups together consecutive elements that satisfy [eq]. Lazy. + For instance [group (=) [1;1;1;2;2;3;3;1]] yields + [[1;1;1]; [2;2]; [3;3]; [1]] + @since NEXT_RELEASE *) + +val uniq : 'a equal -> 'a t -> 'a t +(** [uniq eq l] returns [l] but removes consecutive duplicates. Lazy. + In other words, if several values that are equal follow one another, + only the first of them is kept. + @since NEXT_RELEASE *) + val flat_map : ('a -> 'b t) -> 'a t -> 'b t val filter_map : ('a -> 'b option) -> 'a t -> 'b t @@ -115,6 +137,16 @@ val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool val merge : 'a ord -> 'a t -> 'a t -> 'a t (** Merge two sorted iterators into a sorted iterator *) +val sort : ?cmp:'a ord -> 'a t -> 'a t +(** Eager sort. Requires the iterator to be finite. O(n ln(n)) time + and space. + @since NEXT_RELEASE *) + +val sort_uniq : ?cmp:'a ord -> 'a t -> 'a t +(** Eager sort that removes duplicate values. Requires the iterator to be + finite. O(n ln(n)) time and space. + @since NEXT_RELEASE *) + (** {2 Implementations} @since NEXT_RELEASE *) From 78551b5e843d8093f58e3b42a393598cdafffe8d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 18 Jul 2014 02:55:53 +0200 Subject: [PATCH 15/30] tests --- core/CCKList.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/core/CCKList.ml b/core/CCKList.ml index 99a56459..2b22e399 100644 --- a/core/CCKList.ml +++ b/core/CCKList.ml @@ -52,6 +52,12 @@ let repeat ?n x = match n with | None -> _forever x | Some n -> _repeat n x +(*$T + repeat ~n:4 0 |> to_list = [0;0;0;0] + repeat ~n:0 1 |> to_list = [] + repeat 1 |> take 20 |> to_list = (repeat ~n:20 1 |> to_list) +*) + let is_empty l = match l () with | `Nil -> true | `Cons _ -> false @@ -141,6 +147,10 @@ let rec append l1 l2 () = match l1 () with let rec cycle l () = append l (cycle l) () +(*$T + cycle (of_list [1;2]) |> take 5 |> to_list = [1;2;1;2;1] +*) + let rec flat_map f l () = match l () with | `Nil -> `Nil | `Cons (x, l') -> From 490c72d5f885cd5a0b5dd60e3bbb94618a36a5f9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Jul 2014 00:01:17 +0200 Subject: [PATCH 16/30] CCList.Ref to help use references on lists --- core/CCList.ml | 33 +++++++++++++++++++++++++++++++++ core/CCList.mli | 28 ++++++++++++++++++++++++++++ 2 files changed, 61 insertions(+) diff --git a/core/CCList.ml b/core/CCList.ml index b95942ed..ddb0fa5c 100644 --- a/core/CCList.ml +++ b/core/CCList.ml @@ -510,6 +510,39 @@ module Zipper = struct | _, [] -> raise Not_found end +(** {2 References on Lists} *) + +module Ref = struct + type 'a t = 'a list ref + + let push l x = l := x :: !l + + let pop l = match !l with + | [] -> None + | x::tail -> + l := tail; + Some x + + let pop_exn l = match !l with + | [] -> failwith "CCList.Ref.pop_exn" + | x::tail -> + l := tail; + x + + let create() = ref [] + + let clear l = l := [] + + let lift f l = f !l + + let push_list r l = + r := List.rev_append l !r + + (*$T + let l = Ref.create() in Ref.push l 1; Ref.push_list l [2;3]; !l = [3;2;1] + *) +end + (** {2 Monadic Operations} *) module type MONAD = sig type 'a t diff --git a/core/CCList.mli b/core/CCList.mli index a94820f5..2c885a51 100644 --- a/core/CCList.mli +++ b/core/CCList.mli @@ -225,6 +225,34 @@ module Zipper : sig @raise Not_found if the zipper is at an end *) end +(** {2 References on Lists} +@since NEXT_RELEASE *) + +module Ref : sig + type 'a t = 'a list ref + + val push : 'a t -> 'a -> unit + + val pop : 'a t -> 'a option + + val pop_exn : 'a t -> 'a + (** Unsafe version of {!pop}. + @raise Failure if the list is empty *) + + val create : unit -> 'a t + (** Create a new list reference *) + + val clear : _ t -> unit + (** Remove all elements *) + + val lift : ('a list -> 'b) -> 'a t -> 'b + (** Apply a list function to the content *) + + val push_list : 'a t -> 'a list -> unit + (** Add elements of the list at the beginning of the list ref. Elements + at the end of the list will be at the beginning of the list ref *) +end + (** {2 Monadic Operations} *) module type MONAD = sig type 'a t From e5803404034018421fbf587cc496f8b0c91c994c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 22 Jul 2014 00:04:32 +0200 Subject: [PATCH 17/30] big upgrade of RAL (random access lists) --- misc/RAL.ml | 68 ++++++++++++++++++++++++++++++++++++++++++++++------ misc/RAL.mli | 28 +++++++++++++++++++--- 2 files changed, 86 insertions(+), 10 deletions(-) diff --git a/misc/RAL.ml b/misc/RAL.ml index dcb57e93..f1b3f7ca 100644 --- a/misc/RAL.ml +++ b/misc/RAL.ml @@ -33,6 +33,9 @@ type +'a tree = and +'a t = (int * 'a tree) list (** Functional array of complete trees *) +(* TODO: inline list's nodes + TODO: encode "complete binary tree" into types *) + (** {2 Functions on trees} *) @@ -62,6 +65,8 @@ let rec tree_update size t i v =match t, i with let empty = [] +let return x = [1, Leaf x] + let is_empty = function | [] -> true | _ -> false @@ -95,24 +100,52 @@ let tl l = match l with let size' = size / 2 in (size', t1) :: (size', t2) :: l' +let front l = match l with + | [] -> None + | (_, Leaf x) :: tl -> Some (x, tl) + | (size, Node (x, t1, t2)) :: l' -> + let size' = size / 2 in + Some (x, (size', t1) :: (size', t2) :: l') + +let front_exn l = match l with + | [] -> raise (Invalid_argument "RAL.front") + | (_, Leaf x) :: tl -> x, tl + | (size, Node (x, t1, t2)) :: l' -> + let size' = size / 2 in + x, (size', t1) :: (size', t2) :: l' + +let rec _remove prefix l i = + let x, l' = front_exn l in + if i=0 + then List.fold_left (fun l x -> cons x l) l prefix + else _remove (x::prefix) l' (i-1) + +let remove l i = _remove [] l i + +let rec _map_tree f t = match t with + | Leaf x -> Leaf (f x) + | Node (x, l, r) -> Node (f x, _map_tree f l, _map_tree f r) + +let map f l = List.map (fun (i,t) -> i, _map_tree f t) l + let rec length l = match l with | [] -> 0 | (size,_) :: l' -> size + length l' -let rec iter l f = match l with +let rec iter f l = match l with | [] -> () - | (_, Leaf x) :: l' -> f x; iter l' f - | (_, t) :: l' -> iter_tree t f; iter l' f + | (_, Leaf x) :: l' -> f x; iter f l' + | (_, t) :: l' -> iter_tree t f; iter f l' and iter_tree t f = match t with | Leaf x -> f x | Node (x, t1, t2) -> f x; iter_tree t1 f; iter_tree t2 f -let rec fold l acc f = match l with +let rec fold f acc l = match l with | [] -> acc - | (_, Leaf x) :: l' -> fold l' (f acc x) f + | (_, Leaf x) :: l' -> fold f (f acc x) l' | (_, t) :: l' -> let acc' = fold_tree t acc f in - fold l' acc' f + fold f acc' l' and fold_tree t acc f = match t with | Leaf x -> f acc x | Node (x, t1, t2) -> @@ -120,6 +153,27 @@ and fold_tree t acc f = match t with let acc = fold_tree t1 acc f in fold_tree t2 acc f +let rec fold_rev f acc l = match l with + | [] -> acc + | (_, Leaf x) :: l' -> f (fold f acc l') x + | (_, t) :: l' -> + let acc = fold_rev f acc l' in + fold_tree_rev t acc f +and fold_tree_rev t acc f = match t with + | Leaf x -> f acc x + | Node (x, t1, t2) -> + let acc = fold_tree_rev t2 acc f in + let acc = fold_tree_rev t1 acc f in + f acc x + +let append l1 l2 = fold_rev (fun l2 x -> cons x l2) l2 l1 + let of_list l = List.fold_right cons l empty -let to_list l = List.rev (fold l [] (fun l x -> x :: l)) +let rec of_list_map f l = match l with + | [] -> empty + | x::l' -> + let y = f x in + cons y (of_list_map f l') + +let to_list l = List.rev (fold (fun l x -> x :: l) [] l) diff --git a/misc/RAL.mli b/misc/RAL.mli index 31dc223e..daca6d0b 100644 --- a/misc/RAL.mli +++ b/misc/RAL.mli @@ -43,13 +43,26 @@ val is_empty : _ t -> bool val cons : 'a -> 'a t -> 'a t (** Add an element at the front of the list *) +val return : 'a -> 'a t + +val map : ('a -> 'b) -> 'a t -> 'b t + (** Map on elements *) + val hd : 'a t -> 'a - (** First element of the list, or @raise Invalid_argument if the list is empty *) + (** First element of the list, or + @raise Invalid_argument if the list is empty *) val tl : 'a t -> 'a t (** Remove the first element from the list, or @raise Invalid_argument if the list is empty *) +val front : 'a t -> ('a * 'a t) option + (** Remove and return the first element of the list *) + +val front_exn : 'a t -> 'a * 'a t + (** Unsafe version of {!front}. + @raise Invalid_argument if the list is empty *) + val length : 'a t -> int (** Number of elements *) @@ -61,13 +74,22 @@ val set : 'a t -> int -> 'a -> 'a t (** [set l i v] sets the [i]-th element of the list to [v]. O(log(n)). @raise Invalid_argument if the list has less than [i+1] elements. *) -val iter : 'a t -> ('a -> unit) -> unit +val remove : 'a t -> int -> 'a t + (** [remove l i] removes the [i]-th element of [v]. + @raise Invalid_argument if the list has less than [i+1] elements. *) + +val append : 'a t -> 'a t -> 'a t + +val iter : ('a -> unit) -> 'a t -> unit (** Iterate on the list's elements *) -val fold : 'a t -> 'b -> ('b -> 'a -> 'b) -> 'b +val fold : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** Fold on the list's elements *) val of_list : 'a list -> 'a t (** Convert a list to a RAL. {b Caution}: non tail-rec *) +val of_list_map : ('a -> 'b) -> 'a list -> 'b t + (** Combination of {!of_list} and {!map} *) + val to_list : 'a t -> 'a list From 31d977054ec29fc4d838bfe0af6f11066f6e8796 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 23 Jul 2014 00:05:06 +0200 Subject: [PATCH 18/30] CCIO: monad for IO actions-as-values --- _oasis | 2 +- core/CCIO.ml | 185 ++++++++++++++++++++++++++++++++++++++++++++++++++ core/CCIO.mli | 159 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 345 insertions(+), 1 deletion(-) create mode 100644 core/CCIO.ml create mode 100644 core/CCIO.mli diff --git a/_oasis b/_oasis index c9a02e07..e8bcb1fd 100644 --- a/_oasis +++ b/_oasis @@ -46,7 +46,7 @@ Library "containers" Modules: CCVector, CCDeque, CCGen, CCSequence, CCFQueue, CCMultiMap, CCMultiSet, CCBV, CCPrint, CCPersistentHashtbl, CCError, CCHeap, CCList, CCOpt, CCPair, CCFun, CCHash, CCCat, - CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, + CCKList, CCInt, CCBool, CCArray, CCBatch, CCOrd, CCIO, CCRandom, CCLinq, CCKTree, CCTrie, CCString, CCHashtbl FindlibName: containers diff --git a/core/CCIO.ml b/core/CCIO.ml new file mode 100644 index 00000000..989e0354 --- /dev/null +++ b/core/CCIO.ml @@ -0,0 +1,185 @@ + +(* +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 IO Monad} *) + +type _ t = + | Return : 'a -> 'a t + | Map : ('a -> 'b) * 'a t -> 'b t + | Bind : ('a -> 'b t) * 'a t -> 'b t + | Star : ('a -> 'b) t * 'a t -> 'b t + | Repeat : int * 'a t -> 'a list t + | RepeatIgnore : int * 'a t -> unit t + | Wrap : (unit -> 'a) -> 'a t + | WrapJoin : (unit -> 'a t) -> 'a t + +type 'a io = 'a t +type 'a or_error = [ `Ok of 'a | `Error of string ] + +let (>>=) x f = Bind(f,x) + +let map f x = Map(f, x) + +let (>|=) x f = Map(f, x) + +let return x = Return x +let pure = return + +let (<*>) f a = Star (f, a) + +let lift = map + +let lift2 f a b = + a >>= fun x -> map (f x) b + +let lift3 f a b c = + a >>= fun x -> + b >>= fun y -> map (f x y) c + +let repeat i a = + if i <= 0 then Return [] else Repeat (i,a) + +let repeat' i a = + if i <= 0 then Return () else RepeatIgnore (i,a) + +let rec _run : type a. a t -> a = function + | Return x -> x + | Map (f, a) -> f (_run a) + | Bind (f, a) -> _run (f (_run a)) + | Star (f, a) -> _run f (_run a) + | Repeat (i,a) -> _repeat [] i a + | RepeatIgnore (i,a) -> _repeat_ignore i a + | Wrap f -> f() + | WrapJoin f -> _run (f()) + +and _repeat : type a. a list -> int -> a t -> a list + = fun acc i a -> match i with + | 0 -> List.rev acc + | _ -> + let x = _run a in + _repeat (x::acc) (i-1) a + +and _repeat_ignore : type a. int -> a t -> unit + = fun i a -> match i with + | 0 -> () + | _ -> + let _ = _run a in + _repeat_ignore (i-1) a + +let _printers = ref [] + +exception PrinterResult of string + +let _print_exn e = + try + List.iter + (fun p -> match p e with + | None -> () + | Some msg -> raise (PrinterResult msg) + ) !_printers; + Printexc.to_string e + with PrinterResult s -> s + +let run x = + try `Ok (_run x) + with e -> `Error (_print_exn e) + +let register_printer p = _printers := p :: !_printers + +(** {2 Standard Wrappers} *) + +let _with_in flags filename f () = + let ic = open_in_gen flags 0x644 filename in + try + f ic + with e -> + close_in ic; + raise e + +let with_in ?(flags=[]) filename f = + WrapJoin (_with_in flags filename f) + +let _read ic s i len () = input ic s i len +let read ic s i len = Wrap (_read ic s i len) + +let _read_line ic () = Pervasives.input_line ic +let read_line ic = Wrap(_read_line ic) + +let _with_out flags filename f () = + let oc = open_out_gen flags 0x644 filename in + try + f oc + with e -> + close_out oc; + raise e + +let with_out ?(flags=[]) filename f = + WrapJoin (_with_out flags filename f) + +let _write oc s i len () = output oc s i len +let write oc s i len = Wrap (_write oc s i len) + +let _write_str oc s () = output oc s 0 (String.length s) +let write_str oc s = Wrap (_write_str oc s) + +let _write_buf oc buf () = Buffer.output_buffer oc buf +let write_buf oc buf = Wrap (_write_buf oc buf) + +let flush oc = Wrap (fun () -> Pervasives.flush oc) + +(** {2 Seq} *) + +(* TODO: WIP +module Seq = struct + type 'a step_result = + | Yield of 'a + | Stop + + type 'a gen = unit -> 'a step_result io + + type _ iter = + | Gen : 'a gen -> 'a iter + | Pure : ('a -> 'b step_result) * 'a iter -> 'b iter + | General : + ('b -> 'a -> [`Stop | `Continue of ('b * 'c option)]) + * 'b * 'a iter -> 'c iter + + type 'a t = 'a iter io + (** Gen = restartable iterator *) + + let _map f x = Yield (f x) + + let map f seq = Pure (_map f, seq) + + let rec _next : type a. a iter -> 'a step_result +end +*) + +(** {2 Raw} *) + +module Raw = struct + let wrap f = Wrap f +end diff --git a/core/CCIO.mli b/core/CCIO.mli new file mode 100644 index 00000000..b3a2140f --- /dev/null +++ b/core/CCIO.mli @@ -0,0 +1,159 @@ + +(* +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 IO Monad} *) + +type 'a t +type 'a io = 'a t + +type 'a or_error = [ `Ok of 'a | `Error of string ] + +val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +(** wait for the result of an action, then use a function to build a + new action and execute it *) + +val return : 'a -> 'a t +(** Just return a value *) + +val repeat : int -> 'a t -> 'a list t +(** Repeat an IO action as many times as required *) + +val repeat' : int -> 'a t -> unit t +(** Same as {!repeat}, but ignores the result *) + +val map : ('a -> 'b) -> 'a t -> 'b t +(** Map values *) + +val (>|=) : 'a t -> ('a -> 'b) -> 'b t + +val pure : 'a -> 'a t +val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + +val lift : ('a -> 'b) -> 'a t -> 'b t +(** Synonym to {!map} *) + +val lift2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t +val lift3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t + +val run : 'a t -> 'a or_error +(** Run an IO action. + @return either [`Ok x] when [x] is the successful result of the + computation, or some [`Error "message"] *) + +val register_printer : (exn -> string option) -> unit +(** [register_printer p] register [p] as a possible failure printer. + If [run a] raises an exception [e], [p e] is evaluated. If [p e = Some msg] + then the error message will be [msg], otherwise other printers will + be tried *) + +(** {2 Standard Wrappers} *) + +(** {6 Input} *) + +val with_in : ?flags:open_flag list -> string -> (in_channel -> 'a t) -> 'a t + +val read : in_channel -> string -> int -> int -> int t + +val read_line : in_channel -> string t + +(** {6 Output} *) + +val with_out : ?flags:open_flag list -> string -> (out_channel -> 'a t) -> 'a t + +val write : out_channel -> string -> int -> int -> unit t + +val write_str : out_channel -> string -> unit t + +val write_buf : out_channel -> Buffer.t -> unit t + +val flush : out_channel -> unit t + +(** {2 Streams} *) + +(* XXX: WIP +module Seq : sig + type +'a t + + val map : ('a -> 'b io) -> 'a t -> 'b t + (** Map values with actions *) + + val map_pure : ('a -> 'b) -> 'a t -> 'b t + (** Map values with a pure function *) + + val filter_map : ('a -> 'b option) -> 'a t -> 'b t + + val flat_map : ('a -> 'b t) -> 'a t -> 'b t + (** Map each value to a sub sequence of values *) + + val general_iter : ('b -> 'a -> [`Stop | `Continue of ('b * 'c option)]) -> + 'b -> 'a t -> 'c t + (** [general_iter f acc seq] performs a [filter_map] over [seq], + using [f]. [f] is given a state and the current value, and + can either return [`Stop] to indicate it stops traversing, + or [`Continue (st, c)] where [st] is the new state and + [c] an optional output value. + The result is the stream of values output by [f] *) + + (** {6 Consume} *) + + val iter : ('a -> _ io) -> 'a t -> unit io + (** Iterate on the stream, with an action for each element *) + + (** {6 Standard Wrappers} *) + + type 'a step_result = + | Yield of 'a + | Stop + + type 'a gen = unit -> 'a step_result io + + val of_fun : 'a gen io -> 'a t + (** Create a stream from a function that yields an element or stops *) + + val with_in : ?flags:open_flag list -> string -> 'a t + + val lines : in_channel io -> string t + (** Lines of an input channel *) + + val output : ?sep:string -> out_channel -> string t -> unit io + (** [output oc seq] outputs every value of [seq] into [oc], separated + with the optional argument [sep] (default: ["\n"]) *) + + val length : _ t -> int io + (** Length of the stream *) + + val fold : ('b -> 'a -> 'b io) -> 'b -> 'a t -> 'b io + (** [fold f acc seq] folds over [seq], consuming it. Every call to [f] + has the right to return an IO value. *) +end +*) + +(** {2 Low level access} *) +module Raw : sig + val wrap : (unit -> 'a) -> 'a t + (** [wrap f] is the IO action that, when executed, returns [f ()]. + [f] should be callable as many times as required *) +end From a913b6f1c0fa3c7394598f2c411701d45881780d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 23 Jul 2014 01:05:24 +0200 Subject: [PATCH 19/30] CCIO.Seq for io streams --- core/CCIO.ml | 94 ++++++++++++++++++++++++++++++++++++++++++++------- core/CCIO.mli | 32 +++++++++--------- 2 files changed, 97 insertions(+), 29 deletions(-) diff --git a/core/CCIO.ml b/core/CCIO.ml index 989e0354..bc566f43 100644 --- a/core/CCIO.ml +++ b/core/CCIO.ml @@ -152,7 +152,6 @@ let flush oc = Wrap (fun () -> Pervasives.flush oc) (** {2 Seq} *) -(* TODO: WIP module Seq = struct type 'a step_result = | Yield of 'a @@ -160,23 +159,92 @@ module Seq = struct type 'a gen = unit -> 'a step_result io - type _ iter = - | Gen : 'a gen -> 'a iter - | Pure : ('a -> 'b step_result) * 'a iter -> 'b iter - | General : - ('b -> 'a -> [`Stop | `Continue of ('b * 'c option)]) - * 'b * 'a iter -> 'c iter + type 'a t = 'a gen - type 'a t = 'a iter io - (** Gen = restartable iterator *) + let _stop () = return Stop + let _yield x = return (Yield x) - let _map f x = Yield (f x) + let map_pure f gen () = + gen() >>= function + | Stop -> _stop () + | Yield x -> _yield (f x) - let map f seq = Pure (_map f, seq) + let map f g () = + g() >>= function + | Stop -> _stop () + | Yield x -> f x >>= _yield - let rec _next : type a. a iter -> 'a step_result + let rec filter_map f g () = + g() >>= function + | Stop -> _stop() + | Yield x -> + match f x with + | None -> filter_map f g() + | Some y -> _yield y + + let rec flat_map f g () = + g() >>= function + | Stop -> _stop () + | Yield x -> + f x >>= fun g' -> _flat_map_aux f g g' () + and _flat_map_aux f g g' () = + g'() >>= function + | Stop -> flat_map f g () + | Yield x -> _yield x + + let general_iter f acc g = + let acc = ref acc in + let rec _next () = + g() >>= function + | Stop -> _stop() + | Yield x -> + f !acc x >>= function + | `Stop -> _stop() + | `Continue (acc', ret) -> + acc := acc'; + match ret with + | None -> _next() + | Some y -> _yield y + in + _next + + (** {6 Consume} *) + + let rec fold_pure f acc g = + g() >>= function + | Stop -> return acc + | Yield x -> fold_pure f (f acc x) g + + let length g = fold_pure (fun acc _ -> acc+1) 0 g + + let rec fold f acc g = + g() >>= function + | Stop -> return acc + | Yield x -> + f acc x >>= fun acc' -> fold f acc' g + + let rec iter f g = + g() >>= function + | Stop -> return () + | Yield x -> f x >>= fun _ -> iter f g + + let of_fun g = g + + let lines ic () = + try _yield (input_line ic) + with End_of_file -> _stop() + + let output ?(sep="\n") oc seq = + let first = ref true in + iter + (fun s -> + ( if !first + then (first:=false; return ()) + else write_str oc sep + ) >>= fun () -> + write_str oc s + ) seq end -*) (** {2 Raw} *) diff --git a/core/CCIO.mli b/core/CCIO.mli index b3a2140f..e0f36cdb 100644 --- a/core/CCIO.mli +++ b/core/CCIO.mli @@ -93,9 +93,9 @@ val flush : out_channel -> unit t (** {2 Streams} *) -(* XXX: WIP module Seq : sig - type +'a t + type 'a t + (** An IO stream of values of type 'a, consumable (iterable only once) *) val map : ('a -> 'b io) -> 'a t -> 'b t (** Map values with actions *) @@ -105,10 +105,10 @@ module Seq : sig val filter_map : ('a -> 'b option) -> 'a t -> 'b t - val flat_map : ('a -> 'b t) -> 'a t -> 'b t + val flat_map : ('a -> 'b t io) -> 'a t -> 'b t (** Map each value to a sub sequence of values *) - val general_iter : ('b -> 'a -> [`Stop | `Continue of ('b * 'c option)]) -> + val general_iter : ('b -> 'a -> [`Stop | `Continue of ('b * 'c option)] io) -> 'b -> 'a t -> 'c t (** [general_iter f acc seq] performs a [filter_map] over [seq], using [f]. [f] is given a state and the current value, and @@ -122,6 +122,16 @@ module Seq : sig val iter : ('a -> _ io) -> 'a t -> unit io (** Iterate on the stream, with an action for each element *) + val length : _ t -> int io + (** Length of the stream *) + + val fold : ('b -> 'a -> 'b io) -> 'b -> 'a t -> 'b io + (** [fold f acc seq] folds over [seq], consuming it. Every call to [f] + has the right to return an IO value. *) + + val fold_pure : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b io + (** [fold f acc seq] folds over [seq], consuming it. [f] is pure. *) + (** {6 Standard Wrappers} *) type 'a step_result = @@ -130,26 +140,16 @@ module Seq : sig type 'a gen = unit -> 'a step_result io - val of_fun : 'a gen io -> 'a t + val of_fun : 'a gen -> 'a t (** Create a stream from a function that yields an element or stops *) - val with_in : ?flags:open_flag list -> string -> 'a t - - val lines : in_channel io -> string t + val lines : in_channel -> string t (** Lines of an input channel *) val output : ?sep:string -> out_channel -> string t -> unit io (** [output oc seq] outputs every value of [seq] into [oc], separated with the optional argument [sep] (default: ["\n"]) *) - - val length : _ t -> int io - (** Length of the stream *) - - val fold : ('b -> 'a -> 'b io) -> 'b -> 'a t -> 'b io - (** [fold f acc seq] folds over [seq], consuming it. Every call to [f] - has the right to return an IO value. *) end -*) (** {2 Low level access} *) module Raw : sig From b88461d8349b706ec833710cd80942c7c0e3e077 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 23 Jul 2014 11:32:46 +0200 Subject: [PATCH 20/30] new combinators for CCIO --- core/CCIO.ml | 131 ++++++++++++++++++++++++++++++++++++++++++++++++-- core/CCIO.mli | 55 ++++++++++++++++++++- 2 files changed, 179 insertions(+), 7 deletions(-) diff --git a/core/CCIO.ml b/core/CCIO.ml index bc566f43..3553e966 100644 --- a/core/CCIO.ml +++ b/core/CCIO.ml @@ -28,19 +28,26 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. type _ t = | Return : 'a -> 'a t + | Fail : string -> 'a t | Map : ('a -> 'b) * 'a t -> 'b t | Bind : ('a -> 'b t) * 'a t -> 'b t + | BindWith : unit t * ('a -> 'b t) * 'a t -> 'b t | Star : ('a -> 'b) t * 'a t -> 'b t | Repeat : int * 'a t -> 'a list t | RepeatIgnore : int * 'a t -> unit t | Wrap : (unit -> 'a) -> 'a t | WrapJoin : (unit -> 'a t) -> 'a t + | SequenceMap : ('a -> 'b t) * 'a list -> 'b list t type 'a io = 'a t type 'a or_error = [ `Ok of 'a | `Error of string ] let (>>=) x f = Bind(f,x) +let bind ?finalize f a = match finalize with + | None -> Bind(f,a) + | Some b -> BindWith (b,f,a) + let map f x = Map(f, x) let (>|=) x f = Map(f, x) @@ -48,6 +55,8 @@ let (>|=) x f = Map(f, x) let return x = Return x let pure = return +let fail msg = Fail msg + let (<*>) f a = Star (f, a) let lift = map @@ -59,37 +68,69 @@ let lift3 f a b c = a >>= fun x -> b >>= fun y -> map (f x y) c +let sequence_map f l = + SequenceMap (f,l) + +let sequence l = + let _id x = x in + SequenceMap(_id, l) + let repeat i a = if i <= 0 then Return [] else Repeat (i,a) let repeat' i a = if i <= 0 then Return () else RepeatIgnore (i,a) +exception IOFailure of string + let rec _run : type a. a t -> a = function | Return x -> x + | Fail msg -> raise (IOFailure msg) | Map (f, a) -> f (_run a) | Bind (f, a) -> _run (f (_run a)) + | BindWith (finalize, f, a) -> + begin try + let res = _run (f (_run a)) in + _run finalize; + res + with e -> + _run finalize; + raise e + end | Star (f, a) -> _run f (_run a) | Repeat (i,a) -> _repeat [] i a | RepeatIgnore (i,a) -> _repeat_ignore i a | Wrap f -> f() | WrapJoin f -> _run (f()) - + | SequenceMap (f, l) -> _sequence_map f l [] and _repeat : type a. a list -> int -> a t -> a list = fun acc i a -> match i with | 0 -> List.rev acc | _ -> let x = _run a in _repeat (x::acc) (i-1) a - and _repeat_ignore : type a. int -> a t -> unit = fun i a -> match i with | 0 -> () | _ -> let _ = _run a in _repeat_ignore (i-1) a - -let _printers = ref [] +and _sequence_map : type a b. (a -> b t) -> a list -> b list -> b list + = fun f l acc -> match l with + | [] -> List.rev acc + | a::tail -> + let x = _run (f a) in + _sequence_map f tail (x::acc) + +let _printers = + ref [ + (* default printer *) + ( function IOFailure msg + | Sys_error msg -> Some msg + | Exit -> Some "exit" + | _ -> None + ) + ] exception PrinterResult of string @@ -107,6 +148,12 @@ let run x = try `Ok (_run x) with e -> `Error (_print_exn e) +exception IO_error of string + +let run_exn x = + try _run x + with e -> raise (IO_error (_print_exn e)) + let register_printer p = _printers := p :: !_printers (** {2 Standard Wrappers} *) @@ -125,9 +172,30 @@ let with_in ?(flags=[]) filename f = let _read ic s i len () = input ic s i len let read ic s i len = Wrap (_read ic s i len) -let _read_line ic () = Pervasives.input_line ic +let _read_line ic () = + try Some (Pervasives.input_line ic) + with End_of_file -> None let read_line ic = Wrap(_read_line ic) +let rec _read_lines ic acc = + read_line ic + >>= function + | None -> return (List.rev acc) + | Some l -> _read_lines ic (l::acc) + +let read_lines ic = _read_lines ic [] + +let _read_all ic () = + let buf = Buffer.create 128 in + try + while true do + Buffer.add_channel buf ic 1024 + done; + "" (* never returned *) + with End_of_file -> Buffer.contents buf + +let read_all ic = Wrap(_read_all ic) + let _with_out flags filename f () = let oc = open_out_gen flags 0x644 filename in try @@ -145,6 +213,11 @@ let write oc s i len = Wrap (_write oc s i len) let _write_str oc s () = output oc s 0 (String.length s) let write_str oc s = Wrap (_write_str oc s) +let _write_line oc l () = + output_string oc l; + output_char oc '\n' +let write_line oc l = Wrap (_write_line oc l) + let _write_buf oc buf () = Buffer.output_buffer oc buf let write_buf oc buf = Wrap (_write_buf oc buf) @@ -208,6 +281,22 @@ module Seq = struct in _next + (* apply all actions from [l] to [x] *) + let rec _apply_all_to x l = match l with + | [] -> return () + | f::tail -> f x >>= fun () -> _apply_all_to x tail + + let _tee funs g () = + g() >>= function + | Stop -> _stop() + | Yield x -> + _apply_all_to x funs >>= fun () -> + _yield x + + let tee funs g = match funs with + | [] -> g + | _::_ -> _tee funs g + (** {6 Consume} *) let rec fold_pure f acc g = @@ -230,10 +319,42 @@ module Seq = struct let of_fun g = g + (* TODO: wrapper around with_in? using bind ~finalize:... ? *) + + let chunks ~size ic = + let buf = Buffer.create size in + let next() = + try + Buffer.add_channel buf ic size; + let s = Buffer.contents buf in + Buffer.clear buf; + _yield s + with End_of_file -> _stop() + in + next + let lines ic () = try _yield (input_line ic) with End_of_file -> _stop() + let words g = + failwith "words: not implemented yet" + (* TODO: state machine that goes: + - 0: read input chunk + - switch to "search for ' '", and yield word + - goto 0 if no ' ' found + - yield leftover when g returns Stop + let buf = Buffer.create 32 in + let next() = + g() >>= function + | Stop -> _stop + | Yield s -> + Buffer.add_string buf s; + search_ + in + next + *) + let output ?(sep="\n") oc seq = let first = ref true in iter diff --git a/core/CCIO.mli b/core/CCIO.mli index e0f36cdb..4f42dd44 100644 --- a/core/CCIO.mli +++ b/core/CCIO.mli @@ -24,7 +24,12 @@ 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 IO Monad} *) +(** {1 IO Monad} + +A simple abstraction over blocking IO, with strict evaluation. This is in +no way an alternative to Lwt/Async if you need concurrency. + +@since NEXT_RELEASE *) type 'a t type 'a io = 'a t @@ -49,6 +54,13 @@ val map : ('a -> 'b) -> 'a t -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t +val bind : ?finalize:(unit t) -> ('a -> 'b t) -> 'a t -> 'b t +(** [bind f a] runs the action [a] and applies [f] to its result + to obtain a new action. It then behaves exactly like this new + action. + @param finalize an optional action that is always run after evaluating + the whole action *) + val pure : 'a -> 'a t val (<*>) : ('a -> 'b) t -> 'a t -> 'b t @@ -58,11 +70,27 @@ val lift : ('a -> 'b) -> 'a t -> 'b t val lift2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t val lift3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t +val sequence : 'a t list -> 'a list t +(** Runs operations one by one and gather their results *) + +val sequence_map : ('a -> 'b t) -> 'a list -> 'b list t +(** Generalization of {!sequence} *) + +val fail : string -> 'a t +(** [fail msg] fails with the given message. Running the IO value will + return an [`Error] variant *) + val run : 'a t -> 'a or_error (** Run an IO action. @return either [`Ok x] when [x] is the successful result of the computation, or some [`Error "message"] *) +exception IO_error of string + +val run_exn : 'a t -> 'a +(** Unsafe version of {!run}. It assumes non-failure. + @raise IO_error if the execution didn't go well *) + val register_printer : (exn -> string option) -> unit (** [register_printer p] register [p] as a possible failure printer. If [run a] raises an exception [e], [p e] is evaluated. If [p e = Some msg] @@ -76,8 +104,16 @@ val register_printer : (exn -> string option) -> unit val with_in : ?flags:open_flag list -> string -> (in_channel -> 'a t) -> 'a t val read : in_channel -> string -> int -> int -> int t +(** Read a chunk into the given string *) -val read_line : in_channel -> string t +val read_line : in_channel -> string option t +(** Read a line from the channel. Returns [None] if the input is terminated. *) + +val read_lines : in_channel -> string list t +(** Read all lines eagerly *) + +val read_all : in_channel -> string t +(** Read the whole channel into a buffer, then converted into a string *) (** {6 Output} *) @@ -89,8 +125,12 @@ val write_str : out_channel -> string -> unit t val write_buf : out_channel -> Buffer.t -> unit t +val write_line : out_channel -> string -> unit t + val flush : out_channel -> unit t +(* TODO: printf/fprintf wrappers *) + (** {2 Streams} *) module Seq : sig @@ -117,6 +157,11 @@ module Seq : sig [c] an optional output value. The result is the stream of values output by [f] *) + val tee : ('a -> unit io) list -> 'a t -> 'a t + (** [tee funs seq] behaves like [seq], but each element is given to + every function [f] in [funs]. This function [f] returns an action that + is eagerly executed. *) + (** {6 Consume} *) val iter : ('a -> _ io) -> 'a t -> unit io @@ -143,9 +188,15 @@ module Seq : sig val of_fun : 'a gen -> 'a t (** Create a stream from a function that yields an element or stops *) + val chunks : size:int -> in_channel -> string t + (** Read the channel's content into chunks of size [size] *) + val lines : in_channel -> string t (** Lines of an input channel *) + val words : string t -> string t + (** Split strings into words at " " boundaries *) + val output : ?sep:string -> out_channel -> string t -> unit io (** [output oc seq] outputs every value of [seq] into [oc], separated with the optional argument [sep] (default: ["\n"]) *) From d03ea3dc54336e350d199edb4345429f2b1ff5d7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 23 Jul 2014 12:25:00 +0200 Subject: [PATCH 21/30] CCIO: explicit finalizer system, to use a >>>= operator rather than callbacks. bugfix in Seq.chunks --- core/CCIO.ml | 75 ++++++++++++++++++++++++++++++--------------------- core/CCIO.mli | 52 ++++++++++++++++++++++++++++++++--- 2 files changed, 94 insertions(+), 33 deletions(-) diff --git a/core/CCIO.ml b/core/CCIO.ml index 3553e966..f91e33cb 100644 --- a/core/CCIO.ml +++ b/core/CCIO.ml @@ -31,22 +31,22 @@ type _ t = | Fail : string -> 'a t | Map : ('a -> 'b) * 'a t -> 'b t | Bind : ('a -> 'b t) * 'a t -> 'b t - | BindWith : unit t * ('a -> 'b t) * 'a t -> 'b t + | WithGuard: unit t * 'a t -> 'a t (* run guard in any case *) | Star : ('a -> 'b) t * 'a t -> 'b t | Repeat : int * 'a t -> 'a list t | RepeatIgnore : int * 'a t -> unit t | Wrap : (unit -> 'a) -> 'a t - | WrapJoin : (unit -> 'a t) -> 'a t | SequenceMap : ('a -> 'b t) * 'a list -> 'b list t type 'a io = 'a t +type 'a with_finalizer = ('a t * unit t) t type 'a or_error = [ `Ok of 'a | `Error of string ] let (>>=) x f = Bind(f,x) let bind ?finalize f a = match finalize with | None -> Bind(f,a) - | Some b -> BindWith (b,f,a) + | Some b -> WithGuard (b, Bind (f,a)) let map f x = Map(f, x) @@ -81,6 +81,14 @@ let repeat i a = let repeat' i a = if i <= 0 then Return () else RepeatIgnore (i,a) +(** {2 Finalizers} *) + +let (>>>=) a f = + a >>= function + | x, finalizer -> WithGuard (finalizer, x >>= f) + +(** {2 Running} *) + exception IOFailure of string let rec _run : type a. a t -> a = function @@ -88,20 +96,19 @@ let rec _run : type a. a t -> a = function | Fail msg -> raise (IOFailure msg) | Map (f, a) -> f (_run a) | Bind (f, a) -> _run (f (_run a)) - | BindWith (finalize, f, a) -> + | WithGuard (g, a) -> begin try - let res = _run (f (_run a)) in - _run finalize; + let res = _run a in + _run g; res with e -> - _run finalize; + _run g; raise e end | Star (f, a) -> _run f (_run a) | Repeat (i,a) -> _repeat [] i a | RepeatIgnore (i,a) -> _repeat_ignore i a | Wrap f -> f() - | WrapJoin f -> _run (f()) | SequenceMap (f, l) -> _sequence_map f l [] and _repeat : type a. a list -> int -> a t -> a list = fun acc i a -> match i with @@ -158,16 +165,14 @@ let register_printer p = _printers := p :: !_printers (** {2 Standard Wrappers} *) -let _with_in flags filename f () = - let ic = open_in_gen flags 0x644 filename in - try - f ic - with e -> - close_in ic; - raise e +let _open_in mode flags filename () = + open_in_gen flags mode filename +let _close_in ic () = close_in ic -let with_in ?(flags=[]) filename f = - WrapJoin (_with_in flags filename f) +let with_in ?(mode=0o644) ?(flags=[]) filename = + Wrap (_open_in mode flags filename) + >>= fun ic -> + Return (Return ic, Wrap (_close_in ic)) let _read ic s i len () = input ic s i len let read ic s i len = Wrap (_read ic s i len) @@ -196,16 +201,17 @@ let _read_all ic () = let read_all ic = Wrap(_read_all ic) -let _with_out flags filename f () = - let oc = open_out_gen flags 0x644 filename in - try - f oc - with e -> - close_out oc; - raise e +let _open_out mode flags filename () = + open_out_gen flags mode filename +let _close_out oc () = close_out oc -let with_out ?(flags=[]) filename f = - WrapJoin (_with_out flags filename f) +let with_out ?(mode=0o644) ?(flags=[]) filename = + Wrap(_open_out mode (Open_wronly::flags) filename) + >>= fun oc -> + Return(Return oc, Wrap(_close_out oc)) + +let with_out_a ?mode ?(flags=[]) filename = + with_out ?mode ~flags:(Open_creat::Open_append::flags) filename let _write oc s i len () = output oc s i len let write oc s i len = Wrap (_write oc s i len) @@ -323,13 +329,18 @@ module Seq = struct let chunks ~size ic = let buf = Buffer.create size in + let eof = ref false in let next() = - try + if !eof then _stop() + else try Buffer.add_channel buf ic size; let s = Buffer.contents buf in Buffer.clear buf; _yield s - with End_of_file -> _stop() + with End_of_file -> + let s = Buffer.contents buf in + eof := true; + if s="" then _stop() else _yield s in next @@ -355,16 +366,20 @@ module Seq = struct next *) - let output ?(sep="\n") oc seq = + let output ?sep oc seq = let first = ref true in iter (fun s -> + (* print separator *) ( if !first then (first:=false; return ()) - else write_str oc sep + else match sep with + | None -> return () + | Some sep -> write_str oc sep ) >>= fun () -> write_str oc s ) seq + >>= fun () -> flush oc end (** {2 Raw} *) diff --git a/core/CCIO.mli b/core/CCIO.mli index 4f42dd44..2a09c7b3 100644 --- a/core/CCIO.mli +++ b/core/CCIO.mli @@ -29,11 +29,37 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. A simple abstraction over blocking IO, with strict evaluation. This is in no way an alternative to Lwt/Async if you need concurrency. -@since NEXT_RELEASE *) +@since NEXT_RELEASE + +Examples: + +- obtain the list of lines of a file: +{[ +let l = CCIO.((with_in "/tmp/some_file" >>>= read_lines) |> run_exn);; +]} + +- transfer one file into another: +{[ +# let a = CCIO.( + with_in "input" >>>= fun ic -> + with_out ~flags:[Open_creat] "output" >>>= fun oc -> + Seq.chunks 512 ic + |> Seq.output oc +) ;; + +# run a;; +]} + +*) type 'a t type 'a io = 'a t +type 'a with_finalizer +(** A value of type ['a with_finalizer] is similar to a value ['a t] but + also contains a finalizer that must be run to cleanup. + See {!(>>>=)} to get rid of it. *) + type 'a or_error = [ `Ok of 'a | `Error of string ] val (>>=) : 'a t -> ('a -> 'b t) -> 'b t @@ -80,6 +106,15 @@ val fail : string -> 'a t (** [fail msg] fails with the given message. Running the IO value will return an [`Error] variant *) +(** {2 Finalizers} *) + +val (>>>=) : 'a with_finalizer -> ('a -> 'b t) -> 'b t +(** Alternative to {!(>>=)} that also takes a [unit t] value, that is a + finalizer. This action will run in any case (even failure). + Other than the finalizer, this behaves like {!(>>=)} *) + +(** {2 Running} *) + val run : 'a t -> 'a or_error (** Run an IO action. @return either [`Ok x] when [x] is the successful result of the @@ -101,7 +136,11 @@ val register_printer : (exn -> string option) -> unit (** {6 Input} *) -val with_in : ?flags:open_flag list -> string -> (in_channel -> 'a t) -> 'a t +val with_in : ?mode:int -> ?flags:open_flag list -> + string -> in_channel with_finalizer +(** Open an input file with the given optional flag list. + It yields a [in_channel] with a finalizer attached. See {!(>>>=)} to + use it. *) val read : in_channel -> string -> int -> int -> int t (** Read a chunk into the given string *) @@ -117,7 +156,14 @@ val read_all : in_channel -> string t (** {6 Output} *) -val with_out : ?flags:open_flag list -> string -> (out_channel -> 'a t) -> 'a t +val with_out : ?mode:int -> ?flags:open_flag list -> + string -> out_channel with_finalizer +(** Same as {!with_in} but for an output channel *) + +val with_out_a : ?mode:int -> ?flags:open_flag list -> + string -> out_channel with_finalizer +(** Similar to {!with_out} but with the [Open_append] and [Open_creat] + flags activated *) val write : out_channel -> string -> int -> int -> unit t From 0e77e6bedf220f8ac6e8cb915f8d6861b94d61ae Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 25 Jul 2014 12:25:48 +0200 Subject: [PATCH 22/30] readme: add ci hook --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index 6083c7e0..a0ace7c7 100644 --- a/README.md +++ b/README.md @@ -20,6 +20,8 @@ ocaml-containers 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)). +[![Build Status](http://ci.cedeela.fr/buildStatus/icon?job=containers)](http://ci.cedeela.fr/job/containers/) + ## Use You can either build and install the library (see `Build`), or just copy From 057300c9ac5c7966546ed2a4f54a0094d3c97907 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 5 Aug 2014 00:15:17 +0200 Subject: [PATCH 23/30] details (comments) --- core/CCIO.mli | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/core/CCIO.mli b/core/CCIO.mli index 2a09c7b3..155c5c2a 100644 --- a/core/CCIO.mli +++ b/core/CCIO.mli @@ -177,7 +177,11 @@ val flush : out_channel -> unit t (* TODO: printf/fprintf wrappers *) -(** {2 Streams} *) +(** {2 Streams} + +Iterators on chunks of bytes, or lines, or any other value using combinators. +Those iterators are usable only once, because their source might +be usable only once (think of a socket) *) module Seq : sig type 'a t @@ -245,7 +249,8 @@ module Seq : sig val output : ?sep:string -> out_channel -> string t -> unit io (** [output oc seq] outputs every value of [seq] into [oc], separated - with the optional argument [sep] (default: ["\n"]) *) + with the optional argument [sep] (default: ["\n"]). + It blocks until all values of [seq] are produced and written to [oc]. *) end (** {2 Low level access} *) From bf2203f9e25111a9d737c68b2d2979d08eb8d767 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 5 Aug 2014 00:23:04 +0200 Subject: [PATCH 24/30] renamed threads/future to threads/CCFuture --- .ocamlinit | 3 ++- _oasis | 4 ++-- threads/{future.ml => CCFuture.ml} | 0 threads/{future.mli => CCFuture.mli} | 0 4 files changed, 4 insertions(+), 3 deletions(-) rename threads/{future.ml => CCFuture.ml} (100%) rename threads/{future.mli => CCFuture.mli} (100%) diff --git a/.ocamlinit b/.ocamlinit index 7711334d..be85d342 100644 --- a/.ocamlinit +++ b/.ocamlinit @@ -3,11 +3,12 @@ #directory "_build/core";; #directory "_build/misc";; #directory "_build/string";; +#directory "_build/threads";; #directory "_build/tests/";; #load "containers.cma";; #load "containers_string.cma";; #load "containers_misc.cma";; -#require "threads";; +#thread;; #load "containers_thread.cma";; open Containers_misc;; #install_printer Bencode.pretty;; diff --git a/_oasis b/_oasis index e8bcb1fd..db498281 100644 --- a/_oasis +++ b/_oasis @@ -74,13 +74,13 @@ Library "containers_misc" Library "containers_thread" Path: threads/ - Modules: Future + Modules: CCFuture FindlibName: thread FindlibParent: containers Build$: flag(thread) Install$: flag(thread) BuildDepends: containers,threads - XMETARequires: containers,threads,lwt + XMETARequires: containers,threads Library "containers_lwt" Path: lwt diff --git a/threads/future.ml b/threads/CCFuture.ml similarity index 100% rename from threads/future.ml rename to threads/CCFuture.ml diff --git a/threads/future.mli b/threads/CCFuture.mli similarity index 100% rename from threads/future.mli rename to threads/CCFuture.mli From 691f4e5068e0b79aa7fd3d326cc3b9eaed5395f9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 5 Aug 2014 00:32:45 +0200 Subject: [PATCH 25/30] more CCIO.Seq combinators --- core/CCIO.ml | 38 ++++++++++++++++++++++++++++++++++++++ core/CCIO.mli | 13 ++++++++++++- 2 files changed, 50 insertions(+), 1 deletion(-) diff --git a/core/CCIO.ml b/core/CCIO.ml index f91e33cb..cb688075 100644 --- a/core/CCIO.ml +++ b/core/CCIO.ml @@ -261,6 +261,12 @@ module Seq = struct | None -> filter_map f g() | Some y -> _yield y + let rec filter f g () = + g() >>= function + | Stop -> _stop() + | Yield x -> + if f x then _yield x else filter f g() + let rec flat_map f g () = g() >>= function | Stop -> _stop () @@ -287,6 +293,38 @@ module Seq = struct in _next + let take n seq = + general_iter + (fun n x -> if n<=0 + then return `Stop + else return (`Continue (n-1, Some x)) + ) n seq + + let drop n seq = + general_iter + (fun n x -> if n<=0 + then return (`Continue (n, Some x)) + else return (`Continue (n-1, None)) + ) n seq + + let take_while p seq = + general_iter + (fun () x -> + p x >|= function + | true -> `Continue ((), Some x) + | false -> `Stop + ) () seq + + let drop_while p seq = + general_iter + (fun dropping x -> + if dropping + then p x >|= function + | true -> `Continue (true, None) + | false -> `Continue (false, Some x) + else return (`Continue (false, Some x)) + ) true seq + (* apply all actions from [l] to [x] *) let rec _apply_all_to x l = match l with | [] -> return () diff --git a/core/CCIO.mli b/core/CCIO.mli index 155c5c2a..1d097617 100644 --- a/core/CCIO.mli +++ b/core/CCIO.mli @@ -195,9 +195,19 @@ module Seq : sig val filter_map : ('a -> 'b option) -> 'a t -> 'b t + val filter : ('a -> bool) -> 'a t -> 'a t + val flat_map : ('a -> 'b t io) -> 'a t -> 'b t (** Map each value to a sub sequence of values *) + val take : int -> 'a t -> 'a t + + val drop : int -> 'a t -> 'a t + + val take_while : ('a -> bool io) -> 'a t -> 'a t + + val drop_while : ('a -> bool io) -> 'a t -> 'a t + val general_iter : ('b -> 'a -> [`Stop | `Continue of ('b * 'c option)] io) -> 'b -> 'a t -> 'c t (** [general_iter f acc seq] performs a [filter_map] over [seq], @@ -245,7 +255,8 @@ module Seq : sig (** Lines of an input channel *) val words : string t -> string t - (** Split strings into words at " " boundaries *) + (** Split strings into words at " " boundaries. + {b NOT IMPLEMENTED} *) val output : ?sep:string -> out_channel -> string t -> unit io (** [output oc seq] outputs every value of [seq] into [oc], separated From 12207ab95ad2858adfb9559a587c09868c233128 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 5 Aug 2014 01:22:26 +0200 Subject: [PATCH 26/30] building blocks for CCIO.Seq --- core/CCIO.ml | 29 +++++++++++++++++++++++++++++ core/CCIO.mli | 6 ++++++ 2 files changed, 35 insertions(+) diff --git a/core/CCIO.ml b/core/CCIO.ml index cb688075..1e9313d1 100644 --- a/core/CCIO.ml +++ b/core/CCIO.ml @@ -363,6 +363,35 @@ module Seq = struct let of_fun g = g + let empty () = _stop() + + let singleton x = + let first = ref true in + fun () -> + if !first then (first := false; _yield x) else _stop() + + let cons x g = + let first = ref true in + fun () -> + if !first then (first := false; _yield x) else g() + + let of_list l = + let l = ref l in + fun () -> match !l with + | [] -> _stop() + | x::tail -> l:= tail; _yield x + + let of_array a = + let i = ref 0 in + fun () -> + if !i = Array.length a + then _stop() + else ( + let x = a.(!i) in + incr i; + _yield x + ) + (* TODO: wrapper around with_in? using bind ~finalize:... ? *) let chunks ~size ic = diff --git a/core/CCIO.mli b/core/CCIO.mli index 1d097617..58e24dea 100644 --- a/core/CCIO.mli +++ b/core/CCIO.mli @@ -248,6 +248,12 @@ module Seq : sig val of_fun : 'a gen -> 'a t (** Create a stream from a function that yields an element or stops *) + val empty : 'a t + val singleton : 'a -> 'a t + val cons : 'a -> 'a t -> 'a t + val of_list : 'a list -> 'a t + val of_array : 'a array -> 'a t + val chunks : size:int -> in_channel -> string t (** Read the channel's content into chunks of size [size] *) From 0660fde92b318a39ca10800ecd37f35ad047229e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 5 Aug 2014 01:22:44 +0200 Subject: [PATCH 27/30] CCIO.File for basic filenames manipulations --- core/CCIO.ml | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++ core/CCIO.mli | 42 ++++++++++++++++++++++++++++++++++ 2 files changed, 105 insertions(+) diff --git a/core/CCIO.ml b/core/CCIO.ml index 1e9313d1..b0c27718 100644 --- a/core/CCIO.ml +++ b/core/CCIO.ml @@ -449,6 +449,69 @@ module Seq = struct >>= fun () -> flush oc end +(** {6 File and file names} *) + +module File = struct + type t = string + + let to_string f = f + + let make f = + if Filename.is_relative f + then Filename.concat (Sys.getcwd()) f + else f + + let exists f = Wrap (fun () -> Sys.file_exists f) + + let is_directory f = Wrap (fun () -> Sys.is_directory f) + + let remove f = Wrap (fun () -> Sys.remove f) + + let _read_dir d () = + if Sys.is_directory d + then + let arr = Sys.readdir d in + Seq.of_array arr + |> Seq.map_pure make + else Seq.empty + + let rec _walk d () = + if Sys.is_directory d + then + let arr = Sys.readdir d in + let tail = Seq.of_array arr + |> Seq.flat_map + (fun s -> return (_walk (Filename.concat d s) ())) + in Seq.cons (`Dir,d) tail + else Seq.singleton (`File, d) + + let walk t = Wrap (_walk t) + + let read_dir ?(recurse=false) d = + if recurse + then walk d + >|= Seq.filter_map + (function + | `File, f -> Some f + | `Dir, _ -> None + ) + else Wrap (_read_dir d) + + let rec _read_dir_rec d () = + if Sys.is_directory d + then + let arr = Sys.readdir d in + Seq.of_array arr + |> Seq.map_pure (fun s -> Filename.concat d s) + |> Seq.flat_map + (fun s -> + if Sys.is_directory s + then return (_read_dir_rec s ()) + else return (Seq.singleton s) + ) + else Seq.empty +end + (** {2 Raw} *) module Raw = struct diff --git a/core/CCIO.mli b/core/CCIO.mli index 58e24dea..9fc78d96 100644 --- a/core/CCIO.mli +++ b/core/CCIO.mli @@ -270,6 +270,48 @@ module Seq : sig It blocks until all values of [seq] are produced and written to [oc]. *) end +(** {6 File and file names} + +How to list recursively files in a directory: +{[ + CCIO.( + File.read_dir ~recurse:true (File.make "/tmp") + >>= Seq.output ~sep:"\n" stdout + ) |> CCIO.run_exn ;; + + ]} + +See {!File.walk} if you also need to list directories. +*) + +module File : sig + type t = string + (** A file is always represented by its absolute path *) + + val to_string : t -> string + + val make : string -> t + (** Build a file representation from a path (absolute or relative) *) + + val exists : t -> bool io + + val is_directory : t -> bool io + + val remove : t -> unit io + + val read_dir : ?recurse:bool -> t -> t Seq.t io + (** [read_dir d] returns a sequence of files and directory contained + in the directory [d] (or an empty stream if [d] is not a directory) + @param recurse if true (default [false]), sub-directories are also + explored *) + + val walk : t -> ([`File | `Dir] * t) Seq.t io + (** similar to {!read_dir} (with [recurse=true]), this function walks + a directory recursively and yields either files or directories. + Is a file anything that doesn't satisfy {!is_directory} (including + symlinks, etc.) *) +end + (** {2 Low level access} *) module Raw : sig val wrap : (unit -> 'a) -> 'a t From 1214bfe777b4d20daaafb42fa3d265d183e0f9e4 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 5 Aug 2014 01:30:33 +0200 Subject: [PATCH 28/30] minor doc details --- core/CCIO.mli | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/core/CCIO.mli b/core/CCIO.mli index 9fc78d96..a31c42cb 100644 --- a/core/CCIO.mli +++ b/core/CCIO.mli @@ -30,15 +30,19 @@ A simple abstraction over blocking IO, with strict evaluation. This is in no way an alternative to Lwt/Async if you need concurrency. @since NEXT_RELEASE +*) +(** Examples: - obtain the list of lines of a file: + {[ let l = CCIO.((with_in "/tmp/some_file" >>>= read_lines) |> run_exn);; ]} - transfer one file into another: + {[ # let a = CCIO.( with_in "input" >>>= fun ic -> @@ -49,7 +53,6 @@ let l = CCIO.((with_in "/tmp/some_file" >>>= read_lines) |> run_exn);; # run a;; ]} - *) type 'a t @@ -266,7 +269,7 @@ module Seq : sig val output : ?sep:string -> out_channel -> string t -> unit io (** [output oc seq] outputs every value of [seq] into [oc], separated - with the optional argument [sep] (default: ["\n"]). + with the optional argument [sep] (default: None). It blocks until all values of [seq] are produced and written to [oc]. *) end From 2812f797e901ca2b9aa3aea8bd863b1e989a54eb Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 5 Aug 2014 11:18:15 +0200 Subject: [PATCH 29/30] CCMultiMap now also contains a functor to build bidirectional multimaps --- core/CCMultiMap.ml | 133 ++++++++++++++++++++++++++++++++++++++++++++ core/CCMultiMap.mli | 63 +++++++++++++++++++++ 2 files changed, 196 insertions(+) diff --git a/core/CCMultiMap.ml b/core/CCMultiMap.ml index 3eedb5f7..29be19a8 100644 --- a/core/CCMultiMap.ml +++ b/core/CCMultiMap.ml @@ -225,3 +225,136 @@ module Make(K : OrderedType)(V : OrderedType) = struct let values m k = iter m (fun _ v -> k v) end + +module type BIDIR = sig + type t + type left + type right + + val empty : t + + val is_empty : t -> bool + + val add : t -> left -> right -> t + (** Add a binding (left,right) *) + + val remove : t -> left -> right -> t + (** Remove a specific binding *) + + val cardinal_left : t -> int + (** number of distinct left keys *) + + val cardinal_right : t -> int + (** number of distinct right keys *) + + val remove_left : t -> left -> t + (** Remove all bindings for the left key *) + + val remove_right : t -> right -> t + (** Remove all bindings for the right key *) + + val mem_left : t -> left -> bool + (** Is the left key present in at least one pair? *) + + val mem_right : t -> right -> bool + (** Is the right key present in at least one pair? *) + + val find_left : t -> left -> right sequence + (** Find all bindings for this given left-key *) + + val find_right : t -> right -> left sequence + (** Find all bindings for this given right-key *) + + val find1_left : t -> left -> right option + (** like {!find_left} but returns at most one value *) + + val find1_right : t -> right -> left option + (** like {!find_right} but returns at most one value *) + + val fold : ('a -> left -> right -> 'a) -> 'a -> t -> 'a + (** Fold on pairs *) + + val pairs : t -> (left * right) sequence + (** Iterate on pairs *) + + val add_pairs : t -> (left * right) sequence -> t + (** Add pairs *) + + val seq_left : t -> left sequence + val seq_right : t -> right sequence +end + +let _fold_seq f acc seq = + let acc = ref acc in + seq (fun x -> acc := f !acc x); + !acc + +let _head_seq seq = + let r = ref None in + begin try seq (fun x -> r := Some x; raise Exit) + with Exit -> (); + end; + !r + +module MakeBidir(L : OrderedType)(R : OrderedType) = struct + type left = L.t + type right = R.t + + module MapL = Make(L)(R) + module MapR = Make(R)(L) + + type t = { + left : MapL.t; + right : MapR.t; + } + + let empty = { + left = MapL.empty; + right = MapR.empty; + } + + let is_empty m = MapL.is_empty m.left + + let add m a b = { + left = MapL.add m.left a b; + right = MapR.add m.right b a; + } + + let remove m a b = { + left = MapL.remove m.left a b; + right = MapR.remove m.right b a; + } + + let cardinal_left m = MapL.size m.left + let cardinal_right m = MapR.size m.right + + let find_left m a = MapL.find_iter m.left a + let find_right m b = MapR.find_iter m.right b + + let remove_left m a = + _fold_seq + (fun m b -> remove m a b) + m (find_left m a) + + let remove_right m b = + _fold_seq + (fun m a -> remove m a b) + m (find_right m b) + + let mem_left m a = MapL.mem m.left a + let mem_right m b = MapR.mem m.right b + + let find1_left m a = _head_seq (find_left m a) + let find1_right m b = _head_seq (find_right m b) + + let fold f acc m = + MapL.fold m.left acc f + + let pairs m = MapL.to_seq m.left + + let add_pairs m seq = _fold_seq (fun m (a,b) -> add m a b) m seq + + let seq_left m = MapL.keys m.left + + let seq_right m = MapR.keys m.right +end diff --git a/core/CCMultiMap.mli b/core/CCMultiMap.mli index 8d6e9e71..850bb93f 100644 --- a/core/CCMultiMap.mli +++ b/core/CCMultiMap.mli @@ -104,3 +104,66 @@ module type OrderedType = sig end module Make(K : OrderedType)(V : OrderedType) : S with type key = K.t and type value = V.t + +(** {2 Two-Way Multimap} *) + +module type BIDIR = sig + type t + type left + type right + + val empty : t + + val is_empty : t -> bool + + val add : t -> left -> right -> t + (** Add a binding (left,right) *) + + val remove : t -> left -> right -> t + (** Remove a specific binding *) + + val cardinal_left : t -> int + (** number of distinct left keys *) + + val cardinal_right : t -> int + (** number of distinct right keys *) + + val remove_left : t -> left -> t + (** Remove all bindings for the left key *) + + val remove_right : t -> right -> t + (** Remove all bindings for the right key *) + + val mem_left : t -> left -> bool + (** Is the left key present in at least one pair? *) + + val mem_right : t -> right -> bool + (** Is the right key present in at least one pair? *) + + val find_left : t -> left -> right sequence + (** Find all bindings for this given left-key *) + + val find_right : t -> right -> left sequence + (** Find all bindings for this given right-key *) + + val find1_left : t -> left -> right option + (** like {!find_left} but returns at most one value *) + + val find1_right : t -> right -> left option + (** like {!find_right} but returns at most one value *) + + val fold : ('a -> left -> right -> 'a) -> 'a -> t -> 'a + (** Fold on pairs *) + + val pairs : t -> (left * right) sequence + (** Iterate on pairs *) + + val add_pairs : t -> (left * right) sequence -> t + (** Add pairs *) + + val seq_left : t -> left sequence + val seq_right : t -> right sequence +end + +module MakeBidir(L : OrderedType)(R : OrderedType) : BIDIR + with type left = L.t and type right = R.t From 9f04b4a0d7bd09145648d8f8c66a3ef04db04a89 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 5 Aug 2014 11:20:30 +0200 Subject: [PATCH 30/30] doc --- core/CCMultiMap.mli | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/core/CCMultiMap.mli b/core/CCMultiMap.mli index 850bb93f..238eb7fb 100644 --- a/core/CCMultiMap.mli +++ b/core/CCMultiMap.mli @@ -105,7 +105,11 @@ end module Make(K : OrderedType)(V : OrderedType) : S with type key = K.t and type value = V.t -(** {2 Two-Way Multimap} *) +(** {2 Two-Way Multimap} +Represents n-to-n mappings between two types. Each element from the "left" +is mapped to several right values, and conversely. + +@since NEXT_RELEASE *) module type BIDIR = sig type t