OCaml simple generators

gen.ml

(*---------------------------------------------------------------------------
   Copyright (c) 2015 Daniel C. Bünzli. All rights reserved.
   Distributed under the BSD3 license, see license at the end of the file.
   %%NAME%% release %%VERSION%%
  ---------------------------------------------------------------------------*)

(* Simple generators according to:

   Kiselyov, Peyton-Jones, Sabry
   Lazy v. Yield: Incremental, Linear Pretty-printing
   Springer's LNCS 7705, pp. 190-206
   http://okmij.org/ftp/continuations/PPYield/

   But with type checked composition. *)

module G : sig
  type ('a, 'b) gen = 'a consumer -> 'b
  and 'a consumer = 'a -> unit
  type 'a producer = ('a, unit) gen
  type ('a, 'b) transducer = 'a producer -> 'b producer

  val yield : 'a consumer -> 'a -> unit
  val iter : 'a consumer -> 'a producer -> unit
  val map : ('a -> 'b) -> ('a, 'b) transducer
  val fold : ('a -> 'b -> 'a) -> 'a -> 'b producer -> (unit -> 'a)
end = struct
  type ('a, 'b) gen = 'a consumer -> 'b
  and 'a consumer = 'a -> unit
  type 'a producer = ('a, unit) gen
  type ('a, 'b) transducer = 'a producer -> 'b producer

  let yield k v = k v
  let iter konsumer producer = producer konsumer
  let map f gen = fun k -> iter (fun x -> yield k (f x)) gen
  let fold f acc producer = fun () ->
    let acc = ref acc in
    iter (fun v -> acc := f !acc v) producer;
    !acc
end

module P : sig
  val lines_of_file : string -> string G.producer
  val chars_of_file : string -> char G.producer
end = struct
  let close_in ic = Printf.printf "trace: closing!%!\n"; close_in ic

  let with_inf fname loop =
    let ic = open_in fname in
    let v = try loop ic with e -> close_in ic; raise e in
    close_in ic; v

  let lines_of_file fname = fun k ->
    let rec loop ic =
      match (try Some (input_line ic) with End_of_file -> None) with
      | None -> ()
      | Some line -> G.yield k line; loop ic
    in
    with_inf fname loop

  let chars_of_file fname = fun k ->
    let rec loop ic =
      match (try Some (input_char ic) with End_of_file -> None) with
      | None -> ()
      | Some c -> G.yield k c; loop ic
    in
    with_inf fname loop
end

module C : sig
  val output_char : char -> unit
  val output_line : string -> unit
end = struct
  let output_char = print_char
  let output_line = print_endline
end

let test_file = "/tmp/testf.txt"

let make_test =
  let h = open_out test_file in
  output_string h "2\n3\n5\n7\n11\n13\nINVALID";
  close_out h;
  Printf.printf "\nWrote test file %s\n" test_file

let lines_of_char : (char, string) G.transducer = fun gen k ->
  let tr b = function
  | '\n' ->
      Printf.printf "trace: line %S\n%!" (Buffer.contents b);
      G.yield k (Buffer.contents b); Buffer.clear b; b
  | c -> Buffer.add_char b c; b
  in
  let eog = function
  | b when Buffer.length b = 0 -> ()
  | b -> G.yield k (Buffer.contents b); ()
  in
  eog (G.fold tr (Buffer.create 80) gen ())

let cat fname = G.iter C.output_char (P.chars_of_file fname)
let cat_lines fname =
  G.iter C.output_line (lines_of_char (P.chars_of_file fname))

exception Exists
let exists gen =
  try G.iter (fun v -> if v then raise Exists else ()) gen; false
  with Exists -> true

let any pred gen = exists (G.map (fun v -> (pred v)) gen)

let t2_gen () =
  any (function x -> x > 3)
    (G.map int_of_string (lines_of_char (P.chars_of_file test_file)))

let () =
  Printf.printf "\nCat by chars\n"; cat test_file;
  Printf.printf "\nCat by lines\n"; cat_lines test_file;
  assert (t2_gen ());
  ()

(*---------------------------------------------------------------------------
   Copyright (c) 2015 Daniel C. Bünzli.
   All rights reserved.

   Redistribution and use in source and binary forms, with or without
   modification, are permitted provided that the following conditions
   are met:

   1. Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

   2. 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.

   3. Neither the name of Daniel C. Bünzli nor the names of
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

   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
   OWNER 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.
  ---------------------------------------------------------------------------*)

gen_exn.ml

(*---------------------------------------------------------------------------
   Copyright (c) 2015 Daniel C. Bünzli. All rights reserved.
   Distributed under the BSD3 license, see license at the end of the file.
   %%NAME%% release %%VERSION%%
  ---------------------------------------------------------------------------*)

(* Simple generators according to:

   Kiselyov, Peyton-Jones, Sabry
   Lazy v. Yield: Incremental, Linear Pretty-printing
   Springer's LNCS 7705, pp. 190-206
   http://okmij.org/ftp/continuations/PPYield/

   Rewrite of http://okmij.org/ftp/continuations/PPYield/simple_gen.ml
   Composition is not statically type checked. *)

module G : sig
  type 'a gen = unit -> 'a
  type producer = unit gen
  type consumer = exn -> unit
  type 'a transducer = 'a gen -> 'a gen

  val yield : exn -> unit
  val iter : consumer -> producer -> unit
  val map : (exn -> exn) -> unit transducer
  val fold : ('a -> exn -> 'a) -> 'a -> producer -> 'a gen
end = struct
  type 'a gen = unit -> 'a
  type producer = unit gen
  type consumer = exn -> unit
  type 'a transducer = 'a gen -> 'a gen

  let yield_handler = ref (fun _ -> invalid_arg "no yield handler")
  let yield v = !yield_handler v

  let iter consumer producer =
    let old_handler = !yield_handler in
    let rec new_handler v =
      try
        yield_handler := old_handler;
        consumer v;
        yield_handler := new_handler;
      with
      | e -> yield_handler := new_handler; raise e
    in
    try
      yield_handler := new_handler;
      let v = producer () in
      yield_handler := old_handler;
      v
    with
    | e -> yield_handler := old_handler; raise e

  let map f gen = fun () -> iter (fun x -> yield (f x)) gen

  let fold f acc producer = fun () ->
    let acc = ref acc in
    iter (fun v -> acc := f !acc v) producer;
    !acc
end

module P : sig
  exception Eline of string
  val lines_of_file : string -> unit G.gen

  exception Echar of char
  val chars_of_file : string -> unit G.gen
end = struct
  let close_in ic = Printf.printf "trace: closing!%!\n"; close_in ic

  let with_inf fname loop =
    let ic = open_in fname in
    let v = try loop ic with e -> close_in ic; raise e in
    close_in ic; v

  exception Eline of string
  let lines_of_file fname = fun () ->
    let rec loop ic =
      match (try Some (input_line ic) with End_of_file -> None) with
      | None -> ()
      | Some line -> G.yield (Eline line); loop ic
    in
    with_inf fname loop

  exception Echar of char
  let chars_of_file fname = fun () ->
    let rec loop ic =
      match (try Some (input_char ic) with End_of_file -> None) with
      | None -> ()
      | Some c -> G.yield (Echar c); loop ic
    in
    with_inf fname loop
end

module C : sig
  val output_char : exn -> unit
  val output_line : exn -> unit
end = struct
  let output_char = function
  | P.Echar c -> print_char c
  | e -> raise e

  let output_line = function
  | P.Eline l -> print_endline l
  | e -> raise e
end

let test_file = "/tmp/testf.txt"

let make_test =
  let h = open_out test_file in
  output_string h "2\n3\n5\n7\n11\n13\nINVALID";
  close_out h;
  Printf.printf "\nWrote test file %s\n" test_file

let lines_of_char : unit G.transducer = fun gen () ->
  let tr b = function
  | P.Echar '\n' ->
      Printf.printf "trace: line %S\n%!" (Buffer.contents b);
      G.yield (P.Eline (Buffer.contents b)); Buffer.clear b; b
  | P.Echar c -> Buffer.add_char b c; b
  | e -> raise e
  in
  let eog = function
  | b when Buffer.length b = 0 -> ()
  | b -> G.yield (P.Eline (Buffer.contents b)); ()
  in
  eog (G.fold tr (Buffer.create 80) gen ())

let cat fname = G.iter C.output_char (P.chars_of_file fname)
let cat_lines fname =
  G.iter C.output_line (lines_of_char (P.chars_of_file fname))

exception Ebool of bool
exception Exists

let exists gen =
  let is_true = function
  | Ebool true -> raise Exists
  | Ebool false -> ()
  | e -> raise e
  in
  try G.iter is_true gen; false with Exists -> true

let any pred gen = exists (G.map (fun v -> Ebool (pred v)) gen)

exception Eint of int

let t2_gen () =
  any (function Eint x -> x > 3 | e -> raise e)
    (G.map (function P.Eline s -> Eint (int_of_string s) | e -> raise e)
        (lines_of_char (P.chars_of_file test_file)))

let () =
  Printf.printf "\nCat by chars\n"; cat test_file;
  Printf.printf "\nCat by lines\n"; cat_lines test_file;
  assert (t2_gen ());
  ()



(*---------------------------------------------------------------------------
   Copyright (c) 2015 Daniel C. Bünzli.
   All rights reserved.

   Redistribution and use in source and binary forms, with or without
   modification, are permitted provided that the following conditions
   are met:

   1. Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

   2. 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.

   3. Neither the name of Daniel C. Bünzli nor the names of
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

   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
   OWNER 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.
  ---------------------------------------------------------------------------*)

sgen.ml

(* Simple generators according to:

   Kiselyov, Peyton-Jones, Sabry
   Lazy v. Yield: Incremental, Linear Pretty-printing
   Springer's LNCS 7705, pp. 190-206
   http://okmij.org/ftp/continuations/PPYield/

   But with type checked composition.

   This one also gets rid of producer as a generator returning
   unit. This was propagating in all the combinators in a bad
   way. Producers may want to return errors rather than unit.

   Removing the transducer abbreviation, which is less readable
   than its expansion. *)

module G : sig
  type 'a consumer = 'a -> unit
  type ('a, 'b) gen = 'a consumer -> 'b

  val iter : 'a consumer -> ('a, 'b) gen -> 'b
  val map : ('a -> 'b) -> ('a, 'c) gen -> ('b, 'c) gen
  val fold : ('a -> 'b -> 'a) -> 'a -> ('b, 'c) gen -> ('a, 'c) gen
end = struct
  type 'a consumer = 'a -> unit
  type ('a, 'b) gen = 'a consumer -> 'b

  let iter yield g = g yield
  let map f g = fun yield -> iter (fun x -> yield (f x)) g
  let fold f acc g = fun yield ->
    let acc = ref acc in
    let v = iter (fun v -> acc := f !acc v) g in
    yield !acc; v
end

module P : sig
  val lines_of_file : string -> (string, unit) G.gen
  val chars_of_file : string -> (char, unit) G.gen
end = struct
  let close_in ic = Printf.printf "trace: closing!%!\n"; close_in ic

  let with_inf fname loop =
    let ic = open_in fname in
    let v = try loop ic with e -> close_in ic; raise e in
    close_in ic; v

  let lines_of_file fname = fun yield ->
    let rec loop ic =
      match (try Some (input_line ic) with End_of_file -> None) with
      | None -> ()
      | Some line -> yield line; loop ic
    in
    with_inf fname loop

  let chars_of_file fname = fun yield ->
    let rec loop ic =
      match (try Some (input_char ic) with End_of_file -> None) with
      | None -> ()
      | Some c -> yield c; loop ic
    in
    with_inf fname loop
end

module C : sig
  val output_char : char -> unit
  val output_line : string -> unit
end = struct
  let output_char = print_char
  let output_line = print_endline
end

let test_file = "/tmp/testf.txt"

let make_test =
  let h = open_out test_file in
  output_string h "2\n3\n5\n7\n11\n13\nINVALID";
  close_out h;
  Printf.printf "\nWrote test file %s\n" test_file

let lines_of_char : (char, unit) G.gen -> (string, unit) G.gen =
  fun gen yield ->
    let tr b = function
    | '\n' ->
        Printf.printf "trace: line %S\n%!" (Buffer.contents b);
      yield (Buffer.contents b); Buffer.clear b; b
    | c -> Buffer.add_char b c; b
    in
    let eog = function
    | b when Buffer.length b = 0 -> ()
    | b -> yield (Buffer.contents b); ()
    in
    G.iter eog (G.fold tr (Buffer.create 80) gen)

let cat fname = G.iter C.output_char (P.chars_of_file fname)
let cat_lines fname =
  G.iter C.output_line (lines_of_char (P.chars_of_file fname))

exception Exists
let exists gen =
  try G.iter (fun v -> if v then raise Exists else ()) gen; false
  with Exists -> true

let any pred gen = exists (G.map (fun v -> (pred v)) gen)

let t2_gen () =
  any (function x -> x > 3)
    (G.map int_of_string (lines_of_char (P.chars_of_file test_file)))

let () =
  Printf.printf "\nCat by chars\n"; cat test_file;
  Printf.printf "\nCat by lines\n"; cat_lines test_file;
  assert (t2_gen ());
  ()

(*---------------------------------------------------------------------------
   Copyright (c) 2015 Daniel C. Bünzli.
   All rights reserved.

   Redistribution and use in source and binary forms, with or without
   modification, are permitted provided that the following conditions
   are met:

   1. Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

   2. 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.

   3. Neither the name of Daniel C. Bünzli nor the names of
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

   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
   OWNER 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.
  ---------------------------------------------------------------------------*)