Skip to content

Commit f6fd9a7

Browse files
nojafnojaf
committed
Complete mk_type_desc
1 parent 2c487c5 commit f6fd9a7

File tree

2 files changed

+95
-47
lines changed

2 files changed

+95
-47
lines changed

‎tools/src/prettier_printer.ml

Lines changed: 10 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,10 @@
11
(* open Analysis *)
22

33
module DSL = struct
4-
type application = {name: string; argument: oak}
5-
6-
and namedField = {name: string; value: oak}
4+
type namedField = {name: string; value: oak}
75

86
and oak =
9-
| Application of application
7+
| Application of string * oak
108
| Record of namedField list
119
| Ident of string
1210
| Tuple of namedField list
@@ -90,7 +88,7 @@ module CodePrinter = struct
9088
let mode =
9189
match ctx.mode with
9290
| Standard -> "Standard"
93-
| TrySingleLine _ -> "TrySingleLine"
91+
| TrySingleLine -> "TrySingleLine"
9492
| ConfirmedMultiline -> "ConfirmedMultiline"
9593
in
9694
Format.printf
@@ -199,24 +197,20 @@ module CodePrinter = struct
199197

200198
let rec genOak (oak : oak) : appendEvents =
201199
match oak with
202-
| Application application -> genApplication application
200+
| Application (name, argument) -> genApplication name argument
203201
| Record record -> genRecord record
204202
| Ident ident -> genIdent ident
205203
| String str -> !-(Format.sprintf "\"%s\"" str)
206204
| Tuple ts -> genTuple ts
207205
| List xs -> genList xs
208206

209-
and genApplication (application : application) : appendEvents =
210-
let short =
211-
!-(application.name) +> sepOpenT
212-
+> genOak application.argument
213-
+> sepCloseT
214-
in
207+
and genApplication (name : string) (argument : oak) : appendEvents =
208+
let short = !-name +> sepOpenT +> genOak argument +> sepCloseT in
215209
let long =
216-
!-(application.name) +> sepOpenT
217-
+> (match application.argument with
218-
| List _ | Record _ -> genOak application.argument
219-
| _ -> indentAndNln (genOak application.argument) +> sepNln)
210+
!-name +> sepOpenT
211+
+> (match argument with
212+
| List _ | Record _ -> genOak argument
213+
| _ -> indentAndNln (genOak argument) +> sepNln)
220214
+> sepCloseT
221215
in
222216
expressionFitsOnRestOfLine short long

‎tools/src/print_tast.ml

Lines changed: 85 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@ module Transform = struct
88
let mk_string_option (o : string option) : oak =
99
match o with
1010
| None -> Ident "None"
11-
| Some s -> Application {name = "Some"; argument = String s}
11+
| Some s -> Application ("Some", String s)
1212

1313
let mk_string_list (items : string list) : oak =
1414
List (items |> List.map (fun s -> String s))
@@ -36,50 +36,105 @@ module Transform = struct
3636
| Reither _ -> Ident "row_field.Reither"
3737
| Rabsent -> Ident "row_field.Rabsent"
3838

39+
let mk_field_kind = function
40+
| Types.Fvar _ -> Ident "field_kind.Fvar"
41+
| Types.Fpresent -> Ident "field_kind.Fpresent"
42+
| Types.Fabsent -> Ident "field_kind.Fabsent"
43+
3944
let rec mk_type_desc (desc : Types.type_desc) : oak =
4045
match desc with
41-
| Tlink {desc} ->
42-
Application {name = "type_desc.Tlink"; argument = mk_type_desc desc}
46+
| Tlink {desc} -> Application ("type_desc.Tlink", mk_type_desc desc)
4347
| Tvar var -> (
4448
match var with
45-
| None -> Application {name = "type_desc.Tvar"; argument = Ident "None"}
46-
| Some s -> Application {name = "type_desc.Tvar"; argument = Ident s})
49+
| None -> Application ("type_desc.Tvar", Ident "None")
50+
| Some s -> Application ("type_desc.Tvar", Ident s))
4751
| Tconstr (path, ts, _) ->
4852
let ts =
4953
ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc)
5054
in
5155
Application
52-
{
53-
name = "type_desc.Tconstr";
54-
argument =
55-
Tuple
56-
[
57-
{name = "path"; value = Ident (path_to_string path)};
58-
{name = "ts"; value = List ts};
59-
];
60-
}
56+
( "type_desc.Tconstr",
57+
Tuple
58+
[
59+
{name = "path"; value = Ident (path_to_string path)};
60+
{name = "ts"; value = List ts};
61+
] )
6162
| Tarrow (_, t1, t2, _) ->
6263
Application
63-
{
64-
name = "type_desc.Tarrow";
65-
argument =
64+
( "type_desc.Tarrow",
65+
Tuple
66+
[
67+
{name = "t1"; value = mk_type_desc t1.desc};
68+
{name = "t2"; value = mk_type_desc t2.desc};
69+
] )
70+
| Ttuple ts ->
71+
let ts =
72+
ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc)
73+
in
74+
Application ("type_desc.Ttuple", List ts)
75+
| Tobject (t, r) -> (
76+
match !r with
77+
| None -> Application ("type_desc.Tobject", mk_type_desc t.desc)
78+
| Some (path, ts) ->
79+
Application
80+
( "type_desc.Tobject",
6681
Tuple
6782
[
68-
{name = "t1"; value = mk_type_desc t1.desc};
69-
{name = "t2"; value = mk_type_desc t2.desc};
70-
];
71-
}
72-
| Ttuple _ -> Ident "type_desc.Ttuple"
73-
| Tobject _ -> Ident "type_desc.Tobject"
74-
| Tfield _ -> Ident "type_desc.Tfield"
83+
{name = "type_expr"; value = mk_type_desc t.desc};
84+
{name = "path"; value = Ident (path_to_string path)};
85+
{
86+
name = "ts";
87+
value =
88+
List
89+
(ts
90+
|> List.map (fun (t : Types.type_expr) ->
91+
mk_type_desc t.desc));
92+
};
93+
] ))
94+
| Tfield (field, fk, t1, t2) ->
95+
Application
96+
( "type_desc.Tfield",
97+
Tuple
98+
[
99+
{name = "name"; value = String field};
100+
{name = "field_kind"; value = mk_field_kind fk};
101+
{name = "t1"; value = mk_type_desc t1.desc};
102+
{name = "t2"; value = mk_type_desc t2.desc};
103+
] )
75104
| Tnil -> Ident "type_desc.Tnil"
76-
| Tsubst _ -> Ident "type_desc.Tsubst"
105+
| Tsubst t -> Application ("type_desc.Tsubst", mk_type_desc t.desc)
77106
| Tvariant row_descr ->
107+
Application ("type_desc.Tvariant", mk_row_desc row_descr)
108+
| Tunivar so -> Application ("type_desc.Tunivar", mk_string_option so)
109+
| Tpoly (t, ts) ->
110+
let ts =
111+
ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc)
112+
in
113+
Application
114+
( "type_desc.Tpoly",
115+
Tuple
116+
[
117+
{name = "t"; value = mk_type_desc t.desc};
118+
{name = "ts"; value = List ts};
119+
] )
120+
| Tpackage (path, lids, ts) ->
121+
let lids =
122+
lids
123+
|> List.map (fun (lid : Longident.t) ->
124+
List
125+
(Longident.flatten lid |> List.map (fun ident -> String ident)))
126+
in
127+
let ts =
128+
ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc)
129+
in
78130
Application
79-
{name = "type_desc.Tvariant"; argument = mk_row_desc row_descr}
80-
| Tunivar _ -> Ident "type_desc.Tunivar"
81-
| Tpoly _ -> Ident "type_desc.Tpoly"
82-
| Tpackage _ -> Ident "type_desc.Tpackage"
131+
( "type_desc.Tpackage",
132+
Tuple
133+
[
134+
{name = "path"; value = Ident (path_to_string path)};
135+
{name = "lids"; value = List lids};
136+
{name = "ts"; value = List ts};
137+
] )
83138

84139
and mk_row_desc (row_desc : Types.row_desc) : oak =
85140
let fields =
@@ -211,8 +266,7 @@ module Transform = struct
211266
let kind =
212267
match item.kind with
213268
| SharedTypes.Module.Value v ->
214-
Application
215-
{name = "SharedTypes.Module.Value"; argument = mk_type_desc v.desc}
269+
Application ("SharedTypes.Module.Value", mk_type_desc v.desc)
216270
| SharedTypes.Module.Type _ -> Ident "Type"
217271
| SharedTypes.Module.Module _ -> Ident "Module"
218272
in

0 commit comments

Comments
 (0)