diff --git a/analysis/bin/main.ml b/analysis/bin/main.ml index 7b679375b6..67eaed7aa9 100644 --- a/analysis/bin/main.ml +++ b/analysis/bin/main.ml @@ -223,6 +223,10 @@ 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 + | [_; "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 new file mode 100644 index 0000000000..ebaf39907b --- /dev/null +++ b/analysis/src/CmtViewer.ml @@ -0,0 +1,84 @@ +let loc_to_string (loc : Warnings.loc) : string = + 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) + +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 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 + + 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) -> + 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) + |> 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)); + + (* Dump all locItems (typed nodes) *) + let locItems = + match full.extra with + | {locItems} -> + locItems |> List.filter (fun locItem -> filter locItem.loc) + 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) diff --git a/analysis/src/SharedTypes.ml b/analysis/src/SharedTypes.ml index 57cb753ff9..8eef8e9adf 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 @@ -532,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