diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 392883d386..05c331313c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -109,8 +109,6 @@ jobs: # Verify that the compiler still builds with older OCaml versions - os: ubuntu-24.04 ocaml_compiler: ocaml-variants.5.2.1+options,ocaml-option-static - # Reanalyze does not work on OCaml 5.3.0 anymore, therefore run it on 5.2.1 - run_reanalyze: true - os: ubuntu-24.04 ocaml_compiler: ocaml-variants.5.0.0+options,ocaml-option-static - os: ubuntu-24.04 @@ -191,10 +189,6 @@ jobs: if: steps.cache-opam-env.outputs.cache-hit != 'true' run: opam install . --deps-only --with-test - - name: "Install reanalyze" - if: steps.cache-opam-env.outputs.cache-hit != 'true' && matrix.run_reanalyze - run: opam install reanalyze - - name: Cache OPAM environment if: steps.cache-opam-env.outputs.cache-hit != 'true' uses: actions/cache/save@v4 @@ -305,10 +299,6 @@ jobs: if: ${{ runner.os == 'Windows' }} run: opam exec -- make test-syntax - - name: "Syntax: Run reanalyze" - if: matrix.run_reanalyze - run: opam exec -- make reanalyze - - name: Build runtime/stdlib run: ./scripts/buildRuntime.sh shell: bash diff --git a/CHANGELOG.md b/CHANGELOG.md index 0a70aff209..e129b995c4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,6 +19,7 @@ - Add `inert` attribute to `JsxDOM.domProps`. https://github.com/rescript-lang/rescript/pull/7326 - Make reanalyze exception tracking work with the new stdlib. https://github.com/rescript-lang/rescript/pull/7328 - Fix Pervasive.max using boolean comparison for floats. https://github.com/rescript-lang/rescript/pull/7333 +- Experimental: Support nested/inline record types - records defined inside of other records, without needing explicit separate type definitions. https://github.com/rescript-lang/rescript/pull/7241 #### :boom: Breaking Change diff --git a/analysis/src/Hover.ml b/analysis/src/Hover.ml index d01d49873e..f0979d695c 100644 --- a/analysis/src/Hover.ml +++ b/analysis/src/Hover.ml @@ -101,26 +101,50 @@ let findRelevantTypesFromType ~file ~package typ = constructors |> List.filter_map (fromConstructorPath ~env:envToSearch) let expandTypes ~file ~package ~supportsMarkdownLinks typ = - findRelevantTypesFromType typ ~file ~package - |> List.map (fun {decl; env; loc; path} -> - let linkToTypeDefinitionStr = - if supportsMarkdownLinks then - Markdown.goToDefinitionText ~env ~pos:loc.Warnings.loc_start - else "" - in - Markdown.divider - ^ (if supportsMarkdownLinks then Markdown.spacing else "") - ^ Markdown.codeBlock - (decl - |> Shared.declToString ~printNameAsIs:true - (SharedTypes.pathIdentToString path)) - ^ linkToTypeDefinitionStr ^ "\n") + match findRelevantTypesFromType typ ~file ~package with + | {decl; path} :: _ + when Res_parsetree_viewer.has_inline_record_definition_attribute + decl.type_attributes -> + (* We print inline record types just with their definition, not the constr pointing + to them, since that doesn't make sense to show the user. *) + ( [ + Markdown.codeBlock + (decl + |> Shared.declToString ~printNameAsIs:true + (SharedTypes.pathIdentToString path)); + ], + `InlineType ) + | all -> + ( all + |> List.map (fun {decl; env; loc; path} -> + let linkToTypeDefinitionStr = + if + supportsMarkdownLinks + && not + (Res_parsetree_viewer + .has_inline_record_definition_attribute + decl.type_attributes) + then Markdown.goToDefinitionText ~env ~pos:loc.Warnings.loc_start + else "" + in + Markdown.divider + ^ (if supportsMarkdownLinks then Markdown.spacing else "") + ^ Markdown.codeBlock + (decl + |> Shared.declToString ~printNameAsIs:true + (SharedTypes.pathIdentToString path)) + ^ linkToTypeDefinitionStr ^ "\n"), + `Default ) (* Produces a hover with relevant types expanded in the main type being hovered. *) let hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks typ = let typeString = Markdown.codeBlock (typ |> Shared.typeToString) in - typeString :: expandTypes ~file ~package ~supportsMarkdownLinks typ - |> String.concat "\n" + let expandedTypes, expansionType = + expandTypes ~file ~package ~supportsMarkdownLinks typ + in + match expansionType with + | `Default -> typeString :: expandedTypes |> String.concat "\n" + | `InlineType -> expandedTypes |> String.concat "\n" (* Leverages autocomplete functionality to produce a hover for a position. This makes it (most often) work with unsaved content. *) @@ -171,10 +195,13 @@ let newHover ~full:{file; package} ~supportsMarkdownLinks locItem = let typeDef = Markdown.codeBlock (Shared.declToString name decl) in match decl.type_manifest with | None -> Some typeDef - | Some typ -> - Some - (typeDef :: expandTypes ~file ~package ~supportsMarkdownLinks typ - |> String.concat "\n")) + | Some typ -> ( + let expandedTypes, expansionType = + expandTypes ~file ~package ~supportsMarkdownLinks typ + in + match expansionType with + | `Default -> Some (typeDef :: expandedTypes |> String.concat "\n") + | `InlineType -> Some (expandedTypes |> String.concat "\n"))) | LModule (Definition (stamp, _tip)) | LModule (LocalReference (stamp, _tip)) -> ( match Stamps.findModule file.stamps stamp with diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index ee6370dba7..e2289f600a 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -1016,6 +1016,7 @@ let new_declaration newtype manifest = type_attributes = []; type_immediate = false; type_unboxed = unboxed_false_default_false; + type_inlined_types = []; } let instance_constructor ?in_pattern cstr = @@ -4185,6 +4186,7 @@ let nondep_type_decl env mid id is_covariant decl = type_attributes = decl.type_attributes; type_immediate = decl.type_immediate; type_unboxed = decl.type_unboxed; + type_inlined_types = decl.type_inlined_types; } with Not_found -> clear_hash (); diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index b1c69741cf..df16f61971 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -86,6 +86,7 @@ let constructor_args priv cd_args cd_res path rep = type_attributes = []; type_immediate = false; type_unboxed; + type_inlined_types = []; } in (existentials, [newgenconstr path type_params], Some tdecl) diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index b64e3e23d1..6deed6ffa3 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -203,6 +203,7 @@ let decl_abstr = type_attributes = []; type_immediate = false; type_unboxed = unboxed_false_default_false; + type_inlined_types = []; } let decl_abstr_imm = {decl_abstr with type_immediate = true} diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 3d20431ba8..dd43032381 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -25,6 +25,8 @@ open Types open Btype open Outcometree +type printing_context = {inlined_types: type_inlined_type list} + let print_res_poly_identifier : (string -> string) ref = ref (fun _ -> assert false) @@ -577,9 +579,33 @@ let reset_and_mark_loops_list tyl = reset (); List.iter mark_loops tyl +let filter_params tyl = + let params = + List.fold_left + (fun tyl ty -> + let ty = repr ty in + if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl + else ty :: tyl) + [] tyl + in + List.rev params + +let mark_loops_constructor_arguments = function + | Cstr_tuple l -> List.iter mark_loops l + | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l + +let find_inlined_type name (printing_context : printing_context option) = + match printing_context with + | None -> None + | Some {inlined_types} -> + inlined_types + |> List.find_opt (fun inlined_type -> + match inlined_type with + | Record {type_name} -> type_name = name) + (* Disabled in classic mode when printing an unification error *) -let rec tree_of_typexp sch ty = +let rec tree_of_typexp ?(printing_context : printing_context option) sch ty = let ty = repr ty in let px = proxy ty in if List.mem_assq px !names && not (List.memq px !delayed) then @@ -603,20 +629,33 @@ let rec tree_of_typexp sch ty = match (repr ty1).desc with | Tconstr (path, [ty], _) when Path.same path Predef.path_option -> - tree_of_typexp sch ty + tree_of_typexp ?printing_context sch ty | _ -> Otyp_stuff "" - else tree_of_typexp sch ty1 + else tree_of_typexp ?printing_context sch ty1 in (* should pass arity here? *) - Otyp_arrow (lab, t1, tree_of_typexp sch ty2, arity) + Otyp_arrow (lab, t1, tree_of_typexp ?printing_context sch ty2, arity) in pr_arrow l ty1 ty2 - | Ttuple tyl -> Otyp_tuple (tree_of_typlist sch tyl) + | Ttuple tyl -> Otyp_tuple (tree_of_typlist ?printing_context sch tyl) + | Tconstr (p, _tyl, _abbrev) + when printing_context + |> find_inlined_type (Path.name p) + |> Option.is_some -> ( + match + find_inlined_type (Path.name p) printing_context |> Option.get + with + | Record {labels} -> + (* Print inlined records as actual inlined record structures, not a reference to the inlined type only. *) + Otyp_record (List.map (tree_of_label ?printing_context) labels)) | Tconstr (p, tyl, _abbrev) -> let p', s = best_type_path p in let tyl' = apply_subst s tyl in - if is_nth s && not (tyl' = []) then tree_of_typexp sch (List.hd tyl') - else Otyp_constr (tree_of_path p', tree_of_typlist sch tyl') + if is_nth s && not (tyl' = []) then + tree_of_typexp ?printing_context sch (List.hd tyl') + else + Otyp_constr + (tree_of_path p', tree_of_typlist ?printing_context sch tyl') | Tvariant row -> ( let row = row_repr row in let fields = @@ -636,7 +675,9 @@ let rec tree_of_typexp sch ty = | Some (p, tyl) when namable_row row -> let p', s = best_type_path p in let id = tree_of_path p' in - let args = tree_of_typlist sch (apply_subst s tyl) in + let args = + tree_of_typlist ?printing_context sch (apply_subst s tyl) + in let out_variant = if is_nth s then List.hd args else Otyp_constr (id, args) in @@ -651,29 +692,31 @@ let rec tree_of_typexp sch ty = let non_gen = (not (row.row_closed && all_present)) && is_non_gen sch px in - let fields = List.map (tree_of_row_field sch) fields in + let fields = + List.map (tree_of_row_field ?printing_context sch) fields + in let tags = if all_present then None else Some (List.map fst present) in Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)) - | Tobject (fi, nm) -> tree_of_typobject sch fi !nm - | Tnil | Tfield _ -> tree_of_typobject sch ty None - | Tsubst ty -> tree_of_typexp sch ty + | Tobject (fi, nm) -> tree_of_typobject ?printing_context sch fi !nm + | Tnil | Tfield _ -> tree_of_typobject ?printing_context sch ty None + | Tsubst ty -> tree_of_typexp ?printing_context sch ty | Tlink _ -> fatal_error "Printtyp.tree_of_typexp" - | Tpoly (ty, []) -> tree_of_typexp sch ty + | Tpoly (ty, []) -> tree_of_typexp ?printing_context sch ty | Tpoly (ty, tyl) -> (*let print_names () = List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; prerr_string "; " in *) let tyl = List.map repr tyl in - if tyl = [] then tree_of_typexp sch ty + if tyl = [] then tree_of_typexp ?printing_context sch ty else let old_delayed = !delayed in (* Make the names delayed, so that the real type is printed once when used as proxy *) List.iter add_delayed tyl; let tl = List.map (name_of_type new_name) tyl in - let tr = Otyp_poly (tl, tree_of_typexp sch ty) in + let tr = Otyp_poly (tl, tree_of_typexp ?printing_context sch ty) in (* Forget names when we leave scope *) remove_names tyl; delayed := old_delayed; @@ -683,7 +726,7 @@ let rec tree_of_typexp sch ty = let n = List.map (fun li -> String.concat "." (Longident.flatten li)) n in - Otyp_module (Path.name p, n, tree_of_typlist sch tyl) + Otyp_module (Path.name p, n, tree_of_typlist ?printing_context sch tyl) in if List.memq px !delayed then delayed := Ext_list.filter !delayed (( != ) px); @@ -692,19 +735,20 @@ let rec tree_of_typexp sch ty = Otyp_alias (pr_typ (), name_of_type new_name px)) else pr_typ () -and tree_of_row_field sch (l, f) = +and tree_of_row_field ?printing_context sch (l, f) = match row_field_repr f with | Rpresent None | Reither (true, [], _, _) -> (l, false, []) - | Rpresent (Some ty) -> (l, false, [tree_of_typexp sch ty]) + | Rpresent (Some ty) -> (l, false, [tree_of_typexp ?printing_context sch ty]) | Reither (c, tyl, _, _) -> if c (* contradiction: constant constructor with an argument *) then - (l, true, tree_of_typlist sch tyl) - else (l, false, tree_of_typlist sch tyl) + (l, true, tree_of_typlist ?printing_context sch tyl) + else (l, false, tree_of_typlist ?printing_context sch tyl) | Rabsent -> (l, false, [] (* actually, an error *)) -and tree_of_typlist sch tyl = List.map (tree_of_typexp sch) tyl +and tree_of_typlist ?printing_context sch tyl = + List.map ((tree_of_typexp ?printing_context) sch) tyl -and tree_of_typobject sch fi nm = +and tree_of_typobject ?printing_context sch fi nm = match nm with | None -> let pr_fields fi = @@ -720,13 +764,13 @@ and tree_of_typobject sch fi nm = let sorted_fields = List.sort (fun (n, _) (n', _) -> String.compare n n') present_fields in - tree_of_typfields sch rest sorted_fields + tree_of_typfields ?printing_context sch rest sorted_fields in let fields, rest = pr_fields fi in Otyp_object (fields, rest) | Some (p, ty :: tyl) -> let non_gen = is_non_gen sch (repr ty) in - let args = tree_of_typlist sch tyl in + let args = tree_of_typlist ?printing_context sch tyl in let p', s = best_type_path p in assert (s = Id); Otyp_class (non_gen, tree_of_path p', args) @@ -734,7 +778,7 @@ and tree_of_typobject sch fi nm = and is_non_gen sch ty = sch && is_Tvar ty && ty.level <> generic_level -and tree_of_typfields sch rest = function +and tree_of_typfields ?printing_context sch rest = function | [] -> let rest = match rest.desc with @@ -745,60 +789,15 @@ and tree_of_typfields sch rest = function in ([], rest) | (s, t) :: l -> - let field = (s, tree_of_typexp sch t) in - let fields, rest = tree_of_typfields sch rest l in + let field = (s, tree_of_typexp ?printing_context sch t) in + let fields, rest = tree_of_typfields ?printing_context sch rest l in (field :: fields, rest) -let typexp sch ppf ty = !Oprint.out_type ppf (tree_of_typexp sch ty) - -let type_expr ppf ty = typexp false ppf ty - -and type_sch ppf ty = typexp true ppf ty - -and type_scheme ppf ty = - reset_and_mark_loops ty; - typexp true ppf ty - -(* Maxence *) -let type_scheme_max ?(b_reset_names = true) ppf ty = - if b_reset_names then reset_names (); - typexp true ppf ty -(* End Maxence *) - -let tree_of_type_scheme ty = - reset_and_mark_loops ty; - tree_of_typexp true ty - -(* Print one type declaration *) - -let tree_of_constraints params = - List.fold_right - (fun ty list -> - let ty' = unalias ty in - if proxy ty != proxy ty' then - let tr = tree_of_typexp true ty in - (tr, tree_of_typexp true ty') :: list - else list) - params [] - -let filter_params tyl = - let params = - List.fold_left - (fun tyl ty -> - let ty = repr ty in - if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl - else ty :: tyl) - [] tyl - in - List.rev params - -let mark_loops_constructor_arguments = function - | Cstr_tuple l -> List.iter mark_loops l - | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l - -let rec tree_of_type_decl id decl = +and tree_of_type_decl id decl = reset (); + let inlined_types = decl.type_inlined_types in + let printing_context = {inlined_types} in let params = filter_params decl.type_params in (match decl.type_manifest with @@ -868,29 +867,33 @@ let rec tree_of_type_decl id decl = in ( Ident.name id, List.map2 - (fun ty cocn -> (type_param (tree_of_typexp false ty), cocn)) + (fun ty cocn -> + (type_param (tree_of_typexp ~printing_context false ty), cocn)) params vari ) in let tree_of_manifest ty1 = match ty_manifest with | None -> ty1 - | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1) + | Some ty -> Otyp_manifest (tree_of_typexp ~printing_context false ty, ty1) in let name, args = type_defined decl in - let constraints = tree_of_constraints params in + let constraints = tree_of_constraints ~printing_context params in let untagged = ref false in let ty, priv = match decl.type_kind with | Type_abstract -> ( match ty_manifest with | None -> (Otyp_abstract, Public) - | Some ty -> (tree_of_typexp false ty, decl.type_private)) + | Some ty -> (tree_of_typexp ~printing_context false ty, decl.type_private) + ) | Type_variant cstrs -> untagged := Ast_untagged_variants.process_untagged decl.type_attributes; - ( tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), + ( tree_of_manifest + (Otyp_sum (List.map (tree_of_constructor ~printing_context) cstrs)), decl.type_private ) | Type_record (lbls, _rep) -> - ( tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + ( tree_of_manifest + (Otyp_record (List.map (tree_of_label ~printing_context) lbls)), decl.type_private ) | Type_open -> (tree_of_manifest Otyp_open, decl.type_private) in @@ -905,11 +908,11 @@ let rec tree_of_type_decl id decl = otype_cstrs = constraints; } -and tree_of_constructor_arguments = function - | Cstr_tuple l -> tree_of_typlist false l +and tree_of_constructor_arguments ?printing_context = function + | Cstr_tuple l -> tree_of_typlist ?printing_context false l | Cstr_record l -> [Otyp_record (List.map tree_of_label l)] -and tree_of_constructor cd = +and tree_of_constructor ?printing_context cd = let name = Ident.name cd.cd_id in let nullary = Ast_untagged_variants.is_nullary_variant cd.cd_args in let repr = @@ -925,25 +928,61 @@ and tree_of_constructor cd = | Some (BigInt s) -> Some (Printf.sprintf "@as(%sn)" s) | Some (Untagged _) (* should never happen *) | None -> None in - let arg () = tree_of_constructor_arguments cd.cd_args in + let arg () = tree_of_constructor_arguments ?printing_context cd.cd_args in match cd.cd_res with | None -> (name, arg (), None, repr) | Some res -> let nm = !names in names := []; - let ret = tree_of_typexp false res in + let ret = tree_of_typexp ?printing_context false res in let args = arg () in names := nm; (name, args, Some ret, repr) -and tree_of_label l = +and tree_of_label ?printing_context l = let opt = l.ld_optional in let typ = match l.ld_type.desc with | Tconstr (p, [t1], _) when opt && Path.same p Predef.path_option -> t1 | _ -> l.ld_type in - (Ident.name l.ld_id, l.ld_mutable = Mutable, opt, tree_of_typexp false typ) + ( Ident.name l.ld_id, + l.ld_mutable = Mutable, + opt, + tree_of_typexp ?printing_context false typ ) + +and tree_of_constraints ?printing_context params = + List.fold_right + (fun ty list -> + let ty' = unalias ty in + if proxy ty != proxy ty' then + let tr = tree_of_typexp ?printing_context true ty in + (tr, tree_of_typexp ?printing_context true ty') :: list + else list) + params [] + +let typexp ?printing_context sch ppf ty = + !Oprint.out_type ppf (tree_of_typexp ?printing_context sch ty) + +let type_expr ppf ty = typexp false ppf ty + +and type_sch ppf ty = typexp true ppf ty + +and type_scheme ppf ty = + reset_and_mark_loops ty; + typexp true ppf ty + +(* Maxence *) +let type_scheme_max ?(b_reset_names = true) ppf ty = + if b_reset_names then reset_names (); + typexp true ppf ty +(* End Maxence *) + +let tree_of_type_scheme ty = + reset_and_mark_loops ty; + tree_of_typexp true ty + +(* Print one type declaration *) let tree_of_type_declaration id decl rs = Osig_type (tree_of_type_decl id decl, tree_of_rec rs) @@ -1055,6 +1094,7 @@ let dummy = type_attributes = []; type_immediate = false; type_unboxed = unboxed_false_default_false; + type_inlined_types = []; } let hide_rec_items = function diff --git a/compiler/ml/printtyp.mli b/compiler/ml/printtyp.mli index a2bf9823fb..bb7c3bd7ea 100644 --- a/compiler/ml/printtyp.mli +++ b/compiler/ml/printtyp.mli @@ -19,6 +19,9 @@ open Format open Types open Outcometree +type printing_context = {inlined_types: type_inlined_type list} +(** Tracks things like inlined records, to help with printing. *) + val print_res_poly_identifier : (string -> string) ref val longident : formatter -> Longident.t -> unit val ident : formatter -> Ident.t -> unit @@ -62,7 +65,8 @@ val modtype : formatter -> module_type -> unit val signature : formatter -> signature -> unit val tree_of_modtype_declaration : Ident.t -> modtype_declaration -> out_sig_item val tree_of_signature : Types.signature -> out_sig_item list -val tree_of_typexp : bool -> type_expr -> out_type +val tree_of_typexp : + ?printing_context:printing_context -> bool -> type_expr -> out_type val modtype_declaration : Ident.t -> formatter -> modtype_declaration -> unit val type_expansion : type_expr -> Format.formatter -> type_expr -> unit val prepare_expansion : type_expr * type_expr -> type_expr * type_expr diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index b439b52f11..b30d32c611 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -294,6 +294,7 @@ let type_declaration s decl = type_attributes = attrs s decl.type_attributes; type_immediate = decl.type_immediate; type_unboxed = decl.type_unboxed; + type_inlined_types = decl.type_inlined_types; } in cleanup_types (); diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 4d14ddc3f2..44bf252d3a 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3104,6 +3104,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp type_attributes = []; type_immediate = false; type_unboxed = unboxed_false_default_false; + type_inlined_types = []; } in Ident.set_current_time ty.level; diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index f31ae8f7fd..14169f2194 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -107,6 +107,7 @@ let enter_type rec_flag env sdecl id = type_attributes = sdecl.ptype_attributes; type_immediate = false; type_unboxed = unboxed_false_default_false; + type_inlined_types = []; } in Env.add_type ~check:true id decl env @@ -683,6 +684,7 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = type_attributes = sdecl.ptype_attributes; type_immediate = false; type_unboxed = unboxed_status; + type_inlined_types = []; } in @@ -1481,7 +1483,25 @@ let transl_type_decl env rec_flag sdecl_list = let tdecls = List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in - let decls = List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in + let inline_types = + tdecls + |> List.filter (fun tdecl -> + tdecl.typ_attributes + |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> + txt = "res.inlineRecordDefinition") + |> Option.is_some) + |> List.filter_map (fun tdecl -> + match tdecl.typ_type.type_kind with + | Type_record (labels, _) -> + Some (Record {type_name = tdecl.typ_name.txt; labels}) + | _ -> None) + in + let decls = + List.map + (fun tdecl -> + (tdecl.typ_id, {tdecl.typ_type with type_inlined_types = inline_types})) + tdecls + in let sdecl_list = Variant_type_spread.expand_dummy_constructor_args sdecl_list decls in @@ -1935,6 +1955,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = type_attributes = sdecl.ptype_attributes; type_immediate = false; type_unboxed; + type_inlined_types = []; } in (match row_path with @@ -1985,6 +2006,7 @@ let abstract_type_decl arity = type_attributes = []; type_immediate = false; type_unboxed = unboxed_false_default_false; + type_inlined_types = []; } in Ctype.end_def (); diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index e012a636cc..0419c76e99 100644 --- a/compiler/ml/typemod.ml +++ b/compiler/ml/typemod.ml @@ -335,6 +335,7 @@ let merge_constraint initial_env loc sg constr = type_attributes = []; type_immediate = false; type_unboxed = unboxed_false_default_false; + type_inlined_types = []; } and id_row = Ident.create (s ^ "#row") in let initial_env = Env.add_type ~check:false id_row decl_row initial_env in diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 1886f2a727..86ec0614e8 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -134,8 +134,12 @@ type type_declaration = { type_attributes: Parsetree.attributes; type_immediate: bool; type_unboxed: unboxed_status; + type_inlined_types: type_inlined_type list; } +and type_inlined_type = + | Record of {type_name: string; labels: label_declaration list} + and type_kind = | Type_abstract | Type_record of label_declaration list * record_representation diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 71c19f629a..a13d64885b 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -262,8 +262,13 @@ type type_declaration = { type_attributes: Parsetree.attributes; type_immediate: bool; (* true iff type should not be a pointer *) type_unboxed: unboxed_status; + type_inlined_types: type_inlined_type list; + (** Representation of inlined types, needed for printing *) } +and type_inlined_type = + | Record of {type_name: string; labels: label_declaration list} + and type_kind = | Type_abstract | Type_record of label_declaration list * record_representation diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index b1724b239a..d2f7bad50c 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -10,6 +10,12 @@ module Parser = Res_parser let mk_loc start_loc end_loc = Location.{loc_start = start_loc; loc_end = end_loc; loc_ghost = false} +type inline_types_context = { + mutable found_inline_types: + (string * Warnings.loc * Parsetree.type_kind) list; + params: (Parsetree.core_type * Asttypes.variance) list; +} + module Recover = struct let default_expr () = let id = Location.mknoloc "rescript.exprhole" in @@ -134,11 +140,15 @@ module ErrorMessages = struct let forbidden_inline_record_declaration = "An inline record type declaration is only allowed in a variant \ - constructor's declaration" + constructor's declaration or nested inside of a record type declaration" let poly_var_int_with_suffix number = "A numeric polymorphic variant cannot be followed by a letter. Did you \ mean `#" ^ number ^ "`?" + + let multiple_inline_record_definitions_at_same_path = + "Only one inline record definition is allowed per record field. This \ + defines more than one inline record." end module InExternal = struct @@ -3974,7 +3984,7 @@ and parse_array_exp p = (* TODO: check attributes in the case of poly type vars, * might be context dependend: parseFieldDeclaration (see ocaml) *) -and parse_poly_type_expr p = +and parse_poly_type_expr ?current_type_name_path ?inline_types_context p = let start_pos = p.Parser.start_pos in match p.Parser.token with | SingleQuote -> ( @@ -4000,7 +4010,7 @@ and parse_poly_type_expr p = Ast_helper.Typ.arrow ~loc ~arity:(Some 1) Nolabel typ return_type | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) | _ -> assert false) - | _ -> parse_typ_expr p + | _ -> parse_typ_expr ?current_type_name_path ?inline_types_context p (* 'a 'b 'c *) and parse_type_var_list p = @@ -4028,7 +4038,8 @@ and parse_lident_list p = in loop p [] -and parse_atomic_typ_expr ~attrs p = +and parse_atomic_typ_expr ?current_type_name_path ?inline_types_context ~attrs p + = Parser.leave_breadcrumb p Grammar.AtomicTypExpr; let start_pos = p.Parser.start_pos in let typ = @@ -4071,7 +4082,28 @@ and parse_atomic_typ_expr ~attrs p = | Lbracket -> parse_polymorphic_variant_type ~attrs p | Uident _ | Lident _ -> let constr = parse_value_path p in - let args = parse_type_constructor_args ~constr_name:constr p in + let args = + parse_type_constructor_args ?inline_types_context + ?current_type_name_path ~constr_name:constr p + in + let number_of_inline_records_in_args = + match inline_types_context with + | None -> 0 + | Some inline_types_context -> + let inline_types = inline_types_context.found_inline_types in + args + |> List.filter (fun (c : Parsetree.core_type) -> + match c.ptyp_desc with + | Ptyp_constr ({txt = Lident typename}, _) -> + inline_types + |> List.exists (fun (name, _, _) -> name = typename) + | _ -> false) + |> List.length + in + if number_of_inline_records_in_args > 1 then + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message + ErrorMessages.multiple_inline_record_definitions_at_same_path); Ast_helper.Typ.constr ~loc:(mk_loc start_pos p.prev_end_pos) ~attrs constr args @@ -4085,7 +4117,9 @@ and parse_atomic_typ_expr ~attrs p = let extension = parse_extension p in let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Typ.extension ~attrs ~loc extension - | Lbrace -> parse_record_or_object_type ~attrs p + | Lbrace -> + parse_record_or_object_type ?current_type_name_path ?inline_types_context + ~attrs p | Eof -> Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); Recover.default_type () @@ -4147,7 +4181,8 @@ and parse_package_constraint p = Some (type_constr, typ) | _ -> None -and parse_record_or_object_type ~attrs p = +and parse_record_or_object_type ?current_type_name_path ?inline_types_context + ~attrs p = (* for inline record in constructor *) let start_pos = p.Parser.start_pos in Parser.expect Lbrace p; @@ -4161,20 +4196,40 @@ and parse_record_or_object_type ~attrs p = Asttypes.Closed | _ -> Asttypes.Closed in - let () = - match p.token with - | Lident _ -> - Parser.err p - (Diagnostics.message ErrorMessages.forbidden_inline_record_declaration) - | _ -> () - in - let fields = - parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parse_string_field_declaration p - in - Parser.expect Rbrace p; - let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Typ.object_ ~loc ~attrs fields closed_flag + match (p.token, inline_types_context, current_type_name_path) with + | Lident _, Some inline_types_context, Some current_type_name_path -> + let labels = + parse_comma_delimited_region ~grammar:Grammar.RecordDecl ~closing:Rbrace + ~f: + (parse_field_declaration_region ~current_type_name_path + ~inline_types_context) + p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let inline_type_name = current_type_name_path |> String.concat "." in + + inline_types_context.found_inline_types <- + (inline_type_name, loc, Parsetree.Ptype_record labels) + :: inline_types_context.found_inline_types; + + let lid = Location.mkloc (Longident.Lident inline_type_name) loc in + Ast_helper.Typ.constr ~loc lid (inline_types_context.params |> List.map fst) + | _ -> + let () = + match p.token with + | Lident _ -> + Parser.err p + (Diagnostics.message ErrorMessages.forbidden_inline_record_declaration) + | _ -> () + in + let fields = + parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parse_string_field_declaration p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.object_ ~loc ~attrs fields closed_flag (* TODO: check associativity in combination with attributes *) and parse_type_alias p typ = @@ -4374,7 +4429,8 @@ and parse_es6_arrow_type ~attrs p = * | uident.lident * | uident.uident.lident --> long module path *) -and parse_typ_expr ?attrs ?(es6_arrow = true) ?(alias = true) p = +and parse_typ_expr ?current_type_name_path ?inline_types_context ?attrs + ?(es6_arrow = true) ?(alias = true) p = (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *) let start_pos = p.Parser.start_pos in let attrs = @@ -4385,7 +4441,10 @@ and parse_typ_expr ?attrs ?(es6_arrow = true) ?(alias = true) p = let typ = if es6_arrow && is_es6_arrow_type p then parse_es6_arrow_type ~attrs p else - let typ = parse_atomic_typ_expr ~attrs p in + let typ = + parse_atomic_typ_expr ?current_type_name_path ?inline_types_context + ~attrs p + in parse_arrow_type_rest ~es6_arrow ~start_pos typ p in let typ = if alias then parse_type_alias p typ else typ in @@ -4424,15 +4483,19 @@ and parse_tuple_type ~attrs ~first ~start_pos p = let tuple_loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Typ.tuple ~attrs ~loc:tuple_loc typexprs -and parse_type_constructor_arg_region p = - if Grammar.is_typ_expr_start p.Parser.token then Some (parse_typ_expr p) +and parse_type_constructor_arg_region ?inline_types_context + ?current_type_name_path p = + if Grammar.is_typ_expr_start p.Parser.token then + Some (parse_typ_expr ?inline_types_context ?current_type_name_path p) else if p.token = LessThan then ( Parser.next p; - parse_type_constructor_arg_region p) + parse_type_constructor_arg_region ?inline_types_context + ?current_type_name_path p) else None (* Js.Nullable.value<'a> *) -and parse_type_constructor_args ~constr_name p = +and parse_type_constructor_args ?inline_types_context ?current_type_name_path + ~constr_name p = let opening = p.Parser.token in let opening_start_pos = p.start_pos in match opening with @@ -4442,7 +4505,11 @@ and parse_type_constructor_args ~constr_name p = let type_args = (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) parse_comma_delimited_region ~grammar:Grammar.TypExprList - ~closing:GreaterThan ~f:parse_type_constructor_arg_region p + ~closing:GreaterThan + ~f: + (parse_type_constructor_arg_region ?inline_types_context + ?current_type_name_path) + p in let () = match p.token with @@ -4526,7 +4593,8 @@ and parse_field_declaration p = let loc = mk_loc start_pos typ.ptyp_loc.loc_end in Ast_helper.Type.field ~attrs ~loc ~mut ~optional name typ -and parse_field_declaration_region ?found_object_field p = +and parse_field_declaration_region ?current_type_name_path ?inline_types_context + ?found_object_field p = let start_pos = p.Parser.start_pos in let attrs = parse_attributes p in let mut = @@ -4551,12 +4619,17 @@ and parse_field_declaration_region ?found_object_field p = | Lident _ -> let lident, loc = parse_lident p in let name = Location.mkloc lident loc in + let current_type_name_path = + match current_type_name_path with + | None -> None + | Some current_type_name_path -> Some (current_type_name_path @ [name.txt]) + in let optional = parse_optional_label p in let typ = match p.Parser.token with | Colon -> Parser.next p; - parse_poly_type_expr p + parse_poly_type_expr ?current_type_name_path ?inline_types_context p | _ -> Ast_helper.Typ.constr ~loc:name.loc ~attrs {name with txt = Lident name.txt} @@ -4582,12 +4655,15 @@ and parse_field_declaration_region ?found_object_field p = * | { field-decl, field-decl } * | { field-decl, field-decl, field-decl, } *) -and parse_record_declaration p = +and parse_record_declaration ?current_type_name_path ?inline_types_context p = Parser.leave_breadcrumb p Grammar.RecordDecl; Parser.expect Lbrace p; let rows = parse_comma_delimited_region ~grammar:Grammar.RecordDecl ~closing:Rbrace - ~f:parse_field_declaration_region p + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types_context) + p in Parser.expect Rbrace p; Parser.eat_breadcrumb p; @@ -4830,7 +4906,7 @@ and parse_type_constructor_declarations ?first p = * ∣ = private record-decl * | = .. *) -and parse_type_representation p = +and parse_type_representation ?current_type_name_path ?inline_types_context p = Parser.leave_breadcrumb p Grammar.TypeRepresentation; (* = consumed *) let private_flag = @@ -4841,7 +4917,10 @@ and parse_type_representation p = match p.Parser.token with | Bar | Uident _ -> Parsetree.Ptype_variant (parse_type_constructor_declarations p) - | Lbrace -> Parsetree.Ptype_record (parse_record_declaration p) + | Lbrace -> + Parsetree.Ptype_record + (parse_record_declaration ?current_type_name_path ?inline_types_context + p) | DotDot -> Parser.next p; Ptype_open @@ -5032,7 +5111,8 @@ and parse_type_equation_or_constr_decl p = (* TODO: is this a good idea? *) (None, Asttypes.Public, Parsetree.Ptype_abstract) -and parse_record_or_object_decl p = +and parse_record_or_object_decl ?current_type_name_path ?inline_types_context p + = let start_pos = p.Parser.start_pos in Parser.expect Lbrace p; match p.Parser.token with @@ -5088,7 +5168,9 @@ and parse_record_or_object_decl p = let found_object_field = ref false in let fields = parse_comma_delimited_region ~grammar:Grammar.RecordDecl ~closing:Rbrace - ~f:(parse_field_declaration_region ~found_object_field) + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types_context ~found_object_field) p in Parser.expect Rbrace p; @@ -5159,7 +5241,11 @@ and parse_record_or_object_decl p = match attrs with | [] -> parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parse_field_declaration_region p + ~closing:Rbrace + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types_context) + p | attr :: _ as attrs -> let first = let field = parse_field_declaration p in @@ -5176,7 +5262,11 @@ and parse_record_or_object_decl p = in first :: parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parse_field_declaration_region p + ~closing:Rbrace + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types_context) + p in Parser.expect Rbrace p; Parser.eat_breadcrumb p; @@ -5366,14 +5456,17 @@ and parse_polymorphic_variant_type_args p = | [typ] -> typ | types -> Ast_helper.Typ.tuple ~loc ~attrs types -and parse_type_equation_and_representation p = +and parse_type_equation_and_representation ?current_type_name_path + ?inline_types_context p = match p.Parser.token with | (Equal | Bar) as token -> ( if token = Bar then Parser.expect Equal p; Parser.next p; match p.Parser.token with | Uident _ -> parse_type_equation_or_constr_decl p - | Lbrace -> parse_record_or_object_decl p + | Lbrace -> + parse_record_or_object_decl ?current_type_name_path ?inline_types_context + p | Private -> parse_private_eq_or_repr p | Bar | DotDot -> let priv, kind = parse_type_representation p in @@ -5383,7 +5476,10 @@ and parse_type_equation_and_representation p = match p.Parser.token with | Equal -> Parser.next p; - let priv, kind = parse_type_representation p in + let priv, kind = + parse_type_representation ?current_type_name_path + ?inline_types_context p + in (manifest, priv, kind) | _ -> (manifest, Public, Parsetree.Ptype_abstract))) | _ -> (None, Public, Parsetree.Ptype_abstract) @@ -5449,9 +5545,13 @@ and parse_type_extension ~params ~attrs ~name p = let constructors = loop p [first] in Ast_helper.Te.mk ~attrs ~params ~priv name constructors -and parse_type_definitions ~attrs ~name ~params ~start_pos p = +and parse_type_definitions ~current_type_name_path ~inline_types_context ~attrs + ~name ~params ~start_pos p = let type_def = - let manifest, priv, kind = parse_type_equation_and_representation p in + let manifest, priv, kind = + parse_type_equation_and_representation ~current_type_name_path + ~inline_types_context p + in let cstrs = parse_type_constraints p in let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest @@ -5500,8 +5600,26 @@ and parse_type_definition_or_extension ~attrs p = (longident |> ErrorMessages.type_declaration_name_longident |> Diagnostics.message) in - let type_defs = parse_type_definitions ~attrs ~name ~params ~start_pos p in - TypeDef {rec_flag; types = type_defs} + let current_type_name_path = Longident.flatten name.txt in + let inline_types_context = {found_inline_types = []; params} in + let type_defs = + parse_type_definitions ~inline_types_context ~current_type_name_path + ~attrs ~name ~params ~start_pos p + in + let rec_flag = + if List.length inline_types_context.found_inline_types > 0 then + Asttypes.Recursive + else rec_flag + in + let inline_types = + inline_types_context.found_inline_types + |> List.map (fun (inline_type_name, loc, kind) -> + Ast_helper.Type.mk ~params + ~attrs:[(Location.mknoloc "res.inlineRecordDefinition", PStr [])] + ~loc ~kind + {name with txt = inline_type_name}) + in + TypeDef {rec_flag; types = inline_types @ type_defs} (* external value-name : typexp = external-declaration *) and parse_external_def ~attrs ~start_pos p = diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 71696b0845..5b3f7ac5f9 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -72,6 +72,13 @@ let has_await_attribute attrs = | _ -> false) attrs +let has_inline_record_definition_attribute attrs = + List.exists + (function + | {Location.txt = "res.inlineRecordDefinition"}, _ -> true + | _ -> false) + attrs + let has_res_pat_variant_spread_attribute attrs = List.exists (function @@ -198,7 +205,8 @@ let filter_parsing_attrs attrs = Location.txt = ( "res.braces" | "ns.braces" | "res.iflet" | "res.ternary" | "res.await" | "res.template" | "res.taggedTemplate" - | "res.patVariantSpread" | "res.dictPattern" ); + | "res.patVariantSpread" | "res.dictPattern" + | "res.inlineRecordDefinition" ); }, _ ) -> false @@ -352,7 +360,7 @@ let has_attributes attrs = | ( { Location.txt = ( "res.braces" | "ns.braces" | "res.iflet" | "res.ternary" - | "res.await" | "res.template" ); + | "res.await" | "res.template" | "res.inlineRecordDefinition" ); }, _ ) -> false @@ -547,7 +555,7 @@ let is_printable_attribute attr = | ( { Location.txt = ( "res.iflet" | "res.braces" | "ns.braces" | "JSX" | "res.await" - | "res.template" | "res.ternary" ); + | "res.template" | "res.ternary" | "res.inlineRecordDefinition" ); }, _ ) -> false diff --git a/compiler/syntax/src/res_parsetree_viewer.mli b/compiler/syntax/src/res_parsetree_viewer.mli index e74233eda9..1774563491 100644 --- a/compiler/syntax/src/res_parsetree_viewer.mli +++ b/compiler/syntax/src/res_parsetree_viewer.mli @@ -15,6 +15,7 @@ val functor_type : * Parsetree.module_type val has_await_attribute : Parsetree.attributes -> bool +val has_inline_record_definition_attribute : Parsetree.attributes -> bool val has_res_pat_variant_spread_attribute : Parsetree.attributes -> bool val has_dict_pattern_attribute : Parsetree.attributes -> bool diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 9b313a00ea..3b88fe5f43 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -450,6 +450,15 @@ let polyvar_ident_to_string poly_var_ident = Doc.concat [Doc.text "#"; print_poly_var_ident poly_var_ident] |> Doc.to_string ~width:80 +let find_inline_record_definition inline_record_name + (inline_record_definitions : Parsetree.type_declaration list option) = + match inline_record_definitions with + | None -> None + | Some inline_record_definitions -> + inline_record_definitions + |> List.find_opt (fun (r : Parsetree.type_declaration) -> + r.ptype_name.txt = inline_record_name) + let print_lident l = let flat_lid_opt lid = let rec flat accu = function @@ -569,6 +578,23 @@ and print_structure_item ~state (si : Parsetree.structure_item) cmt_tbl = | Asttypes.Recursive -> Doc.text "rec " in print_value_bindings ~state ~rec_flag value_bindings cmt_tbl + | Pstr_type (Recursive, type_declarations) + when type_declarations + |> List.find_opt (fun (td : Parsetree.type_declaration) -> + Res_parsetree_viewer.has_inline_record_definition_attribute + td.ptype_attributes) + |> Option.is_some -> + let inline_record_definitions, regular_declarations = + type_declarations + |> List.partition (fun (td : Parsetree.type_declaration) -> + Res_parsetree_viewer.has_inline_record_definition_attribute + td.ptype_attributes) + in + print_type_declarations ~inline_record_definitions ~state + ~rec_flag: + (if List.length regular_declarations > 1 then Doc.text "rec " + else Doc.nil) + regular_declarations cmt_tbl | Pstr_type (rec_flag, type_declarations) -> let rec_flag = match rec_flag with @@ -1107,11 +1133,12 @@ and print_value_description ~state value_description cmt_tbl = else Doc.nil); ]) -and print_type_declarations ~state ~rec_flag type_declarations cmt_tbl = +and print_type_declarations ?inline_record_definitions ~state ~rec_flag + type_declarations cmt_tbl = print_listi ~get_loc:(fun n -> n.Parsetree.ptype_loc) ~nodes:type_declarations - ~print:(print_type_declaration2 ~state ~rec_flag) + ~print:(print_type_declaration2 ?inline_record_definitions ~state ~rec_flag) cmt_tbl (* @@ -1217,8 +1244,8 @@ and print_type_declaration ~state ~name ~equal_sign ~rec_flag i (Doc.concat [attrs; prefix; type_name; type_params; manifest_and_kind; constraints]) -and print_type_declaration2 ~state ~rec_flag (td : Parsetree.type_declaration) - cmt_tbl i = +and print_type_declaration2 ?inline_record_definitions ~state ~rec_flag + (td : Parsetree.type_declaration) cmt_tbl i = let name = let doc = print_ident_like td.Parsetree.ptype_name.txt in print_comments doc cmt_tbl td.ptype_name.loc @@ -1278,7 +1305,8 @@ and print_type_declaration2 ~state ~rec_flag (td : Parsetree.type_declaration) manifest; Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; print_private_flag td.ptype_private; - print_record_declaration ~state lds cmt_tbl; + print_record_declaration ?inline_record_definitions ~state lds + cmt_tbl; ] | Ptype_variant cds -> let manifest = @@ -1371,8 +1399,8 @@ and print_type_param ~state (param : Parsetree.core_type * Asttypes.variance) in Doc.concat [printed_variance; print_typ_expr ~state typ cmt_tbl] -and print_record_declaration ~state (lds : Parsetree.label_declaration list) - cmt_tbl = +and print_record_declaration ?inline_record_definitions ~state + (lds : Parsetree.label_declaration list) cmt_tbl = let force_break = match (lds, List.rev lds) with | first :: _, last :: _ -> @@ -1391,7 +1419,10 @@ and print_record_declaration ~state (lds : Parsetree.label_declaration list) ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun ld -> - let doc = print_label_declaration ~state ld cmt_tbl in + let doc = + print_label_declaration ?inline_record_definitions + ~state ld cmt_tbl + in print_comments doc cmt_tbl ld.Parsetree.pld_loc) lds); ]); @@ -1556,7 +1587,8 @@ and print_constructor_arguments ?(is_dot_dot_dot = false) ~state ~indent in if indent then Doc.indent args else args -and print_label_declaration ~state (ld : Parsetree.label_declaration) cmt_tbl = +and print_label_declaration ?inline_record_definitions ~state + (ld : Parsetree.label_declaration) cmt_tbl = let attrs = print_attributes ~state ~loc:ld.pld_name.loc ld.pld_attributes cmt_tbl in @@ -1581,10 +1613,11 @@ and print_label_declaration ~state (ld : Parsetree.label_declaration) cmt_tbl = name; optional; (if is_dot then Doc.nil else Doc.text ": "); - print_typ_expr ~state ld.pld_type cmt_tbl; + print_typ_expr ?inline_record_definitions ~state ld.pld_type cmt_tbl; ]) -and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = +and print_typ_expr ?inline_record_definitions ~(state : State.t) + (typ_expr : Parsetree.core_type) cmt_tbl = let print_arrow ~arity typ_expr = let max_arity = match arity with @@ -1689,6 +1722,19 @@ and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = | Ptyp_object (fields, open_flag) -> print_object ~state ~inline:false fields open_flag cmt_tbl | Ptyp_arrow {arity} -> print_arrow ~arity typ_expr + | Ptyp_constr ({txt = Lident inline_record_name}, _) + when inline_record_definitions + |> find_inline_record_definition inline_record_name + |> Option.is_some -> ( + match + inline_record_definitions + |> find_inline_record_definition inline_record_name + with + | Some {ptype_kind = Ptype_record lds} -> + print_record_declaration + ~inline_record_definitions:(inline_record_definitions |> Option.get) + ~state lds cmt_tbl + | _ -> assert false) | Ptyp_constr (longident_loc, [{ptyp_desc = Ptyp_object (fields, open_flag)}]) -> (* for foo<{"a": b}>, when the object is long and needs a line break, we @@ -1729,7 +1775,8 @@ and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun typexpr -> - print_typ_expr ~state typexpr cmt_tbl) + print_typ_expr ?inline_record_definitions ~state + typexpr cmt_tbl) constr_args); ]); Doc.trailing_comma; @@ -1737,7 +1784,8 @@ and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = Doc.greater_than; ])) | Ptyp_tuple types -> print_tuple_type ~state ~inline:false types cmt_tbl - | Ptyp_poly ([], typ) -> print_typ_expr ~state typ cmt_tbl + | Ptyp_poly ([], typ) -> + print_typ_expr ?inline_record_definitions ~state typ cmt_tbl | Ptyp_poly (string_locs, typ) -> Doc.concat [ diff --git a/tests/analysis_tests/tests-generic-jsx-transform/package-lock.json b/tests/analysis_tests/tests-generic-jsx-transform/package-lock.json index 9898a917de..43c32c3717 100644 --- a/tests/analysis_tests/tests-generic-jsx-transform/package-lock.json +++ b/tests/analysis_tests/tests-generic-jsx-transform/package-lock.json @@ -9,6 +9,7 @@ } }, "../../..": { + "name": "rescript", "version": "12.0.0-alpha.10", "hasInstallScript": true, "license": "SEE LICENSE IN LICENSE", diff --git a/tests/analysis_tests/tests-incremental-typechecking/package-lock.json b/tests/analysis_tests/tests-incremental-typechecking/package-lock.json index 307967524e..8168914865 100644 --- a/tests/analysis_tests/tests-incremental-typechecking/package-lock.json +++ b/tests/analysis_tests/tests-incremental-typechecking/package-lock.json @@ -9,6 +9,7 @@ } }, "../../..": { + "name": "rescript", "version": "12.0.0-alpha.10", "hasInstallScript": true, "license": "SEE LICENSE IN LICENSE", diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/package-lock.json b/tests/analysis_tests/tests-reanalyze/deadcode/package-lock.json index 6c579396cd..bc5a8754dc 100644 --- a/tests/analysis_tests/tests-reanalyze/deadcode/package-lock.json +++ b/tests/analysis_tests/tests-reanalyze/deadcode/package-lock.json @@ -15,6 +15,7 @@ } }, "../../../..": { + "name": "rescript", "version": "12.0.0-alpha.10", "dev": true, "hasInstallScript": true, diff --git a/tests/analysis_tests/tests-reanalyze/termination/package-lock.json b/tests/analysis_tests/tests-reanalyze/termination/package-lock.json index da7d58b7fd..52e45f77df 100644 --- a/tests/analysis_tests/tests-reanalyze/termination/package-lock.json +++ b/tests/analysis_tests/tests-reanalyze/termination/package-lock.json @@ -12,6 +12,7 @@ } }, "../../../..": { + "name": "rescript", "version": "12.0.0-alpha.10", "dev": true, "hasInstallScript": true, diff --git a/tests/analysis_tests/tests/src/NestedRecords.res b/tests/analysis_tests/tests/src/NestedRecords.res new file mode 100644 index 0000000000..17077fd510 --- /dev/null +++ b/tests/analysis_tests/tests/src/NestedRecords.res @@ -0,0 +1,28 @@ +// +type options = { + extra: { + name: string, + superExtra: {age: int}, + }, +} + +let options = { + extra: { + name: "test", + superExtra: { + age: 2222, + }, + }, +} + +// options +// ^hov + +// options.extra +// ^hov + +// options.extra.superExtra +// ^hov + +// options.extra.superExtra.age +// ^hov diff --git a/tests/analysis_tests/tests/src/NestedRecordsHover.res b/tests/analysis_tests/tests/src/NestedRecordsHover.res new file mode 100644 index 0000000000..ab41d9a44c --- /dev/null +++ b/tests/analysis_tests/tests/src/NestedRecordsHover.res @@ -0,0 +1,27 @@ +type options = { + extra?: { + name: string, + superExtra?: {age: int}, + otherExtra: option<{test: bool, anotherInlined: {record: bool}}>, + }, +} + +let options = { + // ^hov + extra: { + name: "test", + //^hov + superExtra: { + age: 2222, + //^hov + }, + otherExtra: Some({ + test: true, + // ^hov + anotherInlined: { + record: true, + // ^hov + }, + }), + }, +} diff --git a/tests/analysis_tests/tests/src/expected/NestedRecords.res.txt b/tests/analysis_tests/tests/src/expected/NestedRecords.res.txt new file mode 100644 index 0000000000..db012ca3c9 --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/NestedRecords.res.txt @@ -0,0 +1,118 @@ +Hover src/NestedRecords.res 17:5 +Nothing at that position. Now trying to use completion. +posCursor:[17:5] posNoWhite:[17:4] Found expr:[17:3->17:10] +Pexp_ident options:[17:3->17:10] +Completable: Cpath Value[options] +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[options] +Path options +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +{"contents": {"kind": "markdown", "value": "```rescript\noptions\n```\n\n---\n\n```\n \n```\n```rescript\ntype options = {\n extra: {name: string, superExtra: {age: int}},\n}\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22NestedRecords.res%22%2C1%2C0%5D)\n\n\n---\n\n```\n \n```\n```rescript\ntype options.extra = {name: string, superExtra: {age: int}}\n```\n"}} + +Hover src/NestedRecords.res 20:13 +Nothing at that position. Now trying to use completion. +posCursor:[20:13] posNoWhite:[20:12] Found expr:[20:3->20:16] +Pexp_field [20:3->20:10] extra:[20:11->20:16] +Completable: Cpath Value[options].extra +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[options].extra +ContextPath Value[options] +Path options +ContextPath Value[options]->extra +ContextPath Value[options] +Path options +CPPipe pathFromEnv: found:true +Path NestedRecords.extra +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +{"contents": {"kind": "markdown", "value": "```rescript\ntype options.extra = {name: string, superExtra: {age: int}}\n```"}} + +Hover src/NestedRecords.res 23:26 +Nothing at that position. Now trying to use completion. +posCursor:[23:26] posNoWhite:[23:25] Found expr:[23:3->23:27] +Pexp_field [23:3->23:16] superExtra:[23:17->23:27] +Completable: Cpath Value[options].extra.superExtra +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[options].extra.superExtra +ContextPath Value[options].extra +ContextPath Value[options] +Path options +ContextPath Value[options]->extra +ContextPath Value[options] +Path options +CPPipe pathFromEnv: found:true +Path NestedRecords.extra +ContextPath Value[options].extra->superExtra +ContextPath Value[options].extra +ContextPath Value[options] +Path options +ContextPath Value[options]->extra +ContextPath Value[options] +Path options +CPPipe pathFromEnv: found:true +Path NestedRecords.extra +CPPipe pathFromEnv: found:true +Path NestedRecords.superExtra +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +{"contents": {"kind": "markdown", "value": "```rescript\ntype options.extra.superExtra = {age: int}\n```"}} + +Hover src/NestedRecords.res 26:29 +Nothing at that position. Now trying to use completion. +posCursor:[26:29] posNoWhite:[26:28] Found expr:[26:3->26:31] +Pexp_field [26:3->26:27] age:[26:28->26:31] +Completable: Cpath Value[options].extra.superExtra.age +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[options].extra.superExtra.age +ContextPath Value[options].extra.superExtra +ContextPath Value[options].extra +ContextPath Value[options] +Path options +ContextPath Value[options]->extra +ContextPath Value[options] +Path options +CPPipe pathFromEnv: found:true +Path NestedRecords.extra +ContextPath Value[options].extra->superExtra +ContextPath Value[options].extra +ContextPath Value[options] +Path options +ContextPath Value[options]->extra +ContextPath Value[options] +Path options +CPPipe pathFromEnv: found:true +Path NestedRecords.extra +CPPipe pathFromEnv: found:true +Path NestedRecords.superExtra +ContextPath Value[options].extra.superExtra->age +ContextPath Value[options].extra.superExtra +ContextPath Value[options].extra +ContextPath Value[options] +Path options +ContextPath Value[options]->extra +ContextPath Value[options] +Path options +CPPipe pathFromEnv: found:true +Path NestedRecords.extra +ContextPath Value[options].extra->superExtra +ContextPath Value[options].extra +ContextPath Value[options] +Path options +ContextPath Value[options]->extra +ContextPath Value[options] +Path options +CPPipe pathFromEnv: found:true +Path NestedRecords.extra +CPPipe pathFromEnv: found:true +Path NestedRecords.superExtra +CPPipe pathFromEnv: found:true +Path NestedRecords.age +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +{"contents": {"kind": "markdown", "value": "```rescript\nint\n```"}} + diff --git a/tests/analysis_tests/tests/src/expected/NestedRecordsHover.res.txt b/tests/analysis_tests/tests/src/expected/NestedRecordsHover.res.txt new file mode 100644 index 0000000000..d0a0dc63b8 --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/NestedRecordsHover.res.txt @@ -0,0 +1,15 @@ +Hover src/NestedRecordsHover.res 8:7 +{"contents": {"kind": "markdown", "value": "```rescript\noptions\n```\n\n---\n\n```\n \n```\n```rescript\ntype options = {\n extra?: {\n name: string,\n superExtra?: {age: int},\n otherExtra: option<\n {\n test: bool,\n anotherInlined: {record: bool},\n },\n >,\n },\n}\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22NestedRecordsHover.res%22%2C0%2C0%5D)\n\n\n---\n\n```\n \n```\n```rescript\ntype options.extra = {\n name: string,\n superExtra?: {age: int},\n otherExtra: option<\n {\n test: bool,\n anotherInlined: {record: bool},\n },\n >,\n}\n```\n"}} + +Hover src/NestedRecordsHover.res 11:6 +{"contents": {"kind": "markdown", "value": "```rescript\ntype options.extra = {\n name: string,\n superExtra?: {age: int},\n otherExtra: option<\n {\n test: bool,\n anotherInlined: {record: bool},\n },\n >,\n}\n```"}} + +Hover src/NestedRecordsHover.res 14:8 +{"contents": {"kind": "markdown", "value": "```rescript\ntype options.extra.superExtra = {age: int}\n```"}} + +Hover src/NestedRecordsHover.res 18:9 +{"contents": {"kind": "markdown", "value": "```rescript\ntype options.extra.otherExtra = {\n test: bool,\n anotherInlined: {record: bool},\n}\n```"}} + +Hover src/NestedRecordsHover.res 21:11 +{"contents": {"kind": "markdown", "value": "```rescript\ntype options.extra.otherExtra.anotherInlined = {\n record: bool,\n}\n```"}} + diff --git a/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected b/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected new file mode 100644 index 0000000000..be9fed0456 --- /dev/null +++ b/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected @@ -0,0 +1,14 @@ + + We've found a bug for you! + /.../fixtures/inline_types_record_type_params.res:13:12-15 + + 11 ┆ name: "test", + 12 ┆ superExtra: { + 13 ┆ age: 2222, + 14 ┆ }, + 15 ┆ otherExtra: Some({test: true, anotherInlined: {record: true}}), + + This has type: int + But it's expected to have type: string + + You can convert int to string with Belt.Int.toString. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/inline_types_record_type_params.res b/tests/build_tests/super_errors/fixtures/inline_types_record_type_params.res new file mode 100644 index 0000000000..38ff228bf3 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/inline_types_record_type_params.res @@ -0,0 +1,17 @@ +type options<'age> = { + extra?: { + name: string, + superExtra?: {age: 'age}, + otherExtra: option<{test: bool, anotherInlined: {record: bool}}>, + }, +} + +let opts2: options = { + extra: { + name: "test", + superExtra: { + age: 2222, + }, + otherExtra: Some({test: true, anotherInlined: {record: true}}), + }, +} diff --git a/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt b/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt index 872b3da415..bcb3df033f 100644 --- a/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typeDef/expected/inlineRecord.res.txt @@ -8,19 +8,7 @@ 7 ┆ score: int 8 ┆ } - An inline record type declaration is only allowed in a variant constructor's declaration - - - Syntax error! - syntax_tests/data/parsing/errors/typeDef/inlineRecord.res:14:5-10 - - 12 ┆ name: string, - 13 ┆ address: { - 14 ┆ street: string, - 15 ┆ country: string, - 16 ┆ } - - An inline record type declaration is only allowed in a variant constructor's declaration + An inline record type declaration is only allowed in a variant constructor's declaration or nested inside of a record type declaration Syntax error! @@ -32,17 +20,19 @@ │ nder(props) 20 │ - An inline record type declaration is only allowed in a variant constructor's declaration + An inline record type declaration is only allowed in a variant constructor's declaration or nested inside of a record type declaration type nonrec entity = | Director | Student of { name: string ; reportCard: < passing: bool ;score: int > } -type nonrec user = - { +type user.address = { + street: string ; + country: string }[@@res.inlineRecordDefinition ] +and user = { name: string ; - address: < street: string ;country: string > } + address: user.address } let make [arity:1](props : < handleClick: Click.t -> unit (a:1) ;value: string > ) diff --git a/tests/syntax_tests/data/parsing/errors/typeDef/nestedRecord.res b/tests/syntax_tests/data/parsing/errors/typeDef/nestedRecord.res new file mode 100644 index 0000000000..2ece4f2703 --- /dev/null +++ b/tests/syntax_tests/data/parsing/errors/typeDef/nestedRecord.res @@ -0,0 +1,5 @@ +type options = { + extra?: { + name: result<{first: bool}, {second: bool}>, + }, +} \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/typexpr/expected/objectSpread.res.txt b/tests/syntax_tests/data/parsing/errors/typexpr/expected/objectSpread.res.txt index 9772fd07a0..bd46eeae3c 100644 --- a/tests/syntax_tests/data/parsing/errors/typexpr/expected/objectSpread.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typexpr/expected/objectSpread.res.txt @@ -19,7 +19,7 @@ 9 │ let f = (x: {a: int, b: int}) => () 10 │ - An inline record type declaration is only allowed in a variant constructor's declaration + An inline record type declaration is only allowed in a variant constructor's declaration or nested inside of a record type declaration type nonrec u = { ...: a ; diff --git a/tests/tests/src/nested_records.mjs b/tests/tests/src/nested_records.mjs new file mode 100644 index 0000000000..2664b1d9ae --- /dev/null +++ b/tests/tests/src/nested_records.mjs @@ -0,0 +1,22 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +let options = { + extra: { + name: "test", + superExtra: { + age: 2222 + }, + otherExtra: { + test: true, + anotherInlined: { + record: true + } + } + } +}; + +export { + options, +} +/* No side effect */ diff --git a/tests/tests/src/nested_records.res b/tests/tests/src/nested_records.res new file mode 100644 index 0000000000..ec507c813d --- /dev/null +++ b/tests/tests/src/nested_records.res @@ -0,0 +1,17 @@ +type options = { + extra?: { + name: string, + superExtra?: {age: int}, + otherExtra: option<{test: bool, anotherInlined: {record: bool}}>, + }, +} + +let options = { + extra: { + name: "test", + superExtra: { + age: 2222, + }, + otherExtra: Some({test: true, anotherInlined: {record: true}}), + }, +} diff --git a/tests/tests/src/nested_records_with_type_params.mjs b/tests/tests/src/nested_records_with_type_params.mjs new file mode 100644 index 0000000000..5530eeee12 --- /dev/null +++ b/tests/tests/src/nested_records_with_type_params.mjs @@ -0,0 +1,38 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +let options = { + extra: { + name: "test", + superExtra: { + age: 2222 + }, + otherExtra: { + test: true, + anotherInlined: { + record: true + } + } + } +}; + +let opts2 = { + extra: { + name: "test", + superExtra: { + age: "1234" + }, + otherExtra: { + test: true, + anotherInlined: { + record: true + } + } + } +}; + +export { + options, + opts2, +} +/* No side effect */ diff --git a/tests/tests/src/nested_records_with_type_params.res b/tests/tests/src/nested_records_with_type_params.res new file mode 100644 index 0000000000..7427c75a6b --- /dev/null +++ b/tests/tests/src/nested_records_with_type_params.res @@ -0,0 +1,27 @@ +type options<'age> = { + extra?: { + name: string, + superExtra?: {age: 'age}, + otherExtra: option<{test: bool, anotherInlined: {record: bool}}>, + }, +} + +let options = { + extra: { + name: "test", + superExtra: { + age: 2222, + }, + otherExtra: Some({test: true, anotherInlined: {record: true}}), + }, +} + +let opts2: options = { + extra: { + name: "test", + superExtra: { + age: "1234", + }, + otherExtra: Some({test: true, anotherInlined: {record: true}}), + }, +}