CCIO: explicit finalizer system, to use a >>>= operator rather than callbacks.

bugfix in Seq.chunks

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
+        let res = _run a in
-        _run finalize;
+        _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 _open_in mode flags filename () =
-  let ic = open_in_gen flags 0x644 filename in
+  open_in_gen flags mode filename
-  try
+let _close_in ic () = close_in ic
-    f ic
-  with e ->
-    close_in ic;
-    raise e
 
-let with_in ?(flags=[]) filename f =
+let with_in ?(mode=0o644) ?(flags=[]) filename =
-  WrapJoin (_with_in flags filename f)
+  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 _open_out mode flags filename () =
-  let oc = open_out_gen flags 0x644 filename in
+  open_out_gen flags mode filename
-  try
+let _close_out oc () = close_out oc
-    f oc
-  with e ->
-    close_out oc;
-    raise e
 
-let with_out ?(flags=[]) filename f =
+let with_out ?(mode=0o644) ?(flags=[]) filename =
-  WrapJoin (_with_out flags filename f)
+  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} *)

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