build: use asai 0.1

bantorra.opam

@@ -13,7 +13,7 @@ dev-repo: "git+https://github.com/RedPRL/bantorra.git"
 depends: [
   "dune" {>= "2.0"}
   "ocaml" {>= "5.1"}
-  "asai"
+  "asai" {>= "0.1"}
   "algaeff" {>= "0.2"}
   "bos" {>= "0.2"}
   "bwd" {>= "2.1"}
@@ -24,9 +24,6 @@ depends: [
   "ocamlfind" {>= "1.8"}
   "odoc" {with-doc}
 ]
-pin-depends: [
-  [ "asai.0.1.0~dev" "git+https://github.com/RedPRL/asai" ]
-]
 build: [
   ["dune" "build" "-p" name "-j" jobs]
   ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test}

src/Bantorra.ml

@@ -1,7 +1,6 @@
 module Manager = Manager
 module Router = Router
-module ErrorCode = ErrorCode
-module Error = Error
+module Logger = Logger
 module UnitPath = UnitPath
 module FilePath = FilePath
 module File = File

src/Bantorra.mli

@@ -6,9 +6,7 @@ module Manager = Manager
 
 module Router = Router
 
-module ErrorCode = ErrorCode
-
-module Error = Error
+module Logger = Logger
 
 (** {1 Helper Modules} *)
 

src/File.ml

@@ -1,5 +1,4 @@
 module U = Unix
-module E = Error
 module F = FilePath
 
 (* invariant: absolute path *)
@@ -10,41 +9,43 @@ let (/) = F.add_unit_seg
 let wrap_bos =
   function
   | Ok r -> r
-  | Error (`Msg msg) -> E.fatalf `System "%s" msg
+  | Error (`Msg msg) -> Logger.fatal `System msg
 
 let get_cwd () = F.of_fpath @@ wrap_bos @@ Bos.OS.Dir.current ()
 
 (** Read the entire file as a string. *)
 let read p =
-  E.tracef "File.read(%a)" (F.pp ~relative_to:(get_cwd())) p @@ fun () ->
+  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)
 
 (** Write a string to a file. *)
 let write p s =
-  E.tracef "File.write(%a)" (F.pp ~relative_to:(get_cwd())) p @@ fun () ->
+  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
 
 let ensure_dir p =
-  E.tracef "File.ensure_dir(%a)" (F.pp ~relative_to:(get_cwd())) p @@ fun () ->
+  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)
 
 let file_exists p =
   wrap_bos @@ Bos.OS.File.exists (F.to_fpath p)
 
 let locate_anchor ~anchor start_dir =
-  E.tracef "File.locate_anchor(%s,%a)" anchor (F.pp ~relative_to:(get_cwd())) start_dir @@ fun () ->
+  Logger.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 E.fatalf `AnchorNotFound "No anchor found all the way up to the root"
+    then Logger.fatal `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 =
-  E.tracef "File.hijacking_anchors_exist(%s,%a)" anchor (F.pp ~relative_to:(get_cwd())) root @@ fun () ->
+  Logger.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
   | first_seg :: segs ->
@@ -93,21 +94,21 @@ let read_env_path var =
 
 (* XXX I did not test the following code on different platforms. *)
 let get_xdg_config_home ~app_name =
-  E.tracef "File.get_xdg_config_home" @@ fun () ->
+  Logger.trace "When calculating the 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 =
-        E.try_with get_home
-          ~fatal:(fun _ -> E.fatalf `System "Both XDG_CONFIG_HOME and HOME are not set")
+        Logger.try_with get_home
+          ~fatal:(fun _ -> Logger.fatal `System "Both XDG_CONFIG_HOME and HOME are not set")
       in
       home/".config"/app_name
     | MacOS ->
       let home =
-        E.try_with get_home
-          ~fatal:(fun _ -> E.fatalf `System "Both XDG_CONFIG_HOME and HOME are not set")
+        Logger.try_with get_home
+          ~fatal:(fun _ -> Logger.fatal `System "Both XDG_CONFIG_HOME and HOME are not set")
       in
       home/"Library"/"Application Support"/app_name
     | Windows ->
@@ -116,33 +117,33 @@ let get_xdg_config_home ~app_name =
         | Ok app_data ->
           app_data/app_name/"config"
         | Error _ ->
-          E.fatalf `System "Both XDG_CONFIG_HOME and APPDATA are not set"
+          Logger.fatal `System "Both XDG_CONFIG_HOME and APPDATA are not set"
       end
 
 (* XXX I did not test the following code on different platforms. *)
 let get_xdg_cache_home ~app_name =
-  E.tracef "File.get_xdg_cache_home" @@ fun () ->
+  Logger.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 =
-        E.try_with get_home
-          ~fatal:(fun _ -> E.fatalf `System "Both XDG_CACHE_HOME and HOME are not set")
+        Logger.try_with get_home
+          ~fatal:(fun _ -> Logger.fatal `System "Both XDG_CACHE_HOME and HOME are not set")
       in
       home/".cache"/app_name
     | MacOS ->
       let home =
-        E.try_with get_home
-          ~fatal:(fun _ -> E.fatalf `System "Both XDG_CACHE_HOME and HOME are not set")
+        Logger.try_with get_home
+          ~fatal:(fun _ -> Logger.fatal `System "Both XDG_CACHE_HOME and HOME are not set")
       in
       home/"Library"/"Caches"/app_name
     | Windows ->
       begin
         match read_env_path "LOCALAPPDATA" with
         | Error _ ->
-          E.fatalf `System "Both XDG_CACHE_HOME and LOCALAPPDATA are not set"
+          Logger.fatal `System "Both XDG_CACHE_HOME and LOCALAPPDATA are not set"
         | Ok local_app_data ->
           local_app_data/app_name/"cache"
       end
@@ -157,6 +158,6 @@ let get_package_dir pkg =
     FilePath.of_string @@ Findlib.package_directory pkg
   with
   | Findlib.No_such_package (pkg, msg) ->
-    E.fatalf `System "No package named %s: %s" pkg msg
+    Logger.fatalf `System "@[<2>No package named `%s':@ %s@]" pkg msg
   | Findlib.Package_loop pkg ->
-    E.fatalf `System "Package %s required by itself" pkg
+    Logger.fatalf `System "Package `%s' is required by itself" pkg

src/FilePath.ml

@@ -1,5 +1,3 @@
-module E = Error
-
 type t = Fpath.t (* must be an absolute, normalized path (no . or ..) *)
 
 let equal = Fpath.equal
@@ -24,7 +22,7 @@ let add_ext = Fpath.add_ext
 
 let add_unit_seg p s =
   if not (UnitPath.is_seg s) then
-    E.fatalf `System "%s not a valid unit segment" s;
+    Logger.fatalf `System "`%s' not a valid unit segment" s;
   Fpath.add_seg p s
 
 let append_unit p u =
@@ -44,17 +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 -> E.fatalf `System "Tilde expansion was not enabled for the file path `%a'" Fpath.pp p
+      | None -> Logger.fatalf `System "Tilde expansion was 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
-      E.fatalf `System "File path `%a' is not absolute" Fpath.pp p
+      Logger.fatalf `System "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 () ->
   match Fpath.of_string p with
-  | Error (`Msg msg) -> E.fatalf `System "Cannot parse file path `%s': %s" (String.escaped p) msg
+  | Error (`Msg msg) -> Logger.fatal `System msg
   | Ok p -> of_fpath ?relative_to ?expanding_tilde p
 
 let to_string = Fpath.to_string

src/Logger.ml

@@ -0,0 +1,34 @@
+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)

src/Manager.ml

@@ -1,5 +1,3 @@
-module E = Error
-
 type t =
   { version : string
   ; anchor : string
@@ -50,9 +48,9 @@ let library_root = Library.root
 
 let resolve lm ?(max_depth=255) =
   let rec global ~depth ?starting_dir route path ~suffix =
-    E.tracef "Resolving library via route %a" (Json_repr.pp (module Json_repr.Ezjsonm)) route @@ fun () ->
+    Logger.tracef "@[<2>When resolving library via the route:@ %a@]" (Json_repr.pp (module Json_repr.Ezjsonm)) route @@ fun () ->
     if depth > max_depth then
-      E.fatalf `InvalidLibrary "Library resolution stack overflow (max depth = %i)." max_depth
+      Logger.fatalf `InvalidLibrary "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

src/Marshal.ml

@@ -1,5 +1,3 @@
-module E = Error
-
 type value = Json_repr.ezjsonm
 
 let rec find_duplicate_key =
@@ -15,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
-      E.fatalf `JSONFormat "Duplicate key " (find_duplicate_key sorted_pairs)
+      Logger.fatalf `JSONFormat "Duplicate key: %s" (find_duplicate_key sorted_pairs)
     else
       `O sorted_uniq_pairs
   | `A elems -> `A (List.map normalize elems)
@@ -25,19 +23,19 @@ let destruct enc json =
   try
     Json_encoding.destruct enc json
   with e ->
-    E.fatalf `JSONFormat "%a" (Json_encoding.print_error ?print_unknown:None) e
+    Logger.fatalf `JSONFormat "%a" (Json_encoding.print_error ?print_unknown:None) e
 
 let construct enc data =
   try
     Json_encoding.construct enc data
   with e ->
-    E.fatalf `JSONFormat "%a" (Json_encoding.print_error ?print_unknown:None) e
+    Logger.fatalf `JSONFormat "%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) ->
-    E.fatalf `JSONFormat "%s" msg
+    Logger.fatal `JSONFormat msg
 
 let read enc path =
   File.read path |> parse enc

src/Router.ml

@@ -1,5 +1,3 @@
-module E = Error
-
 type param = Json_repr.ezjsonm
 type t = param -> FilePath.t
 type pipe = param -> param
@@ -14,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 -> E.fatalf `InvalidRoute "Router %s does not exist" name
+  | None -> Logger.fatalf `InvalidRoute "Router %s does not exist" name
 
 let fix ?(hop_limit=255) (f : t -> t) route =
   let rec go i route =
     if i <= 0 then
-      E.fatalf `InvalidLibrary "Exceeded hop limit (%d)" hop_limit
+      Logger.fatalf `InvalidLibrary "Exceeded hop limit (%d)" hop_limit
     else
       f (go (i-1)) route
   in
@@ -39,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 -> E.fatalf `InvalidRoute "Entry %s does not exist" (Marshal.to_string param)
+  | None -> Logger.fatalf `InvalidRoute "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
-      E.fatalf `InvalidRoute "Could not resolve %s within %i rewrites" (Marshal.to_string param) max_tries
+      Logger.fatalf `InvalidRoute "Could not resolve %s within %i rewrites" (Marshal.to_string param) max_tries
     else
       let param = Marshal.normalize param in
       match lookup param with