Skip to content

Commit 7ccd648

Browse files
cristianoccristianoc
committed
Test vendor gentype.
1 parent 5bfa5fa commit 7ccd648

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

44 files changed

+6670
-0
lines changed

‎jscomp/dune

+3
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
depends
77
ext
88
frontend
9+
gentype
910
js_parser
1011
main
1112
ml
@@ -30,6 +31,8 @@
3031

3132
(copy_files# frontend/*.{ml,mli})
3233

34+
(copy_files# gentype/*.{ml,mli})
35+
3336
(copy_files# js_parser/*.{ml,mli})
3437

3538
(copy_files# main/*.{ml,mli})

‎jscomp/gentype/Annotation.ml

+247
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,247 @@
1+
type import = {name : string; importPath : ImportPath.t}
2+
3+
type attributePayload =
4+
| BoolPayload of bool
5+
| FloatPayload of string
6+
| IdentPayload of Longident.t
7+
| IntPayload of string
8+
| StringPayload of string
9+
| TuplePayload of attributePayload list
10+
| UnrecognizedPayload
11+
12+
type t = GenType | GenTypeOpaque | NoGenType
13+
14+
let toString annotation =
15+
match annotation with
16+
| GenType -> "GenType"
17+
| GenTypeOpaque -> "GenTypeOpaque"
18+
| NoGenType -> "NoGenType"
19+
20+
let tagIsGenType s = s = "genType" || s = "gentype"
21+
22+
let tagIsGenTypeAs s = s = "genType.as" || s = "gentype.as"
23+
24+
let tagIsBsAs s = s = "bs.as" || s = "as"
25+
26+
let tagIsBsInt s = s = "bs.int" || s = "int"
27+
28+
let tagIsBsString s = s = "bs.string" || s = "string"
29+
30+
let tagIsUnboxed s = s = "unboxed" || s = "ocaml.unboxed"
31+
32+
let tagIsGenTypeImport s = s = "genType.import" || s = "gentype.import"
33+
34+
let tagIsGenTypeOpaque s = s = "genType.opaque" || s = "gentype.opaque"
35+
36+
let tagIsOneOfTheGenTypeAnnotations s =
37+
tagIsGenType s || tagIsGenTypeAs s || tagIsGenTypeImport s
38+
|| tagIsGenTypeOpaque s
39+
40+
let tagIsGenTypeIgnoreInterface s =
41+
s = "genType.ignoreInterface" || s = "gentype.ignoreInterface"
42+
43+
let tagIsOcamlDoc s = s = "ocaml.doc"
44+
45+
let tagIsInternLocal s = s = "internal.local"
46+
47+
let rec getAttributePayload checkText (attributes : Typedtree.attributes) =
48+
let rec fromExpr (expr : Parsetree.expression) =
49+
match expr with
50+
| {pexp_desc = Pexp_constant (Pconst_string (s, _))} ->
51+
Some (StringPayload s)
52+
| {pexp_desc = Pexp_constant (Pconst_integer (n, _))} -> Some (IntPayload n)
53+
| {pexp_desc = Pexp_constant (Pconst_float (s, _))} -> Some (FloatPayload s)
54+
| {
55+
pexp_desc = Pexp_construct ({txt = Lident (("true" | "false") as s)}, _);
56+
_;
57+
} ->
58+
Some (BoolPayload (s = "true"))
59+
| {pexp_desc = Pexp_tuple exprs} ->
60+
let payloads =
61+
exprs |> List.rev
62+
|> List.fold_left
63+
(fun payloads expr ->
64+
match expr |> fromExpr with
65+
| Some payload -> payload :: payloads
66+
| None -> payloads)
67+
[]
68+
in
69+
Some (TuplePayload payloads)
70+
| {pexp_desc = Pexp_ident {txt}} -> Some (IdentPayload txt)
71+
| _ -> None
72+
in
73+
match attributes with
74+
| [] -> None
75+
| ({Asttypes.txt}, payload) :: _tl when checkText txt -> (
76+
match payload with
77+
| PStr [] -> Some UnrecognizedPayload
78+
| PStr ({pstr_desc = Pstr_eval (expr, _)} :: _) -> expr |> fromExpr
79+
| PStr ({pstr_desc = Pstr_extension _} :: _) -> Some UnrecognizedPayload
80+
| PStr ({pstr_desc = Pstr_value _} :: _) -> Some UnrecognizedPayload
81+
| PStr ({pstr_desc = Pstr_primitive _} :: _) -> Some UnrecognizedPayload
82+
| PStr ({pstr_desc = Pstr_type _} :: _) -> Some UnrecognizedPayload
83+
| PStr ({pstr_desc = Pstr_typext _} :: _) -> Some UnrecognizedPayload
84+
| PStr ({pstr_desc = Pstr_exception _} :: _) -> Some UnrecognizedPayload
85+
| PStr ({pstr_desc = Pstr_module _} :: _) -> Some UnrecognizedPayload
86+
| PStr ({pstr_desc = Pstr_recmodule _} :: _) -> Some UnrecognizedPayload
87+
| PStr ({pstr_desc = Pstr_modtype _} :: _) -> Some UnrecognizedPayload
88+
| PStr ({pstr_desc = Pstr_open _} :: _) -> Some UnrecognizedPayload
89+
| PStr ({pstr_desc = Pstr_class _} :: _) -> Some UnrecognizedPayload
90+
| PStr ({pstr_desc = Pstr_class_type _} :: _) -> Some UnrecognizedPayload
91+
| PStr ({pstr_desc = Pstr_include _} :: _) -> Some UnrecognizedPayload
92+
| PStr ({pstr_desc = Pstr_attribute _} :: _) -> Some UnrecognizedPayload
93+
| PPat _ -> Some UnrecognizedPayload
94+
| PSig _ -> Some UnrecognizedPayload
95+
| PTyp _ -> Some UnrecognizedPayload)
96+
| _hd :: tl -> getAttributePayload checkText tl
97+
98+
let getGenTypeAsRenaming attributes =
99+
match attributes |> getAttributePayload tagIsGenTypeAs with
100+
| Some (StringPayload s) -> Some s
101+
| None -> (
102+
match attributes |> getAttributePayload tagIsGenType with
103+
| Some (StringPayload s) -> Some s
104+
| _ -> None)
105+
| _ -> None
106+
107+
let getBsAsRenaming attributes =
108+
match attributes |> getAttributePayload tagIsBsAs with
109+
| Some (StringPayload s) -> Some s
110+
| _ -> None
111+
112+
let getBsAsInt attributes =
113+
match attributes |> getAttributePayload tagIsBsAs with
114+
| Some (IntPayload s) -> (
115+
try Some (int_of_string s) with Failure _ -> None)
116+
| _ -> None
117+
118+
let getAttributeImportRenaming attributes =
119+
let attributeImport = attributes |> getAttributePayload tagIsGenTypeImport in
120+
let genTypeAsRenaming = attributes |> getGenTypeAsRenaming in
121+
match (attributeImport, genTypeAsRenaming) with
122+
| Some (StringPayload importString), _ ->
123+
(Some importString, genTypeAsRenaming)
124+
| ( Some
125+
(TuplePayload [StringPayload importString; StringPayload renameString]),
126+
_ ) ->
127+
(Some importString, Some renameString)
128+
| _ -> (None, genTypeAsRenaming)
129+
130+
let getDocString attributes =
131+
let docPayload = attributes |> getAttributePayload tagIsOcamlDoc in
132+
match docPayload with
133+
| Some (StringPayload docString) -> "/** " ^ docString ^ " */\n"
134+
| _ -> ""
135+
136+
let hasAttribute checkText (attributes : Typedtree.attributes) =
137+
getAttributePayload checkText attributes <> None
138+
139+
let fromAttributes ~loc (attributes : Typedtree.attributes) =
140+
if hasAttribute tagIsGenTypeOpaque attributes then GenTypeOpaque
141+
else if hasAttribute (fun s -> tagIsGenType s || tagIsGenTypeAs s) attributes
142+
then (
143+
(match attributes |> getAttributePayload tagIsGenType with
144+
| Some UnrecognizedPayload -> ()
145+
| Some _ ->
146+
Log_.Color.setup ();
147+
Log_.info ~loc ~name:"Warning genType" (fun ppf () ->
148+
Format.fprintf ppf "Annotation payload is ignored")
149+
| _ -> ());
150+
GenType)
151+
else NoGenType
152+
153+
let rec moduleTypeCheckAnnotation ~checkAnnotation
154+
({mty_desc} : Typedtree.module_type) =
155+
match mty_desc with
156+
| Tmty_signature signature ->
157+
signature |> signatureCheckAnnotation ~checkAnnotation
158+
| Tmty_ident _ | Tmty_functor _ | Tmty_with _ | Tmty_typeof _ | Tmty_alias _
159+
->
160+
false
161+
162+
and moduleDeclarationCheckAnnotation ~checkAnnotation
163+
({md_attributes; md_type; md_loc = loc} : Typedtree.module_declaration) =
164+
md_attributes |> checkAnnotation ~loc
165+
|| md_type |> moduleTypeCheckAnnotation ~checkAnnotation
166+
167+
and signatureItemCheckAnnotation ~checkAnnotation
168+
(signatureItem : Typedtree.signature_item) =
169+
match signatureItem with
170+
| {Typedtree.sig_desc = Typedtree.Tsig_type (_, typeDeclarations)} ->
171+
typeDeclarations
172+
|> List.exists
173+
(fun ({typ_attributes; typ_loc = loc} : Typedtree.type_declaration) ->
174+
typ_attributes |> checkAnnotation ~loc)
175+
| {sig_desc = Tsig_value {val_attributes; val_loc = loc}} ->
176+
val_attributes |> checkAnnotation ~loc
177+
| {sig_desc = Tsig_module moduleDeclaration} ->
178+
moduleDeclaration |> moduleDeclarationCheckAnnotation ~checkAnnotation
179+
| {sig_desc = Tsig_attribute attribute; sig_loc = loc} ->
180+
[attribute] |> checkAnnotation ~loc
181+
| _ -> false
182+
183+
and signatureCheckAnnotation ~checkAnnotation (signature : Typedtree.signature)
184+
=
185+
signature.sig_items
186+
|> List.exists (signatureItemCheckAnnotation ~checkAnnotation)
187+
188+
let rec structureItemCheckAnnotation ~checkAnnotation
189+
(structureItem : Typedtree.structure_item) =
190+
match structureItem with
191+
| {Typedtree.str_desc = Typedtree.Tstr_type (_, typeDeclarations)} ->
192+
typeDeclarations
193+
|> List.exists
194+
(fun ({typ_attributes; typ_loc = loc} : Typedtree.type_declaration) ->
195+
typ_attributes |> checkAnnotation ~loc)
196+
| {str_desc = Tstr_value (_loc, valueBindings)} ->
197+
valueBindings
198+
|> List.exists
199+
(fun ({vb_attributes; vb_loc = loc} : Typedtree.value_binding) ->
200+
vb_attributes |> checkAnnotation ~loc)
201+
| {str_desc = Tstr_primitive {val_attributes; val_loc = loc}} ->
202+
val_attributes |> checkAnnotation ~loc
203+
| {str_desc = Tstr_module moduleBinding} ->
204+
moduleBinding |> moduleBindingCheckAnnotation ~checkAnnotation
205+
| {str_desc = Tstr_recmodule moduleBindings} ->
206+
moduleBindings
207+
|> List.exists (moduleBindingCheckAnnotation ~checkAnnotation)
208+
| {str_desc = Tstr_include {incl_attributes; incl_mod; incl_loc = loc}} ->
209+
incl_attributes |> checkAnnotation ~loc
210+
|| incl_mod |> moduleExprCheckAnnotation ~checkAnnotation
211+
| _ -> false
212+
213+
and moduleExprCheckAnnotation ~checkAnnotation
214+
(moduleExpr : Typedtree.module_expr) =
215+
match moduleExpr.mod_desc with
216+
| Tmod_structure structure ->
217+
structure |> structureCheckAnnotation ~checkAnnotation
218+
| Tmod_constraint
219+
(moduleExpr, _moduleType, moduleTypeConstraint, _moduleCoercion) -> (
220+
moduleExpr |> moduleExprCheckAnnotation ~checkAnnotation
221+
||
222+
match moduleTypeConstraint with
223+
| Tmodtype_explicit moduleType ->
224+
moduleType |> moduleTypeCheckAnnotation ~checkAnnotation
225+
| Tmodtype_implicit -> false)
226+
| Tmod_ident _ | Tmod_functor _ | Tmod_apply _ | Tmod_unpack _ -> false
227+
228+
and moduleBindingCheckAnnotation ~checkAnnotation
229+
({mb_expr; mb_attributes; mb_loc = loc} : Typedtree.module_binding) =
230+
mb_attributes |> checkAnnotation ~loc
231+
|| mb_expr |> moduleExprCheckAnnotation ~checkAnnotation
232+
233+
and structureCheckAnnotation ~checkAnnotation (structure : Typedtree.structure)
234+
=
235+
structure.str_items
236+
|> List.exists (structureItemCheckAnnotation ~checkAnnotation)
237+
238+
let sanitizeVariableName name = name |> Str.global_replace (Str.regexp "-") "_"
239+
240+
let importFromString importString : import =
241+
let name =
242+
let base = importString |> Filename.basename in
243+
(try base |> Filename.chop_extension with Invalid_argument _ -> base)
244+
|> sanitizeVariableName
245+
in
246+
let importPath = ImportPath.fromStringUnsafe importString in
247+
{name; importPath}

‎jscomp/gentype/CodeItem.ml

+57
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,57 @@
1+
open GenTypeCommon
2+
3+
type exportType = {
4+
loc : Location.t;
5+
nameAs : string option;
6+
opaque : bool option;
7+
type_ : type_;
8+
typeVars : string list;
9+
resolvedTypeName : ResolvedName.t;
10+
}
11+
12+
type importValue = {
13+
asPath : string;
14+
importAnnotation : Annotation.import;
15+
type_ : type_;
16+
valueName : string;
17+
}
18+
19+
type exportValue = {
20+
docString : string;
21+
moduleAccessPath : Runtime.moduleAccessPath;
22+
originalName : string;
23+
resolvedName : ResolvedName.t;
24+
type_ : type_;
25+
}
26+
27+
type exportFromTypeDeclaration = {
28+
exportType : exportType;
29+
annotation : Annotation.t;
30+
}
31+
32+
type importType = {
33+
typeName : string;
34+
asTypeName : string option;
35+
importPath : ImportPath.t;
36+
}
37+
38+
type exportTypeItem = {
39+
typeVars : string list;
40+
type_ : type_;
41+
annotation : Annotation.t;
42+
}
43+
44+
type exportTypeMap = exportTypeItem StringMap.t
45+
46+
type typeDeclaration = {
47+
exportFromTypeDeclaration : exportFromTypeDeclaration;
48+
importTypes : importType list;
49+
}
50+
51+
type t = ExportValue of exportValue | ImportValue of importValue
52+
53+
type translation = {
54+
importTypes : importType list;
55+
codeItems : t list;
56+
typeDeclarations : typeDeclaration list;
57+
}

0 commit comments

Comments
 (0)