Skip to content

Commit 5e0e44e

Browse files
zthzth
committed
add debug utilities
1 parent b1dbc3c commit 5e0e44e

File tree

6 files changed

+488
-25
lines changed

6 files changed

+488
-25
lines changed

‎analysis/src/Commands.ml‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -408,6 +408,13 @@ let test ~path =
408408
| "cle" ->
409409
print_endline ("Code Lens " ^ path);
410410
codeLens ~path ~debug:false
411+
| "ast" ->
412+
print_endline
413+
("Dump AST " ^ path ^ " " ^ string_of_int line ^ ":"
414+
^ string_of_int col);
415+
let currentFile = createCurrentFile () in
416+
DumpAst.dump ~pos:(line, col) ~currentFile;
417+
Sys.remove currentFile
411418
| _ -> ());
412419
print_newline ())
413420
in

‎analysis/src/CompletionFrontEnd.ml‎

Lines changed: 5 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -7,26 +7,6 @@ let rec skipWhite text i =
77
| ' ' | '\n' | '\r' | '\t' -> skipWhite text (i - 1)
88
| _ -> i
99

10-
let offsetOfLine text line =
11-
let ln = String.length text in
12-
let rec loop i lno =
13-
if i >= ln then None
14-
else
15-
match text.[i] with
16-
| '\n' -> if lno = line - 1 then Some (i + 1) else loop (i + 1) (lno + 1)
17-
| _ -> loop (i + 1) lno
18-
in
19-
match line with
20-
| 0 -> Some 0
21-
| _ -> loop 0 0
22-
23-
let positionToOffset text (line, character) =
24-
match offsetOfLine text line with
25-
| None -> None
26-
| Some bol ->
27-
if bol + character <= String.length text then Some (bol + character)
28-
else None
29-
3010
type prop = {
3111
name: string;
3212
posStart: int * int;
@@ -226,7 +206,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor ~text =
226206
in
227207
let posBeforeCursor = (fst posCursor, max 0 (snd posCursor - 1)) in
228208
let charBeforeCursor, blankAfterCursor =
229-
match positionToOffset text posCursor with
209+
match Pos.positionToOffset text posCursor with
230210
| Some offset when offset > 0 -> (
231211
let charBeforeCursor = text.[offset - 1] in
232212
let charAtCursor =
@@ -405,7 +385,9 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor ~text =
405385
else if id.loc.loc_ghost then ()
406386
else if id.loc |> Loc.hasPos ~pos:posBeforeCursor then
407387
let posStart, posEnd = Loc.range id.loc in
408-
match (positionToOffset text posStart, positionToOffset text posEnd) with
388+
match
389+
(Pos.positionToOffset text posStart, Pos.positionToOffset text posEnd)
390+
with
409391
| Some offsetStart, Some offsetEnd ->
410392
(* Can't trust the parser's location
411393
E.g. @foo. let x... gives as label @foo.let *)
@@ -788,7 +770,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor ~text =
788770
else None
789771

790772
let completionWithParser ~debug ~path ~posCursor ~currentFile ~text =
791-
match positionToOffset text posCursor with
773+
match Pos.positionToOffset text posCursor with
792774
| Some offset ->
793775
completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor ~text
794776
| None -> None

‎analysis/src/DumpAst.ml‎

Lines changed: 315 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,315 @@
1+
open SharedTypes
2+
(* This is intended to be a debug tool. It's by no means complete. Rather, you're encouraged to extend this with printing whatever types you need printing. *)
3+
4+
let emptyLocDenom = "<x>"
5+
let hasCursorDenom = "<*>"
6+
let noCursorDenom = ""
7+
8+
let printLocDenominator loc ~pos =
9+
match loc |> CursorPosition.classifyLoc ~pos with
10+
| EmptyLoc -> emptyLocDenom
11+
| HasCursor -> hasCursorDenom
12+
| NoCursor -> noCursorDenom
13+
14+
let printLocDenominatorLoc loc ~pos =
15+
match loc |> CursorPosition.classifyLocationLoc ~pos with
16+
| CursorPosition.EmptyLoc -> emptyLocDenom
17+
| HasCursor -> hasCursorDenom
18+
| NoCursor -> noCursorDenom
19+
20+
let printLocDenominatorPos pos ~posStart ~posEnd =
21+
match CursorPosition.classifyPositions pos ~posStart ~posEnd with
22+
| CursorPosition.EmptyLoc -> emptyLocDenom
23+
| HasCursor -> hasCursorDenom
24+
| NoCursor -> noCursorDenom
25+
26+
let addIndentation indentation =
27+
let rec indent str indentation =
28+
if indentation < 1 then str else indent (str ^ " ") (indentation - 1)
29+
in
30+
indent "" indentation
31+
32+
let printAttributes attributes =
33+
match List.length attributes with
34+
| 0 -> ""
35+
| _ ->
36+
"["
37+
^ (attributes
38+
|> List.map (fun ({Location.txt}, _payload) -> "@" ^ txt)
39+
|> String.concat ",")
40+
^ "]"
41+
42+
let printConstant const =
43+
match const with
44+
| Parsetree.Pconst_integer (s, _) -> "Pconst_integer(" ^ s ^ ")"
45+
| Pconst_char c -> "Pconst_char(" ^ String.make 1 c ^ ")"
46+
| Pconst_string (s, delim) ->
47+
let delim =
48+
match delim with
49+
| None -> ""
50+
| Some delim -> delim ^ " "
51+
in
52+
"Pconst_string(" ^ delim ^ s ^ delim ^ ")"
53+
| Pconst_float (s, _) -> "Pconst_float(" ^ s ^ ")"
54+
55+
let printCoreType typ ~pos =
56+
printAttributes typ.Parsetree.ptyp_attributes
57+
^ (typ.ptyp_loc |> printLocDenominator ~pos)
58+
^
59+
match typ.ptyp_desc with
60+
| Ptyp_any -> "Ptyp_any"
61+
| Ptyp_var name -> "Ptyp_var(" ^ str name ^ ")"
62+
| Ptyp_constr (loc, _types) ->
63+
"Ptyp_constr("
64+
^ (loc |> printLocDenominatorLoc ~pos)
65+
^ (Utils.flattenLongIdent loc.txt |> ident |> str)
66+
^ ")"
67+
| Ptyp_variant _ -> "Ptyp_variant(<unimplemented>)"
68+
| _ -> "<unimplemented_ptyp_desc>"
69+
70+
let rec printPattern pattern ~pos ~indentation =
71+
printAttributes pattern.Parsetree.ppat_attributes
72+
^ (pattern.ppat_loc |> printLocDenominator ~pos)
73+
^
74+
match pattern.Parsetree.ppat_desc with
75+
| Ppat_or (pat1, pat2) ->
76+
"Ppat_or(\n"
77+
^ addIndentation (indentation + 1)
78+
^ printPattern pat1 ~pos ~indentation:(indentation + 2)
79+
^ ",\n"
80+
^ addIndentation (indentation + 1)
81+
^ printPattern pat2 ~pos ~indentation:(indentation + 2)
82+
^ "\n" ^ addIndentation indentation ^ ")"
83+
| Ppat_extension (({txt} as loc), _) ->
84+
"Ppat_extension(%" ^ (loc |> printLocDenominatorLoc ~pos) ^ txt ^ ")"
85+
| Ppat_var ({txt} as loc) ->
86+
"Ppat_var(" ^ (loc |> printLocDenominatorLoc ~pos) ^ txt ^ ")"
87+
| Ppat_constant const -> "Ppat_constant(" ^ printConstant const ^ ")"
88+
| Ppat_construct (({txt} as loc), maybePat) ->
89+
"Ppat_construct("
90+
^ (loc |> printLocDenominatorLoc ~pos)
91+
^ (Utils.flattenLongIdent txt |> ident |> str)
92+
^ (match maybePat with
93+
| None -> ""
94+
| Some pat -> "," ^ printPattern pat ~pos ~indentation)
95+
^ ")"
96+
| Ppat_variant (label, maybePat) ->
97+
"Ppat_variant(" ^ str label
98+
^ (match maybePat with
99+
| None -> ""
100+
| Some pat -> "," ^ printPattern pat ~pos ~indentation)
101+
^ ")"
102+
| Ppat_record (fields, _) ->
103+
"Ppat_record(\n"
104+
^ addIndentation (indentation + 1)
105+
^ "fields:\n"
106+
^ (fields
107+
|> List.map (fun ((Location.{txt} as loc), pat) ->
108+
addIndentation (indentation + 2)
109+
^ (loc |> printLocDenominatorLoc ~pos)
110+
^ (Utils.flattenLongIdent txt |> ident |> str)
111+
^ ": "
112+
^ printPattern pat ~pos ~indentation:(indentation + 2))
113+
|> String.concat "\n")
114+
^ "\n" ^ addIndentation indentation ^ ")"
115+
| Ppat_tuple patterns ->
116+
"Ppat_tuple(\n"
117+
^ (patterns
118+
|> List.map (fun pattern ->
119+
addIndentation (indentation + 2)
120+
^ (pattern |> printPattern ~pos ~indentation:(indentation + 2)))
121+
|> String.concat ",\n")
122+
^ "\n" ^ addIndentation indentation ^ ")"
123+
| Ppat_any -> "Ppat_any"
124+
| Ppat_constraint (pattern, typ) ->
125+
"Ppat_constraint(\n"
126+
^ addIndentation (indentation + 1)
127+
^ printCoreType typ ~pos ^ ",\n"
128+
^ addIndentation (indentation + 1)
129+
^ (pattern |> printPattern ~pos ~indentation:(indentation + 1))
130+
^ "\n" ^ addIndentation indentation ^ ")"
131+
| v -> Printf.sprintf "<unimplemented_ppat_desc: %s>" (Utils.identifyPpat v)
132+
133+
and printCase case ~pos ~indentation ~caseNum =
134+
addIndentation indentation
135+
^ Printf.sprintf "case %i:\n" caseNum
136+
^ addIndentation (indentation + 1)
137+
^ "pattern"
138+
^ (case.Parsetree.pc_lhs.ppat_loc |> printLocDenominator ~pos)
139+
^ ":\n"
140+
^ addIndentation (indentation + 2)
141+
^ printPattern case.Parsetree.pc_lhs ~pos ~indentation
142+
^ "\n"
143+
^ addIndentation (indentation + 1)
144+
^ "expr"
145+
^ (case.Parsetree.pc_rhs.pexp_loc |> printLocDenominator ~pos)
146+
^ ":\n"
147+
^ addIndentation (indentation + 2)
148+
^ printExprItem case.pc_rhs ~pos ~indentation:(indentation + 2)
149+
150+
and printExprItem expr ~pos ~indentation =
151+
printAttributes expr.Parsetree.pexp_attributes
152+
^ (expr.pexp_loc |> printLocDenominator ~pos)
153+
^
154+
match expr.Parsetree.pexp_desc with
155+
| Pexp_match (matchExpr, cases) ->
156+
"Pexp_match("
157+
^ printExprItem matchExpr ~pos ~indentation:0
158+
^ ")\n"
159+
^ (cases
160+
|> List.mapi (fun caseNum case ->
161+
printCase case ~pos ~caseNum:(caseNum + 1)
162+
~indentation:(indentation + 1))
163+
|> String.concat "\n")
164+
| Pexp_ident {txt} ->
165+
"Pexp_ident:" ^ (Utils.flattenLongIdent txt |> SharedTypes.ident)
166+
| Pexp_apply (expr, args) ->
167+
let printLabel labelled ~pos =
168+
match labelled with
169+
| None -> "<unlabelled>"
170+
| Some labelled ->
171+
printLocDenominatorPos pos ~posStart:labelled.posStart
172+
~posEnd:labelled.posEnd
173+
^ "~"
174+
^ if labelled.opt then "?" else "" ^ labelled.name
175+
in
176+
let args = extractExpApplyArgs ~args in
177+
"Pexp_apply(\n"
178+
^ addIndentation (indentation + 1)
179+
^ "expr:\n"
180+
^ addIndentation (indentation + 2)
181+
^ printExprItem expr ~pos ~indentation:(indentation + 2)
182+
^ "\n"
183+
^ addIndentation (indentation + 1)
184+
^ "args:\n"
185+
^ (args
186+
|> List.map (fun arg ->
187+
addIndentation (indentation + 2)
188+
^ printLabel arg.label ~pos ^ "=\n"
189+
^ addIndentation (indentation + 3)
190+
^ printExprItem arg.exp ~pos ~indentation:(indentation + 3))
191+
|> String.concat ",\n")
192+
^ "\n" ^ addIndentation indentation ^ ")"
193+
| Pexp_constant constant -> "Pexp_constant(" ^ printConstant constant ^ ")"
194+
| Pexp_construct (({txt} as loc), maybeExpr) ->
195+
"Pexp_construct("
196+
^ (loc |> printLocDenominatorLoc ~pos)
197+
^ (Utils.flattenLongIdent txt |> ident |> str)
198+
^ (match maybeExpr with
199+
| None -> ""
200+
| Some expr -> ", " ^ printExprItem expr ~pos ~indentation)
201+
^ ")"
202+
| Pexp_variant (label, maybeExpr) ->
203+
"Pexp_variant(" ^ str label
204+
^ (match maybeExpr with
205+
| None -> ""
206+
| Some expr -> "," ^ printExprItem expr ~pos ~indentation)
207+
^ ")"
208+
| Pexp_fun (arg, _maybeDefaultArgExpr, pattern, nextExpr) ->
209+
"Pexp_fun(\n"
210+
^ addIndentation (indentation + 1)
211+
^ "arg: "
212+
^ (match arg with
213+
| Nolabel -> "Nolabel"
214+
| Labelled name -> "Labelled(" ^ name ^ ")"
215+
| Optional name -> "Optional(" ^ name ^ ")")
216+
^ ",\n"
217+
^ addIndentation (indentation + 2)
218+
^ "pattern: "
219+
^ printPattern pattern ~pos ~indentation:(indentation + 2)
220+
^ ",\n"
221+
^ addIndentation (indentation + 1)
222+
^ "next expr:\n"
223+
^ addIndentation (indentation + 2)
224+
^ printExprItem nextExpr ~pos ~indentation:(indentation + 2)
225+
^ "\n" ^ addIndentation indentation ^ ")"
226+
| Pexp_extension (({txt} as loc), _) ->
227+
"Pexp_extension(%" ^ (loc |> printLocDenominatorLoc ~pos) ^ txt ^ ")"
228+
| Pexp_assert expr ->
229+
"Pexp_assert(" ^ printExprItem expr ~pos ~indentation ^ ")"
230+
| Pexp_field (exp, loc) ->
231+
"Pexp_field("
232+
^ (loc |> printLocDenominatorLoc ~pos)
233+
^ printExprItem exp ~pos ~indentation
234+
^ ")"
235+
| Pexp_record (fields, _) ->
236+
"Pexp_record(\n"
237+
^ addIndentation (indentation + 1)
238+
^ "fields:\n"
239+
^ (fields
240+
|> List.map (fun ((Location.{txt} as loc), expr) ->
241+
addIndentation (indentation + 2)
242+
^ (loc |> printLocDenominatorLoc ~pos)
243+
^ (Utils.flattenLongIdent txt |> ident |> str)
244+
^ ": "
245+
^ printExprItem expr ~pos ~indentation:(indentation + 2))
246+
|> String.concat "\n")
247+
^ "\n" ^ addIndentation indentation ^ ")"
248+
| Pexp_tuple exprs ->
249+
"Pexp_tuple(\n"
250+
^ (exprs
251+
|> List.map (fun expr ->
252+
addIndentation (indentation + 2)
253+
^ (expr |> printExprItem ~pos ~indentation:(indentation + 2)))
254+
|> String.concat ",\n")
255+
^ "\n" ^ addIndentation indentation ^ ")"
256+
| v -> Printf.sprintf "<unimplemented_pexp_desc: %s>" (Utils.identifyPexp v)
257+
258+
let printValueBinding value ~pos ~indentation =
259+
printAttributes value.Parsetree.pvb_attributes
260+
^ "value" ^ ":\n"
261+
^ addIndentation (indentation + 1)
262+
^ (value.pvb_pat |> printPattern ~pos ~indentation:(indentation + 1))
263+
^ "\n" ^ addIndentation indentation ^ "expr:\n"
264+
^ addIndentation (indentation + 1)
265+
^ printExprItem value.pvb_expr ~pos ~indentation:(indentation + 1)
266+
267+
let printStructItem structItem ~pos ~source =
268+
match structItem.Parsetree.pstr_loc |> CursorPosition.classifyLoc ~pos with
269+
| HasCursor -> (
270+
let startOffset =
271+
match Pos.positionToOffset source (structItem.pstr_loc |> Loc.start) with
272+
| None -> 0
273+
| Some offset -> offset
274+
in
275+
let endOffset =
276+
(* Include the next line of the source since that will hold the ast comment pointing to the position.
277+
Caveat: this only works for single line sources with a comment on the next line. Will need to be
278+
adapted if that's not the only use case.*)
279+
let line, _col = structItem.pstr_loc |> Loc.end_ in
280+
match Pos.positionToOffset source (line + 2, 0) with
281+
| None -> 0
282+
| Some offset -> offset
283+
in
284+
285+
("\nSource:\n// "
286+
^ String.sub source startOffset (endOffset - startOffset)
287+
^ "\n")
288+
^ printLocDenominator structItem.pstr_loc ~pos
289+
^
290+
match structItem.pstr_desc with
291+
| Pstr_eval (expr, _attributes) ->
292+
"Pstr_eval(\n" ^ printExprItem expr ~pos ~indentation:1 ^ "\n)"
293+
| Pstr_value (recFlag, values) ->
294+
"Pstr_value(\n"
295+
^ (match recFlag with
296+
| Recursive -> " rec,\n"
297+
| Nonrecursive -> "")
298+
^ (values
299+
|> List.map (fun value ->
300+
addIndentation 1 ^ printValueBinding value ~pos ~indentation:1)
301+
|> String.concat ",\n")
302+
^ "\n)"
303+
| _ -> "<structure_item_not_implemented>")
304+
| _ -> ""
305+
306+
let dump ~currentFile ~pos =
307+
let {Res_driver.parsetree = structure; source} =
308+
Res_driver.parsingEngine.parseImplementation ~forPrinter:true
309+
~filename:currentFile
310+
in
311+
312+
print_endline
313+
(structure
314+
|> List.map (fun structItem -> printStructItem structItem ~pos ~source)
315+
|> String.concat "")

0 commit comments

Comments
 (0)