Skip to content

Instantly share code, notes, and snippets.

@dbuenzli

dbuenzli/gen.ml

Last active June 11, 2022 18:13
Show Gist options
  • Star 6 You must be signed in to star a gist
  • Fork 5 You must be signed in to fork a gist
  • Save dbuenzli/74be3c9fe51e017790b5 to your computer and use it in GitHub Desktop.
Save dbuenzli/74be3c9fe51e017790b5 to your computer and use it in GitHub Desktop.
Download ZIP
OCaml simple generators
Raw
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.
---------------------------------------------------------------------------*)
Raw
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.
---------------------------------------------------------------------------*)
Raw
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.
---------------------------------------------------------------------------*)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment