use labels with locations in typedtree

Author: zth

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 (Location.mknoloc entry.label),
                      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 =

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
            | _ -> ());

analysis/src/ProcessExtra.ml

@@ -410,6 +410,23 @@ let expr ~env ~(extra : extra) (iter : Tast_iterator.iterator)
   | Texp_field (inner, lident, _label_description) ->
     addForField ~env ~extra ~recordType:inner.exp_type
       ~fieldType:expression.exp_type lident
+  | Texp_apply {funct; args} ->
+    args
+    |> List.iter (fun (label, _) ->
+           match label with
+           | Asttypes.Labelled {txt; loc} | Optional {txt; loc} -> (
+             let rec findArgType (t : Types.type_expr) =
+               match t.desc with
+               | Tarrow ((Labelled lbl | Optional lbl), argType, _, _, _)
+                 when lbl = txt ->
+                 Some argType
+               | Tarrow (_, _, next, _, _) -> findArgType next
+               | _ -> None
+             in
+             match findArgType funct.exp_type with
+             | None -> ()
+             | Some argType -> addLocItem extra loc (OtherExpression argType))
+           | _ -> ())
   | _ ->
     addLocItem extra expression.exp_loc (OtherExpression expression.exp_type));
   Tast_iterator.default_iterator.expr iter expression

compiler/ml/printtyped.ml

@@ -125,6 +125,11 @@ let arg_label i ppf = function
   | Optional s -> line i ppf "Optional \"%s\"\n" s
   | Labelled s -> line i ppf "Labelled \"%s\"\n" s
 
+let arg_label_loc i ppf = function
+  | Nolabel -> line i ppf "Nolabel\n"
+  | Optional {txt = s} -> line i ppf "Optional \"%s\"\n" s
+  | Labelled {txt = s} -> line i ppf "Labelled \"%s\"\n" s
+
 let record_representation i ppf =
   let open Types in
   function
@@ -658,7 +663,7 @@ and record_field i ppf = function
 
 and label_x_expression i ppf (l, e) =
   line i ppf "<arg>\n";
-  arg_label (i + 1) ppf l;
+  arg_label_loc (i + 1) ppf l;
   match e with
   | None -> ()
   | Some e -> expression (i + 1) ppf e

compiler/ml/translcore.ml

@@ -1019,7 +1019,7 @@ and transl_apply ?(inlined = Default_inline)
   | _ ->
     (build_apply lam []
        (List.map
-          (fun (l, x) -> (may_map transl_exp x, Btype.is_optional l))
+          (fun (l, x) -> (may_map transl_exp x, Btype.is_optional_loc l))
           sargs)
       : Lambda.lambda)
 

compiler/ml/typecore.ml

@@ -2417,6 +2417,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
     end_def ();
     unify_var env (newvar ()) funct.exp_type;
 
+    let args_with_loc =
+      List.map2 (fun (sarg, _) (_, label_exp) -> (sarg, label_exp)) sargs args
+    in
     let mk_apply funct args =
       rue
         {
@@ -2435,8 +2438,8 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
       | _ -> false
     in
 
-    if fully_applied && not is_primitive then rue (mk_apply funct args)
-    else rue (mk_apply funct args)
+    if fully_applied && not is_primitive then rue (mk_apply funct args_with_loc)
+    else rue (mk_apply funct args_with_loc)
   | Pexp_match (sarg, caselist) ->
     begin_def ();
     let arg = type_exp env sarg in

compiler/ml/typedtree.ml

@@ -85,7 +85,7 @@ and expression_desc =
     }
   | Texp_apply of {
       funct: expression;
-      args: (Noloc.arg_label * expression option) list;
+      args: (arg_label * expression option) list;
       partial: bool;
     }
   | Texp_match of expression * case list * case list * partial

compiler/ml/typedtree.mli

@@ -148,7 +148,7 @@ and expression_desc =
          *)
   | Texp_apply of {
       funct: expression;
-      args: (Noloc.arg_label * expression option) list;
+      args: (arg_label * expression option) list;
       partial: bool;
     }
       (** E0 ~l1:E1 ... ~ln:En