build: adopt asai 0.3 (#78)

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

src/Bantorra.mli

@@ -6,7 +6,7 @@ module Manager = Manager
 
 module Router = Router
 
-module Logger = Logger
+module Reporter : Asai.MinimumSigs.Reporter
 
 (** {1 Helper Modules} *)
 

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

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

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

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

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)

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

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)

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")
       "<meta http-equiv=\"refresh\" content=\"0;url=https://support.mozilla.org/kb/captive-portal\"/>"