Separate generic and lexifi compilations

Makefile

@@ -1,4 +1,4 @@
-.PHONY: clean examples check dca
+.PHONY: lexifi clean examples check dca
 
 dca:
 	dune build dead_code_analyzer.install
@@ -13,3 +13,6 @@ clean:
 	dune clean
 	make -C examples clean
 	make -C check clean
+
+lexifi:
+	dune build src/deadLexiFi.exe

src/deadCode.ml

@@ -696,7 +696,7 @@ let run_analysis state =
     state.State.config.paths_to_analyze
     state
 
-let () =
+let run () =
 try
     let config = Config.parse_cli () in
     let state = State.init config in

src/deadCode.mli

@@ -200,3 +200,5 @@ See option {b -E} for the syntax of <display>
 {b --help}  Display this list of options
 
   *)
+
+val run : unit -> unit

src/deadCodeAnalyzer.ml

@@ -0,0 +1 @@
+let () = DeadLib.DeadCode.run ()

src/deadLexiFi.ml

@@ -19,7 +19,9 @@ open Parsetree
 open Types
 open Typedtree
 
-open DeadCommon
+open DeadLib.DeadCommon
+
+module State = DeadLib.State
 
 
                 (********   ATTRIBUTES   ********)
@@ -31,144 +33,133 @@ let used = ref []
 let field_link = Hashtbl.create 256
 let dyn_used = Hashtbl.create 256
 
-
-
-let () =
-
-  DeadLexiFi.sig_value :=
-    (fun value ->
-      let add strct = match strct.pstr_desc with
-        | Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _, _)); _}, _) ->
-            hashtbl_add_unique_to_list str s value.val_loc.loc_start
-        | _ -> ()
-      in
-      let add = function
-        | {attr_name = {txt = "mlfi.value_approx"; _}; attr_payload = PStr structure; _} ->
-            List.iter add structure
-        | _ -> ()
-      in
-      List.iter add value.val_attributes
-    );
-
-
-  DeadLexiFi.type_ext :=
-    (fun ct ->
-      (* TO CHECK *)
-      List.iter
-        (fun {attr_name = {txt; _}; _} ->
-          used := (txt, ct.ctyp_loc.loc_start) :: !used;
+let sig_value (value : Types.value_description) =
+  let add strct = match strct.pstr_desc with
+    | Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _, _)); _}, _) ->
+        hashtbl_add_unique_to_list str s value.val_loc.loc_start
+    | _ -> ()
+  in
+  let add = function
+    | {attr_name = {txt = "mlfi.value_approx"; _}; attr_payload = PStr structure; _} ->
+        List.iter add structure
+    | _ -> ()
+  in
+  List.iter add value.val_attributes
+
+let type_ext ct =
+  (* TO CHECK *)
+  List.iter
+    (fun {attr_name = {txt; _}; _} ->
+      used := (txt, ct.ctyp_loc.loc_start) :: !used;
+    )
+    ct.ctyp_attributes
+
+let type_decl td =
+   List.iter
+     (fun {attr_name = {txt; _}; _} ->
+        used := (txt, td.typ_loc.loc_start) :: !used;
+     )
+     td.typ_type.type_attributes
+
+let tstr_type typ ctype =
+  let state = State.get_current () in
+  let modname = State.File_infos.get_modname state.file_infos in
+  let path =
+    let partial_path_rev =
+      typ.typ_name.Asttypes.txt :: !mods
+    in
+    modname :: List.rev partial_path_rev
+    |> String.concat "."
+  in
+  let is_user_defined s =
+    let l = [_variant; "bool"; "float"; "int"; "string"; "unit"] in
+    let mod_name =
+      let rec loop s pos len =
+        if len = String.length s then s
+        else if s.[pos] = '.' then String.sub s (pos - len) len
+        else loop s (pos + 1) (len + 1)
+      in loop s 0 0
+    in
+    not (String.contains s ' ')
+    && (s <> String.capitalize_ascii s && not (List.mem s l)
+      || String.contains s '.' && mod_name <> "Pervasives")
+  in
+  if is_user_defined ctype then
+    hashtbl_add_to_list field_link path ctype
+
+let ttype_of e =
+  let state = State.get_current () in
+  let modname = State.File_infos.get_modname state.file_infos in
+  let name =
+    List.rev (modname :: !mods)
+    |> String.concat "."
+  in
+  let call_site =
+    if e.exp_loc.Location.loc_ghost then !last_loc
+    else e.exp_loc.Location.loc_start
+  in
+  dyn_rec := (name, e.exp_type, call_site) :: !dyn_rec
+
+let prepare_report decs =
+  let state = State.get_current () in
+  let sections = state.config.sections in
+  List.iter
+    (fun (strin, pos) ->
+      hashtbl_find_list str strin
+      |> List.iter
+        (fun loc ->
+          if exported sections.exported_values loc then
+            LocHash.add_set references loc pos
         )
-        ct.ctyp_attributes
-    );
-
-  DeadLexiFi.type_decl :=
-    (fun td ->
-       List.iter
-         (fun {attr_name = {txt; _}; _} ->
-            used := (txt, td.typ_loc.loc_start) :: !used;
-         )
-         td.typ_type.type_attributes
-    );
-
-
-  DeadLexiFi.tstr_type :=
-    (fun typ ctype ->
-      let state = State.get_current () in
-      let modname = State.File_infos.get_modname state.file_infos in
-      let path =
-        let partial_path_rev =
-          typ.typ_name.Asttypes.txt :: !mods
+    )
+    !used;
+  let rec process (p, typ, call_site) =
+    match get_deep_desc typ with
+    | Tarrow (_, t, _, _) -> process (p, t, call_site)
+    | Ttuple ts -> List.iter (fun t -> process (p, t, call_site)) ts
+    | Tconstr (path, ts, _) ->
+        let name = Path.name path in
+        let name =
+          if String.contains name '.' then name
+          else p ^ "." ^ name
         in
-        modname :: List.rev partial_path_rev
-        |> String.concat "."
-      in
-      let is_user_defined s =
-        let l = [_variant; "bool"; "float"; "int"; "string"; "unit"] in
-        let mod_name =
-          let rec loop s pos len =
-            if len = String.length s then s
-            else if s.[pos] = '.' then String.sub s (pos - len) len
-            else loop s (pos + 1) (len + 1)
-          in loop s 0 0
+        let met = ref [] in
+        let rec proc name =
+          if not (List.mem name !met) then begin
+            met := name :: !met;
+            name :: List.fold_left (fun acc name -> acc @ (proc name)) [] (hashtbl_find_list field_link name)
+          end
+          else []
         in
-        not (String.contains s ' ')
-        && (s <> String.capitalize_ascii s && not (List.mem s l)
-          || String.contains s '.' && mod_name <> "Pervasives")
-      in
-      if is_user_defined ctype then
-        hashtbl_add_to_list field_link path ctype
-    );
-
-
-  DeadLexiFi.ttype_of :=
-    (fun e ->
-      let state = State.get_current () in
-      let modname = State.File_infos.get_modname state.file_infos in
-      let name =
-        List.rev (modname :: !mods)
-        |> String.concat "."
-      in
-      let call_site =
-        if e.exp_loc.Location.loc_ghost then !last_loc
-        else e.exp_loc.Location.loc_start
+        List.iter
+          (fun typ ->
+            hashtbl_add_to_list dyn_used typ call_site
+          )
+          (proc name);
+        List.iter (fun t -> process (p, t, call_site)) ts
+    | _ -> ()
+  in
+  List.iter process !dyn_rec;
+  Hashtbl.iter
+    (fun loc (_, path) ->
+      let rec get_type s pos =
+        if pos = 0 then s
+        else if s.[pos] = '.' then String.sub s 0 pos
+        else get_type s (pos - 1)
       in
-      dyn_rec := (name, e.exp_type, call_site) :: !dyn_rec
-    );
-
-
-  DeadLexiFi.prepare_report :=
-    (fun decs ->
-      let state = State.get_current () in
-      let sections = state.config.sections in
       List.iter
-        (fun (strin, pos) ->
-          hashtbl_find_list str strin
-          |> List.iter
-            (fun loc ->
-              if exported sections.exported_values loc then
-                LocHash.add_set references loc pos
-            )
+        ( if exported ~is_type:true sections.types loc then LocHash.add_set references loc
+          else ignore
         )
-        !used;
-      let rec process (p, typ, call_site) =
-        match get_deep_desc typ with
-        | Tarrow (_, t, _, _) -> process (p, t, call_site)
-        | Ttuple ts -> List.iter (fun t -> process (p, t, call_site)) ts
-        | Tconstr (path, ts, _) ->
-            let name = Path.name path in
-            let name =
-              if String.contains name '.' then name
-              else p ^ "." ^ name
-            in
-            let met = ref [] in
-            let rec proc name =
-              if not (List.mem name !met) then begin
-                met := name :: !met;
-                name :: List.fold_left (fun acc name -> acc @ (proc name)) [] (hashtbl_find_list field_link name)
-              end
-              else []
-            in
-            List.iter
-              (fun typ ->
-                hashtbl_add_to_list dyn_used typ call_site
-              )
-              (proc name);
-            List.iter (fun t -> process (p, t, call_site)) ts
-        | _ -> ()
-      in
-      List.iter process !dyn_rec;
-      Hashtbl.iter
-        (fun loc (_, path) ->
-          let rec get_type s pos =
-            if pos = 0 then s
-            else if s.[pos] = '.' then String.sub s 0 pos
-            else get_type s (pos - 1)
-          in
-          List.iter
-            ( if exported ~is_type:true sections.types loc then LocHash.add_set references loc
-              else ignore
-            )
-            (hashtbl_find_list dyn_used (get_type path (String.length path - 1)))
-        )
-        decs
-    );
+        (hashtbl_find_list dyn_used (get_type path (String.length path - 1)))
+    )
+    decs
+
+let () =
+  DeadLexiFi.sig_value := sig_value;
+  DeadLexiFi.type_ext := type_ext;
+  DeadLexiFi.type_decl := type_decl;
+  DeadLexiFi.tstr_type := tstr_type;
+  DeadLexiFi.ttype_of := ttype_of;
+  DeadLexiFi.prepare_report := prepare_report;
+  DeadLib.DeadCode.run ()

src/deadLexiFi.mli

@@ -0,0 +1 @@
+(** Loading this module sets the extensions internally used at LexiFi. *)

src/dune

@@ -1,6 +1,18 @@
+(library
+ (public_name dead_code_analyzer.lib)
+ (name deadLib)
+ (modules (:standard \ deadCodeAnalyzer deadLexiFi))
+ (libraries compiler-libs.common))
+
 (executable
  (public_name dead_code_analyzer)
- (name deadCode)
- (libraries compiler-libs.common))
+ (name deadCodeAnalyzer)
+ (modules DeadCodeAnalyzer)
+ (libraries dead_code_analyzer.lib))
+
+(executable
+ (name deadLexiFi)
+ (modules DeadLexiFi)
+ (libraries dead_code_analyzer.lib))
 
 (include_subdirs unqualified)