Skip to content

Commit 085a396

Browse files
committed
use labels with locations in typedtree
1 parent e942812 commit 085a396

File tree

8 files changed

+40
-15
lines changed

8 files changed

+40
-15
lines changed

analysis/reanalyze/src/Arnold.ml

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -582,9 +582,9 @@ module ExtendFunctionTable = struct
582582
Texp_apply {funct = {exp_desc = Texp_ident (path, {loc}, _)}; args};
583583
}
584584
when kindOpt <> None ->
585-
let checkArg ((argLabel : Asttypes.Noloc.arg_label), _argOpt) =
585+
let checkArg ((argLabel : Asttypes.arg_label), _argOpt) =
586586
match (argLabel, kindOpt) with
587-
| (Labelled l | Optional l), Some kind ->
587+
| (Labelled {txt = l} | Optional {txt = l}), Some kind ->
588588
kind |> List.for_all (fun {Kind.label} -> label <> l)
589589
| _ -> true
590590
in
@@ -624,9 +624,9 @@ module ExtendFunctionTable = struct
624624
when callee |> FunctionTable.isInFunctionInTable ~functionTable ->
625625
let functionName = Path.name callee in
626626
args
627-
|> List.iter (fun ((argLabel : Asttypes.Noloc.arg_label), argOpt) ->
627+
|> List.iter (fun ((argLabel : Asttypes.arg_label), argOpt) ->
628628
match (argLabel, argOpt |> extractLabelledArgument) with
629-
| Labelled label, Some (path, loc)
629+
| Labelled {txt = label}, Some (path, loc)
630630
when path |> FunctionTable.isInFunctionInTable ~functionTable
631631
->
632632
functionTable
@@ -672,11 +672,11 @@ module CheckExpressionWellFormed = struct
672672
->
673673
let functionName = Path.name functionPath in
674674
args
675-
|> List.iter (fun ((argLabel : Asttypes.Noloc.arg_label), argOpt) ->
675+
|> List.iter (fun ((argLabel : Asttypes.arg_label), argOpt) ->
676676
match argOpt |> ExtendFunctionTable.extractLabelledArgument with
677677
| Some (path, loc) -> (
678678
match argLabel with
679-
| Labelled label -> (
679+
| Labelled {txt = label} -> (
680680
if
681681
functionTable
682682
|> FunctionTable.functionGetKindOfLabel ~functionName
@@ -761,7 +761,7 @@ module Compile = struct
761761
let argsFromKind =
762762
innerFunctionDefinition.kind
763763
|> List.map (fun (entry : Kind.entry) ->
764-
( Asttypes.Noloc.Labelled entry.label,
764+
( Asttypes.Labelled (Location.mknoloc entry.label),
765765
Some
766766
{
767767
expr with
@@ -785,7 +785,7 @@ module Compile = struct
785785
args
786786
|> List.find_opt (fun arg ->
787787
match arg with
788-
| Asttypes.Noloc.Labelled s, Some _ -> s = label
788+
| Asttypes.Labelled {txt = s}, Some _ -> s = label
789789
| _ -> false)
790790
in
791791
let argOpt =

analysis/reanalyze/src/DeadValue.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -104,7 +104,7 @@ let processOptionalArgs ~expType ~(locFrom : Location.t) ~locTo ~path args =
104104
| None -> Some false
105105
in
106106
match lbl with
107-
| Asttypes.Noloc.Optional s when not locFrom.loc_ghost ->
107+
| Asttypes.Optional {txt = s} when not locFrom.loc_ghost ->
108108
if argIsSupplied <> Some false then supplied := s :: !supplied;
109109
if argIsSupplied = None then suppliedMaybe := s :: !suppliedMaybe
110110
| _ -> ());

analysis/src/ProcessExtra.ml

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -410,6 +410,23 @@ let expr ~env ~(extra : extra) (iter : Tast_iterator.iterator)
410410
| Texp_field (inner, lident, _label_description) ->
411411
addForField ~env ~extra ~recordType:inner.exp_type
412412
~fieldType:expression.exp_type lident
413+
| Texp_apply {funct; args} ->
414+
args
415+
|> List.iter (fun (label, _) ->
416+
match label with
417+
| Asttypes.Labelled {txt; loc} | Optional {txt; loc} -> (
418+
let rec findArgType (t : Types.type_expr) =
419+
match t.desc with
420+
| Tarrow ((Labelled lbl | Optional lbl), argType, _, _, _)
421+
when lbl = txt ->
422+
Some argType
423+
| Tarrow (_, _, next, _, _) -> findArgType next
424+
| _ -> None
425+
in
426+
match findArgType funct.exp_type with
427+
| None -> ()
428+
| Some argType -> addLocItem extra loc (OtherExpression argType))
429+
| _ -> ())
413430
| _ ->
414431
addLocItem extra expression.exp_loc (OtherExpression expression.exp_type));
415432
Tast_iterator.default_iterator.expr iter expression

compiler/ml/printtyped.ml

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -125,6 +125,11 @@ let arg_label i ppf = function
125125
| Optional s -> line i ppf "Optional \"%s\"\n" s
126126
| Labelled s -> line i ppf "Labelled \"%s\"\n" s
127127

128+
let arg_label_loc i ppf = function
129+
| Nolabel -> line i ppf "Nolabel\n"
130+
| Optional {txt = s} -> line i ppf "Optional \"%s\"\n" s
131+
| Labelled {txt = s} -> line i ppf "Labelled \"%s\"\n" s
132+
128133
let record_representation i ppf =
129134
let open Types in
130135
function
@@ -658,7 +663,7 @@ and record_field i ppf = function
658663

659664
and label_x_expression i ppf (l, e) =
660665
line i ppf "<arg>\n";
661-
arg_label (i + 1) ppf l;
666+
arg_label_loc (i + 1) ppf l;
662667
match e with
663668
| None -> ()
664669
| Some e -> expression (i + 1) ppf e

compiler/ml/translcore.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1019,7 +1019,7 @@ and transl_apply ?(inlined = Default_inline)
10191019
| _ ->
10201020
(build_apply lam []
10211021
(List.map
1022-
(fun (l, x) -> (may_map transl_exp x, Btype.is_optional l))
1022+
(fun (l, x) -> (may_map transl_exp x, Btype.is_optional_loc l))
10231023
sargs)
10241024
: Lambda.lambda)
10251025

compiler/ml/typecore.ml

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2417,6 +2417,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
24172417
end_def ();
24182418
unify_var env (newvar ()) funct.exp_type;
24192419
2420+
let args_with_loc =
2421+
List.map2 (fun (sarg, _) (_, label_exp) -> (sarg, label_exp)) sargs args
2422+
in
24202423
let mk_apply funct args =
24212424
rue
24222425
{
@@ -2435,8 +2438,8 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
24352438
| _ -> false
24362439
in
24372440
2438-
if fully_applied && not is_primitive then rue (mk_apply funct args)
2439-
else rue (mk_apply funct args)
2441+
if fully_applied && not is_primitive then rue (mk_apply funct args_with_loc)
2442+
else rue (mk_apply funct args_with_loc)
24402443
| Pexp_match (sarg, caselist) ->
24412444
begin_def ();
24422445
let arg = type_exp env sarg in

compiler/ml/typedtree.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -85,7 +85,7 @@ and expression_desc =
8585
}
8686
| Texp_apply of {
8787
funct: expression;
88-
args: (Noloc.arg_label * expression option) list;
88+
args: (arg_label * expression option) list;
8989
partial: bool;
9090
}
9191
| Texp_match of expression * case list * case list * partial

compiler/ml/typedtree.mli

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -148,7 +148,7 @@ and expression_desc =
148148
*)
149149
| Texp_apply of {
150150
funct: expression;
151-
args: (Noloc.arg_label * expression option) list;
151+
args: (arg_label * expression option) list;
152152
partial: bool;
153153
}
154154
(** E0 ~l1:E1 ... ~ln:En

0 commit comments

Comments
 (0)