From de13059bcaf741f0ccb4614c38d201a14be3e55c Mon Sep 17 00:00:00 2001 From: favonia Date: Thu, 5 Sep 2024 19:20:48 +0200 Subject: [PATCH] build: adopt asai 0.3 (#78) --- src/Bantorra.ml | 2 +- src/Bantorra.mli | 2 +- src/File.ml | 56 ++++++++++++++++++++--------------------- src/FilePath.ml | 10 ++++---- src/Logger.ml | 34 ------------------------- src/Manager.ml | 4 +-- src/Marshal.ml | 8 +++--- src/Reporter.ml | 36 ++++++++++++++++++++++++++ src/Router.ml | 10 ++++---- src/UnitPath.ml | 4 +-- src/Web.ml | 8 +++--- src/internal/Git.ml | 12 ++++----- src/internal/Library.ml | 28 ++++++++++----------- src/internal/Table.ml | 2 +- src/internal/Trie.ml | 2 +- test/Example.ml | 4 +-- 16 files changed, 112 insertions(+), 110 deletions(-) delete mode 100644 src/Logger.ml create mode 100644 src/Reporter.ml diff --git a/src/Bantorra.ml b/src/Bantorra.ml index d0534ab..49175f9 100644 --- a/src/Bantorra.ml +++ b/src/Bantorra.ml @@ -1,6 +1,6 @@ module Manager = Manager module Router = Router -module Logger = Logger +module Reporter = Reporter module UnitPath = UnitPath module FilePath = FilePath module File = File diff --git a/src/Bantorra.mli b/src/Bantorra.mli index 5e10df0..55ea072 100644 --- a/src/Bantorra.mli +++ b/src/Bantorra.mli @@ -6,7 +6,7 @@ module Manager = Manager module Router = Router -module Logger = Logger +module Reporter : Asai.MinimumSigs.Reporter (** {1 Helper Modules} *) diff --git a/src/File.ml b/src/File.ml index 9063462..59896d1 100644 --- a/src/File.ml +++ b/src/File.ml @@ -6,45 +6,45 @@ type path = F.t let (/) = F.add_unit_seg -let wrap_bos = +let wrap_bos_error code = function | Ok r -> r - | Error (`Msg msg) -> Logger.fatal `System msg + | Error (`Msg msg) -> Reporter.fatal code msg -let get_cwd () = F.of_fpath @@ wrap_bos @@ Bos.OS.Dir.current () +let get_cwd () = F.of_fpath @@ wrap_bos_error SystemError @@ Bos.OS.Dir.current () (** Read the entire file as a string. *) let read p = - Logger.tracef "When reading the file `%a'" (F.pp ~relative_to:(get_cwd())) p @@ fun () -> - wrap_bos @@ Bos.OS.File.read (F.to_fpath p) + Reporter.tracef "when@ reading@ the@ file@ `%a'" (F.pp ~relative_to:(get_cwd())) p @@ fun () -> + wrap_bos_error FileError @@ Bos.OS.File.read (F.to_fpath p) (** Write a string to a file. *) let write p s = - Logger.tracef "When writing the file `%a'" (F.pp ~relative_to:(get_cwd())) p @@ fun () -> - wrap_bos @@ Bos.OS.File.write (F.to_fpath p) s + Reporter.tracef "when@ writing@ the@ file@ `%a'" (F.pp ~relative_to:(get_cwd())) p @@ fun () -> + wrap_bos_error FileError @@ Bos.OS.File.write (F.to_fpath p) s let ensure_dir p = - Logger.tracef "When calling `ensure_dir' on `%a'" (F.pp ~relative_to:(get_cwd())) p @@ fun () -> - ignore @@ wrap_bos @@ Bos.OS.Dir.create (F.to_fpath p) + Reporter.tracef "when@ calling@ `ensure_dir'@ on@ `%a'" (F.pp ~relative_to:(get_cwd())) p @@ fun () -> + ignore @@ wrap_bos_error FileError @@ Bos.OS.Dir.create (F.to_fpath p) let file_exists p = - wrap_bos @@ Bos.OS.File.exists (F.to_fpath p) + wrap_bos_error FileError @@ Bos.OS.File.exists (F.to_fpath p) let locate_anchor ~anchor start_dir = - Logger.tracef "When locating the anchor `%s' from `%a'" + Reporter.tracef "when@ locating@ the@ anchor@ `%s'@ from@ `%a'" anchor (F.pp ~relative_to:(get_cwd())) start_dir @@ fun () -> let rec go cwd path_acc = if file_exists (cwd/anchor) then cwd, UnitPath.of_list path_acc else if F.is_root cwd - then Logger.fatal `AnchorNotFound "No anchor found all the way up to the root" + then Reporter.fatalf AnchorNotFound "no@ anchor@ found@ all@ the@ way@ up@ to@ the@ root" else go (F.parent cwd) @@ F.basename cwd :: path_acc in go (F.to_dir_path start_dir) [] let locate_hijacking_anchor ~anchor ~root path = - Logger.tracef "When checking whether there's any hijacking anchor `%s'@ between `%a' and `%a'" + Reporter.tracef "when@ checking@ whether@ there's@ any@ hijacking@ anchor@ `%s'@ between@ `%a' and@ `%a'" anchor (F.pp ~relative_to:(get_cwd())) root UnitPath.pp path @@ fun () -> match UnitPath.to_list path with | [] -> None @@ -87,28 +87,28 @@ let guess_scheme = end let get_home () = - F.of_fpath @@ wrap_bos @@ Bos.OS.Dir.user () + F.of_fpath @@ wrap_bos_error MissingEnvironmentVariables @@ Bos.OS.Dir.user () let read_env_path var = Result.map (F.of_fpath ~relative_to:(get_cwd ())) @@ Bos.OS.Env.path var (* XXX I did not test the following code on different platforms. *) let get_xdg_config_home ~app_name = - Logger.trace "When calculating the XDG_CONFIG_HOME" @@ fun () -> + Reporter.tracef "when@ determining@ the@ value@ of@ XDG_CONFIG_HOME" @@ fun () -> match read_env_path "XDG_CONFIG_HOME" with | Ok dir -> dir/app_name | Error _ -> match Lazy.force guess_scheme with | Linux -> let home = - Logger.try_with get_home - ~fatal:(fun _ -> Logger.fatal `System "Both XDG_CONFIG_HOME and HOME are not set") + Reporter.try_with get_home + ~fatal:(fun _ -> Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CONFIG_HOME@ and@ HOME@ are@ absent") in home/".config"/app_name | MacOS -> let home = - Logger.try_with get_home - ~fatal:(fun _ -> Logger.fatal `System "Both XDG_CONFIG_HOME and HOME are not set") + Reporter.try_with get_home + ~fatal:(fun _ -> Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CONFIG_HOME@ and@ HOME@ are@ absent") in home/"Library"/"Application Support"/app_name | Windows -> @@ -117,33 +117,33 @@ let get_xdg_config_home ~app_name = | Ok app_data -> app_data/app_name/"config" | Error _ -> - Logger.fatal `System "Both XDG_CONFIG_HOME and APPDATA are not set" + Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CONFIG_HOME@ and@ APPDATA@ are@ absent" end (* XXX I did not test the following code on different platforms. *) let get_xdg_cache_home ~app_name = - Logger.tracef "When calculating XDG_CACHE_HOME" @@ fun () -> + Reporter.tracef "when calculating XDG_CACHE_HOME" @@ fun () -> match read_env_path "XDG_CACHE_HOME" with | Ok dir -> dir/app_name | Error _ -> match Lazy.force guess_scheme with | Linux -> let home = - Logger.try_with get_home - ~fatal:(fun _ -> Logger.fatal `System "Both XDG_CACHE_HOME and HOME are not set") + Reporter.try_with get_home + ~fatal:(fun _ -> Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CACHE_HOME@ and@ HOME@ are@ absent") in home/".cache"/app_name | MacOS -> let home = - Logger.try_with get_home - ~fatal:(fun _ -> Logger.fatal `System "Both XDG_CACHE_HOME and HOME are not set") + Reporter.try_with get_home + ~fatal:(fun _ -> Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CACHE_HOME@ and@ HOME@ are@ absent") in home/"Library"/"Caches"/app_name | Windows -> begin match read_env_path "LOCALAPPDATA" with | Error _ -> - Logger.fatal `System "Both XDG_CACHE_HOME and LOCALAPPDATA are not set" + Reporter.fatalf MissingEnvironmentVariables "both@ XDG_CACHE_HOME@ and@ LOCALAPPDATA@ are@ absent" | Ok local_app_data -> local_app_data/app_name/"cache" end @@ -158,6 +158,6 @@ let get_package_dir pkg = FilePath.of_string @@ Findlib.package_directory pkg with | Findlib.No_such_package (pkg, msg) -> - Logger.fatalf `System "@[<2>No package named `%s':@ %s@]" pkg msg + Reporter.fatalf InvalidOCamlPackage "@[<2>@[no@ package@ named@ `%s':@]@ %s@]" pkg msg | Findlib.Package_loop pkg -> - Logger.fatalf `System "Package `%s' is required by itself" pkg + Reporter.fatalf InvalidOCamlPackage "package@ `%s'@ is@ requiring@ itself@ (circularity)" pkg diff --git a/src/FilePath.ml b/src/FilePath.ml index bf2d77c..1c02834 100644 --- a/src/FilePath.ml +++ b/src/FilePath.ml @@ -22,7 +22,7 @@ let add_ext = Fpath.add_ext let add_unit_seg p s = if not (UnitPath.is_seg s) then - Logger.fatalf `System "`%s' not a valid unit segment" s; + Reporter.fatalf IllFormedFilePath "`%s'@ not@ a@ valid@ unit@ segment" s; Fpath.add_seg p s let append_unit p u = @@ -42,18 +42,18 @@ let of_fpath ?relative_to ?expanding_tilde p = let p_str = Fpath.to_string p in if p_str == "~" || String.starts_with ~prefix:"~/" p_str then match expanding_tilde with - | None -> Logger.fatalf `System "Tilde expansion was not enabled for the file path `%a'" Fpath.pp p + | None -> Reporter.fatalf IllFormedFilePath "tilde@ expansion@ is@ not@ enabled@ for@ the@ file@ path@ `%a'" Fpath.pp p | Some home -> Fpath.v (Fpath.to_string home ^ String.sub p_str 1 (String.length p_str - 1)) else - Logger.fatalf `System "File path `%a' is not an absolute path" Fpath.pp p + Reporter.fatalf IllFormedFilePath "file@ path@ `%a'@ is@ not@ an@ absolute@ path" Fpath.pp p let to_fpath p = p let of_string ?relative_to ?expanding_tilde p = - Logger.tracef "When parsing the file path `%s'" (String.escaped p) @@ fun () -> + Reporter.tracef "when@ parsing@ the@ file@ path@ `%s'" (String.escaped p) @@ fun () -> match Fpath.of_string p with - | Error (`Msg msg) -> Logger.fatal `System msg + | Error (`Msg msg) -> Reporter.fatal IllFormedFilePath msg | Ok p -> of_fpath ?relative_to ?expanding_tilde p let to_string = Fpath.to_string diff --git a/src/Logger.ml b/src/Logger.ml deleted file mode 100644 index 6705b1a..0000000 --- a/src/Logger.ml +++ /dev/null @@ -1,34 +0,0 @@ -module Code = -struct - (** Type of error codes. See the Asai documentation. *) - type t = - [ `System - | `AnchorNotFound - | `JSONFormat - | `UnitNotFound - | `InvalidLibrary - | `InvalidRoute - | `InvalidRouter - | `Web - ] - - (** Default severity of error codes. See the Asai documentation. *) - let default_severity : t -> Asai.Diagnostic.severity = - function - | `InvalidRouter -> Bug - | _ -> Error - - (** String representation of error codes. See the Asai documentation. *) - let to_string : t -> string = - function - | `System -> "sys" - | `AnchorNotFound -> "anchor" - | `JSONFormat -> "json" - | `UnitNotFound -> "unit" - | `InvalidLibrary -> "lib" - | `InvalidRoute -> "route" - | `InvalidRouter -> "router" - | `Web -> "web" -end - -include Asai.Logger.Make(Code) diff --git a/src/Manager.ml b/src/Manager.ml index aa33b49..0af23b8 100644 --- a/src/Manager.ml +++ b/src/Manager.ml @@ -48,9 +48,9 @@ let library_root = Library.root let resolve lm ?(max_depth=255) = let rec global ~depth ?starting_dir route path ~suffix = - Logger.tracef "@[<2>When resolving library via the route:@ %a@]" (Json_repr.pp (module Json_repr.Ezjsonm)) route @@ fun () -> + Reporter.tracef "@[<2>@[when@ resolving@ library@ via@ the@ route:@]@ @[%a@]@]" (Json_repr.pp (module Json_repr.Ezjsonm)) route @@ fun () -> if depth > max_depth then - Logger.fatalf `InvalidLibrary "Library resolution stack overflow (max depth = %i)" max_depth + Reporter.fatalf LibraryNotFound "library@ resolution@ stack@ overflow@ (max depth = %i)" max_depth else let lib = load_library_from_route lm ?starting_dir route in Library.resolve ~depth ~global lib path ~suffix diff --git a/src/Marshal.ml b/src/Marshal.ml index 260e022..161f811 100644 --- a/src/Marshal.ml +++ b/src/Marshal.ml @@ -13,7 +13,7 @@ let rec normalize : value -> value = let sorted_uniq_pairs = List.sort_uniq (fun (key1, _) (key2, _) -> String.compare key1 key2) pairs in if List.length pairs <> List.length sorted_uniq_pairs then let sorted_pairs = List.sort (fun (key1, _) (key2, _) -> String.compare key1 key2) pairs in - Logger.fatalf `JSONFormat "Duplicate key: %s" (find_duplicate_key sorted_pairs) + Reporter.fatalf IllFormedJSON "duplicate@ key@ `%s'" (find_duplicate_key sorted_pairs) else `O sorted_uniq_pairs | `A elems -> `A (List.map normalize elems) @@ -23,19 +23,19 @@ let destruct enc json = try Json_encoding.destruct enc json with e -> - Logger.fatalf `JSONFormat "%a" (Json_encoding.print_error ?print_unknown:None) e + Reporter.fatalf IllFormedJSON "%a" (Json_encoding.print_error ?print_unknown:None) e let construct enc data = try Json_encoding.construct enc data with e -> - Logger.fatalf `JSONFormat "%a" (Json_encoding.print_error ?print_unknown:None) e + Reporter.fatalf IllFormedJSON "%a" (Json_encoding.print_error ?print_unknown:None) e let parse enc s = destruct enc @@ try Ezjsonm.value_from_string s with | Ezjsonm.Parse_error (_, msg) -> - Logger.fatal `JSONFormat msg + Reporter.fatal IllFormedJSON msg let read enc path = File.read path |> parse enc diff --git a/src/Reporter.ml b/src/Reporter.ml new file mode 100644 index 0000000..6f7b063 --- /dev/null +++ b/src/Reporter.ml @@ -0,0 +1,36 @@ +module Message = +struct + (** Type of error codes. See the asai documentation. *) + type t = + | SystemError (** Generic system errors. *) + | MissingEnvironmentVariables (** Missing HOME or XDG_* environment variables. *) + | FileError (** File paths are valid, but the files do not exist or file permissions are missing. *) + | IllFormedFilePath (** File paths are ill-formed (independent of the file system state). *) + | WebError (** All the network-related errors. *) + + | IllFormedJSON (** Low level JSON parsing errors. *) + + | AnchorNotFound (** Could not find the anchor at the expected library location. *) + | HijackingAnchor (** Having an anchor on the path to the expected anchor. *) + | IllFormedAnchor (** The anchor itself is ill-formed. *) + + | InvalidRouter (** The routing table itself is broken. *) + | LibraryNotFound (** The routing table is okay, but the library cannot be found. *) + | LibraryConflict (** Conflicting libraries are being loaded. *) + | UnitNotFound (** Libraries are loaded, but the unit is not found. *) + | IllFormedUnitPath (** The unit path is ill-formed. *) + + | InvalidOCamlPackage (** Invalid OCaml package. *) + + (** Default severity of error codes. See the asai documentation. *) + let default_severity : t -> Asai.Diagnostic.severity = + function + | InvalidRouter -> Bug + | _ -> Error + + (** String representation of error codes. See the asai documentation. *) + let short_code : t -> string = + function _ -> "E0001" (** XXX assign actual code *) +end + +include Asai.Reporter.Make(Message) diff --git a/src/Router.ml b/src/Router.ml index 9e6c1c5..5bf65c2 100644 --- a/src/Router.ml +++ b/src/Router.ml @@ -3,7 +3,7 @@ type t = param -> FilePath.t type pipe = param -> param type env = {version : string; starting_dir : FilePath.t option} -module Eff = Algaeff.Reader.Make(struct type nonrec env = env end) +module Eff = Algaeff.Reader.Make(struct type t = env end) let get_version () = (Eff.read ()).version let get_starting_dir () = (Eff.read ()).starting_dir let run ~version ?starting_dir = Eff.run ~env:{version; starting_dir} @@ -12,12 +12,12 @@ let dispatch lookup param = let name, param = Marshal.destruct Json_encoding.(tup2 string any_ezjson_value) param in match lookup name with | Some route -> route param - | None -> Logger.fatalf `InvalidRoute "Router %s does not exist" name + | None -> Reporter.fatalf LibraryNotFound "no@ router@ is@ called@ `%s'" name let fix ?(hop_limit=255) (f : t -> t) route = let rec go i route = if i <= 0 then - Logger.fatalf `InvalidLibrary "Exceeded hop limit (%d)" hop_limit + Reporter.fatalf LibraryNotFound "exceeded@ hop@ limit@ (%d)" hop_limit else f (go (i-1)) route in @@ -37,13 +37,13 @@ let rewrite_try_once lookup param = let rewrite_err_on_missing lookup param = let param = Marshal.normalize param in match lookup param with - | None -> Logger.fatalf `InvalidRoute "Entry `%s' does not exist" (Marshal.to_string param) + | None -> Reporter.fatalf LibraryNotFound "entry@ `%s'@ does@ not@ exist" (Marshal.to_string param) | Some param -> param let rewrite_recursively max_tries lookup param = let rec go i = if i = max_tries then - Logger.fatalf `InvalidRoute "Could not resolve %s within %i rewrites" (Marshal.to_string param) max_tries + Reporter.fatalf LibraryNotFound "could@ not@ resolve@ %s@ within@ %i@ rewrites" (Marshal.to_string param) max_tries else let param = Marshal.normalize param in match lookup param with diff --git a/src/UnitPath.ml b/src/UnitPath.ml index d6ac75a..1a3362b 100644 --- a/src/UnitPath.ml +++ b/src/UnitPath.ml @@ -12,7 +12,7 @@ let is_seg s = s <> "" && Fpath.is_seg s && not (Fpath.is_rel_seg s) let assert_seg s = if not (is_seg s) then - Logger.fatalf `InvalidLibrary "`%s' not a valid unit segment" (String.escaped s) + Reporter.fatalf IllFormedUnitPath "`%s'@ not@ a@ valid@ unit@ segment" (String.escaped s) let of_seg s = assert_seg s; [s] @@ -25,7 +25,7 @@ let to_list l = l let of_list l = List.iter assert_seg l; l let of_string ?(allow_ending_slash=false) ?(allow_extra_dots=false) p = - Logger.tracef "When parsing `%s' as a unit path" (String.escaped p) @@ fun () -> + Reporter.tracef "when@ parsing@ `%s'@ as@ a@ unit@ path" (String.escaped p) @@ fun () -> let p = if allow_ending_slash && String.ends_with ~suffix:"/" p then String.sub p 0 (String.length p - 1) diff --git a/src/Web.ml b/src/Web.ml index 7d37309..5489018 100644 --- a/src/Web.ml +++ b/src/Web.ml @@ -1,15 +1,15 @@ let get ?(follow_redirects=true) url = let args = if follow_redirects then ["-L"] else [] in - Logger.tracef "When calling Web.get(%s)" url @@ fun () -> + Reporter.tracef "when reading content from `%s'" url @@ fun () -> match Curly.get ~args url with | Ok {code = 200; body; _} -> body - | Ok {code; _} -> Logger.fatalf `Web "Got code %d" code - | Error err -> Logger.fatalf `Web "%a" Curly.Error.pp err + | Ok {code; _} -> Reporter.fatalf WebError "got@ HTTP@ code@ %d,@ which@ is@ not@ 200" code + | Error err -> Reporter.fatalf WebError "%a" Curly.Error.pp err (* See https://firefox-source-docs.mozilla.org/networking/captive_portals.html *) let online = lazy begin - Logger.try_with ~emit:(fun _ -> ()) ~fatal:(fun _ -> false) @@ fun () -> + Reporter.try_with ~emit:(fun _ -> ()) ~fatal:(fun _ -> false) @@ fun () -> String.equal (get "http://detectportal.firefox.com/canonical.html") "" diff --git a/src/internal/Git.ml b/src/internal/Git.ml index 110272a..a141845 100644 --- a/src/internal/Git.ml +++ b/src/internal/Git.ml @@ -35,7 +35,7 @@ struct let wrap_bos = function | Ok r -> r - | Error (`Msg m) -> Logger.fatalf `InvalidRoute "%s" m + | Error (`Msg m) -> Reporter.fatalf LibraryNotFound "@[<2>@[routing@ failed:@]@ %s@]" m let git ~root = Cmd.(v "git" % "-C" % FilePath.to_string root) @@ -49,7 +49,7 @@ struct let git_remote_reset_origin ~root ~url = begin - Logger.try_with ~fatal:(fun _ -> ()) @@ fun () -> + Reporter.try_with ~fatal:(fun _ -> ()) ~emit:(fun _ -> ()) @@ fun () -> run_null ~err:Bos.OS.Cmd.err_null Cmd.(git ~root % "remote" % "remove" % "origin") end; run_null Cmd.(git ~root % "remote" % "add" % "origin" % url) @@ -60,7 +60,7 @@ struct run_null Cmd.(git ~root % "reset" % "--quiet" % "--hard" % "--recurse-submodules" % "FETCH_HEAD" % "--") in let relaxed () = - Logger.try_with strict ~fatal:Logger.emit_diagnostic + Reporter.try_with strict ~fatal:Reporter.emit_diagnostic in if err_on_failed_fetch then strict () else relaxed () @@ -79,21 +79,21 @@ struct | Some hash_in_use -> let hash = git_rev_parse ~root ~ref:"HEAD" in if hash_in_use <> hash then - Logger.fatalf `InvalidRoute "[@<2>Inconsistent Git commits in use:@ %s and %s for `%s']" hash hash_in_use (String.escaped url) + Reporter.fatalf LibraryConflict "inconsistent@ Git@ commits@ %s@ and@ %s@ are@ used@ for@ `%s'" hash hash_in_use (String.escaped url) else hash end (* more checking about [ref] *) let load_git_repo ~err_on_failed_fetch {root; lock; hash_in_use; url_in_use} {url; ref; path} = - Logger.tracef "When loading the git repository at `%s'" url @@ fun () -> + Reporter.tracef "when@ loading@ the@ git@ repository@ at@ `%s'" url @@ fun () -> Mutex.protect lock @@ fun () -> let url_digest = Digest.to_hex @@ Digest.string url in let git_root = FilePath.append_unit root (UnitPath.of_list ["repos"; url_digest]) in begin match Hashtbl.find_opt url_in_use url_digest with | Some url_in_use when url_in_use <> url -> - Logger.fatalf `InvalidRoute "Unexpected hash collision for URLs %s and %s" url url_in_use + Reporter.fatalf InvalidRouter "unexpected@ hash@ collision@ of@ URLs@ `%s'@ and@ `%s'" url url_in_use | _ -> () end; let hash = diff --git a/src/internal/Library.ml b/src/internal/Library.ml index c9ce9be..531c96b 100644 --- a/src/internal/Library.ml +++ b/src/internal/Library.ml @@ -7,8 +7,8 @@ type t = let (/) = FilePath.add_unit_seg let load_from_root ~version ~premount ~find_cache ~anchor root = - Logger.tracef "@[<2>When loading library at its root:@ version=%s, anchor=%s, root=%a@]" - version anchor (FilePath.pp ~relative_to:(File.get_cwd ())) root @@ fun () -> + Reporter.tracef "when@ loading@ library@ at@ `%a'" + (FilePath.pp ~relative_to:(File.get_cwd ())) root @@ fun () -> let root = FilePath.to_dir_path root in match find_cache root with | Some lib -> lib @@ -17,8 +17,8 @@ let load_from_root ~version ~premount ~find_cache ~anchor root = {root; anchor; loaded_anchor} let load_from_dir ~version ~premount ~find_cache ~anchor dir = - Logger.tracef "@[<2>When loading library from a directory:@ version=%s, anchor=%s, dir=%a)@]" - version anchor (FilePath.pp ~relative_to:(File.get_cwd ())) dir @@ fun () -> + Reporter.tracef "when@ loading@ library@ from@ the@ directory@ `%a'" + (FilePath.pp ~relative_to:(File.get_cwd ())) dir @@ fun () -> let dir = FilePath.to_dir_path dir in match File.locate_anchor ~anchor dir with | root, prefix -> @@ -28,13 +28,13 @@ let load_from_dir ~version ~premount ~find_cache ~anchor dir = else lib, None let load_from_unit ~version ~premount ~find_cache ~anchor filepath ~suffix = - Logger.tracef "@[<2>When loading library from a unit:@ version=%s, anchor=%s, filepath=%a, suffix=%s)" - version anchor (FilePath.pp ~relative_to:(File.get_cwd ())) filepath suffix @@ fun () -> + Reporter.tracef "when@ loading@ library@ of@ the@ unit@ at@ `%a'" + (FilePath.pp ~relative_to:(File.get_cwd ())) filepath @@ fun () -> if not @@ File.file_exists filepath then - Logger.fatalf `InvalidLibrary "The unit `%a' does not exist" (FilePath.pp ~relative_to:(File.get_cwd ())) filepath + Reporter.fatalf UnitNotFound "the@ unit@ `%a'@ does@ not@ exist" (FilePath.pp ~relative_to:(File.get_cwd ())) filepath else if FilePath.has_ext suffix filepath then - Logger.fatalf `InvalidLibrary "The file path `%a' does not have the suffix `%s'" (FilePath.pp ~relative_to:(File.get_cwd ())) filepath suffix; + Reporter.fatalf IllFormedFilePath "the@ file@ path@ `%a'@ does@ not@ have@ the@ suffix@ `%s'" (FilePath.pp ~relative_to:(File.get_cwd ())) filepath suffix; let filepath = FilePath.rem_ext filepath in let root, path_opt = load_from_dir ~version ~premount ~find_cache ~anchor (FilePath.parent filepath) @@ -44,22 +44,22 @@ let load_from_unit ~version ~premount ~find_cache ~anchor filepath ~suffix = let root lib = lib.root let dispatch_path ~depth local ~global (lib : t) (path : UnitPath.t) = - Logger.tracef "When dispatching the path `%a'" UnitPath.pp path @@ fun () -> + Reporter.tracef "when@ dispatching@ the@ path@ `%a'" UnitPath.pp path @@ fun () -> match Anchor.dispatch_path lib.loaded_anchor path with | None -> local lib path | Some (route, path) -> global ~depth:(depth+1) ?starting_dir:(Some lib.root) route path let resolve_local lib path ~suffix = - Logger.tracef "When resolving local path `%a'" UnitPath.pp path @@ fun () -> - if UnitPath.is_root path then Logger.fatalf `InvalidLibrary "Unit path is empty"; + Reporter.tracef "when@ resolving@ local@ unit@ path@ `%a'" UnitPath.pp path @@ fun () -> + if UnitPath.is_root path then Reporter.fatalf UnitNotFound "the unit path is empty"; match File.locate_hijacking_anchor ~anchor:lib.anchor ~root:lib.root path with | Some anchor -> - Logger.fatalf `InvalidLibrary - "The unit `%a' does not belong to the library `%a' because `%a' exists" + Reporter.fatalf HijackingAnchor + "there@ is@ an@ anchor@ at@ `%a'@ hijacking@ the@ unit@ `%a'@ of@ the@ library@ at@ `%a'" + (FilePath.pp ~relative_to:(File.get_cwd ())) anchor UnitPath.pp path (FilePath.pp ~relative_to:(File.get_cwd ())) lib.root - (FilePath.pp ~relative_to:(File.get_cwd ())) anchor | None -> lib, path, FilePath.add_ext suffix (FilePath.append_unit lib.root path) diff --git a/src/internal/Table.ml b/src/internal/Table.ml index bc0f873..8de9c96 100644 --- a/src/internal/Table.ml +++ b/src/internal/Table.ml @@ -17,7 +17,7 @@ let parse ~version str : t = l |> List.iter (fun (key, value) -> let key = Marshal.normalize key in if Hashtbl.mem table key then - Logger.fatalf `InvalidRouter "Duplicate rewrite key `%s'" (Marshal.to_string key) + Reporter.fatalf InvalidRouter "duplicate@ rewrite@ key@ `%s'" (Marshal.to_string key) else Hashtbl.replace table key value ); diff --git a/src/internal/Trie.ml b/src/internal/Trie.ml index 9c5abc8..482b605 100644 --- a/src/internal/Trie.ml +++ b/src/internal/Trie.ml @@ -33,7 +33,7 @@ let add p d = | Some n -> Some (go_node p d n) in try go (UnitPath.to_list p) d - with DuplicateUnitPath -> Logger.fatalf `JSONFormat "Multiple libraries mounted at `%a'" UnitPath.pp p + with DuplicateUnitPath -> Reporter.fatalf IllFormedAnchor "multiple@ libraries@ mounted@ at@ `%a'" UnitPath.pp p let rec find_node p n = match diff --git a/test/Example.ml b/test/Example.ml index 6b3e866..814df75 100644 --- a/test/Example.ml +++ b/test/Example.ml @@ -1,6 +1,6 @@ (** Set up the effect handler of error messages. See the documentation of Asai. *) -module Terminal = Asai.Tty.Make(Bantorra.Logger.Code) -let run_bantorra f = Bantorra.Logger.run f +module Terminal = Asai.Tty.Make(Bantorra.Reporter.Message) +let run_bantorra f = Bantorra.Reporter.run f ~emit:Terminal.display ~fatal:(fun d -> Terminal.display d; failwith "error") open Bantorra