Skip to content

Commit e3ff020

Browse files
nojafnojaf
committed
Proof of concept to print type_expr
1 parent a172fb5 commit e3ff020

File tree

2 files changed

+282
-1
lines changed

2 files changed

+282
-1
lines changed

‎tools/src/print_tast.ml

+265
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,265 @@
1+
(* *)
2+
3+
(** Transform the AST types to the more generic Oak format *)
4+
module Oak = struct
5+
type application = {name: string; argument: oak}
6+
7+
and namedField = {name: string; value: oak}
8+
9+
and oak =
10+
| Application of application
11+
| Record of namedField list
12+
| Ident of string
13+
| Tuple of namedField list
14+
| List of oak list
15+
16+
let rec path_to_string = function
17+
| Path.Pident id -> Ident.name id
18+
| Path.Pdot (p, s, _) -> path_to_string p ^ "." ^ s
19+
| Path.Papply (p1, p2) -> path_to_string p1 ^ "(" ^ path_to_string p2 ^ ")"
20+
21+
let rec mk_type_desc (desc : Types.type_desc) : oak =
22+
match desc with
23+
| Tvar _ -> Ident "type_desc.Tvar"
24+
| Tarrow (_, t1, t2, _) ->
25+
Application
26+
{
27+
name = "type_desc.Tarrow";
28+
argument =
29+
Tuple
30+
[
31+
{name = "t1"; value = mk_type_desc t1.desc};
32+
{name = "t2"; value = mk_type_desc t2.desc};
33+
];
34+
}
35+
| Ttuple _ -> Ident "type_desc.Ttuple"
36+
| Tconstr (path, ts, _) ->
37+
let ts =
38+
ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc)
39+
in
40+
Application
41+
{
42+
name = "type_desc.Tconstr";
43+
argument =
44+
Tuple
45+
[
46+
{name = "path"; value = Ident (path_to_string path)};
47+
{name = "ts"; value = List ts};
48+
];
49+
}
50+
| Tobject _ -> Ident "type_desc.Tobject"
51+
| Tfield _ -> Ident "type_desc.Tfield"
52+
| Tnil -> Ident "type_desc.Tnil"
53+
| Tlink {desc} -> Ident "type_desc.Tlink"
54+
| Tsubst _ -> Ident "type_desc.Tsubst"
55+
| Tvariant row_descr -> Ident "type_desc.Tvariant"
56+
| Tunivar _ -> Ident "type_desc.Tunivar"
57+
| Tpoly _ -> Ident "type_desc.Tpoly"
58+
| Tpackage _ -> Ident "type_desc.Tpackage"
59+
end
60+
61+
(** Transform the Oak types to string *)
62+
module CodePrinter = struct
63+
type writerEvents =
64+
| Write of string
65+
| WriteLine
66+
| IndentBy of int
67+
| UnindentBy of int
68+
69+
type context = {
70+
indent_size: int;
71+
max_line_length: int;
72+
current_indent: int;
73+
current_line_column: int;
74+
events: writerEvents list;
75+
}
76+
77+
let countLines (ctx : context) =
78+
ctx.events
79+
|> List.filter (fun event ->
80+
match event with
81+
| WriteLine -> true
82+
| _ -> false)
83+
|> List.length
84+
85+
type appendEvents = context -> context
86+
87+
let emptyContext =
88+
{
89+
indent_size = 2;
90+
max_line_length = 80;
91+
current_indent = 0;
92+
current_line_column = 0;
93+
events = [];
94+
}
95+
96+
(* Type representing the writer context during code printing
97+
98+
- [indent_size] is the configured indentation size, typically 2
99+
- [current_indent] is the current indentation size
100+
- [current_line_column] is the characters written on the current line
101+
- [events] is the write events in reverse order, head event is last written
102+
*)
103+
104+
let id x = x
105+
106+
(** add a write event to the context *)
107+
let ( !- ) str ctx =
108+
{
109+
ctx with
110+
events = Write str :: ctx.events;
111+
current_line_column = ctx.current_line_column + String.length str;
112+
}
113+
114+
(** compose two context transforming functions *)
115+
let ( +> ) f g ctx = g (f ctx)
116+
117+
let sepNln ctx =
118+
{ctx with events = WriteLine :: ctx.events; current_line_column = 0}
119+
120+
let sepComma ctx = !-", " ctx
121+
let sepSemi ctx = !-"; " ctx
122+
let sepOpenT ctx = !-"(" ctx
123+
let sepCloseT ctx = !-")" ctx
124+
let sepOpenR ctx = !-"{" ctx
125+
let sepCloseR ctx = !-"}" ctx
126+
let sepOpenL ctx = !-"[" ctx
127+
let sepCloseL ctx = !-"]" ctx
128+
let sepEq ctx = !-" = " ctx
129+
let indent ctx =
130+
let nextIdent = ctx.current_indent + ctx.indent_size in
131+
{
132+
ctx with
133+
current_indent = nextIdent;
134+
current_line_column = nextIdent;
135+
events = IndentBy ctx.indent_size :: ctx.events;
136+
}
137+
let unindent ctx =
138+
let nextIdent = ctx.current_indent - ctx.indent_size in
139+
{
140+
ctx with
141+
current_indent = nextIdent;
142+
current_line_column = nextIdent;
143+
events = UnindentBy ctx.indent_size :: ctx.events;
144+
}
145+
146+
let indentAndNln f = indent +> sepNln +> f +> unindent
147+
148+
let col (f : 't -> appendEvents) (intertwine : appendEvents) items ctx =
149+
let rec visit items ctx =
150+
match items with
151+
| [] -> ctx
152+
| [item] -> f item ctx
153+
| item :: rest ->
154+
let ctx' = (f item +> intertwine) ctx in
155+
visit rest ctx'
156+
in
157+
visit items ctx
158+
159+
let expressionFitsOnRestOfLine (f : appendEvents) (fallback : appendEvents)
160+
(ctx : context) =
161+
let current_line_count = countLines ctx in
162+
let shortCtx = f ctx in
163+
let nextLineCount = countLines shortCtx in
164+
if
165+
current_line_count == nextLineCount
166+
&& shortCtx.current_line_column <= ctx.max_line_length
167+
then shortCtx
168+
else fallback ctx
169+
170+
(** Fold all the events in context into text *)
171+
let dump (ctx : context) =
172+
let addSpaces n = String.make n ' ' in
173+
174+
List.fold_right
175+
(fun event (acc, current_indent) ->
176+
match event with
177+
| Write str -> (acc ^ str, current_indent)
178+
| WriteLine -> (acc ^ "\n" ^ addSpaces current_indent, current_indent)
179+
| IndentBy n -> (acc, current_indent + n)
180+
| UnindentBy n -> (acc, current_indent - n))
181+
ctx.events ("", 0)
182+
|> fst
183+
184+
let rec genOak (oak : Oak.oak) : appendEvents =
185+
match oak with
186+
| Oak.Application application -> genApplication application
187+
| Oak.Record record -> genRecord record
188+
| Oak.Ident ident -> genIdent ident
189+
| Oak.Tuple ts -> genTuple ts
190+
| Oak.List xs -> genList xs
191+
192+
and genApplication (application : Oak.application) : appendEvents =
193+
let short =
194+
!-(application.name) +> sepOpenT
195+
+> genOak application.argument
196+
+> sepCloseT
197+
in
198+
let long =
199+
!-(application.name) +> sepOpenT
200+
+> indentAndNln (genOak application.argument)
201+
+> sepNln +> sepCloseT
202+
in
203+
expressionFitsOnRestOfLine short long
204+
205+
and genRecord (recordFields : Oak.namedField list) : appendEvents =
206+
let short =
207+
sepOpenR +> col genNamedField sepSemi recordFields +> sepCloseR
208+
in
209+
let long =
210+
sepOpenR
211+
+> indentAndNln (col genNamedField sepNln recordFields)
212+
+> sepNln +> sepCloseR
213+
in
214+
expressionFitsOnRestOfLine short long
215+
216+
and genTuple (oaks : Oak.namedField list) : appendEvents =
217+
let short = col genNamedField sepComma oaks in
218+
let long = col genNamedField sepNln oaks in
219+
expressionFitsOnRestOfLine short long
220+
221+
and genIdent (ident : string) : appendEvents = !-ident
222+
223+
and genNamedField (field : Oak.namedField) : appendEvents =
224+
let short = !-(field.name) +> sepEq +> genOak field.value in
225+
let long =
226+
!-(field.name) +> sepEq
227+
+>
228+
match field.value with
229+
| Oak.List _ -> genOak field.value
230+
| _ -> indentAndNln (genOak field.value)
231+
in
232+
expressionFitsOnRestOfLine short long
233+
234+
and genList (items : Oak.oak list) : appendEvents =
235+
let short = sepOpenL +> col genOak sepSemi items +> sepCloseL in
236+
let long =
237+
sepOpenL +> indentAndNln (col genOak sepNln items) +> sepNln +> sepCloseL
238+
in
239+
expressionFitsOnRestOfLine short long
240+
end
241+
242+
let print_type_expr (typ : Types.type_expr) : string =
243+
CodePrinter.genOak (Oak.mk_type_desc typ.desc) CodePrinter.emptyContext
244+
|> CodePrinter.dump
245+
246+
(* let oak =
247+
Oak.Application
248+
{
249+
Oak.name = "foo";
250+
argument =
251+
Oak.Tuple [{Oak.name = "foo"; value = Oak.Ident "baaaaaaaaaaaaaaaaar"}];
252+
} *)
253+
(* Oak.Record
254+
[
255+
{Oak.name = "foo"; value = Oak.Ident "baaaaaaaaaaaaaaaaar"};
256+
{Oak.name = "member"; value = Oak.Ident "Zigbar"};
257+
] *)
258+
259+
(* let _ =
260+
CodePrinter.genOak oak CodePrinter.emptyContext
261+
|> CodePrinter.dump |> Format.printf "%s\n" *)
262+
263+
(*
264+
Interpret using ocaml /home/nojaf/projects/rescript-vscode/tools/src/print_tast.ml
265+
*)

‎tools/src/tools.ml

+17-1
Original file line numberDiff line numberDiff line change
@@ -18,11 +18,14 @@ type constructorDoc = {
1818
items: constructorPayload option;
1919
}
2020

21+
type valueSignature = {parameters: string list; returnType: string}
22+
2123
type source = {filepath: string; line: int; col: int}
2224

2325
type docItemDetail =
2426
| Record of {fieldDocs: fieldDoc list}
2527
| Variant of {constructorDocs: constructorDoc list}
28+
| Signature of valueSignature
2629

2730
type docItem =
2831
| Value of {
@@ -31,6 +34,7 @@ type docItem =
3134
signature: string;
3235
name: string;
3336
deprecated: string option;
37+
detail: docItemDetail option;
3438
source: source;
3539
}
3640
| Type of {
@@ -147,6 +151,7 @@ let stringifyDetail ?(indentation = 0) (detail : docItemDetail) =
147151
])
148152
|> array) );
149153
]
154+
| Signature {parameters; returnType} -> returnType
150155

151156
let stringifySource ~indentation source =
152157
let open Protocol in
@@ -160,7 +165,7 @@ let stringifySource ~indentation source =
160165
let rec stringifyDocItem ?(indentation = 0) ~originalEnv (item : docItem) =
161166
let open Protocol in
162167
match item with
163-
| Value {id; docstring; signature; name; deprecated; source} ->
168+
| Value {id; docstring; signature; name; deprecated; source; detail} ->
164169
stringifyObject ~startOnNewline:true ~indentation
165170
[
166171
("id", Some (wrapInQuotes id));
@@ -173,6 +178,11 @@ let rec stringifyDocItem ?(indentation = 0) ~originalEnv (item : docItem) =
173178
("signature", Some (signature |> String.trim |> wrapInQuotes));
174179
("docstrings", Some (stringifyDocstrings docstring));
175180
("source", Some (stringifySource ~indentation:(indentation + 1) source));
181+
( "detail",
182+
match detail with
183+
| None -> None
184+
| Some detail ->
185+
Some (stringifyDetail ~indentation:(indentation + 1) detail) );
176186
]
177187
| Type {id; docstring; signature; name; deprecated; detail; source} ->
178188
stringifyObject ~startOnNewline:true ~indentation
@@ -310,6 +320,11 @@ let typeDetail typ ~env ~full =
310320
})
311321
| _ -> None
312322

323+
let valueDetail (item : SharedTypes.Module.item) (typ : Types.type_expr) =
324+
let s = Print_tast.print_type_expr typ in
325+
Format.printf "%s\n" s;
326+
Some (Signature {parameters = []; returnType = s})
327+
313328
let makeId modulePath ~identifier =
314329
identifier :: modulePath |> List.rev |> SharedTypes.ident
315330

@@ -398,6 +413,7 @@ let extractDocs ~entryPointFile ~debug =
398413
^ Shared.typeToString typ;
399414
name = item.name;
400415
deprecated = item.deprecated;
416+
detail = valueDetail item typ;
401417
source;
402418
})
403419
| Type (typ, _) ->

0 commit comments

Comments
 (0)