@@ -172,7 +172,22 @@ let docsForLabel typeExpr ~file ~package ~supportsMarkdownLinks =
172172 in
173173 typeString :: typeDefinitions |> String. concat " \n "
174174
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 =
176191 let textOpt = Files. readFile currentFile in
177192 match textOpt with
178193 | None | Some "" -> None
@@ -187,8 +202,18 @@ let signatureHelp ~path ~pos ~currentFile ~debug =
187202 Some text.[offsetNoWhite]
188203 else None
189204 in
205+ let locHasCursor loc =
206+ loc |> CursorPosition. locHasCursor ~pos: posBeforeCursor
207+ in
190208 let supportsMarkdownLinks = true in
191209 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
192217 let setFound r =
193218 (* Because we want to handle both piped and regular function calls, and in
194219 the case of piped calls the iterator will process both the pipe and the
@@ -216,7 +241,7 @@ let signatureHelp ~path ~pos ~currentFile ~debug =
216241 let currentUnlabelledArgCount = ! unlabelledArgCount in
217242 unlabelledArgCount := currentUnlabelledArgCount + 1 ;
218243 (* 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
220245 Some (Unlabelled currentUnlabelledArgCount)
221246 else (
222247 (* If this unlabelled arg doesn't have the cursor, record
@@ -286,9 +311,7 @@ let signatureHelp ~path ~pos ~currentFile ~debug =
286311 } );
287312 ] );
288313 }
289- when pexp_loc
290- |> CursorPosition. classifyLoc ~pos: posBeforeCursor
291- == HasCursor ->
314+ when locHasCursor pexp_loc ->
292315 let argAtCursor, extractedArgs =
293316 searchForArgWithCursor ~is PipeExpr:true ~args
294317 in
@@ -298,13 +321,17 @@ let signatureHelp ~path ~pos ~currentFile ~debug =
298321 pexp_desc = Pexp_apply (({pexp_desc = Pexp_ident _} as exp), args);
299322 pexp_loc;
300323 }
301- when pexp_loc
302- |> CursorPosition. classifyLoc ~pos: posBeforeCursor
303- == HasCursor ->
324+ when locHasCursor pexp_loc ->
304325 let argAtCursor, extractedArgs =
305326 searchForArgWithCursor ~is PipeExpr:false ~args
306327 in
307328 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)
308335 | _ -> () );
309336 Ast_iterator. default_iterator.expr iterator expr
310337 in
@@ -314,6 +341,7 @@ let signatureHelp ~path ~pos ~currentFile ~debug =
314341 in
315342 let {Res_driver. parsetree = structure} = parser ~filename: currentFile in
316343 iterator.structure iterator structure |> ignore;
344+ (* Handle function application, if found *)
317345 match ! foundFunctionApplicationExpr with
318346 | Some (argAtCursor , exp , _extractedArgs ) -> (
319347 (* 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 =
395423 | activeParameter -> activeParameter);
396424 }
397425 | _ -> 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