@@ -172,7 +172,22 @@ let docsForLabel typeExpr ~file ~package ~supportsMarkdownLinks =
172
172
in
173
173
typeString :: typeDefinitions |> String. concat " \n "
174
174
175
- let signatureHelp ~path ~pos ~currentFile ~debug =
175
+ let findConstructorArgs ~full ~env ~constructorName loc =
176
+ match
177
+ References. getLocItem ~debug: false ~full
178
+ ~pos: (Pos. ofLexing loc.Location. loc_end)
179
+ with
180
+ | None -> None
181
+ | Some {locType = Typed (_ , typExpr , _ )} -> (
182
+ match TypeUtils. extractType ~env ~package: full.package typExpr with
183
+ | Some (Tvariant {constructors} , _ ) ->
184
+ constructors
185
+ |> List. find_opt (fun (c : Constructor.t ) ->
186
+ c.cname.txt = constructorName)
187
+ | _ -> None )
188
+ | _ -> None
189
+
190
+ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads =
176
191
let textOpt = Files. readFile currentFile in
177
192
match textOpt with
178
193
| None | Some "" -> None
@@ -187,8 +202,18 @@ let signatureHelp ~path ~pos ~currentFile ~debug =
187
202
Some text.[offsetNoWhite]
188
203
else None
189
204
in
205
+ let locHasCursor loc =
206
+ loc |> CursorPosition. locHasCursor ~pos: posBeforeCursor
207
+ in
190
208
let supportsMarkdownLinks = true in
191
209
let foundFunctionApplicationExpr = ref None in
210
+ let foundConstructorExpr = ref None in
211
+ let setFoundConstructor r =
212
+ if allowForConstructorPayloads then
213
+ match ! foundConstructorExpr with
214
+ | None -> foundConstructorExpr := Some r
215
+ | Some _ -> ()
216
+ in
192
217
let setFound r =
193
218
(* Because we want to handle both piped and regular function calls, and in
194
219
the case of piped calls the iterator will process both the pipe and the
@@ -216,7 +241,7 @@ let signatureHelp ~path ~pos ~currentFile ~debug =
216
241
let currentUnlabelledArgCount = ! unlabelledArgCount in
217
242
unlabelledArgCount := currentUnlabelledArgCount + 1 ;
218
243
(* An argument without a label is just the expression, so we can use that. *)
219
- if arg.exp.pexp_loc |> Loc. hasPos ~pos: posBeforeCursor then
244
+ if locHasCursor arg.exp.pexp_loc then
220
245
Some (Unlabelled currentUnlabelledArgCount)
221
246
else (
222
247
(* If this unlabelled arg doesn't have the cursor, record
@@ -286,9 +311,7 @@ let signatureHelp ~path ~pos ~currentFile ~debug =
286
311
} );
287
312
] );
288
313
}
289
- when pexp_loc
290
- |> CursorPosition. classifyLoc ~pos: posBeforeCursor
291
- == HasCursor ->
314
+ when locHasCursor pexp_loc ->
292
315
let argAtCursor, extractedArgs =
293
316
searchForArgWithCursor ~is PipeExpr:true ~args
294
317
in
@@ -298,13 +321,17 @@ let signatureHelp ~path ~pos ~currentFile ~debug =
298
321
pexp_desc = Pexp_apply (({pexp_desc = Pexp_ident _} as exp), args);
299
322
pexp_loc;
300
323
}
301
- when pexp_loc
302
- |> CursorPosition. classifyLoc ~pos: posBeforeCursor
303
- == HasCursor ->
324
+ when locHasCursor pexp_loc ->
304
325
let argAtCursor, extractedArgs =
305
326
searchForArgWithCursor ~is PipeExpr:false ~args
306
327
in
307
328
setFound (argAtCursor, exp, extractedArgs)
329
+ | {pexp_desc = Pexp_construct (lid, Some payloadExp); pexp_loc}
330
+ when locHasCursor payloadExp.pexp_loc
331
+ || CompletionExpressions. isExprHole payloadExp
332
+ && locHasCursor pexp_loc ->
333
+ (* Constructor payloads *)
334
+ setFoundConstructor (lid, payloadExp)
308
335
| _ -> () );
309
336
Ast_iterator. default_iterator.expr iterator expr
310
337
in
@@ -314,6 +341,7 @@ let signatureHelp ~path ~pos ~currentFile ~debug =
314
341
in
315
342
let {Res_driver. parsetree = structure} = parser ~filename: currentFile in
316
343
iterator.structure iterator structure |> ignore;
344
+ (* Handle function application, if found *)
317
345
match ! foundFunctionApplicationExpr with
318
346
| Some (argAtCursor , exp , _extractedArgs ) -> (
319
347
(* Not looking for the cursor position after this, but rather the target function expression's loc. *)
@@ -395,4 +423,200 @@ let signatureHelp ~path ~pos ~currentFile ~debug =
395
423
| activeParameter -> activeParameter);
396
424
}
397
425
| _ -> None )
398
- | _ -> None ))
426
+ | None -> (
427
+ (* Handle constructor payload if we had no function application *)
428
+ match ! foundConstructorExpr with
429
+ | Some (lid , expr ) -> (
430
+ if Debug. verbose () then
431
+ Printf. printf " [signature_help] Found constructor expr!\n " ;
432
+ match Cmt. loadFullCmtFromPath ~path with
433
+ | None ->
434
+ if Debug. verbose () then
435
+ Printf. printf " [signature_help] Could not load cmt\n " ;
436
+ None
437
+ | Some full -> (
438
+ let {file} = full in
439
+ let env = QueryEnv. fromFile file in
440
+ let constructorName = Longident. last lid.txt in
441
+ match
442
+ findConstructorArgs ~full ~env ~constructor Name
443
+ {lid.loc with loc_start = lid.loc.loc_end}
444
+ with
445
+ | None ->
446
+ if Debug. verbose () then
447
+ Printf. printf " [signature_help] Did not find constructor '%s'\n "
448
+ constructorName;
449
+ None
450
+ | Some constructor ->
451
+ let argParts =
452
+ match constructor.args with
453
+ | Args [] -> None
454
+ | InlineRecord fields ->
455
+ let offset = ref 0 in
456
+ Some
457
+ (`InlineRecord
458
+ (fields
459
+ |> List. map (fun (field : field ) ->
460
+ let startOffset = ! offset in
461
+ let argText =
462
+ Printf. sprintf " %s%s: %s" field.fname.txt
463
+ (if field.optional then " ?" else " " )
464
+ (Shared. typeToString
465
+ (if field.optional then
466
+ Utils. unwrapIfOption field.typ
467
+ else field.typ))
468
+ in
469
+ let endOffset =
470
+ startOffset + String. length argText
471
+ in
472
+ offset := endOffset + String. length " , " ;
473
+ (argText, field, (startOffset, endOffset)))))
474
+ | Args [(typ, _)] ->
475
+ Some
476
+ (`SingleArg
477
+ ( typ |> Shared. typeToString,
478
+ docsForLabel ~file: full.file ~package: full.package
479
+ ~supports MarkdownLinks typ ))
480
+ | Args args ->
481
+ let offset = ref 0 in
482
+ Some
483
+ (`TupleArg
484
+ (args
485
+ |> List. map (fun (typ , _ ) ->
486
+ let startOffset = ! offset in
487
+ let argText = typ |> Shared. typeToString in
488
+ let endOffset =
489
+ startOffset + String. length argText
490
+ in
491
+ offset := endOffset + String. length " , " ;
492
+ ( argText,
493
+ docsForLabel ~file: full.file
494
+ ~package: full.package ~supports MarkdownLinks
495
+ typ,
496
+ (startOffset, endOffset) ))))
497
+ in
498
+ let label =
499
+ constructor.cname.txt ^ " ("
500
+ ^ (match argParts with
501
+ | None -> " "
502
+ | Some (`InlineRecord fields ) ->
503
+ " {"
504
+ ^ (fields
505
+ |> List. map (fun (argText , _ , _ ) -> argText)
506
+ |> String. concat " , " )
507
+ ^ " }"
508
+ | Some (`SingleArg (arg , _ )) -> arg
509
+ | Some (`TupleArg items ) ->
510
+ items
511
+ |> List. map (fun (argText , _ , _ ) -> argText)
512
+ |> String. concat " , " )
513
+ ^ " )"
514
+ in
515
+ let activeParameter =
516
+ match expr with
517
+ | {pexp_desc = Pexp_tuple items } -> (
518
+ let idx = ref 0 in
519
+ let tupleItemWithCursor =
520
+ items
521
+ |> List. find_map (fun (item : Parsetree.expression ) ->
522
+ let currentIndex = ! idx in
523
+ idx := currentIndex + 1 ;
524
+ if locHasCursor item.pexp_loc then Some currentIndex
525
+ else None )
526
+ in
527
+ match tupleItemWithCursor with
528
+ | None -> - 1
529
+ | Some i -> i)
530
+ | {pexp_desc = Pexp_record (fields , _ )} -> (
531
+ let fieldNameWithCursor =
532
+ fields
533
+ |> List. find_map
534
+ (fun
535
+ (({loc; txt} , expr ) :
536
+ Longident. t Location. loc * Parsetree. expression )
537
+ ->
538
+ if
539
+ posBeforeCursor > = Pos. ofLexing loc.loc_start
540
+ && posBeforeCursor
541
+ < = Pos. ofLexing expr.pexp_loc.loc_end
542
+ then Some (Longident. last txt)
543
+ else None )
544
+ in
545
+ match (fieldNameWithCursor, argParts) with
546
+ | Some fieldName , Some (`InlineRecord fields ) ->
547
+ let idx = ref 0 in
548
+ let fieldIndex = ref (- 1 ) in
549
+ fields
550
+ |> List. iter (fun (_ , field , _ ) ->
551
+ idx := ! idx + 1 ;
552
+ let currentIndex = ! idx in
553
+ if fieldName = field.fname.txt then
554
+ fieldIndex := currentIndex
555
+ else () );
556
+ ! fieldIndex
557
+ | _ -> - 1 )
558
+ | _ when locHasCursor expr.pexp_loc -> 0
559
+ | _ -> - 1
560
+ in
561
+
562
+ let constructorNameLength = String. length constructor.cname.txt in
563
+ let params =
564
+ match argParts with
565
+ | None -> []
566
+ | Some (`SingleArg (_ , docstring )) ->
567
+ [
568
+ {
569
+ Protocol. label =
570
+ (constructorNameLength + 1 , String. length label - 1 );
571
+ documentation =
572
+ {Protocol. kind = " markdown" ; value = docstring};
573
+ };
574
+ ]
575
+ | Some (`InlineRecord fields ) ->
576
+ (* Account for leading '({' *)
577
+ let baseOffset = constructorNameLength + 2 in
578
+ {
579
+ Protocol. label = (0 , 0 );
580
+ documentation = {Protocol. kind = " markdown" ; value = " " };
581
+ }
582
+ :: (fields
583
+ |> List. map (fun (_ , field , (start , end_ )) ->
584
+ {
585
+ Protocol. label =
586
+ (baseOffset + start, baseOffset + end_);
587
+ documentation =
588
+ {
589
+ Protocol. kind = " markdown" ;
590
+ value = field.docstring |> String. concat " \n " ;
591
+ };
592
+ }))
593
+ | Some (`TupleArg items ) ->
594
+ (* Account for leading '(' *)
595
+ let baseOffset = constructorNameLength + 1 in
596
+ items
597
+ |> List. map (fun (_ , docstring , (start , end_ )) ->
598
+ {
599
+ Protocol. label =
600
+ (baseOffset + start, baseOffset + end_);
601
+ documentation =
602
+ {Protocol. kind = " markdown" ; value = docstring};
603
+ })
604
+ in
605
+ Some
606
+ {
607
+ Protocol. signatures =
608
+ [
609
+ {
610
+ label;
611
+ parameters = params;
612
+ documentation =
613
+ (match List. nth_opt constructor.docstring 0 with
614
+ | None -> None
615
+ | Some docs ->
616
+ Some {Protocol. kind = " markdown" ; value = docs});
617
+ };
618
+ ];
619
+ activeSignature = Some 0 ;
620
+ activeParameter = Some activeParameter;
621
+ }))
622
+ | None -> None )))
0 commit comments