diff --git a/examples/lwt_reporter/dune-project b/examples/lwt_reporter/dune-project new file mode 100644 index 0000000..bd8917e --- /dev/null +++ b/examples/lwt_reporter/dune-project @@ -0,0 +1,23 @@ +(lang dune 3.3) + +(name lwt_reporter_example) + +(generate_opam_files true) + +(license ISC) + +(package + (name lwt_reporter_example) + (synopsis "example") + (depends + (cmdliner + (= 1.1.1)) + (conf-libev + (>= 4-12)) + (dune + (>= 3.4.1)) + (logs + (= 0.7.0)) + (lwt + (>= 5.6.1)) + )) diff --git a/examples/lwt_reporter/lwt_reporter_example.opam b/examples/lwt_reporter/lwt_reporter_example.opam new file mode 100644 index 0000000..b7443d1 --- /dev/null +++ b/examples/lwt_reporter/lwt_reporter_example.opam @@ -0,0 +1,26 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "example" +license: "ISC" +depends: [ + "cmdliner" {= "1.1.1"} + "conf-libev" {>= "4-12"} + "dune" {>= "3.3" & >= "3.4.1"} + "logs" {= "0.7.0"} + "lwt" {>= "5.6.1"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] diff --git a/examples/lwt_reporter/src/bin/dune b/examples/lwt_reporter/src/bin/dune new file mode 100644 index 0000000..bd0a83c --- /dev/null +++ b/examples/lwt_reporter/src/bin/dune @@ -0,0 +1,16 @@ +(executables + (package lwt_reporter_example) + (names main) + (public_names main) + (libraries + lwt_reporter_example + cmdliner + fmt + fmt.cli + fmt.tty + logs + logs.cli + logs.fmt + logs.lwt + lwt.unix + lwt)) diff --git a/examples/lwt_reporter/src/bin/main.ml b/examples/lwt_reporter/src/bin/main.ml new file mode 100644 index 0000000..93e2b96 --- /dev/null +++ b/examples/lwt_reporter/src/bin/main.ml @@ -0,0 +1,88 @@ +[@@@ocaml.warning "-unused-var-strict"] +[@@@ocaml.warning "-unused-field"] + +open Cmdliner + +(* https://erratique.ch/software/logs/doc/Logs_lwt/index.html#report_ex *) +let lwt_reporter () = + let buf_fmt ~like = + let b = Buffer.create 512 in + ( Fmt.with_buffer ~like b, + fun () -> + let m = Buffer.contents b in + Buffer.reset b; + m ) + in + let app, app_flush = buf_fmt ~like:Fmt.stdout in + let dst, dst_flush = buf_fmt ~like:Fmt.stderr in + let report (src : Logs.Src.t) level ~over k msgf = + let k _ = + let write () = + match level with + | Logs.App -> Lwt_io.write Lwt_io.stdout (app_flush ()) + | _ -> Lwt_io.write Lwt_io.stderr (dst_flush ()) + in + let unblock () = + over (); + Lwt.return_unit + in + Lwt.finalize write unblock |> Lwt.ignore_result; + k () (* this is 'k' from 'report' not 'k ()' *) + in + (* Adapted from https://erratique.ch/software/logs/doc/Logs/index.html#ex1 *) + let with_source h k ppf fmt = + Format.kfprintf k ppf + ("%a [%s] @[" ^^ fmt ^^ "@]@.") + Logs_fmt.pp_header (level, h) (Logs.Src.name src) + in + match level with + | Logs.App -> msgf @@ fun ?header ?tags fmt -> with_source header k app fmt + | _ -> msgf @@ fun ?header ?tags fmt -> with_source header k dst fmt + in + { Logs.report } + +(* Inspired by + https://github.com/mjambon/cmdliner-cheatsheet/blob/main/src/Demo_arg_main.ml *) + +type conf = { + name : string; + log : unit; +} + +let name_term = + let default = "John Doe" in + let info = + Arg.info + [ "N"; "name" ] (* '-N' and '--name' will be synonyms *) + ~docv:"NAME" ~doc:"Name to print" + in + Arg.value (Arg.opt Arg.string default info) + +let setup_log style_renderer level = + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (lwt_reporter ()); + () + +let setup_log_term = + Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) + +let conf_term run = + let combine name log = + let conf = { name; log } in + run conf + in + Term.(const combine $ name_term $ setup_log_term) + +let parse_command_line_and_run run = + let info = + Cmd.info "lwt-reporter-example" + (* program name as it will appear in --help *) + in + Cmd.v info (conf_term run) |> Cmd.eval |> Stdlib.exit + +let main conf = + Logs.info (fun m -> m "My name is: %s" conf.name); + Lwt_reporter_example.A_module.log_name conf.name + +let () = parse_command_line_and_run main diff --git a/examples/lwt_reporter/src/lib/a_module.ml b/examples/lwt_reporter/src/lib/a_module.ml new file mode 100644 index 0000000..3755009 --- /dev/null +++ b/examples/lwt_reporter/src/lib/a_module.ml @@ -0,0 +1,5 @@ +let src = Logs.Src.create "a_module" ~doc:"logs from a_module" + +module Log = (val Logs.src_log src : Logs.LOG) + +let log_name name = Log.warn (fun m -> m "My name is: %s" name) diff --git a/examples/lwt_reporter/src/lib/dune b/examples/lwt_reporter/src/lib/dune new file mode 100644 index 0000000..12a1210 --- /dev/null +++ b/examples/lwt_reporter/src/lib/dune @@ -0,0 +1,5 @@ +(library + (name lwt_reporter_example) + (public_name lwt_reporter_example) + (libraries + logs))