library: make the error formatter a parameter

Author: Octachron

Changelog.md

@@ -2,6 +2,8 @@
 
    * Support 5.2
    * Support 5.3
+   * Expose LGPL library
+   * Make the error formatter a parameter
 
 ## Bug fixes
 

core/analysis.ml

@@ -5,7 +5,7 @@ type param = {
   epsilon_dependencies:bool;
   transparent_aliases: bool;
   transparent_extension_nodes: bool;
-  policy: Fault.Policy.t;
+  fault_handler: Fault.handler;
   precomputed_libs: Name.set;
   closed_world: bool;
   sig_only:bool;
@@ -59,38 +59,38 @@ let pair_split l =
   List.fold_left folder {ml=[];mli=[]} l
 
 (** organisation **)
-let signature_error policy = function
+let signature_error fault_handler = function
   | Ok x, _ -> Some x
   | Error e, filename ->
-    Standard_faults.schematic_errors policy (filename,"sig",e);
+    Standard_faults.schematic_errors fault_handler (filename,"sig",e);
     None
 
-let pre_organize policy io files =
+let pre_organize fault_handler io files =
   let units, signatures = split (info_split io) files in
   let signatures =
     Module.Namespace.merge_all @@ Option.List'.filter
-    @@ List.map (signature_error policy) signatures in
+    @@ List.map (signature_error fault_handler) signatures in
   units, signatures
 
-let load_file (io:Io.reader) policy sig_only opens (info,file,n) =
+let load_file (io:Io.reader) fault_handler sig_only opens (info,file,n) =
   let filter_m2l (u: Unit.s) = if sig_only then
       { u with Unit.code = M2l.Sig_only.filter u.code }
     else
       u in
-  io.m2l policy info file n
+  io.m2l fault_handler info file n
   |> filter_m2l
   |> open_within opens
 
 
-let log_conflict policy proj (path, units) =
-  Fault.raise policy Standard_faults.local_module_conflict
+let log_conflict fault_handler proj (path, units) =
+  Fault.raise fault_handler Standard_faults.local_module_conflict
     (path,  List.map proj units)
 
-let organize io policy sig_only opens files =
-  let units, signatures = pre_organize policy io files in
-  let units = List.map (load_file io policy sig_only opens) units in
+let organize io fault_handler sig_only opens files =
+  let units, signatures = pre_organize fault_handler io files in
+  let units = List.map (load_file io fault_handler sig_only opens) units in
   let units, errs = Unit.Group.(split % group) @@ pair_split units in
-  List.iter (log_conflict policy @@ fun (u:Unit.s) -> u.src ) errs;
+  List.iter (log_conflict fault_handler @@ fun (u:Unit.s) -> u.src ) errs;
   units, signatures
 
 
@@ -140,7 +140,7 @@ let start_env io param libs signatures fileset =
 
 let lift p =
   (module struct
-    let policy = p.policy
+    let fault_handler = p.fault_handler
     let epsilon_dependencies = p.epsilon_dependencies
     let transparent_extension_nodes = p.transparent_extension_nodes
     let transparent_aliases = p.transparent_aliases
@@ -206,9 +206,9 @@ module Collisions = struct
       ) m units
 
   (** Print error message for a given collision map *)
-  let handle policy fault collisions =
+  let handle fault_handler fault collisions =
     let err name paths () =
-      Fault.raise policy fault (name,Pkg.Set.elements paths) in
+      Fault.raise fault_handler fault (name,Pkg.Set.elements paths) in
     Nms.Map.fold err collisions ()
 
   (** Compute local/local collisions *)
@@ -229,16 +229,17 @@ end
 (** Analysis step *)
 let main_std io param (task:Common.task) =
   let module F = Standard_faults in
+  let is_silent f = Fault.is_silent param.fault_handler.policy f in
   let units, signatures =
-    organize io param.policy param.sig_only task.opens task.files in
-  if not @@ Fault.is_silent param.policy F.module_conflict then
+    organize io param.fault_handler param.sig_only task.opens task.files in
+  if not (is_silent F.module_conflict) then
     Collisions.libs task units.mli
-    |> Collisions.handle param.policy F.module_conflict;
+    |> Collisions.handle param.fault_handler F.module_conflict;
   let collisions = Collisions.local units.mli in
   let namespace = List.map (fun (u:Unit.s) -> u.path) units.mli in
   let () =
-    if not @@ Fault.is_silent param.policy F.local_module_conflict then
-      Collisions.handle param.policy F.local_module_conflict collisions in
+    if not (is_silent F.local_module_conflict) then
+      Collisions.handle param.fault_handler F.local_module_conflict collisions in
   let e = start_env io param task.libs signatures namespace in
   let {Unit.ml; mli} = solve param e units in
   let ml = remove_units task.invisibles ml in
@@ -248,9 +249,9 @@ let main_std io param (task:Common.task) =
 (** Analysis step *)
 let main_seed io param (task:Common.task) =
   let units, signatures =
-    pre_organize param.policy io task.files in
+    pre_organize param.fault_handler io task.files in
   let file_list = List.map (fun (_k,_x,p) -> p) units in
-  let load_file = load_file io param.policy param.sig_only task.opens in
+  let load_file = load_file io param.fault_handler param.sig_only task.opens in
   let e = start_env io param task.libs signatures file_list in
   let units = solve_from_seeds task.seeds load_file units param e in
   let units = remove_units task.invisibles units in
@@ -261,7 +262,7 @@ let main_seed io param (task:Common.task) =
     ) { ml=[]; mli=[]} units in
   let g, errs = Unit.Group.(split % group) units in
   List.iter
-    (log_conflict param.policy @@ fun (u:Unit.r) -> u.src) errs;
+    (log_conflict param.fault_handler @@ fun (u:Unit.r) -> u.src) errs;
   g
 
 let main io param (task:Common.task) =

core/analysis.mli

@@ -4,7 +4,7 @@ type param = {
   epsilon_dependencies: bool;
   transparent_aliases: bool;
   transparent_extension_nodes: bool;
-  policy: Fault.Policy.t;
+  fault_handler: Fault.handler;
   precomputed_libs: Name.set  ;
   closed_world: bool;
   sig_only:bool;

core/args.ml

@@ -44,7 +44,10 @@ let param0 = {
       precomputed_libs = Name.Set.singleton "stdlib";
       closed_world = false;
       sig_only = false;
-      policy = Codept_policies.policy;
+      fault_handler = {
+        Fault.policy = Codept_policies.policy;
+        err_formatter = Format.err_formatter
+      }
     };
 
     no_include = false;
@@ -80,7 +83,7 @@ let with_output out s f=
 
 let iter_makefile out param interm s =
   with_output out s (fun ppf ->
-      Makefile.main L.(param#.policy) ppf param.synonyms param.makefile interm
+      Makefile.main L.(param#.fault_handler) ppf param.synonyms param.makefile interm
     )
 
 (** {2 Option implementations } *)

core/common.ml

@@ -50,9 +50,9 @@ let is_stdlib_pkg = function
   | _ -> false
 
 
-let classify policy synonyms f =
+let classify fault_handler synonyms f =
   let ext = Support.extension f in
   match Name.Map.find ext synonyms with
   | x -> Some x
   | exception Not_found ->
-    Fault.raise policy Codept_policies.unknown_extension ext; None
+    Fault.raise fault_handler Codept_policies.unknown_extension ext; None

core/common.mli

@@ -38,4 +38,4 @@ val is_stdlib_pkg: Name.t -> bool
 
 (** [classify policy synonyms filename] classifies file type
     according to the dictionary [synonyms] *)
-val classify: Fault.Policy.t -> info Name.map -> string -> info option
+val classify: Fault.handler -> info Name.map -> string -> info option

core/io.ml

@@ -1,7 +1,7 @@
 
 type reader = {
   sign:  string -> (Module.Namespace.t, Schematic.Ext.error) result;
-  m2l: Fault.Policy.t -> Read.kind -> string
+  m2l: Fault.handler -> Read.kind -> string
     -> Namespaced.t -> Unit.s;
   findlib: Common.task -> Findlib.query -> Common.task ;
   env: Module.dict

core/io.mli

@@ -3,7 +3,7 @@
 
 type reader = {
   sign: string -> (Module.Namespace.t, Schematic.Ext.error) result ;
-  m2l: Fault.Policy.t -> Read.kind -> string -> Namespaced.t
+  m2l: Fault.handler -> Read.kind -> string -> Namespaced.t
     -> Unit.s;
   findlib: Common.task -> Findlib.query -> Common.task ;
   env: Module.dict

core/makefile.ml

@@ -42,7 +42,7 @@ let implicit_dep synonyms path =
 
 
 
-let expand_includes policy synonyms includes =
+let expand_includes fault_handler synonyms includes =
   let read_dir expanded dir =
     let dir = Common.expand_dir dir in
     if Sys.file_exists dir && Sys.is_directory dir then
@@ -52,8 +52,9 @@ let expand_includes policy synonyms includes =
           let policy =
             let open Fault in
             Policy.register ~lvl:Level.info
-              Codept_policies.unknown_extension policy in
-          match Common.classify policy synonyms x with
+              Codept_policies.unknown_extension fault_handler.Fault.policy in
+          let fault_handler = Fault.{ fault_handler with policy } in
+          match Common.classify fault_handler synonyms x with
           | None | Some { Common.kind = Signature; _ } -> m
           | Some { Common.kind = Interface | Implementation ; _ } ->
             Modname.Map.add (Unitname.modname (Read.name x))
@@ -121,19 +122,19 @@ let cmo_or_cmi synonyms path =
   | { Unit.mli = true; ml = _ } -> Pkg.cmi path
   |  _ -> Pkg.cmo path
 
-let collision_error policy = function
+let collision_error fault_handler = function
   | a :: _ as l ->
-    Fault.raise policy Standard_faults.local_module_conflict
+    Fault.raise fault_handler Standard_faults.local_module_conflict
       (a.Unit.path, List.map (fun u -> u.Unit.src) l)
   | [] -> ()
 
-let unit_main policy param synonyms printer g =
+let unit_main fault_handler param synonyms printer g =
   let cmo_or_cmi = cmo_or_cmi synonyms and cmi_or = cmi_or synonyms in
   let open Unit in
   let all = param.all in
   let if_all l = if all then l else [] in
   let g, err = Unit.Group.flatten g in
-  List.iter (collision_error policy) [err.ml; err.mli];
+  List.iter (collision_error fault_handler) [err.ml; err.mli];
   match g with
   | { ml= Some impl ; mli = Some intf } ->
     let cmi = Pkg.cmi impl.src in
@@ -167,8 +168,8 @@ let unit_main policy param synonyms printer g =
   | { ml = None; mli = None } -> ()
 
 
-let main policy ppf synonyms param units =
-  let includes = expand_includes policy synonyms param.includes in
+let main fault_handler ppf synonyms param units =
+  let includes = expand_includes fault_handler synonyms param.includes in
   let print_deps x y = print_deps includes param x y ppf in
   let m =regroup units in
-  Unit.Group.Map.iter (unit_main policy param synonyms print_deps) m
+  Unit.Group.Map.iter (unit_main fault_handler param synonyms print_deps) m

core/makefile.mli

@@ -14,5 +14,5 @@ type param =
   }
 
 val main:
-  Fault.Policy.t -> Format.formatter -> Common.synonyms -> param ->
+  Fault.handler -> Format.formatter -> Common.synonyms -> param ->
   Unit.r list Unit.pair -> unit