diff --git a/CHANGELOG.md b/CHANGELOG.md index e9222267f2..6ed53baa56 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -26,6 +26,8 @@ #### :house: Internal +- Use AST nodes with locations for fn arguments in the typed tree. https://github.com/rescript-lang/rescript/pull/7873 + # 12.0.0-beta.14 #### :boom: Breaking Change diff --git a/analysis/reanalyze/src/Arnold.ml b/analysis/reanalyze/src/Arnold.ml index 9eec8d729e..d3a1677e50 100644 --- a/analysis/reanalyze/src/Arnold.ml +++ b/analysis/reanalyze/src/Arnold.ml @@ -582,9 +582,9 @@ module ExtendFunctionTable = struct Texp_apply {funct = {exp_desc = Texp_ident (path, {loc}, _)}; args}; } when kindOpt <> None -> - let checkArg ((argLabel : Asttypes.Noloc.arg_label), _argOpt) = + let checkArg ((argLabel : Asttypes.arg_label), _argOpt) = match (argLabel, kindOpt) with - | (Labelled l | Optional l), Some kind -> + | (Labelled {txt = l} | Optional {txt = l}), Some kind -> kind |> List.for_all (fun {Kind.label} -> label <> l) | _ -> true in @@ -624,9 +624,9 @@ module ExtendFunctionTable = struct when callee |> FunctionTable.isInFunctionInTable ~functionTable -> let functionName = Path.name callee in args - |> List.iter (fun ((argLabel : Asttypes.Noloc.arg_label), argOpt) -> + |> List.iter (fun ((argLabel : Asttypes.arg_label), argOpt) -> match (argLabel, argOpt |> extractLabelledArgument) with - | Labelled label, Some (path, loc) + | Labelled {txt = label}, Some (path, loc) when path |> FunctionTable.isInFunctionInTable ~functionTable -> functionTable @@ -672,11 +672,11 @@ module CheckExpressionWellFormed = struct -> let functionName = Path.name functionPath in args - |> List.iter (fun ((argLabel : Asttypes.Noloc.arg_label), argOpt) -> + |> List.iter (fun ((argLabel : Asttypes.arg_label), argOpt) -> match argOpt |> ExtendFunctionTable.extractLabelledArgument with | Some (path, loc) -> ( match argLabel with - | Labelled label -> ( + | Labelled {txt = label} -> ( if functionTable |> FunctionTable.functionGetKindOfLabel ~functionName @@ -761,7 +761,7 @@ module Compile = struct let argsFromKind = innerFunctionDefinition.kind |> List.map (fun (entry : Kind.entry) -> - ( Asttypes.Noloc.Labelled entry.label, + ( Asttypes.Labelled {txt = entry.label; loc = Location.none}, Some { expr with @@ -785,7 +785,7 @@ module Compile = struct args |> List.find_opt (fun arg -> match arg with - | Asttypes.Noloc.Labelled s, Some _ -> s = label + | Asttypes.Labelled {txt = s}, Some _ -> s = label | _ -> false) in let argOpt = diff --git a/analysis/reanalyze/src/DeadOptionalArgs.ml b/analysis/reanalyze/src/DeadOptionalArgs.ml index 7bfb3969dd..4e1fcc032f 100644 --- a/analysis/reanalyze/src/DeadOptionalArgs.ml +++ b/analysis/reanalyze/src/DeadOptionalArgs.ml @@ -40,7 +40,7 @@ let rec hasOptionalArgs (texpr : Types.type_expr) = let rec fromTypeExpr (texpr : Types.type_expr) = match texpr.desc with | _ when not (active ()) -> [] - | Tarrow ({lbl = Optional s}, tTo, _, _) -> s :: fromTypeExpr tTo + | Tarrow ({lbl = Optional {txt = s}}, tTo, _, _) -> s :: fromTypeExpr tTo | Tarrow (_, tTo, _, _) -> fromTypeExpr tTo | Tlink t -> fromTypeExpr t | Tsubst t -> fromTypeExpr t diff --git a/analysis/reanalyze/src/DeadValue.ml b/analysis/reanalyze/src/DeadValue.ml index 57ddeccd26..df8b6aa0e2 100644 --- a/analysis/reanalyze/src/DeadValue.ml +++ b/analysis/reanalyze/src/DeadValue.ml @@ -104,7 +104,7 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ~path args = | None -> Some false in match lbl with - | Asttypes.Noloc.Optional s when not locFrom.loc_ghost -> + | Asttypes.Optional {txt = s} when not locFrom.loc_ghost -> if argIsSupplied <> Some false then supplied := s :: !supplied; if argIsSupplied = None then suppliedMaybe := s :: !suppliedMaybe | _ -> ()); diff --git a/analysis/src/CompletionBackEnd.ml b/analysis/src/CompletionBackEnd.ml index bbd61eac48..a24b4315fb 100644 --- a/analysis/src/CompletionBackEnd.ml +++ b/analysis/src/CompletionBackEnd.ml @@ -1075,13 +1075,12 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact (* compute the application of the first label, then the next ones *) let args = processApply args [label] in processApply args nextLabels - | (Asttypes.Noloc.Nolabel, _) :: nextArgs, [Asttypes.Noloc.Nolabel] -> - nextArgs + | (Asttypes.Nolabel, _) :: nextArgs, [Asttypes.Nolabel] -> nextArgs | ((Labelled _, _) as arg) :: nextArgs, [Nolabel] -> arg :: processApply nextArgs labels | (Optional _, _) :: nextArgs, [Nolabel] -> processApply nextArgs labels - | ( (((Labelled s1 | Optional s1), _) as arg) :: nextArgs, - [(Labelled s2 | Optional s2)] ) -> + | ( (((Labelled {txt = s1} | Optional {txt = s1}), _) as arg) :: nextArgs, + [(Labelled {txt = s2} | Optional {txt = s2})] ) -> if s1 = s2 then nextArgs else arg :: processApply nextArgs labels | ((Nolabel, _) as arg) :: nextArgs, [(Labelled _ | Optional _)] -> arg :: processApply nextArgs labels @@ -1132,9 +1131,9 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact synthetic = true; contextPath = (match cp with - | CPApply (c, args) -> CPApply (c, args @ [Asttypes.Noloc.Nolabel]) + | CPApply (c, args) -> CPApply (c, args @ [Asttypes.Nolabel]) | CPId _ when TypeUtils.isFunctionType ~env ~package typ -> - CPApply (cp, [Asttypes.Noloc.Nolabel]) + CPApply (cp, [Asttypes.Nolabel]) | _ -> cp); id = fieldName; inJsx; @@ -1893,8 +1892,8 @@ let rec completeTypedValue ?(typeArgContext : typeArgContext option) ~rawOpens args |> List.map (fun ((label, typ) : typedFnArg) -> match label with - | Optional name -> "~" ^ name ^ "=?" - | Labelled name -> "~" ^ name + | Optional {txt = name} -> "~" ^ name ^ "=?" + | Labelled {txt = name} -> "~" ^ name | Nolabel -> if TypeUtils.typeIsUnit typ then "()" else ( diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index 65a26a1467..a5c0f9ce37 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -303,10 +303,7 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) | Pexp_apply {funct = e1; args} -> ( match exprToContextPath ~inJsxContext e1 with | None -> None - | Some contexPath -> - Some - (CPApply (contexPath, args |> List.map fst |> List.map Asttypes.to_noloc)) - ) + | Some contexPath -> Some (CPApply (contexPath, args |> List.map fst))) | Pexp_tuple exprs -> let exprsAsContextPaths = exprs |> List.filter_map (exprToContextPath ~inJsxContext) diff --git a/analysis/src/CreateInterface.ml b/analysis/src/CreateInterface.ml index 107fa5973d..c78548e0d9 100644 --- a/analysis/src/CreateInterface.ml +++ b/analysis/src/CreateInterface.ml @@ -173,8 +173,9 @@ let printSignature ~extractor ~signature = in let lblName = labelDecl.ld_id |> Ident.name in let lbl = - if labelDecl.ld_optional then Asttypes.Noloc.Optional lblName - else Labelled lblName + if labelDecl.ld_optional then + Asttypes.Optional {txt = lblName; loc = Location.none} + else Asttypes.Labelled {txt = lblName; loc = Location.none} in { retType with diff --git a/analysis/src/SharedTypes.ml b/analysis/src/SharedTypes.ml index 73d43ffc39..b44fa53a3e 100644 --- a/analysis/src/SharedTypes.ml +++ b/analysis/src/SharedTypes.ml @@ -4,7 +4,7 @@ let ident l = l |> List.map str |> String.concat "." type path = string list -type typedFnArg = Asttypes.Noloc.arg_label * Types.type_expr +type typedFnArg = Asttypes.arg_label * Types.type_expr let pathToString (path : path) = path |> String.concat "." @@ -619,7 +619,7 @@ module Completable = struct | CPFloat | CPBool | CPOption of contextPath - | CPApply of contextPath * Asttypes.Noloc.arg_label list + | CPApply of contextPath * Asttypes.arg_label list | CPId of { path: string list; completionContext: completionContext; @@ -708,9 +708,9 @@ module Completable = struct contextPathToString cp ^ "(" ^ (labels |> List.map (function - | Asttypes.Noloc.Nolabel -> "Nolabel" - | Labelled s -> "~" ^ s - | Optional s -> "?" ^ s) + | Asttypes.Nolabel -> "Nolabel" + | Labelled {txt} -> "~" ^ txt + | Optional {txt} -> "?" ^ txt) |> String.concat ", ") ^ ")" | CPArray (Some ctxPath) -> "array<" ^ contextPathToString ctxPath ^ ">" diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index 8a4ede7a77..e4c9cb11ae 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -152,14 +152,14 @@ let findActiveParameter ~argAtCursor ~args = (* If a function only has one, unlabelled argument, we can safely assume that's active whenever we're in the signature help for that function, even if we technically didn't find anything at the cursor (which we don't for empty expressions). *) match args with - | [(Asttypes.Noloc.Nolabel, _)] -> Some 0 + | [(Asttypes.Nolabel, _)] -> Some 0 | _ -> None) | Some (Unlabelled unlabelledArgumentIndex) -> let index = ref 0 in args |> List.find_map (fun (label, _) -> match label with - | Asttypes.Noloc.Nolabel when !index = unlabelledArgumentIndex -> + | Asttypes.Nolabel when !index = unlabelledArgumentIndex -> Some !index | _ -> index := !index + 1; @@ -169,7 +169,7 @@ let findActiveParameter ~argAtCursor ~args = args |> List.find_map (fun (label, _) -> match label with - | (Asttypes.Noloc.Labelled labelName | Optional labelName) + | (Asttypes.Labelled {txt = labelName} | Optional {txt = labelName}) when labelName = name -> Some !index | _ -> @@ -472,7 +472,6 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = parameters = parameters |> List.map (fun (argLabel, start, end_) -> - let argLabel = Asttypes.to_noloc argLabel in let paramArgCount = !paramUnlabelledArgCount in paramUnlabelledArgCount := paramArgCount + 1; let unlabelledArgCount = ref 0 in @@ -485,11 +484,12 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = let argCount = !unlabelledArgCount in unlabelledArgCount := argCount + 1; match (lbl, argLabel) with - | ( Asttypes.Noloc.Optional l1, - Asttypes.Noloc.Optional l2 ) + | ( Asttypes.Optional {txt = l1}, + Asttypes.Optional {txt = l2} ) when l1 = l2 -> true - | Labelled l1, Labelled l2 + | ( Labelled {txt = l1}, + Labelled {txt = l2} ) when l1 = l2 -> true | Nolabel, Nolabel diff --git a/analysis/src/TypeUtils.ml b/analysis/src/TypeUtils.ml index d1d15a7636..479ebcd2a9 100644 --- a/analysis/src/TypeUtils.ml +++ b/analysis/src/TypeUtils.ml @@ -902,10 +902,10 @@ let getArgs ~env (t : Types.type_expr) ~full = match t.desc with | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> getArgsLoop ~full ~env ~currentArgumentPosition t1 - | Tarrow ({lbl = Labelled l; typ = tArg}, tRet, _, _) -> + | Tarrow ({lbl = Labelled {txt = l}; typ = tArg}, tRet, _, _) -> (SharedTypes.Completable.Labelled l, tArg) :: getArgsLoop ~full ~env ~currentArgumentPosition tRet - | Tarrow ({lbl = Optional l; typ = tArg}, tRet, _, _) -> + | Tarrow ({lbl = Optional {txt = l}; typ = tArg}, tRet, _, _) -> (Optional l, tArg) :: getArgsLoop ~full ~env ~currentArgumentPosition tRet | Tarrow ({lbl = Nolabel; typ = tArg}, tRet, _, _) -> (Unlabelled {argumentPosition = currentArgumentPosition}, tArg) @@ -1144,7 +1144,7 @@ let getFirstFnUnlabelledArgType ~env ~full t = in let rec findFirstUnlabelledArgType labels = match labels with - | (Asttypes.Noloc.Nolabel, t) :: _ -> Some t + | (Asttypes.Nolabel, t) :: _ -> Some t | _ :: rest -> findFirstUnlabelledArgType rest | [] -> None in diff --git a/compiler/gentype/TranslateCoreType.ml b/compiler/gentype/TranslateCoreType.ml index f110d02b51..882aa87ba6 100644 --- a/compiler/gentype/TranslateCoreType.ml +++ b/compiler/gentype/TranslateCoreType.ml @@ -1,13 +1,14 @@ open GenTypeCommon open! TranslateTypeExprFromTypes -let remove_option ~(label : Asttypes.Noloc.arg_label) +let remove_option ~(label : Asttypes.arg_label) (core_type : Typedtree.core_type) = match (core_type.ctyp_desc, label) with - | Ttyp_constr (Path.Pident id, _, [t]), Optional lbl + | Ttyp_constr (Path.Pident id, _, [t]), Optional {txt = lbl} when Ident.name id = "option" -> Some (lbl, t) - | Ttyp_constr (Pdot (Path.Pident name_space, id, _), _, [t]), Optional lbl + | ( Ttyp_constr (Pdot (Path.Pident name_space, id, _), _, [t]), + Optional {txt = lbl} ) when (* This has a different representation in 4.03+ *) Ident.name name_space = "FB" && id = "option" -> Some (lbl, t) @@ -64,7 +65,10 @@ let rec translate_arrow_type ~config ~type_vars_gen ~no_function_return_dependencies ~type_env ~rev_arg_deps:next_rev_deps ~rev_args:((Nolabel, type_) :: rev_args) | Ttyp_arrow - ( {lbl = (Labelled lbl | Optional lbl) as label; typ = core_type1}, + ( { + lbl = (Labelled {txt = lbl} | Optional {txt = lbl}) as label; + typ = core_type1; + }, core_type2, arity ) when arity = None || rev_args = [] -> ( diff --git a/compiler/gentype/TranslateStructure.ml b/compiler/gentype/TranslateStructure.ml index 9a64cd34a6..8e60259d68 100644 --- a/compiler/gentype/TranslateStructure.ml +++ b/compiler/gentype/TranslateStructure.ml @@ -13,7 +13,7 @@ let rec addAnnotationsToTypes_ ~config ~(expr : Typedtree.expression) let a_name = if a_name = "*opt*" then match arg_label with - | Optional l -> l + | Optional {txt = l} -> l | _ -> "" (* should not happen *) else a_name in diff --git a/compiler/gentype/TranslateTypeExprFromTypes.ml b/compiler/gentype/TranslateTypeExprFromTypes.ml index 5e6024495a..beea6c83ce 100644 --- a/compiler/gentype/TranslateTypeExprFromTypes.ml +++ b/compiler/gentype/TranslateTypeExprFromTypes.ml @@ -2,11 +2,11 @@ open GenTypeCommon type translation = {dependencies: dep list; type_: type_} -let rec remove_option ~(label : Asttypes.Noloc.arg_label) +let rec remove_option ~(label : Asttypes.arg_label) (type_expr : Types.type_expr) = match (type_expr.desc, label) with - | Tconstr (Path.Pident id, [t], _), Optional lbl when Ident.name id = "option" - -> + | Tconstr (Path.Pident id, [t], _), Optional {txt = lbl} + when Ident.name id = "option" -> Some (lbl, t) | Tlink t, _ -> t |> remove_option ~label | _ -> None @@ -344,7 +344,10 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps ~rev_arg_deps:next_rev_deps ~rev_args:((Nolabel, type_) :: rev_args) | Tarrow - ( {lbl = (Labelled lbl | Optional lbl) as label; typ = type_expr1}, + ( { + lbl = (Labelled {txt = lbl} | Optional {txt = lbl}) as label; + typ = type_expr1; + }, type_expr2, _, arity ) diff --git a/compiler/ml/asttypes.ml b/compiler/ml/asttypes.ml index d969740e7b..e12960a005 100644 --- a/compiler/ml/asttypes.ml +++ b/compiler/ml/asttypes.ml @@ -57,18 +57,6 @@ module Noloc = struct | Nolabel (* x => ...*) | Labelled of string (* ~label => ... *) | Optional of string (* ~(label=e) => ... *) - - let same_arg_label (x : arg_label) y = - match x with - | Nolabel -> y = Nolabel - | Labelled s -> ( - match y with - | Labelled s0 -> s = s0 - | _ -> false) - | Optional s -> ( - match y with - | Optional s0 -> s = s0 - | _ -> false) end let to_arg_label ?(loc = Location.none) lbl = diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index 08ce7014d0..2af606a084 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -593,32 +593,24 @@ let forget_abbrev mem path = (**********************************) let is_optional = function - | Noloc.Optional _ -> true - | _ -> false - -let is_optional_loc = function | Optional _ -> true | _ -> false let label_name = function - | Noloc.Nolabel -> "" - | Labelled s | Optional s -> s - -let label_loc_name = function | Nolabel -> "" | Labelled {txt} | Optional {txt} -> txt let prefixed_label_name = function - | Noloc.Nolabel -> "" - | Labelled s -> "~" ^ s - | Optional s -> "?" ^ s + | Nolabel -> "" + | Labelled {txt = s} -> "~" ^ s + | Optional {txt = s} -> "?" ^ s type sargs = (Asttypes.arg_label * Parsetree.expression) list let rec extract_label_aux hd l = function | [] -> None | ((l', t) as p) :: ls -> - if label_loc_name l' = l then Some (l', t, List.rev_append hd ls) + if label_name l' = l then Some (l', t, List.rev_append hd ls) else extract_label_aux (p :: hd) l ls let extract_label l (ls : sargs) : diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli index e19c6a644f..ef099af22b 100644 --- a/compiler/ml/btype.mli +++ b/compiler/ml/btype.mli @@ -180,13 +180,11 @@ val forget_abbrev : abbrev_memo ref -> Path.t -> unit (**** Utilities for labels ****) -val is_optional : Noloc.arg_label -> bool -val is_optional_loc : arg_label -> bool -val label_name : Noloc.arg_label -> label -val label_loc_name : arg_label -> label +val is_optional : arg_label -> bool +val label_name : arg_label -> label (* Returns the label name with first character '?' or '~' as appropriate. *) -val prefixed_label_name : Noloc.arg_label -> label +val prefixed_label_name : arg_label -> label type sargs = (arg_label * Parsetree.expression) list diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 261f0ab905..e15adf31b4 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -1927,7 +1927,7 @@ let rec mcomp type_pairs env t1 t2 = match (t1'.desc, t2'.desc) with | Tvar _, Tvar _ -> assert false | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _) - when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl + when Asttypes.same_arg_label arg1.lbl arg2.lbl || not (is_optional arg1.lbl || is_optional arg2.lbl) -> mcomp type_pairs env arg1.typ arg2.typ; mcomp type_pairs env ret1 ret2 @@ -2344,7 +2344,7 @@ and unify3 env t1 t1' t2 t2' = (match (d1, d2) with | Tarrow (arg1, ret1, c1, a1), Tarrow (arg2, ret2, c2, a2) when a1 = a2 - && (Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl + && (Asttypes.same_arg_label arg1.lbl arg2.lbl || !umode = Pattern && not (is_optional arg1.lbl || is_optional arg2.lbl)) -> ( unify env arg1.typ arg2.typ; @@ -2799,7 +2799,7 @@ let filter_arrow ~env ~arity t l = let t' = newty2 lv (Tarrow ({lbl = l; typ = t1}, t2, Cok, arity)) in link_type t t'; (t1, t2) - | Tarrow (arg, ret, _, _) when Asttypes.Noloc.same_arg_label l arg.lbl -> + | Tarrow (arg, ret, _, _) when Asttypes.same_arg_label l arg.lbl -> (arg.typ, ret) | _ -> raise (Unify []) @@ -2915,7 +2915,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = moregen_occur env t1'.level t2; link_type t1' t2 | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _) - when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl -> + when Asttypes.same_arg_label arg1.lbl arg2.lbl -> moregen inst_nongen type_pairs env arg1.typ arg2.typ; moregen inst_nongen type_pairs env ret1 ret2 | Ttuple tl1, Ttuple tl2 -> @@ -3185,7 +3185,7 @@ let rec eqtype rename type_pairs subst env t1 t2 = raise (Unify []); subst := (t1', t2') :: !subst) | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _) - when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl -> + when Asttypes.same_arg_label arg1.lbl arg2.lbl -> eqtype rename type_pairs subst env arg1.typ arg2.typ; eqtype rename type_pairs subst env ret1 ret2 | Ttuple tl1, Ttuple tl2 -> @@ -3598,7 +3598,7 @@ let rec subtype_rec env trace t1 t2 cstrs = match (t1.desc, t2.desc) with | Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _) - when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl -> + when Asttypes.same_arg_label arg1.lbl arg2.lbl -> let cstrs = subtype_rec env ((arg2.typ, arg1.typ) :: trace) diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index db9db83c81..6785374ac9 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -239,11 +239,7 @@ val with_passive_variants : ('a -> 'b) -> 'a -> 'b (* Call [f] in passive_variants mode, for exhaustiveness check. *) val filter_arrow : - env:Env.t -> - arity:arity -> - type_expr -> - Noloc.arg_label -> - type_expr * type_expr + env:Env.t -> arity:arity -> type_expr -> arg_label -> type_expr * type_expr (* A special case of unification (with l:'a -> 'b). *) val filter_method : Env.t -> string -> private_flag -> type_expr -> type_expr diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index c4285a1fea..9cf370da44 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -152,9 +152,9 @@ let print_name ppf = function | Some name -> fprintf ppf "\"%s\"" name let string_of_label = function - | Noloc.Nolabel -> "" - | Labelled s -> s - | Optional s -> "?" ^ s + | Nolabel -> "" + | Labelled {txt} -> txt + | Optional {txt} -> "?" ^ txt let string_of_arity = function | None -> "" diff --git a/compiler/ml/printtyp.mli b/compiler/ml/printtyp.mli index 755e1ae2be..0fe84f38f1 100644 --- a/compiler/ml/printtyp.mli +++ b/compiler/ml/printtyp.mli @@ -29,7 +29,7 @@ val tree_of_path : Path.t -> out_ident val path : formatter -> Path.t -> unit val string_of_path : Path.t -> string val raw_type_expr : formatter -> type_expr -> unit -val string_of_label : Asttypes.Noloc.arg_label -> string +val string_of_label : Asttypes.arg_label -> string val wrap_printing_env : Env.t -> (unit -> 'a) -> 'a (* Call the function using the environment for type path shortening *) diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 064f0ab55c..6e36b4276c 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -121,9 +121,9 @@ let option i f ppf x = let longident i ppf li = line i ppf "%a\n" fmt_longident li let string i ppf s = line i ppf "\"%s\"\n" s let arg_label i ppf = function - | Noloc.Nolabel -> line i ppf "Nolabel\n" - | Optional s -> line i ppf "Optional \"%s\"\n" s - | Labelled s -> line i ppf "Labelled \"%s\"\n" s + | Nolabel -> line i ppf "Nolabel\n" + | Optional {txt} -> line i ppf "Optional \"%s\"\n" txt + | Labelled {txt} -> line i ppf "Labelled \"%s\"\n" txt let record_representation i ppf = let open Types in diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 90522f13d2..b5061ae69d 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -42,7 +42,7 @@ type error = context: type_clash_context option; } | Apply_non_function of type_expr - | Apply_wrong_label of Noloc.arg_label * type_expr + | Apply_wrong_label of arg_label * type_expr | Label_multiply_defined of { label: string; jsx_component_info: jsx_prop_error_info option; @@ -61,7 +61,7 @@ type error = | Not_subtype of Ctype.type_pairs * Ctype.type_pairs * Ctype.subtype_context option | Too_many_arguments of bool * type_expr - | Abstract_wrong_label of Noloc.arg_label * type_expr + | Abstract_wrong_label of arg_label * type_expr | Scoping_let_module of string * type_expr | Not_a_variant_type of Longident.t | Incoherent_label_order @@ -88,7 +88,7 @@ type error = function_type: type_expr; expected_arity: int; provided_arity: int; - provided_args: Asttypes.Noloc.arg_label list; + provided_args: Asttypes.arg_label list; function_name: Longident.t option; } | Field_not_optional of string * type_expr @@ -756,11 +756,10 @@ let print_expr_type_clash ~context env loc trace ppf = ~pp_sep:(fun ppf _ -> fprintf ppf ",@ ") (fun ppf (label, argtype) -> match label with - | Asttypes.Noloc.Nolabel -> - fprintf ppf "@[%a@]" Printtyp.type_expr argtype - | Labelled label -> + | Asttypes.Nolabel -> fprintf ppf "@[%a@]" Printtyp.type_expr argtype + | Labelled {txt = label} -> fprintf ppf "@[(~%s: %a)@]" label Printtyp.type_expr argtype - | Optional label -> + | Optional {txt = label} -> fprintf ppf "@[(?%s: %a)@]" label Printtyp.type_expr argtype) in match missing_arguments with @@ -1892,7 +1891,6 @@ and is_nonexpansive_opt = function let rec approx_type env sty = match sty.ptyp_desc with | Ptyp_arrow {arg = {lbl = p}; ret = sty; arity} -> - let p = Asttypes.to_noloc p in let ty1 = if is_optional p then type_option (newvar ()) else newvar () in newty (Tarrow ({lbl = p; typ = ty1}, approx_type env sty, Cok, arity)) | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) @@ -1911,7 +1909,6 @@ let rec type_approx env sexp = match sexp.pexp_desc with | Pexp_let (_, _, e) -> type_approx env e | Pexp_fun {arg_label = p; rhs = e; arity} -> - let p = Asttypes.to_noloc p in let ty = if is_optional p then type_option (newvar ()) else newvar () in newty (Tarrow ({lbl = p; typ = ty}, type_approx env e, Cok, arity)) | Pexp_match (_, {pc_rhs = e} :: _) -> type_approx env e @@ -2243,9 +2240,9 @@ let extract_function_name funct = | _ -> None type lazy_args = - (Asttypes.Noloc.arg_label * (unit -> Typedtree.expression) option) list + (Asttypes.arg_label * (unit -> Typedtree.expression) option) list -type targs = (Asttypes.Noloc.arg_label * Typedtree.expression option) list +type targs = (Asttypes.arg_label * Typedtree.expression option) list let rec type_exp ~context ?recarg env sexp = (* We now delegate everything to type_expect *) type_expect ~context ?recarg env sexp (newvar ()) @@ -2382,7 +2379,6 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected arity; async; } -> - let l = Asttypes.to_noloc l in assert (is_optional l); (* default allowed only with optional argument *) let open Ast_helper in @@ -2425,7 +2421,6 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected [Exp.case pat body] | Pexp_fun {arg_label = l; default = None; lhs = spat; rhs = sbody; arity; async} -> - let l = Asttypes.to_noloc l in type_function ?in_function ~arity ~async loc sexp.pexp_attributes env ty_expected l [Ast_helper.Exp.case spat sbody] @@ -3451,7 +3446,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) unify env lhs_type (instance_def Predef.type_int); instance_def Predef.type_int in - let targs = [(to_noloc lhs_label, Some lhs)] in + let targs = [(lhs_label, Some lhs)] in Some (targs, result_type) | ( Some {form = Binary; specialization}, [(lhs_label, lhs_expr); (rhs_label, rhs_expr)] ) -> @@ -3515,9 +3510,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) let rhs = type_expect ~context:None env rhs_expr Predef.type_int in (lhs, rhs, instance_def Predef.type_int)) in - let targs = - [(to_noloc lhs_label, Some lhs); (to_noloc rhs_label, Some rhs)] - in + let targs = [(lhs_label, Some lhs); (rhs_label, Some rhs)] in Some (targs, result_type) | _ -> None) | _ -> None @@ -3570,7 +3563,7 @@ and type_application ~context total_app env funct (sargs : sargs) : function_type = funct.exp_type; expected_arity = arity; provided_arity = List.length sargs; - provided_args = sargs |> List.map (fun (a, _) -> to_noloc a); + provided_args = sargs |> List.map (fun (a, _) -> a); function_name = extract_function_name funct; } )); arity @@ -3592,7 +3585,7 @@ and type_application ~context total_app env funct (sargs : sargs) : function_type = funct.exp_type; expected_arity = required_args + newarity; provided_arity = required_args; - provided_args = sargs |> List.map (fun (a, _) -> to_noloc a); + provided_args = sargs |> List.map (fun (a, _) -> a); function_name = extract_function_name funct; } ))); let new_t = @@ -3620,11 +3613,10 @@ and type_application ~context total_app env funct (sargs : sargs) : in if List.length args < max_arity && total_app then match (expand_head env ty_fun).desc with - | Tarrow ({lbl = Optional l; typ = t1}, t2, _, _) -> - ignored := (Noloc.Optional l, t1, ty_fun.level) :: !ignored; + | Tarrow ({lbl; typ = t1}, t2, _, _) when is_optional lbl -> + ignored := (lbl, t1, ty_fun.level) :: !ignored; let arg = - ( Noloc.Optional l, - Some (fun () -> option_none (instance env t1) Location.none) ) + (lbl, Some (fun () -> option_none (instance env t1) Location.none)) in type_unknown_args max_arity ~args:(arg :: args) ~top_arity:None omitted t2 [] @@ -3636,7 +3628,6 @@ and type_application ~context total_app env funct (sargs : sargs) : (* foo(. ) treated as empty application if all args are optional (hence ignored) *) type_unknown_args max_arity ~args ~top_arity:None omitted ty_fun [] | (l1, sarg1) :: sargl -> - let l1 = to_noloc l1 in let ty1, ty2 = let ty_fun = expand_head env ty_fun in let arity_ok = List.length args < max_arity in @@ -3653,7 +3644,7 @@ and type_application ~context total_app env funct (sargs : sargs) : ({lbl = l1; typ = t1}, t2, Clink (ref Cunknown), top_arity))); (t1, t2) | Tarrow ({lbl = l; typ = t1}, t2, _, _) - when Asttypes.Noloc.same_arg_label l l1 && arity_ok -> + when Asttypes.same_arg_label l l1 && arity_ok -> (t1, t2) | td -> ( let ty_fun = @@ -3706,13 +3697,13 @@ and type_application ~context total_app env funct (sargs : sargs) : Some (fun () -> option_none (instance env ty) Location.none) )) else (sargs, (l, ty, lv) :: omitted, None) | Some (l', sarg0, sargs) -> - if (not optional) && is_optional_loc l' then + if (not optional) && is_optional l' then Location.prerr_warning sarg0.pexp_loc (Warnings.Nonoptional_label (Printtyp.string_of_label l)); ( sargs, omitted, Some - (if (not optional) || is_optional_loc l' then fun () -> + (if (not optional) || is_optional l' then fun () -> type_argument ~context: (type_clash_context_for_function_argument ~label:l' context @@ -4462,7 +4453,7 @@ let report_error env loc ppf error = type_expr typ) | Apply_wrong_label (l, ty) -> let print_message ppf = function - | Noloc.Nolabel -> + | Nolabel -> fprintf ppf "The argument at this position should be labelled." | l -> fprintf ppf "This function does not take the argument @{%s@}." @@ -4544,7 +4535,7 @@ let report_error env loc ppf error = fprintf ppf "the expected type is@ %a@]" type_expr ty) | Abstract_wrong_label (l, ty) -> let label_mark = function - | Noloc.Nolabel -> "but its first argument is not labelled" + | Nolabel -> "but its first argument is not labelled" | l -> sprintf "but its first argument is labelled %s" (prefixed_label_name l) in @@ -4647,12 +4638,10 @@ let report_error env loc ppf error = (* Unlabelled arg counts *) let args_from_type_unlabelled = - args_from_type - |> List.filter (fun arg -> arg = Noloc.Nolabel) - |> List.length + args_from_type |> List.filter (fun arg -> arg = Nolabel) |> List.length in let sargs_unlabelled = - sargs |> List.filter (fun arg -> arg = Noloc.Nolabel) |> List.length + sargs |> List.filter (fun arg -> arg = Nolabel) |> List.length in let mismatch_in_unlabelled_args = args_from_type_unlabelled <> sargs_unlabelled @@ -4663,14 +4652,14 @@ let report_error env loc ppf error = args_from_type |> List.filter_map (fun arg -> match arg with - | Noloc.Labelled n -> Some n + | Labelled {txt = n} -> Some n | Optional _ | Nolabel -> None) in let passed_named_args = sargs |> List.filter_map (fun arg -> match arg with - | Noloc.Labelled n | Optional n -> Some n + | Labelled {txt} | Optional {txt} -> Some txt | Nolabel -> None) in let missing_required_args = @@ -4683,7 +4672,7 @@ let report_error env loc ppf error = args_from_type |> List.filter_map (fun arg -> match arg with - | Noloc.Labelled n | Optional n -> Some n + | Labelled {txt = n} | Optional {txt = n} -> Some n | Nolabel -> None) in let superfluous_args = diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index 3e3a7c0601..eef17d05a8 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -75,7 +75,7 @@ type error = context: Error_message_utils.type_clash_context option; } | Apply_non_function of type_expr - | Apply_wrong_label of Noloc.arg_label * type_expr + | Apply_wrong_label of arg_label * type_expr | Label_multiply_defined of { label: string; jsx_component_info: Error_message_utils.jsx_prop_error_info option; @@ -94,7 +94,7 @@ type error = | Not_subtype of Ctype.type_pairs * Ctype.type_pairs * Ctype.subtype_context option | Too_many_arguments of bool * type_expr - | Abstract_wrong_label of Noloc.arg_label * type_expr + | Abstract_wrong_label of arg_label * type_expr | Scoping_let_module of string * type_expr | Not_a_variant_type of Longident.t | Incoherent_label_order @@ -121,7 +121,7 @@ type error = function_type: type_expr; expected_arity: int; provided_arity: int; - provided_args: Asttypes.Noloc.arg_label list; + provided_args: Asttypes.arg_label list; function_name: Longident.t option; } | Field_not_optional of string * type_expr diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 9ef328be4a..e7274f1245 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -75,7 +75,7 @@ and expression_desc = | Texp_constant of constant | Texp_let of rec_flag * value_binding list * expression | Texp_function of { - arg_label: Noloc.arg_label; + arg_label: arg_label; arity: arity; param: Ident.t; case: case; @@ -84,7 +84,7 @@ and expression_desc = } | Texp_apply of { funct: expression; - args: (Noloc.arg_label * expression option) list; + args: (arg_label * expression option) list; partial: bool; transformed_jsx: bool; } @@ -303,7 +303,7 @@ and core_type = { ctyp_attributes: attribute list; } -and arg = {attrs: attributes; lbl: Noloc.arg_label; typ: core_type} +and arg = {attrs: attributes; lbl: arg_label; typ: core_type} and core_type_desc = | Ttyp_any diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 6e6b1c5159..b1e7083fc7 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -128,7 +128,7 @@ and expression_desc = let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) *) | Texp_function of { - arg_label: Noloc.arg_label; + arg_label: arg_label; arity: arity; param: Ident.t; case: case; @@ -147,7 +147,7 @@ and expression_desc = *) | Texp_apply of { funct: expression; - args: (Noloc.arg_label * expression option) list; + args: (arg_label * expression option) list; partial: bool; transformed_jsx: bool; } @@ -409,7 +409,7 @@ and core_type = { ctyp_attributes: attributes; } -and arg = {attrs: attributes; lbl: Noloc.arg_label; typ: core_type} +and arg = {attrs: attributes; lbl: arg_label; typ: core_type} and core_type_desc = | Ttyp_any diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index ae5a614853..eeca29aa83 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -21,7 +21,7 @@ open Asttypes type type_expr = {mutable desc: type_desc; mutable level: int; id: int} -and arg = {lbl: Noloc.arg_label; typ: type_expr} +and arg = {lbl: arg_label; typ: type_expr} and type_desc = | Tvar of string option diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 25ce43088f..cb9bf06664 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -57,7 +57,7 @@ type type_expr = {mutable desc: type_desc; mutable level: int; id: int} Note on mutability: TBD. *) -and arg = {lbl: Noloc.arg_label; typ: type_expr} +and arg = {lbl: arg_label; typ: type_expr} and type_desc = | Tvar of string option @@ -65,8 +65,8 @@ and type_desc = [Tvar None] ==> [_] *) | Tarrow of arg * type_expr * commutable * arity (** [Tarrow (Nolabel, e1, e2, c)] ==> [e1 -> e2] - [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1 -> e2] - [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2] + [Tarrow (Labelled {txt="l"}, e1, e2, c)] ==> [l:e1 -> e2] + [Tarrow (Optional {txt="l"}, e1, e2, c)] ==> [?l:e1 -> e2] See [commutable] for the last argument. *) | Ttuple of type_expr list (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *) diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 53758e26c1..31c29ea35f 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -321,7 +321,7 @@ and transl_type_aux env policy styp = in ctyp (Ttyp_var name) ty | Ptyp_arrow {arg; ret; arity} -> - let lbl = Asttypes.to_noloc arg.lbl in + let lbl = arg.lbl in let cty1 = transl_type env policy arg.typ in let cty2 = transl_type env policy ret in let ty1 = cty1.ctyp_type in