Inital dump of cmt

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

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)

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