From 6713337a981b669ad5766d535f199f3429d6bdee Mon Sep 17 00:00:00 2001 From: nojaf Date: Tue, 15 Apr 2025 15:49:09 +0200 Subject: [PATCH 1/4] Inital dump of cmt --- analysis/bin/main.ml | 1 + analysis/src/CmtViewer.ml | 36 ++++++++++++++++++++++++++++++++++++ analysis/src/SharedTypes.ml | 17 +++++++++++++++++ 3 files changed, 54 insertions(+) create mode 100644 analysis/src/CmtViewer.ml diff --git a/analysis/bin/main.ml b/analysis/bin/main.ml index 7b679375b6..5f4658231c 100644 --- a/analysis/bin/main.ml +++ b/analysis/bin/main.ml @@ -223,6 +223,7 @@ let main () = Cfg.useRevampedCompletion := true; Commands.test ~path ~debug | args when List.mem "-h" args || List.mem "--help" args -> prerr_endline help + | [_; "cmt"; path] -> CmtViewer.dump path | _ -> prerr_endline help; exit 1 diff --git a/analysis/src/CmtViewer.ml b/analysis/src/CmtViewer.ml new file mode 100644 index 0000000000..42fb660cfc --- /dev/null +++ b/analysis/src/CmtViewer.ml @@ -0,0 +1,36 @@ +let loc_to_string (loc : Warnings.loc) : string = + Format.sprintf "(%d,%d--%d,%d)" loc.loc_start.pos_lnum + (loc.loc_start.pos_cnum - loc.loc_start.pos_bol) + loc.loc_end.pos_lnum + (loc.loc_end.pos_cnum - loc.loc_end.pos_bol) + +let dump path = + match Cmt.loadFullCmtFromPath ~path with + | None -> failwith (Format.sprintf "Could not load cmt for %s" path) + | Some full -> + let open SharedTypes.Stamps in + let stamps = full.file.stamps |> getEntries in + + Printf.printf "Found %d stamps:\n\n" (List.length stamps); + + stamps + |> List.sort (fun (_, a) (_, b) -> + let aLoc = SharedTypes.Stamps.locOfKind a in + let bLoc = SharedTypes.Stamps.locOfKind b in + match compare aLoc.loc_start.pos_lnum bLoc.loc_start.pos_lnum with + | 0 -> compare aLoc.loc_start.pos_cnum bLoc.loc_start.pos_cnum + | c -> c) + |> List.iter (fun (stamp, kind) -> + match kind with + | KType t -> + Printf.printf "%d ktype %s\n" stamp + (loc_to_string t.extentLoc) + | KValue t -> + Printf.printf "%d kvalue %s\n" stamp + (loc_to_string t.extentLoc) + | KModule t -> + Printf.printf "%d kmodule %s\n" stamp + (loc_to_string t.extentLoc) + | KConstructor t -> + Printf.printf "%d kconstructor %s\n" stamp + (loc_to_string t.extentLoc)) diff --git a/analysis/src/SharedTypes.ml b/analysis/src/SharedTypes.ml index 57cb753ff9..e688f68322 100644 --- a/analysis/src/SharedTypes.ml +++ b/analysis/src/SharedTypes.ml @@ -155,6 +155,14 @@ module Declared = struct end module Stamps : sig + type kind = + | KType of Type.t Declared.t + | KValue of Types.type_expr Declared.t + | KModule of Module.t Declared.t + | KConstructor of Constructor.t Declared.t + + val locOfKind : kind -> Warnings.loc + type t val addConstructor : t -> int -> Constructor.t Declared.t -> unit @@ -169,6 +177,7 @@ module Stamps : sig val iterModules : (int -> Module.t Declared.t -> unit) -> t -> unit val iterTypes : (int -> Type.t Declared.t -> unit) -> t -> unit val iterValues : (int -> Types.type_expr Declared.t -> unit) -> t -> unit + val getEntries : t -> (int * kind) list end = struct type 't stampMap = (int, 't Declared.t) Hashtbl.t @@ -178,6 +187,12 @@ end = struct | KModule of Module.t Declared.t | KConstructor of Constructor.t Declared.t + let locOfKind = function + | KType declared -> declared.extentLoc + | KValue declared -> declared.extentLoc + | KModule declared -> declared.extentLoc + | KConstructor declared -> declared.extentLoc + type t = (int, kind) Hashtbl.t let init () = Hashtbl.create 10 @@ -239,6 +254,8 @@ end = struct | KConstructor d -> f stamp d | _ -> ()) stamps + + let getEntries t = t |> Hashtbl.to_seq |> List.of_seq end module File = struct From 23443579935fd9c9b038695f34d9e4803471fa10 Mon Sep 17 00:00:00 2001 From: nojaf Date: Sat, 26 Apr 2025 13:47:35 +0200 Subject: [PATCH 2/4] Dump locItems --- analysis/src/CmtViewer.ml | 30 ++++++++++++++++++++++++++---- 1 file changed, 26 insertions(+), 4 deletions(-) diff --git a/analysis/src/CmtViewer.ml b/analysis/src/CmtViewer.ml index 42fb660cfc..114d076954 100644 --- a/analysis/src/CmtViewer.ml +++ b/analysis/src/CmtViewer.ml @@ -1,5 +1,5 @@ let loc_to_string (loc : Warnings.loc) : string = - Format.sprintf "(%d,%d--%d,%d)" loc.loc_start.pos_lnum + Format.sprintf "(%03d,%03d--%03d,%03d)" loc.loc_start.pos_lnum (loc.loc_start.pos_cnum - loc.loc_start.pos_bol) loc.loc_end.pos_lnum (loc.loc_end.pos_cnum - loc.loc_end.pos_bol) @@ -8,6 +8,7 @@ let dump path = match Cmt.loadFullCmtFromPath ~path with | None -> failwith (Format.sprintf "Could not load cmt for %s" path) | Some full -> + let open SharedTypes in let open SharedTypes.Stamps in let stamps = full.file.stamps |> getEntries in @@ -15,8 +16,8 @@ let dump path = stamps |> List.sort (fun (_, a) (_, b) -> - let aLoc = SharedTypes.Stamps.locOfKind a in - let bLoc = SharedTypes.Stamps.locOfKind b in + let aLoc = locOfKind a in + let bLoc = locOfKind b in match compare aLoc.loc_start.pos_lnum bLoc.loc_start.pos_lnum with | 0 -> compare aLoc.loc_start.pos_cnum bLoc.loc_start.pos_cnum | c -> c) @@ -33,4 +34,25 @@ let dump path = (loc_to_string t.extentLoc) | KConstructor t -> Printf.printf "%d kconstructor %s\n" stamp - (loc_to_string t.extentLoc)) + (loc_to_string t.extentLoc)); + + (* Dump all locItems (typed nodes) *) + let locItems = + match full.extra with + | {locItems} -> locItems + in + + Printf.printf "\nFound %d locItems (typed nodes):\n\n" + (List.length locItems); + + locItems + |> List.sort (fun a b -> + let aLoc = a.loc.Location.loc_start in + let bLoc = b.loc.Location.loc_start in + match compare aLoc.pos_lnum bLoc.pos_lnum with + | 0 -> compare aLoc.pos_cnum bLoc.pos_cnum + | c -> c) + |> List.iter (fun {loc; locType} -> + let locStr = loc_to_string loc in + let kindStr = SharedTypes.locTypeToString locType in + Printf.printf "%s %s\n" locStr kindStr) From b89a2b62105b171da28a55f5511a65cda70df5ac Mon Sep 17 00:00:00 2001 From: nojaf Date: Sat, 26 Apr 2025 13:58:31 +0200 Subject: [PATCH 3/4] Improve locTypeToString --- analysis/src/SharedTypes.ml | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/analysis/src/SharedTypes.ml b/analysis/src/SharedTypes.ml index e688f68322..8eef8e9adf 100644 --- a/analysis/src/SharedTypes.ml +++ b/analysis/src/SharedTypes.ml @@ -549,16 +549,25 @@ let locKindToString = function | NotFound -> "NotFound" | Definition (_, tip) -> "(Definition " ^ Tip.toString tip ^ ")" +let constantToString = function + | Asttypes.Const_int _ -> "Const_int" + | Asttypes.Const_char _ -> "Const_char" + | Asttypes.Const_string _ -> "Const_string" + | Asttypes.Const_float _ -> "Const_float" + | Asttypes.Const_int32 _ -> "Const_int32" + | Asttypes.Const_int64 _ -> "Const_int64" + | Asttypes.Const_bigint _ -> "Const_bigint" + let locTypeToString = function | Typed (name, e, locKind) -> - "Typed " ^ name ^ " " ^ Shared.typeToString e ^ " " - ^ locKindToString locKind - | Constant _ -> "Constant" + Format.sprintf "Typed(%s) %s: %s" (locKindToString locKind) name + (Shared.typeToString e) + | Constant c -> "Constant " ^ constantToString c | OtherExpression e -> "OtherExpression " ^ Shared.typeToString e | OtherPattern e -> "OtherPattern " ^ Shared.typeToString e | LModule locKind -> "LModule " ^ locKindToString locKind - | TopLevelModule _ -> "TopLevelModule" - | TypeDefinition _ -> "TypeDefinition" + | TopLevelModule name -> "TopLevelModule " ^ name + | TypeDefinition (name, _, _) -> "TypeDefinition " ^ name let locItemToString {loc = {Location.loc_start; loc_end}; locType} = let pos1 = Utils.cmtPosToPosition loc_start in From 5e427d15c1301d98d5eba6e6bc20ba873804bce0 Mon Sep 17 00:00:00 2001 From: nojaf Date: Sat, 26 Apr 2025 14:17:08 +0200 Subject: [PATCH 4/4] Filter by cursor --- analysis/bin/main.ml | 3 +++ analysis/src/CmtViewer.ml | 34 ++++++++++++++++++++++++++++++---- 2 files changed, 33 insertions(+), 4 deletions(-) diff --git a/analysis/bin/main.ml b/analysis/bin/main.ml index 5f4658231c..67eaed7aa9 100644 --- a/analysis/bin/main.ml +++ b/analysis/bin/main.ml @@ -224,6 +224,9 @@ let main () = Commands.test ~path ~debug | args when List.mem "-h" args || List.mem "--help" args -> prerr_endline help | [_; "cmt"; path] -> CmtViewer.dump path + | [_; "cmt"; line; col; path] -> + let cursor = Some (int_of_string line, int_of_string col) in + CmtViewer.dump ~cursor path | _ -> prerr_endline help; exit 1 diff --git a/analysis/src/CmtViewer.ml b/analysis/src/CmtViewer.ml index 114d076954..ebaf39907b 100644 --- a/analysis/src/CmtViewer.ml +++ b/analysis/src/CmtViewer.ml @@ -4,15 +4,40 @@ let loc_to_string (loc : Warnings.loc) : string = loc.loc_end.pos_lnum (loc.loc_end.pos_cnum - loc.loc_end.pos_bol) -let dump path = +let filter_by_cursor cursor (loc : Warnings.loc) : bool = + match cursor with + | None -> true + | Some (line, col) -> + let start = loc.loc_start and end_ = loc.loc_end in + let line_in = start.pos_lnum <= line && line <= end_.pos_lnum in + let col_in = + if start.pos_lnum = end_.pos_lnum then + start.pos_cnum - start.pos_bol <= col + && col <= end_.pos_cnum - end_.pos_bol + else if line = start.pos_lnum then col >= start.pos_cnum - start.pos_bol + else if line = end_.pos_lnum then col <= end_.pos_cnum - end_.pos_bol + else true + in + line_in && col_in + +let dump ?(cursor = None) path = match Cmt.loadFullCmtFromPath ~path with | None -> failwith (Format.sprintf "Could not load cmt for %s" path) | Some full -> let open SharedTypes in let open SharedTypes.Stamps in - let stamps = full.file.stamps |> getEntries in + let filter = filter_by_cursor cursor in + cursor + |> Option.iter (fun (line, col) -> + Printf.printf "Filtering by cursor %d,%d\n" line col); + let stamps = + full.file.stamps |> getEntries + |> List.filter (fun (_, stamp) -> filter (locOfKind stamp)) + in - Printf.printf "Found %d stamps:\n\n" (List.length stamps); + let total_stamps = List.length stamps in + Printf.printf "Found %d stamps:\n%s" total_stamps + (if total_stamps > 0 then "\n" else ""); stamps |> List.sort (fun (_, a) (_, b) -> @@ -39,7 +64,8 @@ let dump path = (* Dump all locItems (typed nodes) *) let locItems = match full.extra with - | {locItems} -> locItems + | {locItems} -> + locItems |> List.filter (fun locItem -> filter locItem.loc) in Printf.printf "\nFound %d locItems (typed nodes):\n\n"