diff --git a/.travis.yml b/.travis.yml index b58c7e6d..bddbcf1f 100644 --- a/.travis.yml +++ b/.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 diff --git a/qtest/make.ml b/qtest/make.ml index 9398769c..715234ff 100644 --- a/qtest/make.ml +++ b/qtest/make.ml @@ -1,4 +1,3 @@ - let str_sub ?(offset=0) ~sub:s' s = let open String in let rec aux i = diff --git a/src/core/CCFun.ml b/src/core/CCFun.ml index 0796dee4..df7230e4 100644 --- a/src/core/CCFun.ml +++ b/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 diff --git a/src/core/CCFun.mli b/src/core/CCFun.mli index 2bdc77ef..e5f72f69 100644 --- a/src/core/CCFun.mli +++ b/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 diff --git a/src/core/dune b/src/core/dune index 4ed1429d..08d84df2 100644 --- a/src/core/dune +++ b/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))) diff --git a/src/core/mkshims.ml b/src/core/mkshims.ml index 3aee1744..2a5e19cd 100644 --- a/src/core/mkshims.ml +++ b/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); )