diff --git a/qtest/make.ml b/qtest/make.ml index 0f695470..5c63c9d3 100644 --- a/qtest/make.ml +++ b/qtest/make.ml @@ -22,10 +22,7 @@ let do_not_test file = is_suffix ~sub:".pp.mli" file || is_suffix ~sub:"containers.ml" file || is_suffix ~sub:"_top.ml" file || - is_suffix ~sub:"mkflags.ml" file || - is_suffix ~sub:"mkshims.ml" file || is_suffix ~sub:"cpp.ml" file || - is_suffix ~sub:"unlabel.ml" file || is_suffix ~sub:"check_labelled_mods.ml" file || is_suffix ~sub:"test_random.ml" file || is_suffix ~sub:"test_hash.ml" file || diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index 192a9597..18783909 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -362,18 +362,45 @@ let mark_close_tag st ~or_else s = if !color_enabled then string_of_style_list style else "" | exception No_such_style -> or_else s +[@@@ifge 4.8] + + +let pp_open_tag out s = pp_open_stag out (String_tag s) +let pp_close_tag out () = pp_close_stag out () + +[@@@ocaml.warning "-3"] +let pp_get_formatter_tag_functions = pp_get_formatter_tag_functions +let pp_set_formatter_tag_functions = pp_set_formatter_tag_functions + +let update_tag_funs_ funs f1 f2 = + { funs with + mark_open_tag = f1 ~or_else:funs.mark_open_tag; + mark_close_tag = f2 ~or_else:funs.mark_close_tag; + } + +[@@@ocaml.warning "+3"] + +[@@@else_] + +let update_tag_funs_ funs f1 f2 = + { funs with + mark_open_tag = f1 funs.mark_open_tag; + mark_close_tag = f2 funs.mark_close_tag; + } + +[@@@endif] + (* add color handling to formatter [ppf] *) let set_color_tag_handling ppf = - let open Format in - let functions = CCShimsFormat_.pp_get_formatter_tag_functions ppf () in + let functions = pp_get_formatter_tag_functions ppf () in let st = Stack.create () in (* stack of styles *) let functions' = - CCShimsFormat_.cc_update_funs functions + update_tag_funs_ functions (mark_open_tag st) (mark_close_tag st) in pp_set_mark_tags ppf true; (* enable tags *) - CCShimsFormat_.pp_set_formatter_tag_functions ppf functions' + pp_set_formatter_tag_functions ppf functions' let set_color_default = let first = ref true in @@ -398,14 +425,14 @@ let set_color_default = *) let with_color s pp out x = - CCShimsFormat_.pp_open_tag out s; + pp_open_tag out s; pp out x; - CCShimsFormat_.pp_close_tag out () + pp_close_tag out () let with_colorf s out fmt = - CCShimsFormat_.pp_open_tag out s; + pp_open_tag out s; Format.kfprintf - (fun out -> CCShimsFormat_.pp_close_tag out ()) + (fun out -> pp_close_tag out ()) out fmt (* c: whether colors are enabled *) @@ -422,10 +449,10 @@ let with_color_ksf ~f s fmt = let buf = Buffer.create 64 in let out = Format.formatter_of_buffer buf in if !color_enabled then set_color_tag_handling out; - CCShimsFormat_.pp_open_tag out s; + pp_open_tag out s; Format.kfprintf (fun out -> - CCShimsFormat_.pp_close_tag out (); + pp_close_tag out (); Format.pp_print_flush out (); f (Buffer.contents buf)) out fmt diff --git a/src/core/dune b/src/core/dune index 6b86380d..8d7c1a4e 100644 --- a/src/core/dune +++ b/src/core/dune @@ -1,20 +1,8 @@ -(executable - (name mkshims) - (modules mkshims) - (libraries dune.configurator)) - -(rule - (targets CCShimsFormat_.ml) - (deps ./mkshims.exe) - (action - (run ./mkshims.exe))) - (library (name containers) (public_name containers) (wrapped false) - (modules :standard \ mkshims) (modules_without_implementation CCShims_syntax) (preprocess (action (run %{project_root}/src/core/cpp/cpp.exe %{input-file}))) (flags :standard -warn-error -a+8 -w -32-70 -safe-string diff --git a/src/core/mkshims.ml b/src/core/mkshims.ml deleted file mode 100644 index 9e2c4330..00000000 --- a/src/core/mkshims.ml +++ /dev/null @@ -1,102 +0,0 @@ -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_fmt_pre_408 = " -include Format -let cc_update_funs funs f1 f2 = - let open Format in - { - funs with - mark_open_tag = f1 funs.mark_open_tag; - mark_close_tag = f2 funs.mark_close_tag; - } - -" -let shims_fmt_post_408 = " -open Format - -[@@@ocaml.warning \"-3\"] - -let pp_open_tag = pp_open_tag -let pp_close_tag = pp_close_tag -let pp_get_formatter_tag_functions = pp_get_formatter_tag_functions -let pp_set_formatter_tag_functions = pp_set_formatter_tag_functions - -let cc_update_funs funs f1 f2 = - let open Format in - { - funs with - mark_open_tag = f1 ~or_else:funs.mark_open_tag; - mark_close_tag = f2 ~or_else:funs.mark_close_tag; - } -" - -let shims_let_op_pre_408 = - " - (** glue code for let-operators on OCaml < 4.08 (auto generated) *) - 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 = - " (** glue code for let-operators on OCaml >= 4.08 (auto generated) *) - 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) : 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[@@inline] - - 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[@@inline] -" - -let shims_let_op_list_pre_408 = - " - (** glue code for let-operators on OCaml < 4.08 (auto generated) *) - module type S = sig end - module Make(X:sig end) = struct end -" - -let () = - C.main ~name:"mkshims" (fun c -> - let version = C.ocaml_config_var_exn c "version" in - let major, minor = Scanf.sscanf version "%u.%u" (fun maj min -> maj, min) in - write_file "CCShimsFormat_.ml" (if (major, minor) >= (4,8) then shims_fmt_post_408 else shims_fmt_pre_408); - )