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