From cae0e2054e41b37867442a60f7cfea8b3c34b186 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jean-No=C3=ABl=20Avila?= Date: Sun, 27 Dec 2020 22:03:15 +0100 Subject: [PATCH] Remove dependency to Core_kernel Core_kernel brings in a lot of bloat for a number of used functions which is very low. --- plotkicadsch.opam | 1 - plotkicadsch/src/dune | 1 - plotkicadsch/src/gitFs.ml | 11 +++++++---- plotkicadsch/src/kicadDiff.ml | 31 +++++++++++++++++++------------ plotkicadsch/src/plotgitsch.ml | 2 +- plotkicadsch/src/sysAbst.ml | 23 +++++++++++++++++++---- plotkicadsch/src/trueFs.ml | 17 +++++++++++++---- 7 files changed, 59 insertions(+), 27 deletions(-) diff --git a/plotkicadsch.opam b/plotkicadsch.opam index 812d4f7..8bd7849 100644 --- a/plotkicadsch.opam +++ b/plotkicadsch.opam @@ -27,6 +27,5 @@ depends: [ "git" {>= "2.0.0"} "git-unix" "base64" {>= "3.0.0"} - "core_kernel" "cmdliner" ] diff --git a/plotkicadsch/src/dune b/plotkicadsch/src/dune index 4fcd4ab..2de5a19 100644 --- a/plotkicadsch/src/dune +++ b/plotkicadsch/src/dune @@ -12,7 +12,6 @@ lwt.unix sha base64 - core_kernel cmdliner ) (flags (:standard -w -3 -safe-string)) diff --git a/plotkicadsch/src/gitFs.ml b/plotkicadsch/src/gitFs.ml index fa059e5..03dbf93 100644 --- a/plotkicadsch/src/gitFs.ml +++ b/plotkicadsch/src/gitFs.ml @@ -1,4 +1,4 @@ -open Core_kernel +open StdLabels open Lwt.Infix open DiffFs exception InternalGitError of string @@ -11,7 +11,7 @@ let make commitish = let rev_parse r = SysAbst.pread "git" [|"rev-parse"; r ^ "^{commit}"|] >>= fun s -> - try Lwt.return @@ Store.Hash.of_hex @@ String.prefix s 40 + try Lwt.return @@ Store.Hash.of_hex @@ String.sub ~pos:0 s ~len:(min 40 (String.length s)) with _ -> Lwt.fail (InternalGitError ("cannot parse rev " ^ r)) let label = GitFS commitish @@ -83,10 +83,13 @@ let make commitish = |> List.filter_map ~f:(fun {name; node; _} -> if filter name then Some ([name], Store.Hash.to_hex node) else None ) + ;; let find_dir_local t = - let file_list = Store.Value.Tree.to_list t in - List.filter ~f:(fun entry -> let open Core_kernel.Poly in entry.perm = `Dir) file_list + let open Store.Value.Tree in + to_list t + |> List.filter ~f:(fun {perm;_} -> perm == `Dir) + ;; let rec recurse_dir ?dirname node pattern = let rename name = match dirname with diff --git a/plotkicadsch/src/kicadDiff.ml b/plotkicadsch/src/kicadDiff.ml index f9994fb..319ef0e 100644 --- a/plotkicadsch/src/kicadDiff.ml +++ b/plotkicadsch/src/kicadDiff.ml @@ -1,4 +1,4 @@ -open Core_kernel +open StdLabels open Lwt.Infix module S = Kicadsch.MakeSchPainter (SvgPainter) open Kicadsch.Sigs @@ -18,6 +18,14 @@ let fs_mod = function | GitFS r -> GitFs.make r | TrueFS r -> TrueFs.make r + +let is_suffix ~suffix s = + let suff_length = String.length suffix in + let s_length = String.length s in + (suff_length < s_length) && + (String.equal (String.sub s ~pos:(String.length s - suff_length) ~len:suff_length) suffix) +;; + module L = Kicadsch.MakeSchPainter(ListPainter.L) module LP = struct @@ -33,25 +41,25 @@ module FSPainter (S : SchPainter) (F : Simple_FS) : sig val context_from : S.schContext Lwt.t -> S.schContext Lwt.t end = struct - let find_schematics () = F.list_files (String.is_suffix ~suffix:".sch") + let find_schematics () = F.list_files (is_suffix ~suffix:".sch") let process_file initctx filename = let parse c l = S.parse_line l c in let%lwt init = initctx in F.get_content filename >|= fun ctt -> - let lines = String.split_lines ctt in + let lines = String.split_on_char ~sep:'\n' ctt in let endctx = List.fold_left ~f:parse ~init lines in S.output_context endctx let find_libs () = - F.list_files (String.is_suffix ~suffix:"-cache.lib") >|= List.map ~f:fst + F.list_files (is_suffix ~suffix:"-cache.lib") >|= List.map ~f:fst let read_libs initial_ctx lib_list = Lwt_list.fold_left_s (fun c l -> F.get_content l - >|= String.split_lines + >|= String.split_on_char ~sep:'\n' >|= List.fold_left ~f:(fun ctxt l -> S.add_lib l ctxt) ~init:c ) initial_ctx lib_list @@ -69,7 +77,7 @@ let intersect_lists l1l l2l = ~f:(fun (name2, sha2) -> List.exists ~f:(fun (name1, sha1) -> - List.equal String.equal name1 name2 && not (String.equal sha2 sha1) ) + not (String.equal sha2 sha1) && (List.length name1 == List.length name2) && (List.for_all2 ~f:String.equal name1 name2)) l1 ) l2 |> List.map ~f:fst @@ -168,14 +176,13 @@ let internal_diff (d : string) (c : SvgPainter.diff_colors option) (z: string op | Format _ -> BB.create () let dispatch_rect (res, acc) elt = - let open Float in if (BoundingBox.overlap_ratio res elt) > 0.9 then BoundingBox.add_rect res elt , acc else res, elt::acc let rec aggregate rect rect_list = - let result, remaining = List.fold ~f:dispatch_rect ~init:(rect, []) rect_list in + let result, remaining = List.fold_left ~f:dispatch_rect ~init:(rect, []) rect_list in if Int.equal (List.length remaining) (List.length rect_list) then result, remaining else @@ -221,8 +228,8 @@ let internal_diff (d : string) (c : SvgPainter.diff_colors option) (z: string op rec_draw_difftotal ~prev ~next (new_ctx, new_ctx, new_ctx, out_canevas) [] let display_diff ~from_ctx ~to_ctx (filename:string list) ~keep = - let prev = List.sort ~compare from_ctx in - let next = List.sort ~compare to_ctx in + let prev = List.sort ~cmp:compare from_ctx in + let next = List.sort ~cmp:compare to_ctx in match draw_difftotal ~prev ~next (SvgPainter.get_color_context c z) with @@ -352,7 +359,7 @@ let doit from_fs to_fs file_to_diff differ textdiff libs keep colors zone_color let to_list = ToP.find_schematics () in intersect_lists from_list to_list | Some filename -> - let filename_l = String.split ~on:'/' filename in + let filename_l = String.split_on_char ~sep:'/' filename in Lwt.return [filename_l] in let preload_libs () = @@ -384,6 +391,6 @@ let doit from_fs to_fs file_to_diff differ textdiff libs keep colors zone_color | GitFs.InternalGitError s -> Lwt_io.printf "Git Exception: %s\n" s | a -> - Lwt_io.printf "Exception %s\n" (Exn.to_string a) ) + Lwt_io.printf "Exception %s\n" (Printexc.to_string a) ) in Lwt_main.run catch_errors diff --git a/plotkicadsch/src/plotgitsch.ml b/plotkicadsch/src/plotgitsch.ml index 0ab3571..6851cd7 100644 --- a/plotkicadsch/src/plotgitsch.ml +++ b/plotkicadsch/src/plotgitsch.ml @@ -1,4 +1,4 @@ -open Core_kernel +open StdLabels open KicadDiff open Cmdliner diff --git a/plotkicadsch/src/sysAbst.ml b/plotkicadsch/src/sysAbst.ml index 65ac4e1..734da40 100644 --- a/plotkicadsch/src/sysAbst.ml +++ b/plotkicadsch/src/sysAbst.ml @@ -1,4 +1,4 @@ -open Core_kernel +open StdLabels type os = MacOS | Linux | Windows | Cygwin @@ -14,14 +14,17 @@ let process_output_to_string command = with End_of_file -> let stat = UnixLabels.close_process_in chan in (!res, stat) +;; let cmd_output command = let l, _ = process_output_to_string command in l +;; let launch_on_windows command = let _, s = process_output_to_string ("start " ^ command) in Lwt.return s +;; let detect_os () : os = if Sys.win32 then Windows @@ -37,6 +40,7 @@ let detect_os () : os = Linux | _ -> failwith "unknown operating system" +;; let windows_quote s = let open Re in @@ -44,6 +48,7 @@ let windows_quote s = (Posix.compile_pat {|\^|&|\||\(|<|>|}) ~f:(fun ss -> "^" ^ Group.get ss 0) s +;; let exec c a = match detect_os () with @@ -51,7 +56,8 @@ let exec c a = Lwt_process.exec (c, Array.append [|c|] a) | Cygwin | Windows -> launch_on_windows - @@ Array.fold ~f:(fun f g -> f ^ " " ^ windows_quote g) ~init:c a + @@ Array.fold_left ~f:(fun f g -> f ^ " " ^ windows_quote g) ~init:c a +;; let pread c a = match detect_os () with @@ -60,15 +66,23 @@ let pread c a = | Cygwin | Windows -> Lwt.return @@ cmd_output - (Array.fold ~f:(fun f g -> f ^ " " ^ windows_quote g) ~init:c a) + (Array.fold_left ~f:(fun f g -> f ^ " " ^ windows_quote g) ~init:c a) +;; + +let rec last_exn = function + | [e] -> e + | _::tl -> last_exn tl + | [] -> raise Not_found +;; let build_tmp_svg_name ~keep aprefix aschpath = - let aschname = List.last_exn aschpath in + let aschname = last_exn aschpath in let root_prefix = aprefix ^ String.sub aschname ~pos:0 ~len:(String.length aschname - 4) in if keep then root_prefix ^ ".svg" else Stdlib.Filename.temp_file root_prefix ".svg" +;; let finalize_tmp_file fnl ~keep = match detect_os () with @@ -81,6 +95,7 @@ let finalize_tmp_file fnl ~keep = with _ -> Lwt.return_unit ) | Cygwin | Windows -> Lwt.return_unit +;; let default_opener () = match detect_os () with diff --git a/plotkicadsch/src/trueFs.ml b/plotkicadsch/src/trueFs.ml index 1a53ebc..ffe3803 100644 --- a/plotkicadsch/src/trueFs.ml +++ b/plotkicadsch/src/trueFs.ml @@ -1,4 +1,4 @@ -open Core_kernel +open StdLabels open Lwt.Infix open DiffFs @@ -7,7 +7,16 @@ let make rootname = let label = TrueFS rootname - let rootname = String.lstrip ~drop:(Char.equal '/') rootname + let lstrip c s = + let rec find_non_c c s n = + if s.[n] != c then + String.sub ~pos:n ~len:(String.length s - n) s + else + find_non_c c s (n+1) + in + find_non_c c s 0 + + let rootname = lstrip '/' rootname let rootlength = (String.length rootname) + 1 let get_content filename = @@ -38,8 +47,8 @@ let make rootname = let list_files pattern = let list = dir_contents rootname pattern in let file_list = Lwt_list.map_s (fun filename -> - let filename = String.drop_prefix filename rootlength in - let file_path = String.split ~on:'/' filename in + let filename = String.sub filename ~pos:rootlength ~len:(String.length filename - rootlength) in + let file_path = String.split_on_char ~sep:'/' filename in hash_file file_path) list in file_list end