unikernel/duniverse/fmt/src/tty/dune

@@ -0,0 +1,8 @@
+(library
+ (name fmt_tty)
+ (public_name fmt.tty)
+ (optional)
+ (libraries unix fmt)
+ (modules fmt_tty)
+ (flags :standard -w -3-6-27)
+ (wrapped false))

unikernel/duniverse/fmt/src/tty/fmt_tty.ml

@@ -0,0 +1,61 @@
+(*---------------------------------------------------------------------------
+   Copyright (c) 2015 The fmt programmers. All rights reserved.
+   SPDX-License-Identifier: ISC
+  ---------------------------------------------------------------------------*)
+
+let is_infix ~affix s =
+  (* Damned, already missing astring, from which this is c&p *)
+  let len_a = String.length affix in
+  let len_s = String.length s in
+  if len_a > len_s then false else
+  let max_idx_a = len_a - 1 in
+  let max_idx_s = len_s - len_a in
+  let rec loop i k =
+    if i > max_idx_s then false else
+    if k > max_idx_a then true else
+    if k > 0 then
+      if String.get affix k = String.get s (i + k) then loop i (k + 1) else
+      loop (i + 1) 0
+    else if String.get affix 0 = String.get s i then loop i 1 else
+    loop (i + 1) 0
+  in
+  loop 0 0
+
+let setup ?style_renderer ?utf_8 oc =
+  let ppf =
+    if oc == Stdlib.stdout then Fmt.stdout else
+    if oc == Stdlib.stderr then Fmt.stderr else
+    Format.formatter_of_out_channel oc
+  in
+  let style_renderer = match style_renderer with
+  | Some r -> r
+  | None ->
+      let dumb =
+        try match Sys.getenv "TERM" with
+        | "dumb" | "" -> true
+        | _ -> false
+        with
+        Not_found -> true
+      in
+      let isatty = try Unix.(isatty (descr_of_out_channel oc)) with
+      | Unix.Unix_error _ -> false
+      in
+      if not dumb && isatty then `Ansi_tty else `None
+  in
+  let utf_8 = match utf_8 with
+  | Some b -> b
+  | None ->
+      let has_utf_8 var =
+        try is_infix ~affix:"UTF-8" (String.uppercase_ascii (Sys.getenv var))
+        with Not_found -> false
+      in
+      has_utf_8 "LANG" || has_utf_8 "LC_ALL" || has_utf_8 "LC_CTYPE"
+  in
+  Fmt.set_style_renderer ppf style_renderer;
+  Fmt.set_utf_8 ppf utf_8;
+  ppf
+
+let setup_std_outputs ?style_renderer ?utf_8 () =
+  ignore (setup ?style_renderer ?utf_8 stdout);
+  ignore (setup ?style_renderer ?utf_8 stderr);
+  ()

unikernel/duniverse/fmt/src/tty/fmt_tty.mli

@@ -0,0 +1,33 @@
+(*---------------------------------------------------------------------------
+   Copyright (c) 2015 The fmt programmers. All rights reserved.
+   SPDX-License-Identifier: ISC
+  ---------------------------------------------------------------------------*)
+
+(** [Fmt] TTY setup.
+
+    [Fmt_tty] provides simple automatic setup on channel formatters for:
+    {ul
+    {- {!Fmt.set_style_renderer}. [`Ansi_tty] is used if the channel
+       {{!Unix.isatty}is a tty} and the environment variable
+       [TERM] is defined and its value is not ["dumb"]. [`None] is
+       used otherwise.}
+    {- {!Fmt.set_utf_8}. [true] is used if one of the following
+       environment variables has ["UTF-8"] as a case insensitive
+       substring: [LANG], [LC_ALL], [LC_CTYPE].}} *)
+
+(** {1:tty_setup TTY setup} *)
+
+val setup : ?style_renderer:Fmt.style_renderer -> ?utf_8:bool ->
+  out_channel -> Format.formatter
+(** [setup ?style_renderer ?utf_8 outc] is a formatter for [outc] with
+    {!Fmt.set_style_renderer} and {!Fmt.set_utf_8} correctly setup. If
+    [style_renderer] or [utf_8] are specified they override the automatic
+    setup.
+
+    If [outc] is {!stdout}, {!Fmt.stdout} is returned. If [outc] is
+    {!stderr}, {!Fmt.stderr} is returned. *)
+
+val setup_std_outputs : ?style_renderer:Fmt.style_renderer -> ?utf_8:bool ->
+  unit -> unit
+(** [setup_std_outputs ?style_renderer ?utf_8 ()] applies {!setup}
+    on {!stdout} and {!stderr}. *)

unikernel/duniverse/fmt/src/tty/fmt_tty.mllib

@@ -0,0 +1 @@
+Fmt_tty