From e397d902797719a571862adaac7377f4d40edba7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 21 Feb 2022 22:11:51 -0500 Subject: [PATCH 1/4] wip: use Stag in Format --- src/core/CCFormat.ml | 17 +++++++++++++++-- src/core/CCFormat.mli | 11 +++++++++++ 2 files changed, 26 insertions(+), 2 deletions(-) diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index 18783909..a7a6cb5e 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -336,15 +336,23 @@ module ANSI_codes = struct | _ -> raise No_such_style end +type stag += + | Style of ANSI_codes.style list + let color_enabled = ref false +let mark_open_style st style = + Stack.push style st; + if !color_enabled then string_of_style_list style else "" + +let mark_close_style st style = + (* either prints the tag of [s] or delegate to [or_else] *) let mark_open_tag st ~or_else s = let open ANSI_codes in try let style = style_of_tag_ s in - Stack.push style st; - if !color_enabled then string_of_style_list style else "" + mark_open_style st style with No_such_style -> or_else s let mark_close_tag st ~or_else s = @@ -378,6 +386,11 @@ let update_tag_funs_ funs f1 f2 = mark_close_tag = f2 ~or_else:funs.mark_close_tag; } +let styling stl pp out x = + pp_open_stag out (Style stl); + try pp out x; pp_close_stag out () + with e -> pp_close_stag out (); raise e + [@@@ocaml.warning "+3"] [@@@else_] diff --git a/src/core/CCFormat.mli b/src/core/CCFormat.mli index dcb74c6a..fa616162 100644 --- a/src/core/CCFormat.mli +++ b/src/core/CCFormat.mli @@ -324,6 +324,17 @@ module ANSI_codes : sig is a very shiny style. *) end +[@@@ifge 4.8] + +val styling : ANSI_codes.style list -> 'a printer -> 'a printer +(** [styling st p] is the same printer as [p], except it locally sets + the style [st]. + + Available only on OCaml >= 4.08. + @since NEXT_RELEASE *) + +[@@@endif] + (** {2 IO} *) val output : t -> 'a printer -> 'a -> unit From 38552f5c0c12bb8113425b08e0b1df6693d2a869 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Mar 2022 10:06:08 -0400 Subject: [PATCH 2/4] use stag properly, add `with_styling`. all tests pass again. --- src/core/CCFormat.ml | 99 ++++++++++++++++++++++++++----------------- src/core/CCFormat.mli | 20 +++++++++ 2 files changed, 80 insertions(+), 39 deletions(-) diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index a7a6cb5e..9bc69df7 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -312,8 +312,7 @@ module ANSI_codes = struct exception No_such_style - (* parse a string tag. - TODO: use [stag], for OCaml >= 4.08… *) + (* parse a string tag. *) let style_of_tag_ s = match String.trim s with | "reset" -> [`Reset] | "black" -> [`FG `Black] @@ -343,32 +342,44 @@ let color_enabled = ref false let mark_open_style st style = Stack.push style st; - if !color_enabled then string_of_style_list style else "" + if !color_enabled then ANSI_codes.string_of_style_list style else "" -let mark_close_style st style = +let mark_close_style st : string = + let style = + try + ignore (Stack.pop st); (* pop current style (if well-scoped …) *) + Stack.top st (* look at previous style *) + with Stack.Empty -> + [`Reset] + in + if !color_enabled then ANSI_codes.string_of_style_list style else "" (* either prints the tag of [s] or delegate to [or_else] *) -let mark_open_tag st ~or_else s = - let open ANSI_codes in - try - let style = style_of_tag_ s in - mark_open_style st style - with No_such_style -> or_else s +let mark_open_tag st ~or_else (tag:stag) : string = + match tag with + | Style style -> + mark_open_style st style; + | String_tag s -> + let open ANSI_codes in + begin + try + let style = style_of_tag_ s in + mark_open_style st style + with No_such_style -> or_else tag + end + | _ -> or_else tag -let mark_close_tag st ~or_else s = - let open ANSI_codes in - (* check if it's indeed about color *) - match style_of_tag_ s with - | _ -> - let style = - try - ignore (Stack.pop st); (* pop current style (if well-scoped …) *) - Stack.top st (* look at previous style *) - with Stack.Empty -> - [`Reset] - in - if !color_enabled then string_of_style_list style else "" - | exception No_such_style -> or_else s +let mark_close_tag st ~or_else (tag:stag) : string = + match tag with + | Style _ -> mark_close_style st + | String_tag s -> + let open ANSI_codes in + (* check if it's indeed about color *) + begin match style_of_tag_ s with + | _ -> mark_close_style st + | exception No_such_style -> or_else tag + end + | _ -> or_else tag [@@@ifge 4.8] @@ -376,36 +387,33 @@ let mark_close_tag st ~or_else s = 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 = +let update_tag_funs_ (funs:formatter_stag_functions) f1 f2 = { funs with - mark_open_tag = f1 ~or_else:funs.mark_open_tag; - mark_close_tag = f2 ~or_else:funs.mark_close_tag; + mark_open_stag = f1 ~or_else:funs.mark_open_stag; + mark_close_stag = f2 ~or_else:funs.mark_close_stag; } -let styling stl pp out x = +let with_styling stl out f = pp_open_stag out (Style stl); - try pp out x; pp_close_stag out () + try let x = f() in pp_close_stag out (); x with e -> pp_close_stag out (); raise e -[@@@ocaml.warning "+3"] +let styling stl pp out x = + with_styling stl out @@ fun () -> pp out x [@@@else_] -let update_tag_funs_ funs f1 f2 = +let update_tag_funs_ (funs:formatter_stag_functions) f1 f2 = { funs with - mark_open_tag = f1 funs.mark_open_tag; - mark_close_tag = f2 funs.mark_close_tag; + mark_open_stag = f1 funs.mark_open_stag; + mark_close_stag = f2 funs.mark_close_stag; } [@@@endif] (* add color handling to formatter [ppf] *) let set_color_tag_handling ppf = - let functions = pp_get_formatter_tag_functions ppf () in + let functions = pp_get_formatter_stag_functions ppf () in let st = Stack.create () in (* stack of styles *) let functions' = update_tag_funs_ functions @@ -413,7 +421,7 @@ let set_color_tag_handling ppf = (mark_close_tag st) in pp_set_mark_tags ppf true; (* enable tags *) - pp_set_formatter_tag_functions ppf functions' + pp_set_formatter_stag_functions ppf functions' let set_color_default = let first = ref true in @@ -437,6 +445,19 @@ let set_color_default = s *) +(*$R + set_color_default true; + let s = sprintf + "what is your %a? %a! No, %a! Ahhhhhhh@." + (styling [`FG `White; `Bold] string) "favorite color" + (styling [`FG `Blue] string) "blue" + (styling [`FG `Red] string) "red" + in + assert_equal ~printer:CCFun.id + "what is your \027[37;1mfavorite color\027[0m? \027[34mblue\027[0m! No, \027[31mred\027[0m! Ahhhhhhh\n" + s +*) + let with_color s pp out x = pp_open_tag out s; pp out x; diff --git a/src/core/CCFormat.mli b/src/core/CCFormat.mli index fa616162..507e21d4 100644 --- a/src/core/CCFormat.mli +++ b/src/core/CCFormat.mli @@ -330,6 +330,26 @@ val styling : ANSI_codes.style list -> 'a printer -> 'a printer (** [styling st p] is the same printer as [p], except it locally sets the style [st]. + Example: + {[ + + open CCFormat; + set_color_default true; + sprintf + "what is your %a? %a! No, %a! Ahhhhhhh@." + (styling [`FG `White; `Bold] string) "favorite color" + (styling [`FG `Blue] string) "blue" + (styling [`FG `Red] string) "red" + ]} + + Available only on OCaml >= 4.08. + @since NEXT_RELEASE *) + +val with_styling : ANSI_codes.style list -> t -> (unit -> 'a) -> 'a +(** [with_styling style fmt f] sets the given style on [fmt], + calls [f()], then restores the previous style. + It is useful in imperative-style printers (a sequence of "print a; print b; …"). + Available only on OCaml >= 4.08. @since NEXT_RELEASE *) From 0ce613d7c42373ed2247adfd4d7896db6e388726 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Mar 2022 13:44:54 -0400 Subject: [PATCH 3/4] gate more code in the version conditional --- src/core/CCFormat.ml | 78 +++++++++++++++++++++++++++----------------- 1 file changed, 48 insertions(+), 30 deletions(-) diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index 9bc69df7..4d38beb0 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -335,9 +335,6 @@ module ANSI_codes = struct | _ -> raise No_such_style end -type stag += - | Style of ANSI_codes.style list - let color_enabled = ref false let mark_open_style st style = @@ -354,8 +351,16 @@ let mark_close_style st : string = in if !color_enabled then ANSI_codes.string_of_style_list style else "" +[@@@ifge 4.8] + +type stag += + | Style of ANSI_codes.style list + +let pp_open_tag out s = pp_open_stag out (String_tag s) +let pp_close_tag out () = pp_close_stag out () + (* either prints the tag of [s] or delegate to [or_else] *) -let mark_open_tag st ~or_else (tag:stag) : string = +let mark_open_stag st ~or_else (tag:stag) : string = match tag with | Style style -> mark_open_style st style; @@ -369,7 +374,7 @@ let mark_open_tag st ~or_else (tag:stag) : string = end | _ -> or_else tag -let mark_close_tag st ~or_else (tag:stag) : string = +let mark_close_stag st ~or_else (tag:stag) : string = match tag with | Style _ -> mark_close_style st | String_tag s -> @@ -381,18 +386,6 @@ let mark_close_tag st ~or_else (tag:stag) : string = end | _ -> or_else tag -[@@@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 () - -let update_tag_funs_ (funs:formatter_stag_functions) f1 f2 = - { funs with - mark_open_stag = f1 ~or_else:funs.mark_open_stag; - mark_close_stag = f2 ~or_else:funs.mark_close_stag; - } - let with_styling stl out f = pp_open_stag out (Style stl); try let x = f() in pp_close_stag out (); x @@ -401,27 +394,52 @@ let with_styling stl out f = let styling stl pp out x = with_styling stl out @@ fun () -> pp out x +(* add color handling to formatter [ppf] *) +let set_color_tag_handling ppf = + let st = Stack.create () in (* stack of styles *) + pp_set_mark_tags ppf true; (* enable tags *) + let funs = pp_get_formatter_stag_functions ppf () in + let funs' = { + funs with + mark_open_stag = mark_open_stag st ~or_else:funs.mark_open_stag; + mark_close_stag = mark_close_stag st ~or_else:funs.mark_close_stag; + } + in + pp_set_formatter_stag_functions ppf funs' + [@@@else_] -let update_tag_funs_ (funs:formatter_stag_functions) f1 f2 = - { funs with - mark_open_stag = f1 funs.mark_open_stag; - mark_close_stag = f2 funs.mark_close_stag; - } +(* either prints the tag of [s] or delegate to [or_else] *) +let mark_open_tag st ~or_else (s:string) : string = + let open ANSI_codes in + begin + try + let style = style_of_tag_ s in + mark_open_style st style + with No_such_style -> or_else s + end -[@@@endif] +let mark_close_tag st ~or_else (s:string) : string = + let open ANSI_codes in + (* check if it's indeed about color *) + begin match style_of_tag_ s with + | _ -> mark_close_style st + | exception No_such_style -> or_else s + end (* add color handling to formatter [ppf] *) let set_color_tag_handling ppf = - let functions = pp_get_formatter_stag_functions ppf () in let st = Stack.create () in (* stack of styles *) - let functions' = - update_tag_funs_ functions - (mark_open_tag st) - (mark_close_tag st) - in pp_set_mark_tags ppf true; (* enable tags *) - pp_set_formatter_stag_functions ppf functions' + let funs = pp_get_formatter_tag_functions ppf () in + let functions = { + funs with + mark_open_tag = mark_open_tag st ~or_else:funs.mark_open_tag; + mark_close_stag = mark_close_tag st ~or_else:funs.mark_close_tag; + } in + pp_set_formatter_stag_functions ppf functions + +[@@@endif] let set_color_default = let first = ref true in From 5a4adfa76bfab84a5168b1041a3fb50b7d308554 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 19 Mar 2022 14:13:15 -0400 Subject: [PATCH 4/4] fixes, do not run Format tests on < 4.08 --- qtest/make.ml | 1 + src/core/CCFormat.ml | 30 +++++++++++++++--------------- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/qtest/make.ml b/qtest/make.ml index 5c63c9d3..390400e5 100644 --- a/qtest/make.ml +++ b/qtest/make.ml @@ -19,6 +19,7 @@ let do_not_test file = assert (not (is_suffix ~sub:"make.ml" file)); str_sub ~sub:"Labels.ml" file || is_suffix ~sub:".pp.ml" file || + (if Sys.ocaml_version < "4.08" then Filename.basename file = "CCFormat.ml" else false) || is_suffix ~sub:".pp.mli" file || is_suffix ~sub:"containers.ml" file || is_suffix ~sub:"_top.ml" file || diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index 4d38beb0..f0547d92 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -407,6 +407,19 @@ let set_color_tag_handling ppf = in pp_set_formatter_stag_functions ppf funs' +(*$R + set_color_default true; + let s = sprintf + "what is your %a? %a! No, %a! Ahhhhhhh@." + (styling [`FG `White; `Bold] string) "favorite color" + (styling [`FG `Blue] string) "blue" + (styling [`FG `Red] string) "red" + in + assert_equal ~printer:CCFun.id + "what is your \027[37;1mfavorite color\027[0m? \027[34mblue\027[0m! No, \027[31mred\027[0m! Ahhhhhhh\n" + s +*) + [@@@else_] (* either prints the tag of [s] or delegate to [or_else] *) @@ -435,9 +448,9 @@ let set_color_tag_handling ppf = let functions = { funs with mark_open_tag = mark_open_tag st ~or_else:funs.mark_open_tag; - mark_close_stag = mark_close_tag st ~or_else:funs.mark_close_tag; + mark_close_tag = mark_close_tag st ~or_else:funs.mark_close_tag; } in - pp_set_formatter_stag_functions ppf functions + pp_set_formatter_tag_functions ppf functions [@@@endif] @@ -463,19 +476,6 @@ let set_color_default = s *) -(*$R - set_color_default true; - let s = sprintf - "what is your %a? %a! No, %a! Ahhhhhhh@." - (styling [`FG `White; `Bold] string) "favorite color" - (styling [`FG `Blue] string) "blue" - (styling [`FG `Red] string) "red" - in - assert_equal ~printer:CCFun.id - "what is your \027[37;1mfavorite color\027[0m? \027[34mblue\027[0m! No, \027[31mred\027[0m! Ahhhhhhh\n" - s -*) - let with_color s pp out x = pp_open_tag out s; pp out x;