Merge pull request #266 from c-cube/wip-264-improve

improve on #264

.travis.yml

@@ -15,3 +15,4 @@ env:
   - PACKAGE="containers" OCAML_VERSION="4.06" EXTRA_DEPS="base-threads base-unix"
   - PACKAGE="containers" OCAML_VERSION="4.07" EXTRA_DEPS="base-threads base-unix"
   - PACKAGE="containers" OCAML_VERSION="4.08" EXTRA_DEPS="base-threads base-unix" TESTS=false
+  - PACKAGE="containers" OCAML_VERSION="4.09" EXTRA_DEPS="base-threads base-unix" TESTS=false

qtest/make.ml

@@ -1,4 +1,3 @@
-
 let str_sub ?(offset=0) ~sub:s' s =
   let open String in
   let rec aux i =

src/core/CCFun.ml

@@ -14,19 +14,14 @@ let opaque_identity x = x
 
 include Sys
 include CCShims_.Stdlib
+include CCShimsFun_
 
 let compose f g x = g (f x)
 
 let compose_binop f g x y = g (f x) (f y)
 
-let flip f x y = f y x
-
 let curry f x y = f (x,y)
 
-let id x = x
-
-let const x _ = x
-
 let uncurry f (x,y) = f x y
 
 let tap f x = ignore (f x); x

src/core/CCFun.mli

@@ -3,6 +3,8 @@
 
 (** {1 Basic Functions} *)
 
+include module type of CCShimsFun_
+
 val (|>) : 'a -> ('a -> 'b) -> 'b
 (** A 'pipe' operator. [x |> f] is the same as [f x]. *)
 
@@ -22,16 +24,6 @@ val (@@) : ('a -> 'b) -> 'a -> 'b
 (** [f @@ x] is the same as [f x], but right-associative.
     @since 0.5 *)
 
-val id : 'a -> 'a
-(** Identity function. *)
-
-val const : 'a -> 'b -> 'a
-(** Produce a function that just returns its first argument.
-    [const x y = x] for any [y]. *)
-
-val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c
-(** Reverse the order of arguments for a binary function. *)
-
 val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c
 (** Convert a function which accepts a pair of arguments into a function which accepts two arguments.
     [curry f x y] is [f (x,y)]. *)
@@ -58,16 +50,22 @@ val lexicographic : ('a -> 'a -> int) -> ('a -> 'a -> int) -> 'a -> 'a -> int
 val finally : h:(unit -> _) -> f:(unit -> 'a) -> 'a
 (** [finally h f] calls [f ()] and returns its result. If it raises, the
     same exception is raised; in {b any} case, [h ()] is called after
-    [f ()] terminates. *)
+    [f ()] terminates.
+    If [h ()] raises an exception, then this exception will be passed on and
+    any exception that may have been raised by [f ()] is lost. *)
 
 val finally1 : h:(unit -> _) -> ('a -> 'b) -> 'a -> 'b
 (** [finally1 ~h f x] is the same as [f x], but after the computation,
     [h ()] is called whether [f x] rose an exception or not.
+    If [h ()] raises an exception, then this exception will be passed on and
+    any exception that may have been raised by [f ()] is lost.
     @since 0.16 *)
 
 val finally2 : h:(unit -> _) -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c
 (** [finally2 ~h f x y] is the same as [f x y], but after the computation,
     [h ()] is called whether [f x y] rose an exception or not.
+    If [h ()] raises an exception, then this exception will be passed on and
+    any exception that may have been raised by [f ()] is lost.
     @since 0.16 *)
 
 val opaque_identity : 'a -> 'a

src/core/dune

@@ -30,7 +30,7 @@
   (libraries dune.configurator))
 
 (rule
-  (targets CCShims_.ml CCShimsList_.ml CCShimsArray_.ml CCShimsFormat_.ml)
+  (targets CCShims_.ml CCShimsList_.ml CCShimsFun_.ml CCShimsFun_.mli CCShimsArray_.ml CCShimsFormat_.ml)
   (deps ./mkshims.exe)
   (action (run ./mkshims.exe)))
 

src/core/mkshims.ml

@@ -1,6 +1,9 @@
-
 module C = Configurator.V1
 
+let write_file f s =
+  let out = open_out f in
+  output_string out s; flush out; close_out out
+
 let shims_pre_407 = "module Stdlib = Pervasives"
 
 let shims_post_407 = "module Stdlib = Stdlib"
@@ -35,6 +38,36 @@ let cc_update_funs funs f1 f2 =
   }
 "
 
+let shims_fun_pre_408 = "
+  external id : 'a -> 'a = \"%identity\"
+  let flip f x y = f y x
+  let const x _ = x
+  let negate f x = not (f x)
+  let protect ~finally f =
+    try
+      let x= f() in
+      finally();
+      x
+    with e ->
+      finally();
+      raise e
+
+"
+let shims_fun_mli_pre_408 = "
+  (** This is an API imitating the new standard Fun module *)
+  external id : 'a -> 'a = \"%identity\"
+  val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c
+  val const : 'a -> _ -> 'a
+  val negate : ('a -> bool) -> 'a -> bool
+
+  val protect : finally:(unit -> unit) -> (unit -> 'a) -> 'a
+  (* this doesn't have the exact same semantics as the stdlib's finally.
+      It will not attempt to catch exceptions raised from [finally] at all. *)
+"
+
+let shims_fun_post_408 = "include Fun"
+let shims_fun_mli_post_408 = "include module type of Fun"
+
 let shims_list_pre_408 = "
   include List
   type +'a t = 'a list
@@ -47,10 +80,6 @@ let shims_array_pre_408 = "
 "
 let shims_array_post_408 = "include Array"
 
-let write_file f s =
-  let out = open_out f in
-  output_string out s; flush out; close_out out
-
 let () =
   C.main ~name:"mkshims" (fun c ->
     let version = C.ocaml_config_var_exn c "version" in
@@ -59,4 +88,6 @@ let () =
     write_file "CCShimsList_.ml" (if (major, minor) >= (4,8) then shims_list_post_408 else shims_list_pre_408);
     write_file "CCShimsArray_.ml" (if (major, minor) >= (4,8) then shims_array_post_408 else shims_array_pre_408);
     write_file "CCShimsFormat_.ml" (if (major, minor) >= (4,8) then shims_fmt_post_408 else shims_fmt_pre_408);
+    write_file "CCShimsFun_.ml" (if (major, minor) >= (4,8) then shims_fun_post_408 else shims_fun_pre_408);
+    write_file "CCShimsFun_.mli" (if (major, minor) >= (4,8) then shims_fun_mli_post_408 else shims_fun_mli_pre_408);
   )