├── .gitignore ├── .merlin ├── .ocp-indent ├── B0.ml ├── CHANGES.md ├── DEVEL.md ├── LICENSE.md ├── README.md ├── _tags ├── doc └── index.mld ├── opam ├── pkg ├── META └── pkg.ml ├── src ├── cli │ ├── fmt_cli.ml │ ├── fmt_cli.mli │ └── fmt_cli.mllib ├── fmt.ml ├── fmt.mli ├── fmt.mllib ├── top │ ├── fmt_top.ml │ ├── fmt_top.mllib │ └── fmt_tty_top_init.ml └── tty │ ├── fmt_tty.ml │ ├── fmt_tty.mli │ └── fmt_tty.mllib └── test ├── styled_perf_bug.ml └── test_fmt.ml /.gitignore: -------------------------------------------------------------------------------- 1 | BRZO 2 | _b0 3 | _build 4 | tmp 5 | *~ 6 | \.\#* 7 | \#*# 8 | *.install -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG b0.kit cmdliner 2 | S src 3 | S test 4 | B _build/** 5 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | strict_with=always,match_clause=4,strict_else=never -------------------------------------------------------------------------------- /B0.ml: -------------------------------------------------------------------------------- 1 | open B0_kit.V000 2 | open Result.Syntax 3 | 4 | (* OCaml library names *) 5 | 6 | let compiler_libs_toplevel = B0_ocaml.libname "compiler-libs.toplevel" 7 | let cmdliner = B0_ocaml.libname "cmdliner" 8 | let unix = B0_ocaml.libname "unix" 9 | 10 | let fmt = B0_ocaml.libname "fmt" 11 | let fmt_cli = B0_ocaml.libname "fmt.cli" 12 | let fmt_tty = B0_ocaml.libname "fmt.tty" 13 | let fmt_top = B0_ocaml.libname "fmt.top" 14 | 15 | (* Libraries *) 16 | 17 | let fmt_lib = 18 | B0_ocaml.lib fmt ~srcs:[`Dir ~/"src"] 19 | 20 | let fmt_cli = 21 | let srcs = [`Dir ~/"src/cli"] in 22 | B0_ocaml.lib fmt_cli ~srcs ~requires:[cmdliner; fmt] ~exports:[fmt] 23 | 24 | let fmt_tty = 25 | let srcs = [`Dir ~/"src/tty"] in 26 | B0_ocaml.lib fmt_tty ~srcs ~requires:[unix; fmt] ~exports:[fmt] 27 | 28 | let fmt_top = 29 | let srcs = [`Dir ~/"src/top"; `X ~/"src/top/fmt_tty_top_init.ml"] in 30 | B0_ocaml.lib fmt_top ~srcs ~requires:[compiler_libs_toplevel] 31 | 32 | (* Tests *) 33 | 34 | let test ?(requires = []) = B0_ocaml.test ~requires:(fmt :: requires) 35 | 36 | let test_fmt = test ~/"test/test_fmt.ml" 37 | let styled_perf_bug = 38 | test ~/"test/styled_perf_bug.ml" ~requires:[unix] ~run:false 39 | 40 | (* Packs *) 41 | 42 | let default = 43 | let meta = 44 | B0_meta.empty 45 | |> ~~ B0_meta.authors ["The fmt programmers"] 46 | |> ~~ B0_meta.maintainers 47 | ["Daniel Bünzli "] 48 | |> ~~ B0_meta.homepage "https://erratique.ch/software/fmt" 49 | |> ~~ B0_meta.online_doc "https://erratique.ch/software/fmt/doc/" 50 | |> ~~ B0_meta.licenses ["ISC"] 51 | |> ~~ B0_meta.repo "git+https://erratique.ch/repos/fmt.git" 52 | |> ~~ B0_meta.issues "https://github.com/dbuenzli/fmt/issues" 53 | |> ~~ B0_meta.description_tags 54 | ["string"; "format"; "pretty-print"; "org:erratique"] 55 | |> B0_meta.tag B0_opam.tag 56 | |> ~~ B0_opam.depopts ["base-unix", ""; "cmdliner", ""] 57 | |> ~~ B0_opam.conflicts 58 | [ "cmdliner", {|< "1.3.0"|}] 59 | |> ~~ B0_opam.depends 60 | [ "ocaml", {|>= "4.08.0"|}; 61 | "ocamlfind", {|build|}; 62 | "ocamlbuild", {|build|}; 63 | "topkg", {|build & >= "1.0.3"|}; 64 | ] 65 | |> ~~ B0_opam.build 66 | {|[["ocaml" "pkg/pkg.ml" "build" "--dev-pkg" "%{dev}%" 67 | "--with-base-unix" "%{base-unix:installed}%" 68 | "--with-cmdliner" "%{cmdliner:installed}%"]]|} 69 | in 70 | B0_pack.make "default" ~doc:"fmt package" ~meta ~locked:true @@ 71 | B0_unit.list () 72 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | * Export `fmt` from `fmt.tty` and `fmt.cli` libraries. 4 | 5 | v0.10.0 2025-03-10 La Forclaz (VS) 6 | ---------------------------------- 7 | 8 | * Handle `cmdliner` deprecations. 9 | * Install each library in its own directory. 10 | * Add `Fmt.if'`, thanks to Rizo for the suggestion and patch. 11 | 12 | v0.9.0 2021-10-22 Zagreb 13 | ------------------------ 14 | 15 | * Add alert messages to deprecation annotations (#47). 16 | * The solution using ephemerons introduced in v0.8.7 for attaching 17 | custom data to formatters has unreliable performance characteristics 18 | in some usage scenarios. Namely use of `Fmt.styled` with 19 | `Fmt.[k]str` heavy code as those rely on `Format.{k,a}sprintf` which 20 | allocate one formatter per call. 21 | 22 | Hence we subvert again the `Format` tag system to do dirty 23 | things. However since as of 4.08 tags became an extensible sum type 24 | we can keep our dirty things entirely internal. 25 | 26 | Thanks to Thomas Leonard for reporting and David Kaloper Meršinjak 27 | for further investigations (#52). 28 | 29 | v0.8.10 2021-10-04 Zagreb 30 | ------------------------- 31 | 32 | * Require OCaml >= 4.08. This drops the dependency on the 33 | `stdlib-shims` and `seq` packages. 34 | * Add the `[@@ocaml.deprecated]` annotation to deprecated 35 | functions. Thanks to Antonin Décimo for the patch. 36 | 37 | v0.8.9 2020-09-23 Zagreb 38 | ------------------------ 39 | 40 | * Fix `Dump.{iter_bindings,hashtbl}` which since 0.8.7 no longer 41 | prints seperators. Thanks to Edwin Török for the patch. 42 | * Open the result of `Fmt.error_msg` to make it easier 43 | to compose with other errors. Thanks to Thomas Leonard 44 | for the patch. 45 | 46 | v0.8.8 2019-08-01 Zagreb 47 | ------------------------ 48 | 49 | Fix build on 32-bit platforms. 50 | 51 | v0.8.7 2019-07-21 Zagreb 52 | ------------------------ 53 | 54 | * Require OCaml 4.05. 55 | * Add `Fmt.hex` and friends. Support for hex dumping. 56 | Thanks to David Kaloper Meršinjak for the design and implementation.. 57 | * Add `Fmt.si_size` to format integer magnitudes using SI prefixes. 58 | * Add `Fmt.uint64_ns_span` to format time spans. 59 | * Add `Fmt.truncated` to truncate your long strings. 60 | * Add `Fmt.flush`, has the effect of `Format.pp_print_flush`. 61 | * Add `Fmt.[Dump.]{field,record}` for records (#9). 62 | * Add `Fmt.concat` to apply a list of formatters to a value. 63 | * Add `Fmt.{semi,sps}`, separators. 64 | * Add `Fmt.{error,error_msg}` to format `result` values. 65 | * Add `Fmt.failwith_notrace`. 66 | * Add `Fmt.( ++ )`, alias for `Fmt.append`. 67 | * Add `Fmt.Dump.string`. 68 | * Add more ANSI tty formatting styles and make them composable. 69 | * Change `Fmt.{const,comma,cut,sp}`, generalize signature. 70 | * Change `Fmt.append`, incompatible signature. Use `Fmt.(pair ~sep:nop)` if 71 | you were using it (backward compatible with earlier versions of `Fmt`). 72 | * Deprecate `Fmt.{strf,kstrf,strf_like}` in favor of `Fmt.{str,kstr,str_like}`. 73 | * Deprecate `Fmt.{always,unit}` in favor of `Fmt.any`. 74 | * Deprecate `Fmt.{prefix,suffix}` (specializes Fmt.( ++ )). 75 | * Deprecate `Fmt.styled_unit`. 76 | * No longer subvert the `Format` tag system to do dirty things. 77 | Thanks to David Kaloper Meršinjak for the work. 78 | 79 | v0.8.6 2019-04-01 La Forclaz (VS) 80 | --------------------------------- 81 | 82 | * Add `Fmt.{seq,Dump.seq}` to format `'a Seq.t` values. Thanks to 83 | Hezekiah M. Carty for the patch. 84 | * Handle `Pervasives`'s deprecation via dependency on `stdlib-shims`. 85 | * `Fmt.Dump.signal` format signals added in 4.03. 86 | * Fix toplevel initialization for omod (#33). 87 | * Require at least OCaml 4.03 (drops dependency on `result` and `uchar` 88 | compatibility packages). 89 | 90 | v0.8.5 2017-12-27 La Forclaz (VS) 91 | --------------------------------- 92 | 93 | * Fix `Fmt.{kstrf,strf_like}` when they are partially applied 94 | and repeatedly called. Thanks to Thomas Gazagnaire for the report. 95 | * Add `Fmt.comma`. 96 | * Relax the `Fmt.(invalid_arg, failwith)` type signature. Thanks to 97 | Hezekiah M. Carty for the patch. 98 | 99 | v0.8.4 2017-07-08 Zagreb 100 | ------------------------ 101 | 102 | * Add `Fmt.{invalid_arg,failwith}`. Thanks to Hezekiah M. Carty for the patch. 103 | 104 | v0.8.3 2017-04-13 La Forclaz (VS) 105 | --------------------------------- 106 | 107 | * Fix `Fmt.exn_backtrace`. Thanks to Thomas Leonard for the report. 108 | 109 | v0.8.2 2017-03-20 La Forclaz (VS) 110 | --------------------------------- 111 | 112 | * Fix `META` file. 113 | 114 | v0.8.1 2017-03-15 La Forclaz (VS) 115 | --------------------------------- 116 | 117 | * `Fmt_tty.setup`, treat empty `TERM` env var as dumb. 118 | * Add `Fmt.Dump.uchar` formatter for inspecting `Uchar.t` values. 119 | 120 | v0.8.0 2016-05-23 La Forclaz (VS) 121 | --------------------------------- 122 | 123 | * Build depend on topkg. 124 | * Relicense from BSD3 to ISC. 125 | * Tweak `Fmt.Dump.option` to indent like in sources. 126 | * Add `Fmt.Dump.signal` formatter for `Sys` signal numbers. 127 | * Add `Fmt[.Dump].result`, formatter for `result` values. 128 | * Add `Fmt.{words,paragraphs}` formatters on US-ASCII strings. 129 | * Add `Fmt.exn[_backtrace]`. Thanks to Edwin Török for suggesting. 130 | * Add `Fmt.quote`. 131 | * Rename `Fmt.text_range` to `Fmt.text_loc` and simplify output 132 | when range is a position. 133 | 134 | v0.7.1 2015-12-03 Cambridge (UK) 135 | -------------------------------- 136 | 137 | * Add optional cmdliner support. See the `Fmt_cli` module provided 138 | by the package `fmt.cli`. 139 | 140 | v0.7.0 2015-09-17 Cambridge (UK) 141 | -------------------------------- 142 | 143 | First Release. 144 | -------------------------------------------------------------------------------- /DEVEL.md: -------------------------------------------------------------------------------- 1 | This project uses (perhaps the development version of) [`b0`] for 2 | development. Consult [b0 occasionally] for quick hints on how to 3 | perform common development tasks. 4 | 5 | [`b0`]: https://erratique.ch/software/b0 6 | [b0 occasionally]: https://erratique.ch/software/b0/doc/occasionally.html 7 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 The fmt programmers 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Fmt — OCaml Format pretty-printer combinators 2 | ============================================= 3 | 4 | Fmt exposes combinators to devise `Format` pretty-printing functions. 5 | 6 | Fmt depends only on the OCaml standard library. The optional `Fmt_tty` 7 | library that allows to setup formatters for terminal color output 8 | depends on the Unix library. The optional `Fmt_cli` library that 9 | provides command line support for Fmt depends on [`cmdliner`]. 10 | 11 | Fmt is distributed under the ISC license. 12 | 13 | Home page: 14 | 15 | [`cmdliner`]: http://erratique.ch/software/cmdliner 16 | 17 | ## Installation 18 | 19 | Fmt can be installed with `opam`: 20 | 21 | opam install fmt 22 | opam install base-unix cmdliner fmt # Install all optional libraries 23 | 24 | If you don't use `opam` consult the [`opam`](opam) file for build 25 | instructions. 26 | 27 | ## Documentation 28 | 29 | The documentation can be consulted [online] or via `odig doc fmt`. 30 | 31 | Questions are welcome but better asked on the [OCaml forum] than on the 32 | issue tracker. 33 | 34 | [online]: http://erratique.ch/software/fmt/doc/ 35 | [OCaml forum]: https://discuss.ocaml.org/ 36 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, safe_string 2 | <_b0> : -traverse 3 | : include 4 | : package(unix) 5 | : package(cmdliner) 6 | : package(compiler-libs.toplevel) 7 | -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Fmt {%html: %%VERSION%%%}} 2 | 3 | Fmt exposes combinators to devise {!Format} pretty-printing functions. 4 | 5 | {1:library_fmt Library [fmt]} 6 | 7 | {!modules: Fmt} 8 | 9 | {1:library_tty Library [fmt.tty]} 10 | 11 | {!modules: Fmt_tty} 12 | 13 | {1:library_tty Library [fmt.cli]} 14 | 15 | {!modules: Fmt_cli} 16 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "fmt" 3 | synopsis: "OCaml Format pretty-printer combinators" 4 | description: """\ 5 | Fmt exposes combinators to devise `Format` pretty-printing functions. 6 | 7 | Fmt depends only on the OCaml standard library. The optional `Fmt_tty` 8 | library that allows to setup formatters for terminal color output 9 | depends on the Unix library. The optional `Fmt_cli` library that 10 | provides command line support for Fmt depends on [`Cmdliner`][cmdliner]. 11 | 12 | Fmt is distributed under the ISC license. 13 | 14 | [cmdliner]: http://erratique.ch/software/cmdliner 15 | 16 | Home page: http://erratique.ch/software/fmt""" 17 | maintainer: "Daniel Bünzli " 18 | authors: "The fmt programmers" 19 | license: "ISC" 20 | tags: ["string" "format" "pretty-print" "org:erratique"] 21 | homepage: "https://erratique.ch/software/fmt" 22 | doc: "https://erratique.ch/software/fmt/doc/" 23 | bug-reports: "https://github.com/dbuenzli/fmt/issues" 24 | depends: [ 25 | "ocaml" {>= "4.08.0"} 26 | "ocamlfind" {build} 27 | "ocamlbuild" {build} 28 | "topkg" {build & >= "1.0.3"} 29 | ] 30 | depopts: ["base-unix" "cmdliner"] 31 | conflicts: [ 32 | "cmdliner" {< "1.3.0"} 33 | ] 34 | build: [ 35 | "ocaml" 36 | "pkg/pkg.ml" 37 | "build" 38 | "--dev-pkg" 39 | "%{dev}%" 40 | "--with-base-unix" 41 | "%{base-unix:installed}%" 42 | "--with-cmdliner" 43 | "%{cmdliner:installed}%" 44 | ] 45 | dev-repo: "git+https://erratique.ch/repos/fmt.git" 46 | x-maintenance-intent: ["(latest)"] 47 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "OCaml Format pretty-printer combinators" 2 | version = "%%VERSION_NUM%%" 3 | requires = "" 4 | archive(byte) = "fmt.cma" 5 | archive(native) = "fmt.cmxa" 6 | plugin(byte) = "fmt.cma" 7 | plugin(native) = "fmt.cmxs" 8 | exists_if = "fmt.cma fmt.cmxa" 9 | 10 | package "cli" ( 11 | directory = "cli" 12 | description = "The fmt.cli library" 13 | version = "%%VERSION_NUM%%" 14 | requires = "cmdliner fmt" 15 | exports = "fmt" 16 | archive(byte) = "fmt_cli.cma" 17 | archive(native) = "fmt_cli.cmxa" 18 | plugin(byte) = "fmt_cli.cma" 19 | plugin(native) = "fmt_cli.cmxs" 20 | exists_if = "fmt_cli.cma fmt_cli.cmxa" 21 | ) 22 | 23 | package "top" ( 24 | directory = "top" 25 | description = "The fmt.top library" 26 | version = "%%VERSION_NUM%%" 27 | requires = "fmt fmt.tty" 28 | archive(byte) = "fmt_top.cma" 29 | archive(native) = "fmt_top.cmxa" 30 | plugin(byte) = "fmt_top.cma" 31 | plugin(native) = "fmt_top.cmxs" 32 | exists_if = "fmt_top.cma fmt_top.cmxa" 33 | ) 34 | 35 | package "tty" ( 36 | directory = "tty" 37 | description = "The fmt.tty library" 38 | version = "%%VERSION_NUM%%" 39 | requires = "unix fmt" 40 | exports = "fmt" 41 | archive(byte) = "fmt_tty.cma" 42 | archive(native) = "fmt_tty.cmxa" 43 | plugin(byte) = "fmt_tty.cma" 44 | plugin(native) = "fmt_tty.cmxs" 45 | exists_if = "fmt_tty.cma fmt_tty.cmxa" 46 | ) 47 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let unix = Conf.with_pkg "base-unix" 7 | let cmdliner = Conf.with_pkg "cmdliner" 8 | 9 | let () = 10 | Pkg.describe "fmt" @@ fun c -> 11 | let unix = Conf.value c unix in 12 | let cmdliner = Conf.value c cmdliner in 13 | Ok [ Pkg.mllib "src/fmt.mllib"; 14 | Pkg.mllib ~cond:unix ~dst_dir:"tty" "src/tty/fmt_tty.mllib"; 15 | Pkg.mllib ~cond:cmdliner ~dst_dir:"cli" "src/cli/fmt_cli.mllib"; 16 | Pkg.mllib ~api:[] ~dst_dir:"top" "src/top/fmt_top.mllib"; 17 | Pkg.lib ~dst:"top/fmt_tty_top_init.ml" "src/top/fmt_tty_top_init.ml"; 18 | Pkg.doc "doc/index.mld" ~dst:"odoc-pages/index.mld" ] 19 | -------------------------------------------------------------------------------- /src/cli/fmt_cli.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fmt programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | let strf = Format.asprintf 7 | 8 | open Cmdliner 9 | 10 | let style_renderer ?env ?docs () = 11 | let enum = ["auto", None; "always", Some `Ansi_tty; "never", Some `None] in 12 | let color = Arg.enum enum in 13 | let enum_alts = Arg.doc_alts_enum enum in 14 | let doc = strf "Colorize the output. $(docv) must be %s." enum_alts in 15 | Arg.(value & opt color None & info ["color"] ?env ~doc ~docv:"WHEN" ?docs) 16 | 17 | (*--------------------------------------------------------------------------- 18 | Copyright (c) 2015 The fmt programmers 19 | 20 | Permission to use, copy, modify, and/or distribute this software for any 21 | purpose with or without fee is hereby granted, provided that the above 22 | copyright notice and this permission notice appear in all copies. 23 | 24 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 25 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 26 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 27 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 28 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 29 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 30 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 31 | ---------------------------------------------------------------------------*) 32 | -------------------------------------------------------------------------------- /src/cli/fmt_cli.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fmt programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** {!Cmdliner} support for [Fmt]. *) 7 | 8 | (** {1 Option for setting the style renderer} *) 9 | 10 | val style_renderer : ?env:Cmdliner.Cmd.Env.info -> ?docs:string -> unit -> 11 | Fmt.style_renderer option Cmdliner.Term.t 12 | (** [style_renderer ?env ?docs ()] is a {!Cmdliner} option [--color] that can 13 | be directly used with the optional arguments of 14 | {{!Fmt_tty.tty_setup}TTY setup} or to control 15 | {{!Fmt.set_style_renderer}style rendering}. The option is 16 | documented under [docs] (defaults to the default in 17 | {!Cmdliner.Arg.info}). 18 | 19 | The option is a tri-state enumerated value that when used with 20 | {{!Fmt_tty.tty_setup}TTY setup} takes over the automatic setup: 21 | {ul 22 | {- [--color=never], the value is [Some `None], forces no styling.} 23 | {- [--color=always], the value is [Some `Ansi_tty], forces ANSI styling.} 24 | {- [--color=auto] or absent, the value is [None], automatic setup 25 | takes place.}} 26 | 27 | If [env] is provided, the option default value ([None]) can be 28 | overridden by the corresponding environment variable. *) 29 | 30 | (*--------------------------------------------------------------------------- 31 | Copyright (c) 2015 The fmt programmers 32 | 33 | Permission to use, copy, modify, and/or distribute this software for any 34 | purpose with or without fee is hereby granted, provided that the above 35 | copyright notice and this permission notice appear in all copies. 36 | 37 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 38 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 39 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 40 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 41 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 42 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 43 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 44 | ---------------------------------------------------------------------------*) 45 | -------------------------------------------------------------------------------- /src/cli/fmt_cli.mllib: -------------------------------------------------------------------------------- 1 | Fmt_cli 2 | -------------------------------------------------------------------------------- /src/fmt.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2014 The fmt programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | let invalid_arg' = invalid_arg 7 | 8 | (* Errors *) 9 | 10 | let err_str_formatter = "Format.str_formatter can't be set." 11 | 12 | (* Standard outputs *) 13 | 14 | let stdout = Format.std_formatter 15 | let stderr = Format.err_formatter 16 | 17 | (* Formatting *) 18 | 19 | let pf = Format.fprintf 20 | let pr = Format.printf 21 | let epr = Format.eprintf 22 | let str = Format.asprintf 23 | let kpf = Format.kfprintf 24 | let kstr = Format.kasprintf 25 | let failwith fmt = kstr failwith fmt 26 | let failwith_notrace fmt = kstr (fun s -> raise_notrace (Failure s)) fmt 27 | let invalid_arg fmt = kstr invalid_arg fmt 28 | let error fmt = kstr (fun s -> Error s) fmt 29 | let error_msg fmt = kstr (fun s -> Error (`Msg s)) fmt 30 | 31 | (* Formatters *) 32 | 33 | type 'a t = Format.formatter -> 'a -> unit 34 | 35 | let flush ppf _ = Format.pp_print_flush ppf () 36 | let nop fmt ppf = () 37 | let any fmt ppf _ = pf ppf fmt 38 | let using f pp ppf v = pp ppf (f v) 39 | let const pp_v v ppf _ = pp_v ppf v 40 | let if' bool pp = if bool then pp else nop 41 | let fmt fmt ppf = pf ppf fmt 42 | 43 | (* Separators *) 44 | 45 | let cut ppf _ = Format.pp_print_cut ppf () 46 | let sp ppf _ = Format.pp_print_space ppf () 47 | let sps n ppf _ = Format.pp_print_break ppf n 0 48 | let comma ppf _ = Format.pp_print_string ppf ","; sp ppf () 49 | let semi ppf _ = Format.pp_print_string ppf ";"; sp ppf () 50 | 51 | (* Sequencing *) 52 | 53 | let iter ?sep:(pp_sep = cut) iter pp_elt ppf v = 54 | let is_first = ref true in 55 | let pp_elt v = 56 | if !is_first then (is_first := false) else pp_sep ppf (); 57 | pp_elt ppf v 58 | in 59 | iter pp_elt v 60 | 61 | let iter_bindings ?sep:(pp_sep = cut) iter pp_binding ppf v = 62 | let is_first = ref true in 63 | let pp_binding k v = 64 | if !is_first then (is_first := false) else pp_sep ppf (); 65 | pp_binding ppf (k, v) 66 | in 67 | iter pp_binding v 68 | 69 | let append pp_v0 pp_v1 ppf v = pp_v0 ppf v; pp_v1 ppf v 70 | let ( ++ ) = append 71 | let concat ?sep pps ppf v = iter ?sep List.iter (fun ppf pp -> pp ppf v) ppf pps 72 | 73 | (* Boxes *) 74 | 75 | let box ?(indent = 0) pp_v ppf v = 76 | Format.(pp_open_box ppf indent; pp_v ppf v; pp_close_box ppf ()) 77 | 78 | let hbox pp_v ppf v = 79 | Format.(pp_open_hbox ppf (); pp_v ppf v; pp_close_box ppf ()) 80 | 81 | let vbox ?(indent = 0) pp_v ppf v = 82 | Format.(pp_open_vbox ppf indent; pp_v ppf v; pp_close_box ppf ()) 83 | 84 | let hvbox ?(indent = 0) pp_v ppf v = 85 | Format.(pp_open_hvbox ppf indent; pp_v ppf v; pp_close_box ppf ()) 86 | 87 | let hovbox ?(indent = 0) pp_v ppf v = 88 | Format.(pp_open_hovbox ppf indent; pp_v ppf v; pp_close_box ppf ()) 89 | 90 | (* Brackets *) 91 | 92 | let surround s1 s2 pp_v ppf v = 93 | Format.(pp_print_string ppf s1; pp_v ppf v; pp_print_string ppf s2) 94 | 95 | let parens pp_v = box ~indent:1 (surround "(" ")" pp_v) 96 | let brackets pp_v = box ~indent:1 (surround "[" "]" pp_v) 97 | let oxford_brackets pp_v = box ~indent:2 (surround "[|" "|]" pp_v) 98 | let braces pp_v = box ~indent:1 (surround "{" "}" pp_v) 99 | let quote ?(mark = "\"") pp_v = 100 | let pp_mark ppf _ = Format.pp_print_as ppf 1 mark in 101 | box ~indent:1 (pp_mark ++ pp_v ++ pp_mark) 102 | 103 | (* Stdlib types formatters *) 104 | 105 | let bool = Format.pp_print_bool 106 | let int = Format.pp_print_int 107 | let nativeint ppf v = pf ppf "%nd" v 108 | let int32 ppf v = pf ppf "%ld" v 109 | let int64 ppf v = pf ppf "%Ld" v 110 | let uint ppf v = pf ppf "%u" v 111 | let uint32 ppf v = pf ppf "%lu" v 112 | let uint64 ppf v = pf ppf "%Lu" v 113 | let unativeint ppf v = pf ppf "%nu" v 114 | let char = Format.pp_print_char 115 | let string = Format.pp_print_string 116 | let buffer ppf b = string ppf (Buffer.contents b) 117 | let exn ppf e = string ppf (Printexc.to_string e) 118 | let exn_backtrace ppf (e, bt) = 119 | let pp_backtrace_str ppf s = 120 | let stop = String.length s - 1 (* there's a newline at the end *) in 121 | let rec loop left right = 122 | if right = stop then string ppf (String.sub s left (right - left)) else 123 | if s.[right] <> '\n' then loop left (right + 1) else 124 | begin 125 | string ppf (String.sub s left (right - left)); 126 | cut ppf (); 127 | loop (right + 1) (right + 1) 128 | end 129 | in 130 | if s = "" then (string ppf "No backtrace available.") else 131 | loop 0 0 132 | in 133 | pf ppf "@[Exception: %a@,%a@]" 134 | exn e pp_backtrace_str (Printexc.raw_backtrace_to_string bt) 135 | 136 | let float ppf v = pf ppf "%g" v 137 | let round x = floor (x +. 0.5) 138 | let round_dfrac d x = 139 | if x -. (round x) = 0. then x else (* x is an integer. *) 140 | let m = 10. ** (float_of_int d) in (* m moves 10^-d to 1. *) 141 | (floor ((x *. m) +. 0.5)) /. m 142 | 143 | let round_dsig d x = 144 | if x = 0. then 0. else 145 | let m = 10. ** (floor (log10 (abs_float x))) in (* to normalize x. *) 146 | (round_dfrac d (x /. m)) *. m 147 | 148 | let float_dfrac d ppf f = pf ppf "%g" (round_dfrac d f) 149 | let float_dsig d ppf f = pf ppf "%g" (round_dsig d f) 150 | 151 | let pair ?sep:(pp_sep = cut) pp_fst pp_snd ppf (fst, snd) = 152 | pp_fst ppf fst; pp_sep ppf (); pp_snd ppf snd 153 | 154 | let option ?none:(pp_none = nop) pp_v ppf = function 155 | | None -> pp_none ppf () 156 | | Some v -> pp_v ppf v 157 | 158 | let result ~ok ~error ppf = function 159 | | Ok v -> ok ppf v 160 | | Error e -> error ppf e 161 | 162 | let list ?sep pp_elt = iter ?sep List.iter pp_elt 163 | let array ?sep pp_elt = iter ?sep Array.iter pp_elt 164 | let seq ?sep pp_elt = iter ?sep Seq.iter pp_elt 165 | let hashtbl ?sep pp_binding = iter_bindings ?sep Hashtbl.iter pp_binding 166 | let queue ?sep pp_elt = iter Queue.iter pp_elt 167 | let stack ?sep pp_elt = iter Stack.iter pp_elt 168 | 169 | (* Stdlib type dumpers *) 170 | 171 | module Dump = struct 172 | 173 | (* Stdlib types *) 174 | 175 | let sig_names = 176 | Sys.[ sigabrt, "SIGABRT"; sigalrm, "SIGALRM"; sigfpe, "SIGFPE"; 177 | sighup, "SIGHUP"; sigill, "SIGILL"; sigint, "SIGINT"; 178 | sigkill, "SIGKILL"; sigpipe, "SIGPIPE"; sigquit, "SIGQUIT"; 179 | sigsegv, "SIGSEGV"; sigterm, "SIGTERM"; sigusr1, "SIGUSR1"; 180 | sigusr2, "SIGUSR2"; sigchld, "SIGCHLD"; sigcont, "SIGCONT"; 181 | sigstop, "SIGSTOP"; sigtstp, "SIGTSTP"; sigttin, "SIGTTIN"; 182 | sigttou, "SIGTTOU"; sigvtalrm, "SIGVTALRM"; sigprof, "SIGPROF"; 183 | sigbus, "SIGBUS"; sigpoll, "SIGPOLL"; sigsys, "SIGSYS"; 184 | sigtrap, "SIGTRAP"; sigurg, "SIGURG"; sigxcpu, "SIGXCPU"; 185 | sigxfsz, "SIGXFSZ"; ] 186 | 187 | let signal ppf s = match List.assq_opt s sig_names with 188 | | Some name -> string ppf name 189 | | None -> pf ppf "SIG(%d)" s 190 | 191 | let uchar ppf u = pf ppf "U+%04X" (Uchar.to_int u) 192 | let string ppf s = pf ppf "%S" s 193 | let pair pp_fst pp_snd = 194 | parens (using fst (box pp_fst) ++ comma ++ using snd (box pp_snd)) 195 | 196 | let option pp_v ppf = function 197 | | None -> pf ppf "None" 198 | | Some v -> pf ppf "@[<2>Some@ @[%a@]@]" pp_v v 199 | 200 | let result ~ok ~error ppf = function 201 | | Ok v -> pf ppf "@[<2>Ok@ @[%a@]@]" ok v 202 | | Error e -> pf ppf "@[<2>Error@ @[%a@]@]" error e 203 | 204 | (* Sequencing *) 205 | 206 | let iter iter_f pp_name pp_elt = 207 | let pp_v = iter ~sep:sp iter_f (box pp_elt) in 208 | parens (pp_name ++ sp ++ pp_v) 209 | 210 | let iter_bindings iter_f pp_name pp_k pp_v = 211 | let pp_v = iter_bindings ~sep:sp iter_f (pair pp_k pp_v) in 212 | parens (pp_name ++ sp ++ pp_v) 213 | 214 | (* Stdlib data structures *) 215 | 216 | let list pp_elt = brackets (list ~sep:semi (box pp_elt)) 217 | let array pp_elt = oxford_brackets (array ~sep:semi (box pp_elt)) 218 | let seq pp_elt = brackets (seq ~sep:semi (box pp_elt)) 219 | 220 | let hashtbl pp_k pp_v = 221 | iter_bindings Hashtbl.iter (any "hashtbl") pp_k pp_v 222 | 223 | let stack pp_elt = iter Stack.iter (any "stack") pp_elt 224 | let queue pp_elt = iter Queue.iter (any "queue") pp_elt 225 | 226 | (* Records *) 227 | 228 | let field ?(label = string) l prj pp_v ppf v = 229 | pf ppf "@[<1>%a =@ %a@]" label l pp_v (prj v) 230 | 231 | let record pps = 232 | box ~indent:2 (surround "{ " " }" @@ vbox (concat ~sep:(any ";@,") pps)) 233 | end 234 | 235 | (* Magnitudes *) 236 | 237 | let ilog10 x = 238 | let rec loop p x = if x = 0 then p else loop (p + 1) (x / 10) in 239 | loop (-1) x 240 | 241 | let ipow10 n = 242 | let rec loop acc n = if n = 0 then acc else loop (acc * 10) (n - 1) in 243 | loop 1 n 244 | 245 | let si_symb_max = 16 246 | let si_symb = 247 | [| "y"; "z"; "a"; "f"; "p"; "n"; "u"; "m"; ""; "k"; "M"; "G"; "T"; "P"; 248 | "E"; "Z"; "Y"|] 249 | 250 | let rec pp_at_factor ~scale u symb factor ppf s = 251 | let m = s / factor in 252 | let n = s mod factor in 253 | match m with 254 | | m when m >= 100 -> (* No fractional digit *) 255 | let m_up = if n > 0 then m + 1 else m in 256 | if m_up >= 1000 then si_size ~scale u ppf (m_up * factor) else 257 | pf ppf "%d%s%s" m_up symb u 258 | | m when m >= 10 -> (* One fractional digit w.o. trailing 0 *) 259 | let f_factor = factor / 10 in 260 | let f_m = n / f_factor in 261 | let f_n = n mod f_factor in 262 | let f_m_up = if f_n > 0 then f_m + 1 else f_m in 263 | begin match f_m_up with 264 | | 0 -> pf ppf "%d%s%s" m symb u 265 | | f when f >= 10 -> si_size ~scale u ppf (m * factor + f * f_factor) 266 | | f -> pf ppf "%d.%d%s%s" m f symb u 267 | end 268 | | m -> (* Two or zero fractional digits w.o. trailing 0 *) 269 | let f_factor = factor / 100 in 270 | let f_m = n / f_factor in 271 | let f_n = n mod f_factor in 272 | let f_m_up = if f_n > 0 then f_m + 1 else f_m in 273 | match f_m_up with 274 | | 0 -> pf ppf "%d%s%s" m symb u 275 | | f when f >= 100 -> si_size ~scale u ppf (m * factor + f * f_factor) 276 | | f when f mod 10 = 0 -> pf ppf "%d.%d%s%s" m (f / 10) symb u 277 | | f -> pf ppf "%d.%02d%s%s" m f symb u 278 | 279 | and si_size ~scale u ppf s = match scale < -8 || scale > 8 with 280 | | true -> invalid_arg "~scale is %d, must be in [-8;8]" scale 281 | | false -> 282 | let pow_div_3 = if s = 0 then 0 else (ilog10 s / 3) in 283 | let symb = (scale + 8) + pow_div_3 in 284 | let symb, factor = match symb > si_symb_max with 285 | | true -> si_symb_max, ipow10 ((8 - scale) * 3) 286 | | false -> symb, ipow10 (pow_div_3 * 3) 287 | in 288 | if factor = 1 289 | then pf ppf "%d%s%s" s si_symb.(symb) u 290 | else pp_at_factor ~scale u si_symb.(symb) factor ppf s 291 | 292 | let byte_size ppf s = si_size ~scale:0 "B" ppf s 293 | 294 | let bi_byte_size ppf s = 295 | (* XXX we should get rid of this. *) 296 | let _pp_byte_size k i ppf s = 297 | let pp_frac = float_dfrac 1 in 298 | let div_round_up m n = (m + n - 1) / n in 299 | let float = float_of_int in 300 | if s < k then pf ppf "%dB" s else 301 | let m = k * k in 302 | if s < m then begin 303 | let kstr = if i = "" then "k" (* SI *) else "K" (* IEC *) in 304 | let sk = s / k in 305 | if sk < 10 306 | then pf ppf "%a%s%sB" pp_frac (float s /. float k) kstr i 307 | else pf ppf "%d%s%sB" (div_round_up s k) kstr i 308 | end else 309 | let g = k * m in 310 | if s < g then begin 311 | let sm = s / m in 312 | if sm < 10 313 | then pf ppf "%aM%sB" pp_frac (float s /. float m) i 314 | else pf ppf "%dM%sB" (div_round_up s m) i 315 | end else 316 | let t = k * g in 317 | if s < t then begin 318 | let sg = s / g in 319 | if sg < 10 320 | then pf ppf "%aG%sB" pp_frac (float s /. float g) i 321 | else pf ppf "%dG%sB" (div_round_up s g) i 322 | end else 323 | let p = k * t in 324 | if s < p then begin 325 | let st = s / t in 326 | if st < 10 327 | then pf ppf "%aT%sB" pp_frac (float s /. float t) i 328 | else pf ppf "%dT%sB" (div_round_up s t) i 329 | end else begin 330 | let sp = s / p in 331 | if sp < 10 332 | then pf ppf "%aP%sB" pp_frac (float s /. float p) i 333 | else pf ppf "%dP%sB" (div_round_up s p) i 334 | end 335 | in 336 | _pp_byte_size 1024 "i" ppf s 337 | 338 | (* XXX From 4.08 on use Int64.unsigned_* 339 | 340 | See Hacker's Delight for the implementation of these unsigned_* funs *) 341 | 342 | let unsigned_compare x0 x1 = Int64.(compare (sub x0 min_int) (sub x1 min_int)) 343 | let unsigned_div n d = match d < Int64.zero with 344 | | true -> if unsigned_compare n d < 0 then Int64.zero else Int64.one 345 | | false -> 346 | let q = Int64.(shift_left (div (shift_right_logical n 1) d) 1) in 347 | let r = Int64.(sub n (mul q d)) in 348 | if unsigned_compare r d >= 0 then Int64.succ q else q 349 | 350 | let unsigned_rem n d = Int64.(sub n (mul (unsigned_div n d) d)) 351 | 352 | let us_span = 1_000L 353 | let ms_span = 1_000_000L 354 | let sec_span = 1_000_000_000L 355 | let min_span = 60_000_000_000L 356 | let hour_span = 3600_000_000_000L 357 | let day_span = 86_400_000_000_000L 358 | let year_span = 31_557_600_000_000_000L 359 | 360 | let rec pp_si_span unit_str si_unit si_higher_unit ppf span = 361 | let geq x y = unsigned_compare x y >= 0 in 362 | let m = unsigned_div span si_unit in 363 | let n = unsigned_rem span si_unit in 364 | match m with 365 | | m when geq m 100L -> (* No fractional digit *) 366 | let m_up = if Int64.equal n 0L then m else Int64.succ m in 367 | let span' = Int64.mul m_up si_unit in 368 | if geq span' si_higher_unit then uint64_ns_span ppf span' else 369 | pf ppf "%Ld%s" m_up unit_str 370 | | m when geq m 10L -> (* One fractional digit w.o. trailing zero *) 371 | let f_factor = unsigned_div si_unit 10L in 372 | let f_m = unsigned_div n f_factor in 373 | let f_n = unsigned_rem n f_factor in 374 | let f_m_up = if Int64.equal f_n 0L then f_m else Int64.succ f_m in 375 | begin match f_m_up with 376 | | 0L -> pf ppf "%Ld%s" m unit_str 377 | | f when geq f 10L -> 378 | uint64_ns_span ppf Int64.(add (mul m si_unit) (mul f f_factor)) 379 | | f -> pf ppf "%Ld.%Ld%s" m f unit_str 380 | end 381 | | m -> (* Two or zero fractional digits w.o. trailing zero *) 382 | let f_factor = unsigned_div si_unit 100L in 383 | let f_m = unsigned_div n f_factor in 384 | let f_n = unsigned_rem n f_factor in 385 | let f_m_up = if Int64.equal f_n 0L then f_m else Int64.succ f_m in 386 | match f_m_up with 387 | | 0L -> pf ppf "%Ld%s" m unit_str 388 | | f when geq f 100L -> 389 | uint64_ns_span ppf Int64.(add (mul m si_unit) (mul f f_factor)) 390 | | f when Int64.equal (Int64.rem f 10L) 0L -> 391 | pf ppf "%Ld.%Ld%s" m (Int64.div f 10L) unit_str 392 | | f -> 393 | pf ppf "%Ld.%02Ld%s" m f unit_str 394 | 395 | and pp_non_si unit_str unit unit_lo_str unit_lo unit_lo_size ppf span = 396 | let geq x y = unsigned_compare x y >= 0 in 397 | let m = unsigned_div span unit in 398 | let n = unsigned_rem span unit in 399 | if Int64.equal n 0L then pf ppf "%Ld%s" m unit_str else 400 | let f_m = unsigned_div n unit_lo in 401 | let f_n = unsigned_rem n unit_lo in 402 | let f_m_up = if Int64.equal f_n 0L then f_m else Int64.succ f_m in 403 | match f_m_up with 404 | | f when geq f unit_lo_size -> 405 | uint64_ns_span ppf Int64.(add (mul m unit) (mul f unit_lo)) 406 | | f -> 407 | pf ppf "%Ld%s%Ld%s" m unit_str f unit_lo_str 408 | 409 | and uint64_ns_span ppf span = 410 | let geq x y = unsigned_compare x y >= 0 in 411 | let lt x y = unsigned_compare x y = -1 in 412 | match span with 413 | | s when lt s us_span -> pf ppf "%Ldns" s 414 | | s when lt s ms_span -> pp_si_span "us" us_span ms_span ppf s 415 | | s when lt s sec_span -> pp_si_span "ms" ms_span sec_span ppf s 416 | | s when lt s min_span -> pp_si_span "s" sec_span min_span ppf s 417 | | s when lt s hour_span -> pp_non_si "min" min_span "s" sec_span 60L ppf s 418 | | s when lt s day_span -> pp_non_si "h" hour_span "min" min_span 60L ppf s 419 | | s when lt s year_span -> pp_non_si "d" day_span "h" hour_span 24L ppf s 420 | | s -> 421 | let m = unsigned_div s year_span in 422 | let n = unsigned_rem s year_span in 423 | if Int64.equal n 0L then pf ppf "%Lda" m else 424 | let f_m = unsigned_div n day_span in 425 | let f_n = unsigned_rem n day_span in 426 | let f_m_up = if Int64.equal f_n 0L then f_m else Int64.succ f_m in 427 | match f_m_up with 428 | | f when geq f 366L -> pf ppf "%Lda" (Int64.succ m) 429 | | f -> pf ppf "%Lda%Ldd" m f 430 | 431 | (* Binary formatting *) 432 | 433 | type 'a vec = int * (int -> 'a) 434 | 435 | let iter_vec f (n, get) = for i = 0 to n - 1 do f i (get i) done 436 | let vec ?sep = iter_bindings ?sep iter_vec 437 | 438 | let on_string = using String.(fun s -> length s, get s) 439 | let on_bytes = using Bytes.(fun b -> length b, get b) 440 | 441 | let sub_vecs w (n, get) = 442 | (n - 1) / w + 1, 443 | fun j -> 444 | let off = w * j in 445 | min w (n - off), fun i -> get (i + off) 446 | 447 | let prefix0x = [ 448 | 0xf , fmt "%01x"; 449 | 0xff , fmt "%02x"; 450 | 0xfff , fmt "%03x"; 451 | 0xffff , fmt "%04x"; 452 | 0xfffff , fmt "%05x"; 453 | 0xffffff , fmt "%06x"; 454 | 0xfffffff , fmt "%07x"; ] 455 | 456 | let padded0x ~max = match List.find_opt (fun (x, _) -> max <= x) prefix0x with 457 | | Some (_, pp) -> pp 458 | | None -> fmt "%08x" 459 | 460 | let ascii ?(w = 0) ?(subst = const char '.') () ppf (n, _ as v) = 461 | let pp_char ppf (_, c) = 462 | if '\x20' <= c && c < '\x7f' then char ppf c else subst ppf () 463 | in 464 | vec pp_char ppf v; 465 | if n < w then sps (w - n) ppf () 466 | 467 | let octets ?(w = 0) ?(sep = sp) () ppf (n, _ as v) = 468 | let pp_sep ppf i = if i > 0 && i mod 2 = 0 then sep ppf () in 469 | let pp_char ppf (i, c) = pp_sep ppf i; pf ppf "%02x" (Char.code c) in 470 | vec ~sep:nop pp_char ppf v; 471 | for i = n to w - 1 do pp_sep ppf i; sps 2 ppf () done 472 | 473 | let addresses ?addr ?(w = 16) pp_vec ppf (n, _ as v) = 474 | let addr = match addr with 475 | | Some pp -> pp 476 | | _ -> padded0x ~max:(((n - 1) / w) * w) ++ const string ": " 477 | in 478 | let pp_sub ppf (i, sub) = addr ppf (i * w); box pp_vec ppf sub in 479 | vbox (vec pp_sub) ppf (sub_vecs w v) 480 | 481 | let hex ?(w = 16) () = 482 | addresses ~w ((octets ~w () |> box) ++ sps 2 ++ (ascii ~w () |> box)) 483 | 484 | (* Text and lines *) 485 | 486 | let is_nl c = c = '\n' 487 | let is_nl_or_sp c = is_nl c || c = ' ' 488 | let is_white = function ' ' | '\t' .. '\r' -> true | _ -> false 489 | let not_white c = not (is_white c) 490 | let not_white_or_nl c = is_nl c || not_white c 491 | 492 | let rec stop_at sat ~start ~max s = 493 | if start > max then start else 494 | if sat s.[start] then start else 495 | stop_at sat ~start:(start + 1) ~max s 496 | 497 | let sub s start stop ~max = 498 | if start = stop then "" else 499 | if start = 0 && stop > max then s else 500 | String.sub s start (stop - start) 501 | 502 | let words ppf s = 503 | let max = String.length s - 1 in 504 | let rec loop start s = match stop_at is_white ~start ~max s with 505 | | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~max) 506 | | stop -> 507 | Format.pp_print_string ppf (sub s start stop ~max); 508 | match stop_at not_white ~start:stop ~max s with 509 | | stop when stop > max -> () 510 | | stop -> Format.pp_print_space ppf (); loop stop s 511 | in 512 | let start = stop_at not_white ~start:0 ~max s in 513 | if start > max then () else loop start s 514 | 515 | let paragraphs ppf s = 516 | let max = String.length s - 1 in 517 | let rec loop start s = match stop_at is_white ~start ~max s with 518 | | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~max) 519 | | stop -> 520 | Format.pp_print_string ppf (sub s start stop ~max); 521 | match stop_at not_white_or_nl ~start:stop ~max s with 522 | | stop when stop > max -> () 523 | | stop -> 524 | if s.[stop] <> '\n' 525 | then (Format.pp_print_space ppf (); loop stop s) else 526 | match stop_at not_white_or_nl ~start:(stop + 1) ~max s with 527 | | stop when stop > max -> () 528 | | stop -> 529 | if s.[stop] <> '\n' 530 | then (Format.pp_print_space ppf (); loop stop s) else 531 | match stop_at not_white ~start:(stop + 1) ~max s with 532 | | stop when stop > max -> () 533 | | stop -> 534 | Format.pp_force_newline ppf (); 535 | Format.pp_force_newline ppf (); 536 | loop stop s 537 | in 538 | let start = stop_at not_white ~start:0 ~max s in 539 | if start > max then () else loop start s 540 | 541 | let text ppf s = 542 | let max = String.length s - 1 in 543 | let rec loop start s = match stop_at is_nl_or_sp ~start ~max s with 544 | | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~max) 545 | | stop -> 546 | Format.pp_print_string ppf (sub s start stop ~max); 547 | begin match s.[stop] with 548 | | ' ' -> Format.pp_print_space ppf () 549 | | '\n' -> Format.pp_force_newline ppf () 550 | | _ -> assert false 551 | end; 552 | loop (stop + 1) s 553 | in 554 | loop 0 s 555 | 556 | let lines ppf s = 557 | let max = String.length s - 1 in 558 | let rec loop start s = match stop_at is_nl ~start ~max s with 559 | | stop when stop > max -> Format.pp_print_string ppf (sub s start stop ~max) 560 | | stop -> 561 | Format.pp_print_string ppf (sub s start stop ~max); 562 | Format.pp_force_newline ppf (); 563 | loop (stop + 1) s 564 | in 565 | loop 0 s 566 | 567 | let truncated ~max ppf s = match String.length s <= max with 568 | | true -> Format.pp_print_string ppf s 569 | | false -> 570 | for i = 0 to max - 4 do Format.pp_print_char ppf s.[i] done; 571 | Format.pp_print_string ppf "..." 572 | 573 | let text_loc ppf ((l0, c0), (l1, c1)) = 574 | if (l0 : int) == (l1 : int) && (c0 : int) == (c1 : int) 575 | then pf ppf "%d.%d" l0 c0 576 | else pf ppf "%d.%d-%d.%d" l0 c0 l1 c1 577 | 578 | (* HCI fragments *) 579 | 580 | let one_of ?(empty = nop) pp_v ppf = function 581 | | [] -> empty ppf () 582 | | [v] -> pp_v ppf v 583 | | [v0; v1] -> pf ppf "@[either %a or@ %a@]" pp_v v0 pp_v v1 584 | | _ :: _ as vs -> 585 | let rec loop ppf = function 586 | | [v] -> pf ppf "or@ %a" pp_v v 587 | | v :: vs -> pf ppf "%a,@ " pp_v v; loop ppf vs 588 | | [] -> assert false 589 | in 590 | pf ppf "@[one@ of@ %a@]" loop vs 591 | 592 | let did_you_mean 593 | ?(pre = any "Unknown") ?(post = nop) ~kind pp_v ppf (v, hints) 594 | = 595 | match hints with 596 | | [] -> pf ppf "@[%a %s %a%a.@]" pre () kind pp_v v post () 597 | | hints -> 598 | pf ppf "@[%a %s %a%a.@ Did you mean %a ?@]" 599 | pre () kind pp_v v post () (one_of pp_v) hints 600 | 601 | (* Conditional UTF-8 and styled formatting. *) 602 | 603 | module Imap = Map.Make (Int) 604 | 605 | type 'a attr = int * ('a -> string) * (string -> 'a) 606 | let id = ref 0 607 | let attr (type a) enc dec = incr id; (!id, enc, dec) 608 | 609 | type Format.stag += 610 | | Fmt_store_get : 'a attr -> Format.stag 611 | | Fmt_store_set : 'a attr * 'a -> Format.stag 612 | 613 | let store () = 614 | let s = ref Imap.empty in 615 | fun ~other -> function 616 | | Fmt_store_get (id, _, _) -> Option.value ~default:"" (Imap.find_opt id !s) 617 | | Fmt_store_set ((id, enc, _), v) -> s := Imap.add id (enc v) !s; "ok" 618 | | stag -> other stag 619 | 620 | let setup_store ppf = 621 | let funs = Format.pp_get_formatter_stag_functions ppf () in 622 | let mark_open_stag = store () ~other:funs.mark_open_stag in 623 | Format.pp_set_formatter_stag_functions ppf { funs with mark_open_stag } 624 | 625 | let store_op op ppf = 626 | let funs = Format.pp_get_formatter_stag_functions ppf () in 627 | funs.mark_open_stag op 628 | 629 | let get (_, _, dec as attr) ppf = match store_op (Fmt_store_get attr) ppf with 630 | | "" -> None | s -> Some (dec s) 631 | 632 | let rec set attr v ppf = match store_op (Fmt_store_set (attr, v)) ppf with 633 | | "ok" -> () | _ -> setup_store ppf; set attr v ppf 634 | 635 | let def x = function Some y -> y | _ -> x 636 | 637 | let utf_8_attr = 638 | let enc = function true -> "t" | false -> "f" in 639 | let dec = function "t" -> true | "f" -> false | _ -> assert false in 640 | attr enc dec 641 | 642 | let utf_8 ppf = get utf_8_attr ppf |> def true 643 | let set_utf_8 ppf x = set utf_8_attr x ppf 644 | 645 | type style_renderer = [ `Ansi_tty | `None ] 646 | let style_renderer_attr = 647 | let enc = function `Ansi_tty -> "A" | `None -> "N" in 648 | let dec = function "A" -> `Ansi_tty | "N" -> `None | _ -> assert false in 649 | attr enc dec 650 | 651 | let style_renderer ppf = get style_renderer_attr ppf |> def `None 652 | let set_style_renderer ppf x = set style_renderer_attr x ppf 653 | 654 | let with_buffer ?like buf = 655 | let ppf = Format.formatter_of_buffer buf in 656 | (* N.B. this does slighty more it also makes buf use other installed 657 | semantic tag actions. *) 658 | match like with 659 | | None -> ppf 660 | | Some like -> 661 | let funs = Format.pp_get_formatter_stag_functions like () in 662 | Format.pp_set_formatter_stag_functions ppf funs; 663 | ppf 664 | 665 | let str_like ppf fmt = 666 | let buf = Buffer.create 64 in 667 | let bppf = with_buffer ~like:ppf buf in 668 | let flush ppf = 669 | Format.pp_print_flush ppf (); 670 | let s = Buffer.contents buf in 671 | Buffer.reset buf; s 672 | in 673 | Format.kfprintf flush bppf fmt 674 | 675 | (* Conditional UTF-8 formatting *) 676 | 677 | let if_utf_8 pp_u pp = fun ppf v -> (if utf_8 ppf then pp_u else pp) ppf v 678 | 679 | (* Styled formatting *) 680 | 681 | type color = 682 | [ `Black | `Blue | `Cyan | `Green | `Magenta | `Red | `White | `Yellow ] 683 | 684 | type style = 685 | [ `None | `Bold | `Faint | `Italic | `Underline | `Reverse 686 | | `Fg of [ color | `Hi of color ] 687 | | `Bg of [ color | `Hi of color ] 688 | | color (** deprecated *) ] 689 | 690 | let ansi_style_code = function 691 | | `Bold -> "1" 692 | | `Faint -> "2" 693 | | `Italic -> "3" 694 | | `Underline -> "4" 695 | | `Reverse -> "7" 696 | | `Fg `Black -> "30" 697 | | `Fg `Red -> "31" 698 | | `Fg `Green -> "32" 699 | | `Fg `Yellow -> "33" 700 | | `Fg `Blue -> "34" 701 | | `Fg `Magenta -> "35" 702 | | `Fg `Cyan -> "36" 703 | | `Fg `White -> "37" 704 | | `Bg `Black -> "40" 705 | | `Bg `Red -> "41" 706 | | `Bg `Green -> "42" 707 | | `Bg `Yellow -> "43" 708 | | `Bg `Blue -> "44" 709 | | `Bg `Magenta -> "45" 710 | | `Bg `Cyan -> "46" 711 | | `Bg `White -> "47" 712 | | `Fg (`Hi `Black) -> "90" 713 | | `Fg (`Hi `Red) -> "91" 714 | | `Fg (`Hi `Green) -> "92" 715 | | `Fg (`Hi `Yellow) -> "93" 716 | | `Fg (`Hi `Blue) -> "94" 717 | | `Fg (`Hi `Magenta) -> "95" 718 | | `Fg (`Hi `Cyan) -> "96" 719 | | `Fg (`Hi `White) -> "97" 720 | | `Bg (`Hi `Black) -> "100" 721 | | `Bg (`Hi `Red) -> "101" 722 | | `Bg (`Hi `Green) -> "102" 723 | | `Bg (`Hi `Yellow) -> "103" 724 | | `Bg (`Hi `Blue) -> "104" 725 | | `Bg (`Hi `Magenta) -> "105" 726 | | `Bg (`Hi `Cyan) -> "106" 727 | | `Bg (`Hi `White) -> "107" 728 | | `None -> "0" 729 | (* deprecated *) 730 | | `Black -> "30" 731 | | `Red -> "31" 732 | | `Green -> "32" 733 | | `Yellow -> "33" 734 | | `Blue -> "34" 735 | | `Magenta -> "35" 736 | | `Cyan -> "36" 737 | | `White -> "37" 738 | 739 | let pp_sgr ppf style = 740 | Format.pp_print_as ppf 0 "\027["; 741 | Format.pp_print_as ppf 0 style; 742 | Format.pp_print_as ppf 0 "m" 743 | 744 | let curr_style = attr Fun.id Fun.id 745 | 746 | let styled style pp_v ppf v = match style_renderer ppf with 747 | | `None -> pp_v ppf v 748 | | `Ansi_tty -> 749 | let prev = match get curr_style ppf with 750 | | None -> let zero = "0" in set curr_style zero ppf; zero 751 | | Some s -> s 752 | in 753 | let here = ansi_style_code style in 754 | let curr = match style with 755 | | `None -> here 756 | | _ -> String.concat ";" [prev; here] 757 | in 758 | let finally () = set curr_style prev ppf in 759 | set curr_style curr ppf; 760 | Fun.protect ~finally @@ fun () -> 761 | pp_sgr ppf here; pp_v ppf v; pp_sgr ppf prev 762 | 763 | (* Records *) 764 | 765 | let id = Fun.id 766 | let label = styled (`Fg `Yellow) string 767 | let field ?(label = label) ?(sep = any ":@ ") l prj pp_v ppf v = 768 | pf ppf "@[<1>%a%a%a@]" label l sep () pp_v (prj v) 769 | 770 | let record ?(sep = cut) pps = vbox (concat ~sep pps) 771 | 772 | (* Converting with string converters. *) 773 | 774 | let of_to_string f ppf v = string ppf (f v) 775 | let to_to_string pp_v v = str "%a" pp_v v 776 | 777 | (* Deprecated *) 778 | 779 | let strf = str 780 | let kstrf = kstr 781 | let strf_like = str_like 782 | let always = any 783 | let unit = any 784 | let prefix pp_p pp_v ppf v = pp_p ppf (); pp_v ppf v 785 | let suffix pp_s pp_v ppf v = pp_v ppf v; pp_s ppf () 786 | let styled_unit style fmt = styled style (any fmt) 787 | 788 | (*--------------------------------------------------------------------------- 789 | Copyright (c) 2014 The fmt programmers 790 | 791 | Permission to use, copy, modify, and/or distribute this software for any 792 | purpose with or without fee is hereby granted, provided that the above 793 | copyright notice and this permission notice appear in all copies. 794 | 795 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 796 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 797 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 798 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 799 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 800 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 801 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 802 | ---------------------------------------------------------------------------*) 803 | -------------------------------------------------------------------------------- /src/fmt.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2014 The fmt programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** {!Format} pretty-printer combinators. 7 | 8 | Consult {{!nameconv}naming conventions} for your pretty-printers. 9 | 10 | {b References} 11 | {ul 12 | {- The {!Format} module documentation.} 13 | {- The required reading {!Format} module 14 | {{:https://ocaml.org/learn/tutorials/format.html}tutorial}.}} *) 15 | 16 | (** {1:stdos Standard outputs} *) 17 | 18 | val stdout : Format.formatter 19 | (** [stdout] is the standard output formatter. *) 20 | 21 | val stderr : Format.formatter 22 | (** [stderr] is the standard error formatter. *) 23 | 24 | (** {1:formatting Formatting} *) 25 | 26 | val pf : Format.formatter -> ('a, Format.formatter, unit) Stdlib.format -> 'a 27 | (** [pf] is {!Format.fprintf}. *) 28 | 29 | val pr : ('a, Format.formatter, unit) format -> 'a 30 | (** [pr] is [pf stdout]. *) 31 | 32 | val epr : ('a, Format.formatter, unit) format -> 'a 33 | (** [epr] is [pf stderr]. *) 34 | 35 | val str : ('a, Format.formatter, unit, string) format4 -> 'a 36 | (** [str] is {!Format.asprintf}. 37 | 38 | {b Note.} When using [str] {!utf_8} and {!val-style_renderer} are 39 | always respectively set to [true] and [`None]. See also 40 | {!str_like}. *) 41 | 42 | val kpf : (Format.formatter -> 'a) -> Format.formatter -> 43 | ('b, Format.formatter, unit, 'a) Stdlib.format4 -> 'b 44 | (** [kpf] is {!Format.kfprintf}. *) 45 | 46 | val kstr : 47 | (string -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> 'b 48 | (** [kstr] is like {!str} but continuation based. *) 49 | 50 | val str_like : 51 | Format.formatter -> ('a, Format.formatter, unit, string) format4 -> 'a 52 | (** [str_like ppf] is like {!str} except its {!utf_8} and {!val-style_renderer} 53 | settings are those of [ppf]. *) 54 | 55 | val with_buffer : ?like:Format.formatter -> Buffer.t -> Format.formatter 56 | (** [with_buffer ~like b] is a formatter whose {!utf_8} and 57 | {!val-style_renderer} settings are copied from those of [like] 58 | (if provided). *) 59 | 60 | val failwith : ('a, Format.formatter, unit, 'b) format4 -> 'a 61 | (** [failwith] is [kstr failwith], raises {!Stdlib.Failure} with 62 | a pretty-printed string argument. *) 63 | 64 | val failwith_notrace : ('a, Format.formatter, unit, 'b) format4 -> 'a 65 | (** [failwith_notrace] is like {!failwith} but raises with {!raise_notrace}. *) 66 | 67 | val invalid_arg : ('a, Format.formatter, unit, 'b) format4 -> 'a 68 | (** [invalid_arg] is [kstr invalid_arg], raises 69 | {!Stdlib.Invalid_argument} with a pretty-printed string argument. *) 70 | 71 | val error : ('b, Format.formatter , unit, ('a, string) result) format4 -> 'b 72 | (** [error fmt ...] is [kstr (fun s -> Error s) fmt ...] *) 73 | 74 | val error_msg : 75 | ('b, Format.formatter , unit, ('a, [> `Msg of string]) result) format4 -> 'b 76 | (** [error_msg fmt ...] is [kstr (fun s -> Error (`Msg s)) fmt ...] *) 77 | 78 | (** {1 Formatters} *) 79 | 80 | type 'a t = Format.formatter -> 'a -> unit 81 | (** The type for formatters of values of type ['a]. *) 82 | 83 | val flush : 'a t 84 | (** [flush] has the effect of {!Format.pp_print_flush} *) 85 | 86 | val nop : 'a t 87 | (** [nop] formats nothing. *) 88 | 89 | val any : (unit, Format.formatter, unit) Stdlib.format -> 'a t 90 | (** [any fmt ppf v] formats any value with the constant format [fmt]. *) 91 | 92 | val using : ('a -> 'b) -> 'b t -> 'a t 93 | (** [using f pp ppf v] ppf ppf [(f v)]. *) 94 | 95 | val const : 'a t -> 'a -> 'b t 96 | (** [const pp_v v] always formats [v] using [pp_v]. *) 97 | 98 | val if' : bool -> 'a t -> 'a t 99 | (** [if' bool pp] is [pp] if [bool] is [true] and {!nop} otherwise. *) 100 | 101 | val fmt : ('a, Format.formatter, unit) Stdlib.format -> Format.formatter -> 'a 102 | (** [fmt fmt ppf] is [pf ppf fmt]. If [fmt] is used with a single 103 | non-constant formatting directive, generates a value of type 104 | {!t}. *) 105 | 106 | (** {1:seps Separators} *) 107 | 108 | val cut : 'a t 109 | (** [cut] has the effect of {!Format.pp_print_cut}. *) 110 | 111 | val sp : 'a t 112 | (** [sp] has the effect of {!Format.pp_print_space}. *) 113 | 114 | val sps : int -> 'a t 115 | (** [sps n] has the effect of {!Format.pp_print_break}[ n 0]. *) 116 | 117 | val comma : 'a t 118 | (** [comma] is {!Fmt.any}[ ",@ "]. *) 119 | 120 | val semi : 'a t 121 | (** [semi] is {!Fmt.any}[ ";@ "]. *) 122 | 123 | (** {1:seq Sequencing} *) 124 | 125 | val append : 'a t -> 'a t -> 'a t 126 | (** [append pp_v0 pp_v1 ppf v] is [pp_v0 ppf v; pp_v1 ppf v]. *) 127 | 128 | val ( ++ ) : 'a t -> 'a t -> 'a t 129 | (** [( ++ )] is {!append}. *) 130 | 131 | val concat : ?sep:unit t -> 'a t list -> 'a t 132 | (** [concat ~sep pps] formats a value using the formaters [pps] 133 | and separting each format with [sep] (defaults to {!cut}). *) 134 | 135 | val iter : ?sep:unit t -> (('a -> unit) -> 'b -> unit) -> 'a t -> 'b t 136 | (** [iter ~sep iter pp_elt] formats the iterations of [iter] over a 137 | value using [pp_elt]. Iterations are separated by [sep] (defaults to 138 | {!cut}). *) 139 | 140 | val iter_bindings : ?sep:unit t -> (('a -> 'b -> unit) -> 'c -> unit) -> 141 | ('a * 'b) t -> 'c t 142 | (** [iter_bindings ~sep iter pp_binding] formats the iterations of 143 | [iter] over a value using [pp_binding]. Iterations are separated 144 | by [sep] (defaults to {!cut}). *) 145 | 146 | (** {1:boxes Boxes} *) 147 | 148 | val box : ?indent:int -> 'a t -> 'a t 149 | (** [box ~indent pp ppf] wraps [pp] in a pretty-printing box. The box tries to 150 | print as much as possible on every line, while emphasizing the box structure 151 | (see {!Format.pp_open_box}). Break hints that lead to a new line add 152 | [indent] to the current indentation (defaults to [0]). *) 153 | 154 | val hbox : 'a t -> 'a t 155 | (** [hbox] is like {!box} but is a horizontal box: the line is not split 156 | in this box (but may be in sub-boxes). See {!Format.pp_open_hbox}. *) 157 | 158 | val vbox : ?indent:int -> 'a t -> 'a t 159 | (** [vbox] is like {!box} but is a vertical box: every break hint leads 160 | to a new line which adds [indent] to the current indentation 161 | (defaults to [0]). See {!Format.pp_open_vbox}. *) 162 | 163 | val hvbox : ?indent:int -> 'a t -> 'a t 164 | (** [hvbox] is like {!hbox} if it fits on a single line, or like {!vbox} 165 | otherwise. See {!Format.pp_open_hvbox}. *) 166 | 167 | val hovbox : ?indent:int -> 'a t -> 'a t 168 | (** [hovbox] is a condensed {!box}. See {!Format.pp_open_hovbox}. *) 169 | 170 | (** {1:bracks Brackets} *) 171 | 172 | val parens : 'a t -> 'a t 173 | (** [parens pp_v ppf] is [pf "@[<1>(%a)@]" pp_v]. *) 174 | 175 | val brackets : 'a t -> 'a t 176 | (** [brackets pp_v ppf] is [pf "@[<1>[%a]@]" pp_v]. *) 177 | 178 | val braces : 'a t -> 'a t 179 | (** [braces pp_v ppf] is [pf "@[<1>{%a}@]" pp_v]. *) 180 | 181 | val quote : ?mark:string -> 'a t -> 'a t 182 | (** [quote ~mark pp_v ppf] is [pf "@[<1>@<1>%s%a@<1>%s@]" mark pp_v mark], 183 | [mark] defaults to ["\""], it is always counted as spanning as single 184 | column (this allows for UTF-8 encoded marks). *) 185 | 186 | (** {1:records Records} *) 187 | 188 | val id : 'a -> 'a 189 | (** [id] is {!Fun.id}. *) 190 | 191 | val field : 192 | ?label:string t -> ?sep:unit t -> string -> ('b -> 'a) -> 'a t -> 'b t 193 | (** [field ~label ~sep l prj pp_v] pretty prints a labelled field value as 194 | [pf "@[<1>%a%a%a@]" label l sep () (using prj pp_v)]. [label] defaults 195 | to [styled `Yellow string] and [sep] to [any ":@ "]. *) 196 | 197 | val record : ?sep:unit t -> 'a t list -> 'a t 198 | (** [record ~sep fields] pretty-prints a value using the concatenation of 199 | [fields], separated by [sep] (defaults to [cut]) and framed in a vertical 200 | box. *) 201 | 202 | (** {1:stdlib Stdlib types} 203 | 204 | Formatters for structures give full control to the client over the 205 | formatting process and do not wrap the formatted structures with 206 | boxes. Use the {!Dump} module to quickly format values for 207 | inspection. *) 208 | 209 | val bool : bool t 210 | (** [bool] is {!Format.pp_print_bool}. *) 211 | 212 | val int : int t 213 | (** [int ppf] is [pf ppf "%d"]. *) 214 | 215 | val nativeint : nativeint t 216 | (** [nativeint ppf] is [pf ppf "%nd"]. *) 217 | 218 | val int32 : int32 t 219 | (** [int32 ppf] is [pf ppf "%ld"]. *) 220 | 221 | val int64 : int64 t 222 | (** [int64 ppf] is [pf ppf "%Ld"]. *) 223 | 224 | val uint : int t 225 | (** [uint ppf] is [pf ppf "%u"]. *) 226 | 227 | val unativeint : nativeint t 228 | (** [unativeint ppf] is [pf ppf "%nu"]. *) 229 | 230 | val uint32 : int32 t 231 | (** [uint32 ppf] is [pf ppf "%lu"]. *) 232 | 233 | val uint64 : int64 t 234 | (** [uint64 ppf] is [pf ppf "%Lu"]. *) 235 | 236 | val float : float t 237 | (** [float ppf] is [pf ppf "%g".] *) 238 | 239 | val float_dfrac : int -> float t 240 | (** [float_dfrac d] rounds the float to the [d]th {e decimal} 241 | fractional digit and formats the result with ["%g"]. Ties are 242 | rounded towards positive infinity. The result is only defined 243 | for [0 <= d <= 16]. *) 244 | 245 | val float_dsig : int -> float t 246 | (** [float_dsig d] rounds the normalized {e decimal} significand 247 | of the float to the [d]th decimal fractional digit and formats 248 | the result with ["%g"]. Ties are rounded towards positive 249 | infinity. The result is NaN on infinities and only defined for 250 | [0 <= d <= 16]. 251 | 252 | {b Warning.} The current implementation overflows on large [d] 253 | and floats. *) 254 | 255 | val char : char t 256 | (** [char] is {!Format.pp_print_char}. *) 257 | 258 | val string : string t 259 | (** [string] is {!Format.pp_print_string}. *) 260 | 261 | val buffer : Buffer.t t 262 | (** [buffer] formats a {!Buffer.t} value's current contents. *) 263 | 264 | val exn : exn t 265 | (** [exn] formats an exception. *) 266 | 267 | val exn_backtrace : (exn * Printexc.raw_backtrace) t 268 | (** [exn_backtrace] formats an exception backtrace. *) 269 | 270 | val pair : ?sep:unit t -> 'a t -> 'b t -> ('a * 'b) t 271 | (** [pair ~sep pp_fst pp_snd] formats a pair. The first and second 272 | projection are formatted using [pp_fst] and [pp_snd] and are 273 | separated by [sep] (defaults to {!cut}). *) 274 | 275 | val option : ?none:unit t -> 'a t -> 'a option t 276 | (** [option ~none pp_v] formats an optional value. The [Some] case 277 | uses [pp_v] and [None] uses [none] (defaults to {!nop}). *) 278 | 279 | val result : ok:'a t -> error:'b t -> ('a, 'b) result t 280 | (** [result ~ok ~error] formats a result value using [ok] for the [Ok] 281 | case and [error] for the [Error] case. *) 282 | 283 | val list : ?sep:unit t -> 'a t -> 'a list t 284 | (** [list sep pp_v] formats list elements. Each element of the list is 285 | formatted in order with [pp_v]. Elements are separated by [sep] 286 | (defaults to {!cut}). If the list is empty, this is {!nop}. *) 287 | 288 | val array : ?sep:unit t -> 'a t -> 'a array t 289 | (** [array sep pp_v] formats array elements. Each element of the array 290 | is formatted in order with [pp_v]. Elements are separated by [sep] 291 | (defaults to {!cut}). If the array is empty, this is {!nop}. *) 292 | 293 | val seq : ?sep:unit t -> 'a t -> 'a Seq.t t 294 | (** [seq sep pp_v] formats sequence elements. Each element of the sequence 295 | is formatted in order with [pp_v]. Elements are separated by [sep] 296 | (defaults to {!cut}). If the sequence is empty, this is {!nop}. *) 297 | 298 | val hashtbl : ?sep:unit t -> ('a * 'b) t -> ('a, 'b) Hashtbl.t t 299 | (** [hashtbl ~sep pp_binding] formats the bindings of a hash 300 | table. Each binding is formatted with [pp_binding] and bindings 301 | are separated by [sep] (defaults to {!cut}). If the hash table has 302 | multiple bindings for a given key, all bindings are formatted, 303 | with the most recent binding first. If the hash table is empty, 304 | this is {!nop}. *) 305 | 306 | val queue : ?sep:unit t -> 'a t -> 'a Queue.t t 307 | (** [queue ~sep pp_v] formats queue elements. Each element of the 308 | queue is formatted in least recently added order with 309 | [pp_v]. Elements are separated by [sep] (defaults to {!cut}). If 310 | the queue is empty, this is {!nop}. *) 311 | 312 | val stack : ?sep:unit t -> 'a t -> 'a Stack.t t 313 | (** [stack ~sep pp_v] formats stack elements. Each element of the 314 | stack is formatted from top to bottom order with [pp_v]. Elements 315 | are separated by [sep] (defaults to {!cut}). If the stack is 316 | empty, this is {!nop}. *) 317 | 318 | (** Formatters for inspecting OCaml values. 319 | 320 | Formatters of this module dump OCaml value with little control 321 | over the representation but with good default box structures and, 322 | whenever possible, using OCaml syntax. *) 323 | module Dump : sig 324 | 325 | (** {1:stdlib Stdlib types} *) 326 | 327 | val signal : int t 328 | (** [signal] formats an OCaml {{!Sys.sigabrt}signal number} as a C 329 | POSIX 330 | {{:http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/signal.h.html} 331 | constant} or ["SIG(%d)"] the signal number is unknown. *) 332 | 333 | val uchar : Uchar.t t 334 | (** [uchar] formats an OCaml {!Uchar.t} value using only US-ASCII 335 | encoded characters according to the Unicode 336 | {{:http://www.unicode.org/versions/latest/appA.pdf}notational 337 | convention} for code points. *) 338 | 339 | val string : string t 340 | (** [string] is [pf ppf "%S"]. *) 341 | 342 | val pair : 'a t -> 'b t -> ('a * 'b) t 343 | (** [pair pp_fst pp_snd] formats an OCaml pair using [pp_fst] and [pp_snd] 344 | for the first and second projection. *) 345 | 346 | val option : 'a t -> 'a option t 347 | (** [option pp_v] formats an OCaml option using [pp_v] for the [Some] 348 | case. No parentheses are added. *) 349 | 350 | val result : ok:'a t -> error:'b t -> ('a, 'b) result t 351 | (** [result ~ok ~error] formats an OCaml result using [ok] for the [Ok] 352 | case value and [error] for the [Error] case value. No parentheses 353 | are added. *) 354 | 355 | val list : 'a t -> 'a list t 356 | (** [list pp_v] formats an OCaml list using [pp_v] for the list 357 | elements. *) 358 | 359 | val array : 'a t -> 'a array t 360 | (** [array pp_v] formats an OCaml array using [pp_v] for the array 361 | elements. *) 362 | 363 | val seq : 'a t -> 'a Seq.t t 364 | (** [seq pp_v] formats an OCaml sequence using [pp_v] for the sequence 365 | elements. *) 366 | 367 | val hashtbl : 'a t -> 'b t -> ('a, 'b) Hashtbl.t t 368 | (** [hashtbl pp_k pp_v] formats an unspecified representation of the 369 | bindings of a hash table using [pp_k] for the keys and [pp_v] 370 | for the values. If the hash table has multiple bindings for a 371 | given key, all bindings are formatted, with the most recent 372 | binding first. *) 373 | 374 | val queue : 'a t -> 'a Queue.t t 375 | (** [queue pp_v] formats an unspecified representation of an OCaml 376 | queue using [pp_v] to format its elements, in least recently added 377 | order. *) 378 | 379 | val stack : 'a t -> 'a Stack.t t 380 | (** [stack pp_v] formats an unspecified representation of an OCaml 381 | stack using [pp_v] to format its elements in top to bottom order. *) 382 | 383 | (** {1:record Records} *) 384 | 385 | val field : ?label:string t -> string -> ('b -> 'a) -> 'a t -> 'b t 386 | (** [field ~label l prj pp_v] pretty prints a named field using [label] 387 | (defaults to [styled `Yellow string]) for the label, and [using prj pp_v] 388 | for the field value. *) 389 | 390 | val record : 'a t list -> 'a t 391 | (** [record fields] pretty-prints a value using the concatenation of 392 | [fields], separated by [";@,"], framed in a vertical 393 | box and surrounded by {!braces}. *) 394 | 395 | (** {1:seq Sequencing} 396 | 397 | These are akin to {!iter} and {!iter_bindings} but 398 | delimit the sequences with {!parens}. *) 399 | 400 | val iter : (('a -> unit) -> 'b -> unit) -> 'b t -> 'a t -> 'b t 401 | (** [iter iter pp_name pp_elt] formats an unspecified representation 402 | of the iterations of [iter] over a value using [pp_elt]. The 403 | iteration is named by [pp_name]. *) 404 | 405 | val iter_bindings : (('a -> 'b -> unit) -> 'c -> unit) -> 'c t -> 'a t 406 | -> 'b t -> 'c t 407 | (** [iter_bindings ~sep iter pp_name pp_k pp_v] formats an 408 | unspecified representation of the iterations of [iter] over a 409 | value using [pp_k] and [pp_v]. The iteration is named by 410 | [pp_name]. *) 411 | end 412 | 413 | (** {1:mgs Magnitudes} *) 414 | 415 | val si_size : scale:int -> string -> int t 416 | (** [si_size ~scale unit] formats a non negative integer 417 | representing unit [unit] at scale 10{^scale * 3}, depending on 418 | its magnitude, using power of 3 419 | {{:https://www.bipm.org/en/publications/si-brochure/chapter3.html} 420 | SI prefixes} (i.e. all of them except deca, hector, deci and 421 | centi). Only US-ASCII characters are used, [µ] (10{^-6}) is 422 | written using [u]. 423 | 424 | [scale] indicates the scale 10{^scale * 3} an integer 425 | represents, for example [-1] for m[unit] (10{^-3}), [0] for 426 | [unit] (10{^0}), [1] for [kunit] (10{^3}); it must be in the 427 | range \[[-8];[8]\] or [Invalid_argument] is raised. 428 | 429 | Except at the maximal yotta scale always tries to show three 430 | digits of data with trailing fractional zeros omited. Rounds 431 | towards positive infinity (over approximates). *) 432 | 433 | val byte_size : int t 434 | (** [byte_size] is [si_size ~scale:0 "B"]. *) 435 | 436 | val bi_byte_size : int t 437 | (** [bi_byte_size] formats a byte size according to its magnitude 438 | using {{:https://en.wikipedia.org/wiki/Binary_prefix}binary prefixes} 439 | up to pebi bytes (2{^15}). *) 440 | 441 | val uint64_ns_span : int64 t 442 | (** [uint64_ns_span] formats an {e unsigned} nanosecond time span 443 | according to its magnitude using 444 | {{:http://www.bipm.org/en/publications/si-brochure/chapter3.html}SI 445 | prefixes} on seconds and 446 | {{:http://www.bipm.org/en/publications/si-brochure/table6.html}accepted 447 | non-SI units}. Years are counted in Julian years (365.25 SI-accepted days) 448 | as {{:http://www.iau.org/publications/proceedings_rules/units/}defined} 449 | by the International Astronomical Union (IAU). Only US-ASCII characters 450 | are used ([us] is used for [µs]). *) 451 | 452 | (** {1:binary Binary data} *) 453 | 454 | type 'a vec = int * (int -> 'a) 455 | (** The type for random addressable, sized sequences. Each [(n, f)] 456 | represents the sequence [f 0, ..., f (n - 1)]. *) 457 | 458 | val on_bytes : char vec t -> bytes t 459 | (** [on_bytes pp] is [pp] adapted to format (entire) [bytes]. *) 460 | 461 | val on_string : char vec t -> string t 462 | (** [on_string pp] is [pp] adapted to format (entire) [string]s. *) 463 | 464 | val ascii : ?w:int -> ?subst:unit t -> unit -> char vec t 465 | (** [ascii ~w ~subst ()] formats character sequences by printing 466 | characters in the {e printable US-ASCII range} ([[0x20];[0x7E]]) 467 | as is, and replacing the rest with [subst] (defaults to [fmt "."]). 468 | [w] causes the output to be right padded to the size of formatting 469 | at least [w] sequence elements (defaults to [0]). *) 470 | 471 | val octets : ?w:int -> ?sep:unit t -> unit -> char vec t 472 | (** [octets ~w ~sep ()] formats character sequences as hexadecimal 473 | digits. It prints groups of successive characters of unspecified 474 | length together, separated by [sep] (defaults to {!sp}). [w] 475 | causes the output to be right padded to the size of formatting at 476 | least [w] sequence elements (defaults to [0]). *) 477 | 478 | val addresses : ?addr:int t -> ?w:int -> 'a vec t -> 'a vec t 479 | (** [addresses pp] formats sequences by applying [pp] to consecutive 480 | subsequences of length [w] (defaults to 16). [addr] formats 481 | subsequence offsets (defaults to an unspecified hexadecimal 482 | format). *) 483 | 484 | val hex : ?w:int -> unit -> char vec t 485 | (** [hex ~w ()] formats character sequences as traditional hex dumps, 486 | matching the output of {e xxd} and forcing line breaks after every 487 | [w] characters (defaults to 16). *) 488 | 489 | (** {1:text Words, paragraphs, text and lines} 490 | 491 | {b Note.} These functions only work on US-ASCII strings and/or 492 | with newlines (['\n']). If you are dealing with UTF-8 strings or 493 | different kinds of line endings you should use the pretty-printers 494 | from {!Uuseg_string}. 495 | 496 | {b White space.} White space is one of the following US-ASCII 497 | characters: space [' '] ([0x20]), tab ['\t'] ([0x09]), newline 498 | ['\n'] ([0x0A]), vertical tab ([0x0B]), form feed ([0x0C]), 499 | carriage return ['\r'] ([0x0D]). *) 500 | 501 | val words : string t 502 | (** [words] formats words by suppressing initial and trailing 503 | white space and replacing consecutive white space with 504 | a single {!Format.pp_print_space}. *) 505 | 506 | val paragraphs : string t 507 | (** [paragraphs] formats paragraphs by suppressing initial and trailing 508 | spaces and newlines, replacing blank lines (a line made only 509 | of white space) by a two {!Format.pp_force_newline} and remaining 510 | consecutive white space with a single {!Format.pp_print_space}. *) 511 | 512 | val text : string t 513 | (** [text] formats text by respectively replacing spaces and newlines in 514 | the string with {!Format.pp_print_space} and {!Format.pp_force_newline}. *) 515 | 516 | val lines : string t 517 | (** [lines] formats lines by replacing newlines (['\n']) in the string 518 | with calls to {!Format.pp_force_newline}. *) 519 | 520 | val truncated : max:int -> string t 521 | (** [truncated ~max] formats a string using at most [max] 522 | characters. If the string doesn't fit, it is truncated and ended 523 | with three consecutive dots which do count towards [max]. *) 524 | 525 | val text_loc : ((int * int) * (int * int)) t 526 | (** [text_loc] formats a line-column text range according to 527 | {{:http://www.gnu.org/prep/standards/standards.html#Errors} 528 | GNU conventions}. *) 529 | 530 | (** {1:hci HCI fragments} *) 531 | 532 | val one_of : ?empty:unit t -> 'a t -> 'a list t 533 | (** [one_of ~empty pp_v ppf l] formats according to the length of [l] 534 | {ul 535 | {- [0], formats [empty] (defaults to {!nop}).} 536 | {- [1], formats the element with [pp_v].} 537 | {- [2], formats ["either %a or %a"] with the list elements} 538 | {- [n], formats ["one of %a, ... or %a"] with the list elements}} *) 539 | 540 | val did_you_mean : 541 | ?pre:unit t -> ?post:unit t -> kind:string -> 'a t -> ('a * 'a list) t 542 | (** [did_you_mean ~pre kind ~post pp_v] formats a faulty value [v] of 543 | kind [kind] and a list of [hints] that [v] could have been 544 | mistaken for. 545 | 546 | [pre] defaults to [unit "Unknown"], [post] to {!nop} they surround 547 | the faulty value before the "did you mean" part as follows ["%a %s 548 | %a%a." pre () kind pp_v v post ()]. If [hints] is empty no "did 549 | you mean" part is printed. *) 550 | 551 | (** {1:utf8_cond Conditional UTF-8 formatting} 552 | 553 | {b Note.} Since {!Format} is not UTF-8 aware using UTF-8 output 554 | may derail the pretty printing process. Use the pretty-printers 555 | from {!Uuseg_string} if you are serious about UTF-8 formatting. *) 556 | 557 | val if_utf_8 : 'a t -> 'a t -> 'a t 558 | (** [if_utf_8 pp_u pp ppf v] is: 559 | {ul 560 | {- [pp_u ppf v] if [utf_8 ppf] is [true].} 561 | {- [pp ppf v] otherwise.}} *) 562 | 563 | val utf_8 : Format.formatter -> bool 564 | (** [utf_8 ppf] is [true] if UTF-8 output is enabled on [ppf]. If 565 | {!set_utf_8} hasn't been called on [ppf] this is [true]. *) 566 | 567 | val set_utf_8 : Format.formatter -> bool -> unit 568 | (** [set_utf_8 ppf b] enables or disables conditional UTF-8 formatting 569 | on [ppf]. 570 | 571 | @raise Invalid_argument if [ppf] is {!Format.str_formatter}: it is 572 | is always UTF-8 enabled. *) 573 | 574 | (** {1:styled Styled formatting} *) 575 | 576 | type color = 577 | [ `Black | `Blue | `Cyan | `Green | `Magenta | `Red | `White | `Yellow ] 578 | (** The type for colors. *) 579 | 580 | type style = 581 | [ `None | `Bold | `Faint | `Italic | `Underline | `Reverse 582 | | `Fg of [ color | `Hi of color ] 583 | | `Bg of [ color | `Hi of color ] 584 | | color (** deprecated *) ] 585 | (** The type for styles: 586 | {ul 587 | {- [`None] resets the styling.} 588 | {- [`Bold], [`Faint], [`Italic], [`Underline] and [`Reverse] are 589 | display attributes.} 590 | {- [`Fg _] is the foreground color or high-intensity color on [`Hi _].} 591 | {- [`Bg _] is the background color or high-intensity color on [`Hi _].} 592 | {- [#color] is the foreground color, {b deprecated} use [`Fg 593 | #color] instead.}} *) 594 | 595 | val styled : style -> 'a t -> 'a t 596 | (** [styled s pp] formats like [pp] but styled with [s]. *) 597 | 598 | (** {2 Style rendering control} *) 599 | 600 | type style_renderer = [ `Ansi_tty | `None ] 601 | (** The type for style renderers. 602 | {ul 603 | {- [`Ansi_tty], renders styles using 604 | {{:http://www.ecma-international.org/publications/standards/Ecma-048.htm} 605 | ANSI escape sequences}.} 606 | {- [`None], styled rendering has no effect.}} *) 607 | 608 | val style_renderer : Format.formatter -> style_renderer 609 | (** [style_renderer ppf] is the style renderer used by [ppf]. If 610 | {!set_style_renderer} has never been called on [ppf] this is 611 | [`None]. *) 612 | 613 | val set_style_renderer : Format.formatter -> style_renderer -> unit 614 | (** [set_style_renderer ppf r] sets the style renderer of [ppf] to [r]. 615 | 616 | @raise Invalid_argument if [ppf] is {!Format.str_formatter}: its 617 | renderer is always [`None]. *) 618 | 619 | (** {1:stringconverters Converting with string value converters} *) 620 | 621 | val of_to_string : ('a -> string) -> 'a t 622 | (** [of_to_string f ppf v] is [string ppf (f v)]. *) 623 | 624 | val to_to_string : 'a t -> 'a -> string 625 | (** [to_to_string pp_v v] is [strf "%a" pp_v v]. *) 626 | 627 | (** {1:deprecated Deprecated} *) 628 | 629 | val strf : ('a, Format.formatter, unit, string) format4 -> 'a 630 | [@@ocaml.deprecated "use Fmt.str instead."] 631 | (** @deprecated use {!str} instead. *) 632 | 633 | val kstrf : (string -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> 'b 634 | [@@ocaml.deprecated "use Fmt.kstr instead."] 635 | (** @deprecated use {!kstr} instead. *) 636 | 637 | val strf_like : 638 | Format.formatter -> ('a, Format.formatter, unit, string) format4 -> 'a 639 | [@@ocaml.deprecated "use Fmt.str_like instead."] 640 | (** @deprecated use {!str_like} instead. *) 641 | 642 | val always : (unit, Format.formatter, unit) Stdlib.format -> 'a t 643 | [@@ocaml.deprecated "use Fmt.any instead."] 644 | (** @deprecated use {!any} instead. *) 645 | 646 | val unit : (unit, Format.formatter, unit) Stdlib.format -> unit t 647 | [@@ocaml.deprecated "use Fmt.any instead."] 648 | (** @deprecated use {!any}. *) 649 | 650 | val prefix : unit t -> 'a t -> 'a t 651 | [@@ocaml.deprecated "use Fmt.(++) instead."] 652 | (** @deprecated use {!( ++ )}. *) 653 | 654 | val suffix : unit t -> 'a t -> 'a t 655 | [@@ocaml.deprecated "use Fmt.(++) instead."] 656 | (** @deprecated use {!( ++ )}. *) 657 | 658 | val styled_unit : 659 | style -> (unit, Format.formatter, unit) Stdlib.format -> unit t 660 | [@@ocaml.deprecated "use Fmt.(styled s (any fmt)) instead."] 661 | (** @deprecated use [styled s (any fmt)] instead *) 662 | 663 | (** {1:nameconv Naming conventions} 664 | 665 | Given a type [ty] use: 666 | 667 | {ul 668 | {- [pp_ty] for a pretty printer that provides full control to the 669 | client and does not wrap the formatted value in an enclosing 670 | box. See {{!stdlib}these examples}.} 671 | {- [pp_dump_ty] for a pretty printer that provides little control 672 | over the pretty-printing process, wraps the rendering in an 673 | enclosing box and tries as much as possible to respect the 674 | OCaml syntax. These pretty-printers should make it easy to 675 | inspect and understand values of the given type, they are 676 | mainly used for quick printf debugging and/or toplevel interaction. 677 | See {{!Fmt.Dump.stdlib}these examples}.}} 678 | 679 | If you are in a situation where making a difference between [dump_ty] 680 | and [pp_ty] doesn't make sense then use [pp_ty]. 681 | 682 | For a type [ty] that is the main type of the module (the "[M.t]" 683 | convention) drop the suffix, that is simply use [M.pp] and 684 | [M.pp_dump]. *) 685 | 686 | (*--------------------------------------------------------------------------- 687 | Copyright (c) 2014 The fmt programmers 688 | 689 | Permission to use, copy, modify, and/or distribute this software for any 690 | purpose with or without fee is hereby granted, provided that the above 691 | copyright notice and this permission notice appear in all copies. 692 | 693 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 694 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 695 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 696 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 697 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 698 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 699 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 700 | ---------------------------------------------------------------------------*) 701 | -------------------------------------------------------------------------------- /src/fmt.mllib: -------------------------------------------------------------------------------- 1 | Fmt 2 | -------------------------------------------------------------------------------- /src/top/fmt_top.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fmt programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | let () = ignore (Toploop.use_file Format.err_formatter "fmt_tty_top_init.ml") 7 | 8 | (*--------------------------------------------------------------------------- 9 | Copyright (c) 2015 The fmt programmers 10 | 11 | Permission to use, copy, modify, and/or distribute this software for any 12 | purpose with or without fee is hereby granted, provided that the above 13 | copyright notice and this permission notice appear in all copies. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 16 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 17 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 18 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 19 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 20 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 21 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 22 | ---------------------------------------------------------------------------*) 23 | -------------------------------------------------------------------------------- /src/top/fmt_top.mllib: -------------------------------------------------------------------------------- 1 | Fmt_top -------------------------------------------------------------------------------- /src/top/fmt_tty_top_init.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fmt programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | let () = Fmt_tty.setup_std_outputs () 7 | 8 | (*--------------------------------------------------------------------------- 9 | Copyright (c) 2015 The fmt programmers 10 | 11 | Permission to use, copy, modify, and/or distribute this software for any 12 | purpose with or without fee is hereby granted, provided that the above 13 | copyright notice and this permission notice appear in all copies. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 16 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 17 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 18 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 19 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 20 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 21 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 22 | ---------------------------------------------------------------------------*) 23 | -------------------------------------------------------------------------------- /src/tty/fmt_tty.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fmt programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | let is_infix ~affix s = 7 | (* Damned, already missing astring, from which this is c&p *) 8 | let len_a = String.length affix in 9 | let len_s = String.length s in 10 | if len_a > len_s then false else 11 | let max_idx_a = len_a - 1 in 12 | let max_idx_s = len_s - len_a in 13 | let rec loop i k = 14 | if i > max_idx_s then false else 15 | if k > max_idx_a then true else 16 | if k > 0 then 17 | if String.get affix k = String.get s (i + k) then loop i (k + 1) else 18 | loop (i + 1) 0 19 | else if String.get affix 0 = String.get s i then loop i 1 else 20 | loop (i + 1) 0 21 | in 22 | loop 0 0 23 | 24 | let setup ?style_renderer ?utf_8 oc = 25 | let ppf = 26 | if oc == Stdlib.stdout then Fmt.stdout else 27 | if oc == Stdlib.stderr then Fmt.stderr else 28 | Format.formatter_of_out_channel oc 29 | in 30 | let style_renderer = match style_renderer with 31 | | Some r -> r 32 | | None -> 33 | let dumb = 34 | try match Sys.getenv "TERM" with 35 | | "dumb" | "" -> true 36 | | _ -> false 37 | with 38 | Not_found -> true 39 | in 40 | let isatty = try Unix.(isatty (descr_of_out_channel oc)) with 41 | | Unix.Unix_error _ -> false 42 | in 43 | if not dumb && isatty then `Ansi_tty else `None 44 | in 45 | let utf_8 = match utf_8 with 46 | | Some b -> b 47 | | None -> 48 | let has_utf_8 var = 49 | try is_infix ~affix:"UTF-8" (String.uppercase_ascii (Sys.getenv var)) 50 | with Not_found -> false 51 | in 52 | has_utf_8 "LANG" || has_utf_8 "LC_ALL" || has_utf_8 "LC_CTYPE" 53 | in 54 | Fmt.set_style_renderer ppf style_renderer; 55 | Fmt.set_utf_8 ppf utf_8; 56 | ppf 57 | 58 | let setup_std_outputs ?style_renderer ?utf_8 () = 59 | ignore (setup ?style_renderer ?utf_8 stdout); 60 | ignore (setup ?style_renderer ?utf_8 stderr); 61 | () 62 | 63 | (*--------------------------------------------------------------------------- 64 | Copyright (c) 2015 The fmt programmers 65 | 66 | Permission to use, copy, modify, and/or distribute this software for any 67 | purpose with or without fee is hereby granted, provided that the above 68 | copyright notice and this permission notice appear in all copies. 69 | 70 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 71 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 72 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 73 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 74 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 75 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 76 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 77 | ---------------------------------------------------------------------------*) 78 | -------------------------------------------------------------------------------- /src/tty/fmt_tty.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fmt programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** [Fmt] TTY setup. 7 | 8 | [Fmt_tty] provides simple automatic setup on channel formatters for: 9 | {ul 10 | {- {!Fmt.set_style_renderer}. [`Ansi_tty] is used if the channel 11 | {{!Unix.isatty}is a tty} and the environment variable 12 | [TERM] is defined and its value is not ["dumb"]. [`None] is 13 | used otherwise.} 14 | {- {!Fmt.set_utf_8}. [true] is used if one of the following 15 | environment variables has ["UTF-8"] as a case insensitive 16 | substring: [LANG], [LC_ALL], [LC_CTYPE].}} *) 17 | 18 | (** {1:tty_setup TTY setup} *) 19 | 20 | val setup : ?style_renderer:Fmt.style_renderer -> ?utf_8:bool -> 21 | out_channel -> Format.formatter 22 | (** [setup ?style_renderer ?utf_8 outc] is a formatter for [outc] with 23 | {!Fmt.set_style_renderer} and {!Fmt.set_utf_8} correctly setup. If 24 | [style_renderer] or [utf_8] are specified they override the automatic 25 | setup. 26 | 27 | If [outc] is {!stdout}, {!Fmt.stdout} is returned. If [outc] is 28 | {!stderr}, {!Fmt.stderr} is returned. *) 29 | 30 | val setup_std_outputs : ?style_renderer:Fmt.style_renderer -> ?utf_8:bool -> 31 | unit -> unit 32 | (** [setup_std_outputs ?style_renderer ?utf_8 ()] applies {!setup} 33 | on {!stdout} and {!stderr}. *) 34 | 35 | (*--------------------------------------------------------------------------- 36 | Copyright (c) 2015 The fmt programmers 37 | 38 | Permission to use, copy, modify, and/or distribute this software for any 39 | purpose with or without fee is hereby granted, provided that the above 40 | copyright notice and this permission notice appear in all copies. 41 | 42 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 43 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 44 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 45 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 46 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 47 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 48 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 49 | ---------------------------------------------------------------------------*) 50 | -------------------------------------------------------------------------------- /src/tty/fmt_tty.mllib: -------------------------------------------------------------------------------- 1 | Fmt_tty 2 | -------------------------------------------------------------------------------- /test/styled_perf_bug.ml: -------------------------------------------------------------------------------- 1 | let n = 10000 2 | 3 | let () = 4 | while true do 5 | let t0 = Unix.gettimeofday () in 6 | for _i = 1 to n do 7 | ignore @@ Fmt.str "Hello %a" Fmt.string "world" 8 | done; 9 | let t1 = Unix.gettimeofday () in 10 | Printf.printf "Formatted %.0f messages/second\n%!" (float n /. (t1 -. t0)) 11 | done 12 | -------------------------------------------------------------------------------- /test/test_fmt.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2015 The fmt programmers. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | ---------------------------------------------------------------------------*) 5 | 6 | (* 7 | let test_exn_backtrace () = (* Don't move this test in the file. *) 8 | try failwith "Test" with 9 | | ex -> 10 | let bt = Printexc.get_raw_backtrace () in 11 | let fmt = Fmt.strf "%a" Fmt.exn_backtrace (ex,bt) in 12 | assert begin match Printexc.backtrace_status () with 13 | | false -> fmt = "Exception: Failure(\"Test\")\nNo backtrace available." 14 | | true -> 15 | fmt = "Exception: Failure(\"Test\")\n\ 16 | Raised at file \"pervasives.ml\", line 32, characters 22-33\n\ 17 | Called from file \"test/test.ml\", line 8, characters 6-21" 18 | end 19 | *) 20 | 21 | let test_dump_uchar () = 22 | let str u = Format.asprintf "%a" Fmt.Dump.uchar u in 23 | assert (str Uchar.min = "U+0000"); 24 | assert (str Uchar.(succ min) = "U+0001"); 25 | assert (str Uchar.(of_int 0xFFFF) = "U+FFFF"); 26 | assert (str Uchar.(succ (of_int 0xFFFF)) = "U+10000"); 27 | assert (str Uchar.(pred max) = "U+10FFFE"); 28 | assert (str Uchar.max = "U+10FFFF"); 29 | () 30 | 31 | let test_utf_8 () = 32 | let ppf = Format.formatter_of_buffer (Buffer.create 23) in 33 | assert (Fmt.utf_8 ppf = true); 34 | Fmt.set_utf_8 ppf false; 35 | assert (Fmt.utf_8 ppf = false); 36 | Fmt.set_utf_8 ppf true; 37 | assert (Fmt.utf_8 ppf = true); 38 | () 39 | 40 | let test_style_renderer () = 41 | let ppf = Format.formatter_of_buffer (Buffer.create 23) in 42 | assert (Fmt.style_renderer ppf = `None); 43 | Fmt.set_style_renderer ppf `Ansi_tty; 44 | assert (Fmt.style_renderer ppf = `Ansi_tty); 45 | Fmt.set_style_renderer ppf `None; 46 | assert (Fmt.style_renderer ppf = `None); 47 | () 48 | 49 | let test_exn_typechecks () = 50 | let (_ : bool) = true || Fmt.failwith "%s" "" in 51 | let (_ : bool) = true || Fmt.invalid_arg "%s" "" in 52 | () 53 | 54 | let test_kstr_str_like_partial_app () = 55 | let assertf f = assert (f "X" = f "X") in 56 | let test_kstrf fmt = Fmt.kstr (fun x -> x) fmt in 57 | let test_strf_like fmt = Fmt.str_like Fmt.stderr fmt in 58 | assertf (test_strf_like "%s"); 59 | assertf (test_kstrf "%s"); 60 | () 61 | 62 | 63 | let test_byte_size () = 64 | let size s = Fmt.str "%a" Fmt.byte_size s in 65 | assert (size 0 = "0B"); 66 | assert (size 999 = "999B"); 67 | assert (size 1000 = "1kB"); 68 | assert (size 1001 = "1.01kB"); 69 | assert (size 1010 = "1.01kB"); 70 | assert (size 1011 = "1.02kB"); 71 | assert (size 1020 = "1.02kB"); 72 | assert (size 1100 = "1.1kB"); 73 | assert (size 1101 = "1.11kB"); 74 | assert (size 1109 = "1.11kB"); 75 | assert (size 1111 = "1.12kB"); 76 | assert (size 1119 = "1.12kB"); 77 | assert (size 1120 = "1.12kB"); 78 | assert (size 1121 = "1.13kB"); 79 | assert (size 9990 = "9.99kB"); 80 | assert (size 9991 = "10kB"); 81 | assert (size 9999 = "10kB"); 82 | assert (size 10_000 = "10kB"); 83 | assert (size 10_001 = "10.1kB"); 84 | assert (size 10_002 = "10.1kB"); 85 | assert (size 10_099 = "10.1kB"); 86 | assert (size 10_100 = "10.1kB"); 87 | assert (size 10_100 = "10.1kB"); 88 | assert (size 10_101 = "10.2kB"); 89 | assert (size 10_199 = "10.2kB"); 90 | assert (size 10_199 = "10.2kB"); 91 | assert (size 10_200 = "10.2kB"); 92 | assert (size 10_201 = "10.3kB"); 93 | assert (size 99_901 = "100kB"); 94 | assert (size 99_999 = "100kB"); 95 | assert (size 100_000 = "100kB"); 96 | assert (size 100_001 = "101kB"); 97 | assert (size 100_999 = "101kB"); 98 | assert (size 101_000 = "101kB"); 99 | assert (size 101_001 = "102kB"); 100 | assert (size 999_000 = "999kB"); 101 | assert (size 999_001 = "1MB"); 102 | assert (size 999_999 = "1MB"); 103 | assert (size 1_000_000 = "1MB"); 104 | assert (size 1_000_001 = "1.01MB"); 105 | assert (size 1_009_999 = "1.01MB"); 106 | assert (size 1_010_000 = "1.01MB"); 107 | assert (size 1_010_001 = "1.02MB"); 108 | assert (size 1_019_999 = "1.02MB"); 109 | assert (size 1_020_000 = "1.02MB"); 110 | assert (size 1_020_001 = "1.03MB"); 111 | assert (size 1_990_000 = "1.99MB"); 112 | assert (size 1_990_001 = "2MB"); 113 | assert (size 1_999_999 = "2MB"); 114 | assert (size 2_000_000 = "2MB"); 115 | assert (size 9_990_000 = "9.99MB"); 116 | assert (size 9_990_001 = "10MB"); 117 | assert (size 9_990_999 = "10MB"); 118 | assert (size 10_000_000 = "10MB"); 119 | assert (size 10_000_001 = "10.1MB"); 120 | assert (size 10_099_999 = "10.1MB"); 121 | assert (size 10_100_000 = "10.1MB"); 122 | assert (size 10_900_001 = "11MB"); 123 | assert (size 10_999_999 = "11MB"); 124 | assert (size 11_000_000 = "11MB"); 125 | assert (size 11_000_001 = "11.1MB"); 126 | assert (size 99_900_000 = "99.9MB"); 127 | assert (size 99_900_001 = "100MB"); 128 | assert (size 99_999_999 = "100MB"); 129 | assert (size 100_000_000 = "100MB"); 130 | assert (size 100_000_001 = "101MB"); 131 | assert (size 100_999_999 = "101MB"); 132 | assert (size 101_000_000 = "101MB"); 133 | assert (size 101_000_000 = "101MB"); 134 | assert (size 999_000_000 = "999MB"); 135 | assert (size 999_000_001 = "1GB"); 136 | assert (size 999_999_999 = "1GB"); 137 | assert (size 1_000_000_000 = "1GB"); 138 | assert (size 1_000_000_001 = "1.01GB"); 139 | assert (size 1_000_000_001 = "1.01GB"); 140 | () 141 | 142 | let test_uint64_ns_span () = 143 | let span s = Fmt.str "%a" Fmt.uint64_ns_span (Int64.of_string s) in 144 | assert (span "0u0" = "0ns"); 145 | assert (span "0u999" = "999ns"); 146 | assert (span "0u1_000" = "1us"); 147 | assert (span "0u1_001" = "1.01us"); 148 | assert (span "0u1_009" = "1.01us"); 149 | assert (span "0u1_010" = "1.01us"); 150 | assert (span "0u1_011" = "1.02us"); 151 | assert (span "0u1_090" = "1.09us"); 152 | assert (span "0u1_091" = "1.1us"); 153 | assert (span "0u1_100" = "1.1us"); 154 | assert (span "0u1_101" = "1.11us"); 155 | assert (span "0u1_109" = "1.11us"); 156 | assert (span "0u1_110" = "1.11us"); 157 | assert (span "0u1_111" = "1.12us"); 158 | assert (span "0u1_990" = "1.99us"); 159 | assert (span "0u1_991" = "2us"); 160 | assert (span "0u1_999" = "2us"); 161 | assert (span "0u2_000" = "2us"); 162 | assert (span "0u2_001" = "2.01us"); 163 | assert (span "0u9_990" = "9.99us"); 164 | assert (span "0u9_991" = "10us"); 165 | assert (span "0u9_999" = "10us"); 166 | assert (span "0u10_000" = "10us"); 167 | assert (span "0u10_001" = "10.1us"); 168 | assert (span "0u10_099" = "10.1us"); 169 | assert (span "0u10_100" = "10.1us"); 170 | assert (span "0u10_101" = "10.2us"); 171 | assert (span "0u10_900" = "10.9us"); 172 | assert (span "0u10_901" = "11us"); 173 | assert (span "0u10_999" = "11us"); 174 | assert (span "0u11_000" = "11us"); 175 | assert (span "0u11_001" = "11.1us"); 176 | assert (span "0u11_099" = "11.1us"); 177 | assert (span "0u11_100" = "11.1us"); 178 | assert (span "0u11_101" = "11.2us"); 179 | assert (span "0u99_900" = "99.9us"); 180 | assert (span "0u99_901" = "100us"); 181 | assert (span "0u99_999" = "100us"); 182 | assert (span "0u100_000" = "100us"); 183 | assert (span "0u100_001" = "101us"); 184 | assert (span "0u100_999" = "101us"); 185 | assert (span "0u101_000" = "101us"); 186 | assert (span "0u101_001" = "102us"); 187 | assert (span "0u101_999" = "102us"); 188 | assert (span "0u102_000" = "102us"); 189 | assert (span "0u999_000" = "999us"); 190 | assert (span "0u999_001" = "1ms"); 191 | assert (span "0u999_001" = "1ms"); 192 | assert (span "0u999_999" = "1ms"); 193 | assert (span "0u1_000_000" = "1ms"); 194 | assert (span "0u1_000_001" = "1.01ms"); 195 | assert (span "0u1_009_999" = "1.01ms"); 196 | assert (span "0u1_010_000" = "1.01ms"); 197 | assert (span "0u1_010_001" = "1.02ms"); 198 | assert (span "0u9_990_000" = "9.99ms"); 199 | assert (span "0u9_990_001" = "10ms"); 200 | assert (span "0u9_999_999" = "10ms"); 201 | assert (span "0u10_000_000" = "10ms"); 202 | assert (span "0u10_000_001" = "10.1ms"); 203 | assert (span "0u10_000_001" = "10.1ms"); 204 | assert (span "0u10_099_999" = "10.1ms"); 205 | assert (span "0u10_100_000" = "10.1ms"); 206 | assert (span "0u10_100_001" = "10.2ms"); 207 | assert (span "0u99_900_000" = "99.9ms"); 208 | assert (span "0u99_900_001" = "100ms"); 209 | assert (span "0u99_999_999" = "100ms"); 210 | assert (span "0u100_000_000" = "100ms"); 211 | assert (span "0u100_000_001" = "101ms"); 212 | assert (span "0u100_999_999" = "101ms"); 213 | assert (span "0u101_000_000" = "101ms"); 214 | assert (span "0u101_000_001" = "102ms"); 215 | assert (span "0u999_000_000" = "999ms"); 216 | assert (span "0u999_000_001" = "1s"); 217 | assert (span "0u999_999_999" = "1s"); 218 | assert (span "0u1_000_000_000" = "1s"); 219 | assert (span "0u1_000_000_001" = "1.01s"); 220 | assert (span "0u1_009_999_999" = "1.01s"); 221 | assert (span "0u1_010_000_000" = "1.01s"); 222 | assert (span "0u1_010_000_001" = "1.02s"); 223 | assert (span "0u1_990_000_000" = "1.99s"); 224 | assert (span "0u1_990_000_001" = "2s"); 225 | assert (span "0u1_999_999_999" = "2s"); 226 | assert (span "0u2_000_000_000" = "2s"); 227 | assert (span "0u2_000_000_001" = "2.01s"); 228 | assert (span "0u9_990_000_000" = "9.99s"); 229 | assert (span "0u9_999_999_999" = "10s"); 230 | assert (span "0u10_000_000_000" = "10s"); 231 | assert (span "0u10_000_000_001" = "10.1s"); 232 | assert (span "0u10_099_999_999" = "10.1s"); 233 | assert (span "0u10_100_000_000" = "10.1s"); 234 | assert (span "0u10_100_000_001" = "10.2s"); 235 | assert (span "0u59_900_000_000" = "59.9s"); 236 | assert (span "0u59_900_000_001" = "1min"); 237 | assert (span "0u59_999_999_999" = "1min"); 238 | assert (span "0u60_000_000_000" = "1min"); 239 | assert (span "0u60_000_000_001" = "1min1s"); 240 | assert (span "0u60_999_999_999" = "1min1s"); 241 | assert (span "0u61_000_000_000" = "1min1s"); 242 | assert (span "0u61_000_000_001" = "1min2s"); 243 | assert (span "0u119_000_000_000" = "1min59s"); 244 | assert (span "0u119_000_000_001" = "2min"); 245 | assert (span "0u119_999_999_999" = "2min"); 246 | assert (span "0u120_000_000_000" = "2min"); 247 | assert (span "0u120_000_000_001" = "2min1s"); 248 | assert (span "0u3599_000_000_000" = "59min59s"); 249 | assert (span "0u3599_000_000_001" = "1h"); 250 | assert (span "0u3599_999_999_999" = "1h"); 251 | assert (span "0u3600_000_000_000" = "1h"); 252 | assert (span "0u3600_000_000_001" = "1h1min"); 253 | assert (span "0u3659_000_000_000" = "1h1min"); 254 | assert (span "0u3659_000_000_001" = "1h1min"); 255 | assert (span "0u3659_999_999_999" = "1h1min"); 256 | assert (span "0u3660_000_000_000" = "1h1min"); 257 | assert (span "0u3660_000_000_001" = "1h2min"); 258 | assert (span "0u3660_000_000_001" = "1h2min"); 259 | assert (span "0u3660_000_000_001" = "1h2min"); 260 | assert (span "0u3720_000_000_000" = "1h2min"); 261 | assert (span "0u3720_000_000_001" = "1h3min"); 262 | assert (span "0u7140_000_000_000" = "1h59min"); 263 | assert (span "0u7140_000_000_001" = "2h"); 264 | assert (span "0u7199_999_999_999" = "2h"); 265 | assert (span "0u7200_000_000_000" = "2h"); 266 | assert (span "0u7200_000_000_001" = "2h1min"); 267 | assert (span "0u86340_000_000_000" = "23h59min"); 268 | assert (span "0u86340_000_000_001" = "1d"); 269 | assert (span "0u86400_000_000_000" = "1d"); 270 | assert (span "0u86400_000_000_001" = "1d1h"); 271 | assert (span "0u89999_999_999_999" = "1d1h"); 272 | assert (span "0u90000_000_000_000" = "1d1h"); 273 | assert (span "0u90000_000_000_001" = "1d2h"); 274 | assert (span "0u169200_000_000_000" = "1d23h"); 275 | assert (span "0u169200_000_000_001" = "2d"); 276 | assert (span "0u169200_000_000_001" = "2d"); 277 | assert (span "0u172799_999_999_999" = "2d"); 278 | assert (span "0u172800_000_000_000" = "2d"); 279 | assert (span "0u172800_000_000_001" = "2d1h"); 280 | assert (span "0u31536000_000_000_000" = "365d"); 281 | assert (span "0u31554000_000_000_000" = "365d5h"); 282 | assert ( 283 | (* Technically this should round to a year but it does get rendered. 284 | I don't think it matters, it's not inacurate per se. *) 285 | span "0u31554000_000_000_001" = "365d6h"); 286 | assert (span "0u31557600_000_000_000" = "1a"); 287 | assert (span "0u31557600_000_000_001" = "1a1d"); 288 | assert (span "0u63028800_000_000_000" = "1a365d"); 289 | assert (span "0u63093600_000_000_000" = "1a365d"); 290 | assert (span "0u63093600_000_000_001" = "2a"); 291 | assert (span "0u63115200_000_000_000" = "2a"); 292 | assert (span "0u63115200_000_000_001" = "2a1d"); 293 | () 294 | 295 | let tests () = 296 | test_dump_uchar (); 297 | test_utf_8 (); 298 | test_style_renderer (); 299 | test_kstr_str_like_partial_app (); 300 | test_byte_size (); 301 | test_uint64_ns_span (); 302 | Printf.printf "Done.\n"; 303 | () 304 | 305 | let () = tests () 306 | 307 | (*--------------------------------------------------------------------------- 308 | Copyright (c) 2015 The fmt programmers 309 | 310 | Permission to use, copy, modify, and/or distribute this software for any 311 | purpose with or without fee is hereby granted, provided that the above 312 | copyright notice and this permission notice appear in all copies. 313 | 314 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 315 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 316 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 317 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 318 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 319 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 320 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 321 | ---------------------------------------------------------------------------*) 322 | --------------------------------------------------------------------------------