library: make the error formatter a parameter

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

core/modes.ml

@@ -207,12 +207,12 @@ let pp_cycle ppf path =
 let cycle_in_sort =
   Fault.info ["codept"; "sort"] "Cycle detected when sorting modules" pp_cycle
 
-let mode_policy p  =
-  Fault.register ~lvl:Fault.Level.critical cycle_in_sort p
-
+let mode_fault_handler fh  =
+  let policy = Fault.register ~lvl:Fault.Level.critical cycle_in_sort fh.Fault.policy in
+  { fh with Fault.policy }
 
 let sort _ _ ppf param (units: _ Unit.pair) =
-  let policy = mode_policy param.analyzer.policy in
+  let fault_handler = mode_fault_handler param.analyzer.fault_handler in
   let module G = Unit.Group in
   let gs = G.group units in
   let flat g = fst @@ G.flatten g
@@ -236,7 +236,7 @@ let sort _ _ ppf param (units: _ Unit.pair) =
   let sorted = Sorting.full_topological_sort ~key:fst deps paths in
   match sorted with
   | Error path ->
-    Fault.raise policy cycle_in_sort path
+    Fault.raise fault_handler cycle_in_sort path
   | Ok sorted ->
     Pp.fp ppf "%a"
      (Pp.list ~sep:Pp.(s" ") ~post:Pp.(s"\n") Pkg.pp)

core/params.ml

@@ -100,6 +100,9 @@ module L = struct
       (fun x y -> { x with closed_world = y })
   let sig_only =
     analyzer % create (fun x-> x.sig_only) (fun x y -> { x with sig_only = y })
+  let fault_handler =
+    analyzer % create (fun x -> x.fault_handler) (fun r x -> { r with fault_handler = x })
   let policy =
-    analyzer % create (fun x-> x.policy) (fun x y -> { x with policy = y })
+    fault_handler % create (fun x-> x.Fault.policy) (fun x y -> { x with policy = y })
+
 end

core/params.mli

@@ -51,7 +51,8 @@ module L :
     val precomputed_libs : (t, Name.set) l
     val closed_world : (t, bool) l
     val sig_only : (t, bool) l
-    val policy : (t, Fault.Policy.t) l
+    val fault_handler : (t, Fault.handler) l
+    val policy: (t,Fault.Policy.t) l
     val nested : (t,bool) l
     val inner_fmt : (t, Schematic.format) l
     val ext_fmt : (t,Schematic.format) l

core/single.ml

@@ -15,21 +15,21 @@ open Params
 let approx filename = Approx_parser.(to_upper_bound @@ lower_bound filename)
 
 (** Printing directly from source file *)
-let to_m2l policy sig_only (k,f,_n) =
+let to_m2l fault_handler sig_only (k,f,_n) =
   match Common.classic k with
   | None -> None
   | Some k ->
     match Read.file k f with
     | Ok x ->
       if sig_only then Some (k, M2l.Sig_only.filter x) else Some (k,x)
     | Error (Ocaml (Syntax msg)) ->
-      Fault.raise policy Standard_faults.syntaxerr msg;
+      Fault.raise fault_handler Standard_faults.syntaxerr msg;
       Some(k, approx f)
     | Error (Ocaml (Lexer msg)) ->
-      Fault.raise policy Standard_faults.lexerr (!Location.input_name,msg);
+      Fault.raise fault_handler Standard_faults.lexerr (!Location.input_name,msg);
       Some(k, approx f)
     | Error (Serialized e) ->
-      Standard_faults.schematic_errors policy (f,"m2l",e); None
+      Standard_faults.schematic_errors fault_handler (f,"m2l",e); None
 
 let approx_file _ _ ppf _param (_,f,_) =
   let _name, lower, upper = Approx_parser.file f in
@@ -40,7 +40,7 @@ let one_pass _ _ ppf param (_,filename,_ as x) =
   let param = param.analyzer in
   let module Param = (val Analysis.lift param) in
   let module Sg = Dep_zipper.Make(Envt.Core)(Param) in
-  let start = to_m2l param.policy param.sig_only x in
+  let start = to_m2l param.fault_handler param.sig_only x in
   match
     Option.( start
              >>| snd
@@ -56,7 +56,7 @@ let one_pass _ _ ppf param (_,filename,_ as x) =
 
 let m2l_info _ _ ppf param f =
   let param = param.analyzer in
-  let start = to_m2l param.policy param.sig_only f in
+  let start = to_m2l param.fault_handler param.sig_only f in
   let open Option in
   start
   >>| snd
@@ -66,7 +66,7 @@ let m2l_info _ _ ppf param f =
 let m2l filename (writer:Io.writer) ppf param f =
   let fmt = param.internal_format in
   let param = param.analyzer in
-  let start = to_m2l param.policy param.sig_only f in
+  let start = to_m2l param.fault_handler param.sig_only f in
   let open Option in
   start
   >>| begin fun (k,m) ->