Something went wrong. Try again.
ocaml
Something went wrong. Try again.
2.8 kB · 87 lines
OCaml
at pp-ast
12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788(* * SPDX-FileCopyrightText: 2024 The Forester Project Contributors * SPDX-FileCopyrightText: 2026 The Forester Project Contributors * * SPDX-License-Identifier: GPL-3.0-or-later *)
let forest_tag : URI.t Logs.Tag.def = Logs.Tag.def "forest" ~doc:"URL of the forest producing this message" URI.pp
let tags url = Logs.Tag.(empty |> add forest_tag url)let tags_opt = function None -> Logs.Tag.empty | Some url -> tags url
module Src = struct let compiler = Logs.Src.create "forester.compiler" ~doc: "Tree loading, parsing, evaluation, import graph, planting, rendering"
let frontend = Logs.Src.create "forester.frontend" ~doc:"Routing, HTML/XML rendering, output writing"
let server = Logs.Src.create "forester.server" ~doc:"HTTP server" let lsp = Logs.Src.create "forester.lsp" ~doc:"Language server"
let profile = Logs.Src.create "forester.profile" ~doc:"Timing information for build phases"end
let reporter ?(pp_header = Logs_fmt.pp_header) ?(app = Format.std_formatter) ?(dst = Format.err_formatter) () : Logs.reporter = Logs_threaded.enable (); let report src level ~over k msgf = let k ppf = Format.pp_close_box ppf (); Format.pp_print_newline ppf (); over (); k () in msgf @@ fun ?header ?tags fmt -> let ppf = if level = Logs.App then app else dst in begin match Option.bind tags (Logs.Tag.find forest_tag) with | None -> () | Some url -> Fmt.pf ppf "[%a] " URI.pp url end; if not (Logs.Src.equal src Logs.default) then Fmt.pf ppf "[%s] " (Logs.Src.name src); pp_header ppf (level, header); begin match (level, header) with | Logs.App, None -> () | _ -> Fmt.char ppf ' ' end; Format.pp_open_box ppf 0; Format.kfprintf k ppf fmt in {report}
type t = { debug: 'a. ?src:Logs.src -> 'a Logs.log; info: 'a. ?src:Logs.src -> 'a Logs.log; warn: 'a. ?src:Logs.src -> 'a Logs.log; err: 'a. ?src:Logs.src -> 'a Logs.log; app: 'a. ?src:Logs.src -> 'a Logs.log;}
let with_tags tags log ?src msgf = log ?src (fun m -> msgf (fun ?header ?tags:_ fmt -> m ?header ?tags:(Some tags) fmt))
let span (log : t) name (f : unit -> 'a) : 'a = let start = Unix.gettimeofday () in let result = f () in log.info ~src:Src.profile (fun m -> m "%s: %.3fs" name (Unix.gettimeofday () -. start)); result
let for_url url : t = let tags = tags url in { debug = (fun ?src msgf -> with_tags tags Logs.debug ?src msgf); info = (fun ?src msgf -> with_tags tags Logs.info ?src msgf); warn = (fun ?src msgf -> with_tags tags Logs.warn ?src msgf); err = (fun ?src msgf -> with_tags tags Logs.err ?src msgf); app = (fun ?src msgf -> with_tags tags Logs.app ?src msgf); }