From bf0227d4046713384aee4e454da5244fedf8c91d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 10 Dec 2019 21:38:57 -0600 Subject: [PATCH] feat: on 4.08, support let operators close #276 --- src/core/CCArray.ml | 5 ++++ src/core/CCArray.mli | 4 +++ src/core/CCArrayLabels.mli | 4 +++ src/core/CCList.ml | 6 +++++ src/core/CCList.mli | 4 +++ src/core/CCListLabels.mli | 4 +++ src/core/CCOpt.ml | 9 +++++++ src/core/CCOpt.mli | 4 +++ src/core/CCParse.ml | 6 +++++ src/core/CCParse.mli | 4 +++ src/core/CCRandom.ml | 7 +++++ src/core/CCRandom.mli | 4 +++ src/core/CCResult.ml | 9 +++++++ src/core/CCResult.mli | 4 +++ src/core/CCVector.ml | 7 +++++ src/core/CCVector.mli | 4 +++ src/core/dune | 2 +- src/core/mkshims.ml | 55 +++++++++++++++++++++++++++++++------- 18 files changed, 131 insertions(+), 11 deletions(-) diff --git a/src/core/CCArray.ml b/src/core/CCArray.ml index d05f4c2d..58de07d4 100644 --- a/src/core/CCArray.ml +++ b/src/core/CCArray.ml @@ -739,3 +739,8 @@ end ignore (module CCArray : LL) *) +include CCShimsMkLet_.Make(struct + type 'a t = 'a array + include Infix + let monoid_product a1 a2 = monoid_product (fun x y->x,y) a1 a2 + end) diff --git a/src/core/CCArray.mli b/src/core/CCArray.mli index 7b6e40f8..b2a07cb0 100644 --- a/src/core/CCArray.mli +++ b/src/core/CCArray.mli @@ -377,3 +377,7 @@ module Infix : sig (** [x --^ y] creates an array containing integers in the range [x .. y]. Right bound excluded. @since 0.17 *) end + +(** Let operators on OCaml >= 4.08.0, nothing otherwise + @since NEXT_RELEASE *) +include CCShimsMkLet_.S with type 'a t_let := 'a array diff --git a/src/core/CCArrayLabels.mli b/src/core/CCArrayLabels.mli index 91c15d99..d91fbe1f 100644 --- a/src/core/CCArrayLabels.mli +++ b/src/core/CCArrayLabels.mli @@ -378,3 +378,7 @@ module Infix : sig (** [x --^ y] creates an array containing integers in the range [x .. y]. Right bound excluded. @since 0.17 *) end + +(** Let operators on OCaml >= 4.08.0, nothing otherwise + @since NEXT_RELEASE *) +include CCShimsMkLet_.S with type 'a t_let := 'a array diff --git a/src/core/CCList.ml b/src/core/CCList.ml index 8288e2af..7f7a1200 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -1719,6 +1719,12 @@ module Infix = struct let (--^) = (--^) end +include CCShimsMkLet_.Make(struct + type 'a t = 'a list + include Infix + let monoid_product l1 l2 = product (fun x y -> x,y) l1 l2 + end) + (** {2 IO} *) let pp ?(start="") ?(stop="") ?(sep=", ") pp_item fmt l = diff --git a/src/core/CCList.mli b/src/core/CCList.mli index b93daa6d..08b48c1d 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -743,6 +743,10 @@ module Infix : sig (** @since 0.17 *) end +(** Let operators on OCaml >= 4.08.0, nothing otherwise + @since NEXT_RELEASE *) +include CCShimsMkLet_.S with type 'a t_let := 'a list + (** {2 IO} *) val pp : ?start:string -> ?stop:string -> ?sep:string -> diff --git a/src/core/CCListLabels.mli b/src/core/CCListLabels.mli index de89d3a2..23c538a7 100644 --- a/src/core/CCListLabels.mli +++ b/src/core/CCListLabels.mli @@ -741,6 +741,10 @@ module Infix : sig (** @since 0.17 *) end +(** Let operators on OCaml >= 4.08.0, nothing otherwise + @since NEXT_RELEASE *) +include CCShimsMkLet_.S with type 'a t_let := 'a list + (** {2 IO} *) val pp : ?start:string -> ?stop:string -> ?sep:string -> diff --git a/src/core/CCOpt.ml b/src/core/CCOpt.ml index ed379270..d307b6d9 100644 --- a/src/core/CCOpt.ml +++ b/src/core/CCOpt.ml @@ -105,6 +105,7 @@ let fold f acc o = match o with let get_or ~default x = match x with | None -> default | Some y -> y + let value x ~default = match x with | None -> default | Some y -> y @@ -237,3 +238,11 @@ let return_if b x = return_if false 1 = None return_if true 1 = Some 1 *) + +include CCShimsMkLet_.Make(struct + type 'a t = 'a option + include Infix + let monoid_product o1 o2 = match o1, o2 with + | Some x, Some y -> Some (x,y) + | _ -> None + end) diff --git a/src/core/CCOpt.mli b/src/core/CCOpt.mli index de0f1b93..c7fbd0b7 100644 --- a/src/core/CCOpt.mli +++ b/src/core/CCOpt.mli @@ -199,3 +199,7 @@ val to_seq : 'a t -> 'a sequence @deprecated use {!to_iter} instead *) val pp : 'a printer -> 'a t printer + +(** Let operators on OCaml >= 4.08.0, nothing otherwise + @since NEXT_RELEASE *) +include CCShimsMkLet_.S with type 'a t_let := 'a option diff --git a/src/core/CCParse.ml b/src/core/CCParse.ml index a18b425e..027dd46a 100644 --- a/src/core/CCParse.ml +++ b/src/core/CCParse.ml @@ -527,3 +527,9 @@ module U = struct p3 >>= fun x3 -> string stop *> return (x1,x2,x3) end + +include CCShimsMkLet_.Make(struct + type nonrec 'a t = 'a t + include Infix + let monoid_product a1 a2 = pure (fun x y ->x,y) <*> a1 <*> a2 + end) diff --git a/src/core/CCParse.mli b/src/core/CCParse.mli index 1aa787ee..78eefb9e 100644 --- a/src/core/CCParse.mli +++ b/src/core/CCParse.mli @@ -323,3 +323,7 @@ module U : sig (** Parse a triple using OCaml whitespace conventions. The default is "(a, b, c)". *) end + +(** Let operators on OCaml >= 4.08.0, nothing otherwise + @since NEXT_RELEASE *) +include CCShimsMkLet_.S with type 'a t_let := 'a t diff --git a/src/core/CCRandom.ml b/src/core/CCRandom.ml index 090431d8..b655bb62 100644 --- a/src/core/CCRandom.ml +++ b/src/core/CCRandom.ml @@ -201,6 +201,13 @@ let pure x _st = x let (<*>) f g st = f st (g st) +include CCShimsMkLet_.Make(struct + type nonrec 'a t = 'a t + let (>>=) = (>>=) + let (>|=) = (>|=) + let monoid_product a1 a2 st = a1 st, a2 st + end) + let __default_state = Random.State.make_self_init () let run ?(st=__default_state) g = g st diff --git a/src/core/CCRandom.mli b/src/core/CCRandom.mli index e609aa46..9b1247f8 100644 --- a/src/core/CCRandom.mli +++ b/src/core/CCRandom.mli @@ -158,6 +158,10 @@ val pure : 'a -> 'a t val (<*>) : ('a -> 'b) t -> 'a t -> 'b t +(** Let operators on OCaml >= 4.08.0, nothing otherwise + @since NEXT_RELEASE *) +include CCShimsMkLet_.S with type 'a t_let := 'a t + (** {4 Run a generator} *) val run : ?st:state -> 'a t -> 'a diff --git a/src/core/CCResult.ml b/src/core/CCResult.ml index 040ea008..45f9fd9d 100644 --- a/src/core/CCResult.ml +++ b/src/core/CCResult.ml @@ -338,3 +338,12 @@ let pp pp_x fmt e = match e with let pp' pp_x pp_e fmt e = match e with | Ok x -> Format.fprintf fmt "@[ok(@,%a)@]" pp_x x | Error s -> Format.fprintf fmt "@[error(@,%a)@]" pp_e s + +include CCShimsMkLet_.Make2(struct + type ('a,'e) t = ('a,'e) result + include Infix + let monoid_product x1 x2 = match x1, x2 with + | Ok x, Ok y -> Ok (x,y) + | Error e, _ -> Error e + | _, Error e -> Error e + end) diff --git a/src/core/CCResult.mli b/src/core/CCResult.mli index ddf622f7..28e76b7b 100644 --- a/src/core/CCResult.mli +++ b/src/core/CCResult.mli @@ -253,3 +253,7 @@ val pp : 'a printer -> ('a, string) t printer val pp': 'a printer -> 'e printer -> ('a, 'e) t printer (** Printer that is generic on the error type. *) + +(** Let operators on OCaml >= 4.08.0, nothing otherwise + @since NEXT_RELEASE *) +include CCShimsMkLet_.S2 with type ('a,'e) t_let2 := ('a,'e) result diff --git a/src/core/CCVector.ml b/src/core/CCVector.ml index 90ff1d24..04ed2895 100644 --- a/src/core/CCVector.ml +++ b/src/core/CCVector.ml @@ -1053,3 +1053,10 @@ let pp ?(start="") ?(stop="") ?(sep=", ") pp_item fmt v = pp_item fmt x ) v; Format.pp_print_string fmt stop + +include CCShimsMkLet_.Make2(struct + type nonrec ('a,'e) t = ('a,'e) t + let (>|=) = (>|=) + let (>>=) = (>>=) + let monoid_product a1 a2 = monoid_product (fun x y->x,y) a1 a2 + end) diff --git a/src/core/CCVector.mli b/src/core/CCVector.mli index 5fb86181..a044d3e2 100644 --- a/src/core/CCVector.mli +++ b/src/core/CCVector.mli @@ -311,3 +311,7 @@ val to_string : val pp : ?start:string -> ?stop:string -> ?sep:string -> 'a printer -> ('a,_) t printer + +(** Let operators on OCaml >= 4.08.0, nothing otherwise + @since NEXT_RELEASE *) +include CCShimsMkLet_.S2 with type ('a,'e) t_let2 := ('a,'e) t diff --git a/src/core/dune b/src/core/dune index 62ee34f0..c0de73dc 100644 --- a/src/core/dune +++ b/src/core/dune @@ -6,7 +6,7 @@ (rule (targets CCShims_.ml CCShimsList_.ml CCShimsFun_.ml CCShimsFun_.mli - CCShimsArray_.ml CCShimsFormat_.ml) + CCShimsArray_.ml CCShimsFormat_.ml CCShimsMkLet_.ml) (deps ./mkshims.exe) (action (run ./mkshims.exe))) diff --git a/src/core/mkshims.ml b/src/core/mkshims.ml index df1461ae..7c38512c 100644 --- a/src/core/mkshims.ml +++ b/src/core/mkshims.ml @@ -81,20 +81,54 @@ let shims_array_pre_408 = " let shims_array_post_408 = "include Array" let shims_let_op_pre_408 = - "module Make_let_applicative(X:sig end) = struct end - module Make_let_functor(X:sig end) = struct end + " + module type S = sig type 'a t_let end + module Make(X:sig type 'a t end) = struct type 'a t_let = 'a X.t end + + module type S2 = sig type ('a,'b) t_let2 end + module Make2(X:sig type ('a,'b) t end) = struct type ('a,'b) t_let2 = ('a,'b) X.t end " let shims_let_op_post_408 = - "module Make_let_applicative(X:sig - type 'a t - val (<*>) : ('a -> 'b) t -> 'a t -> 'b t - val (<*>) : ('a -> 'b) t -> 'a t -> 'b t - end) = struct - end - module Make_let_functor(X:sig + " + module type S = sig + type 'a t_let + val (let+) : 'a t_let -> ('a -> 'b) -> 'b t_let + val (and+) : 'a t_let -> 'b t_let -> ('a * 'b) t_let + val (let*) : 'a t_let -> ('a -> 'b t_let) -> 'b t_let + val (and*) : 'a t_let -> 'b t_let -> ('a * 'b) t_let + end + module Make(X:sig type 'a t + val (>|=) : 'a t -> ('a -> 'b) -> 'b t + val monoid_product : 'a t -> 'b t -> ('a * 'b) t val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - end) = struct + end) : S with type 'a t_let = 'a X.t = struct + type 'a t_let = 'a X.t + let (let+) = X.(>|=) + let (and+) = X.monoid_product + let (let*) = X.(>>=) + let (and*) = X.monoid_product + end + + module type S2 = sig + type ('a,'e) t_let2 + val (let+) : ('a,'e) t_let2 -> ('a -> 'b) -> ('b,'e) t_let2 + val (and+) : ('a,'e) t_let2 -> ('b,'e) t_let2 -> ('a * 'b, 'e) t_let2 + val (let*) : ('a,'e) t_let2 -> ('a -> ('b,'e) t_let2) -> ('b,'e) t_let2 + val (and*) : ('a,'e) t_let2 -> ('b,'e) t_let2 -> ('a * 'b,'e) t_let2 + end + + module Make2(X:sig + type ('a,'b) t + val (>|=) : ('a,'e) t -> ('a -> 'b) -> ('b,'e) t + val monoid_product : ('a,'e) t -> ('b,'e) t -> ('a * 'b, 'e) t + val (>>=) : ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t + end) : S2 with type ('a,'e) t_let2 = ('a,'e) X.t = struct + type ('a,'e) t_let2 = ('a,'e) X.t + let (let+) = X.(>|=) + let (and+) = X.monoid_product + let (let*) = X.(>>=) + let (and*) = X.monoid_product end " @@ -108,4 +142,5 @@ let () = 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); + write_file "CCShimsMkLet_.ml" (if (major, minor) >= (4,8) then shims_let_op_post_408 else shims_let_op_pre_408); )