diff --git a/compiler/src/formatting/fmt.re b/compiler/src/formatting/fmt.re index d384c0b82..1cc200999 100644 --- a/compiler/src/formatting/fmt.re +++ b/compiler/src/formatting/fmt.re @@ -289,6 +289,8 @@ type formatter = { print_attribute: (formatter, attribute) => Doc.t, print_application_argument: (formatter, ~infix_wrap: t => t=?, application_argument) => Doc.t, + print_partial_application_argument: + (formatter, ~infix_wrap: t => t=?, partial_application_argument) => Doc.t, print_if: ( formatter, @@ -1157,6 +1159,32 @@ let print_application_argument = (fmt, ~infix_wrap=?, arg) => { ++ fmt.print_expression(fmt, ~infix_wrap?, arg.paa_expr); }; +let print_partial_application_argument = (fmt, ~infix_wrap=?, arg) => { + ( + switch (arg.ppaa_label) { + | Unlabeled => empty + | Labeled({txt: label, loc: label_loc}) + | Default({txt: label, loc: label_loc}) => + string(label) + ++ string("=") + ++ fmt.print_comment_range( + fmt, + label_loc, + switch (arg.ppaa_expr) { + | ArgumentGiven(expr) => expr.pexp_loc + | ArgumentHole(loc) => loc + }, + ) + } + ) + ++ ( + switch (arg.ppaa_expr) { + | ArgumentGiven(expr) => fmt.print_expression(fmt, ~infix_wrap?, expr) + | ArgumentHole(_) => string("_") + } + ); +}; + let print_if = (fmt, ~force_blocks=false, ~loc, condition, true_branch, false_branch) => if (force_blocks) { @@ -1743,6 +1771,69 @@ let print_expression = (fmt, ~infix_wrap=d => group(indent(d)), expr) => { ++ break, ), ) + | PExpPartial(fn, args) => + string("partial") + ++ fmt.print_comment_range( + fmt, + ~allow_breaks=false, + ~none=space, + ~lead=space, + ~trail=space, + enclosing_start_location(expr.pexp_loc), + fn.pexp_loc, + ) + ++ group( + fmt.print_grouped_access_expression(fmt, fn) + ++ parens( + indent( + concat_map( + ~lead= + next => + fmt.print_comment_range( + fmt, + ~none=break, + ~lead=if_broken(space, empty), + ~trail=breakable_space, + fn.pexp_loc, + next.ppaa_loc, + ), + ~sep= + (prev, next) => + fmt.print_comment_range( + fmt, + ~none=breakable_space, + ~lead=space, + ~trail=breakable_space, + prev.ppaa_loc, + next.ppaa_loc, + ), + ~trail= + prev => + fmt.print_comment_range( + fmt, + ~block_end=true, + ~lead=space, + prev.ppaa_loc, + enclosing_end_location(expr.pexp_loc), + ), + ~f= + (~final, a) => + if (final) { + group( + fmt.print_partial_application_argument(fmt, a), + ); + } else { + group( + fmt.print_partial_application_argument(fmt, a) + ++ comma, + ); + }, + args, + ), + ) + ++ break, + ), + ) | PExpLambda( [ { @@ -4119,6 +4210,7 @@ let default_formatter: formatter = { print_match_branch, print_attribute, print_application_argument, + print_partial_application_argument, print_if, print_assignment, print_expression, diff --git a/compiler/src/parsing/ast_helper.re b/compiler/src/parsing/ast_helper.re index 6335163e3..ddf8635a9 100644 --- a/compiler/src/parsing/ast_helper.re +++ b/compiler/src/parsing/ast_helper.re @@ -319,6 +319,31 @@ module Expression = { mk(~loc, ~core_loc, ~attributes?, PExpLambda(a, b)); let apply = (~loc, ~core_loc, ~attributes=?, a, b) => mk(~loc, ~core_loc, ~attributes?, PExpApp(a, b)); + let partial_apply = (~loc, ~core_loc, ~attributes=?, a, b) => + mk(~loc, ~core_loc, ~attributes?, PExpPartial(a, b)); + let total_apply_args = (~loc, ~core_loc, ~attributes=?, a, b) => { + let args = + List.map( + arg => + { + paa_loc: arg.ppaa_loc, + paa_expr: + switch (arg.ppaa_expr) { + | ArgumentGiven(expr) => expr + | ArgumentHole(_) => + raise( + SyntaxError( + loc, + "To use partial application, prefix the function call with `partial`.", + ), + ) + }, + paa_label: arg.ppaa_label, + }, + b, + ); + mk(~loc, ~core_loc, ~attributes?, PExpApp(a, args)); + }; let construct = (~loc, ~core_loc, ~attributes=?, a, b) => mk(~loc, ~core_loc, ~attributes?, PExpConstruct(a, b)); let singleton_construct = (~loc, ~core_loc, ~attributes=?, a) => diff --git a/compiler/src/parsing/ast_helper.rei b/compiler/src/parsing/ast_helper.rei index 0493011b0..6842d818e 100644 --- a/compiler/src/parsing/ast_helper.rei +++ b/compiler/src/parsing/ast_helper.rei @@ -374,6 +374,24 @@ module Expression: { list(application_argument) ) => expression; + let partial_apply: + ( + ~loc: loc, + ~core_loc: loc, + ~attributes: attributes=?, + expression, + list(partial_application_argument) + ) => + expression; + let total_apply_args: + ( + ~loc: loc, + ~core_loc: loc, + ~attributes: attributes=?, + expression, + list(partial_application_argument) + ) => + expression; let construct: ( ~loc: loc, diff --git a/compiler/src/parsing/ast_mapper.re b/compiler/src/parsing/ast_mapper.re index 0235f7f62..d3c270a29 100644 --- a/compiler/src/parsing/ast_mapper.re +++ b/compiler/src/parsing/ast_mapper.re @@ -252,6 +252,26 @@ module E = { el, ), ) + | PExpPartial(e, el) => + partial_apply( + ~loc, + ~core_loc, + ~attributes, + sub.expr(sub, e), + List.map( + arg => + { + ppaa_label: arg.ppaa_label, + ppaa_expr: + switch (arg.ppaa_expr) { + | ArgumentGiven(expr) => ArgumentGiven(sub.expr(sub, expr)) + | ArgumentHole(loc) => ArgumentHole(sub.location(sub, loc)) + }, + ppaa_loc: sub.location(sub, arg.ppaa_loc), + }, + el, + ), + ) | PExpConstruct(id, e) => construct( ~loc, diff --git a/compiler/src/parsing/lexer.re b/compiler/src/parsing/lexer.re index a9a9beeab..ce3c549ce 100644 --- a/compiler/src/parsing/lexer.re +++ b/compiler/src/parsing/lexer.re @@ -291,6 +291,7 @@ let rec token = lexbuf => { | "catch" => positioned(CATCH) | "macro" => positioned(MACRO) | "yield" => positioned(YIELD) + | "partial" => positioned(PARTIAL) | "..." => positioned(ELLIPSIS) | "." => positioned(DOT) | "::" => positioned(COLONCOLON) diff --git a/compiler/src/parsing/parser.messages b/compiler/src/parsing/parser.messages index 2a7142d14..d45a50c9b 100644 --- a/compiler/src/parsing/parser.messages +++ b/compiler/src/parsing/parser.messages @@ -1133,6 +1133,26 @@ program: MODULE UIDENT EOL EOL WASMI64 THICKARROW ## In state 826, spurious reduction of production toplevel_stmt -> expr ## In state 819, spurious reduction of production lseparated_nonempty_list_inner(eos,toplevel_stmt) -> toplevel_stmt ## +program: MODULE UIDENT EOL PARTIAL LIDENT LPAREN RPAREN YIELD +## +## Ends in an error in state: 743. +## +## app_expr -> left_accessor_expr lparen option(comma) rparen . [ LPAREN LBRACK DOT ] +## partial_app_expr -> PARTIAL left_accessor_expr lparen option(comma) rparen . [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LCARET INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 EOL EOF ELSE DASH COMMA COLON AND ] +## +## The known suffix of the stack is as follows: +## PARTIAL left_accessor_expr lparen option(comma) rparen +## +program: MODULE UIDENT EOL PARTIAL LIDENT LPAREN UIDENT RPAREN YIELD +## +## Ends in an error in state: 746. +## +## app_expr -> left_accessor_expr lparen lseparated_nonempty_list_inner(comma,app_arg) option(comma) rparen . [ LPAREN LBRACK DOT ] +## partial_app_expr -> PARTIAL left_accessor_expr lparen lseparated_nonempty_list_inner(comma,app_arg) option(comma) rparen . [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LCARET INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 EOL EOF ELSE DASH COMMA COLON AND ] +## +## The known suffix of the stack is as follows: +## PARTIAL left_accessor_expr lparen lseparated_nonempty_list_inner(comma,app_arg) option(comma) rparen +## Expected a newline character to terminate the statement. @@ -1840,6 +1860,16 @@ program: MODULE UIDENT EOL WHILE LPAREN UIDENT RPAREN EOL YIELD ## In state 1, spurious reduction of production nonempty_list(eol) -> EOL ## In state 5, spurious reduction of production eols -> nonempty_list(eol) ## +program: MODULE UIDENT EOL PARTIAL YIELD +## +## Ends in an error in state: 124. +## +## partial_app_expr -> PARTIAL . left_accessor_expr lparen option(comma) rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LCARET INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 EOL EOF ELSE DASH COMMA COLON AND ] +## partial_app_expr -> PARTIAL . left_accessor_expr lparen lseparated_nonempty_list_inner(comma,app_arg) option(comma) rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LCARET INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 EOL EOF ELSE DASH COMMA COLON AND ] +## +## The known suffix of the stack is as follows: +## PARTIAL +## Expected an expression. @@ -3504,6 +3534,102 @@ program: MODULE UIDENT EOL IF WHILE Expected `(` followed by a condition expression. +program: MODULE UIDENT EOL PARTIAL UIDENT YIELD +## +## Ends in an error in state: 740. +## +## app_expr -> left_accessor_expr . lparen option(comma) rparen [ LPAREN LBRACK DOT ] +## app_expr -> left_accessor_expr . lparen lseparated_nonempty_list_inner(comma,app_arg) option(comma) rparen [ LPAREN LBRACK DOT ] +## array_get -> left_accessor_expr . lbrack expr rbrack [ LPAREN LBRACK DOT ] +## partial_app_expr -> PARTIAL left_accessor_expr . lparen option(comma) rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LCARET INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 EOL EOF ELSE DASH COMMA COLON AND ] +## partial_app_expr -> PARTIAL left_accessor_expr . lparen lseparated_nonempty_list_inner(comma,app_arg) option(comma) rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LCARET INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 EOL EOF ELSE DASH COMMA COLON AND ] +## record_get -> left_accessor_expr . DOT lid [ LPAREN LBRACK DOT ] +## record_get -> left_accessor_expr . DOT eols lid [ LPAREN LBRACK DOT ] +## +## The known suffix of the stack is as follows: +## PARTIAL left_accessor_expr +## +## WARNING: This example involves spurious reductions. +## This implies that, although the LR(1) items shown above provide an +## accurate view of the past (what has been recognized so far), they +## may provide an INCOMPLETE view of the future (what was expected next). +## In state 265, spurious reduction of production qualified_uid -> lseparated_nonempty_list_inner(dot,type_id_str) +## In state 162, spurious reduction of production construct_expr -> qualified_uid +## In state 312, spurious reduction of production left_accessor_expr -> construct_expr +## + +Expected `(` followed by partial application arguments. + +program: MODULE UIDENT EOL PARTIAL LIDENT LPAREN YIELD +## +## Ends in an error in state: 741. +## +## app_expr -> left_accessor_expr lparen . option(comma) rparen [ LPAREN LBRACK DOT ] +## app_expr -> left_accessor_expr lparen . lseparated_nonempty_list_inner(comma,app_arg) option(comma) rparen [ LPAREN LBRACK DOT ] +## partial_app_expr -> PARTIAL left_accessor_expr lparen . option(comma) rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LCARET INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 EOL EOF ELSE DASH COMMA COLON AND ] +## partial_app_expr -> PARTIAL left_accessor_expr lparen . lseparated_nonempty_list_inner(comma,app_arg) option(comma) rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LCARET INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 EOL EOF ELSE DASH COMMA COLON AND ] +## +## The known suffix of the stack is as follows: +## PARTIAL left_accessor_expr lparen +## +## WARNING: This example involves spurious reductions. +## This implies that, although the LR(1) items shown above provide an +## accurate view of the past (what has been recognized so far), they +## may provide an INCOMPLETE view of the future (what was expected next). +## In state 4, spurious reduction of production lparen -> LPAREN +## + +Expected an expression or `_`. + +program: MODULE UIDENT EOL PARTIAL LIDENT LPAREN COMMA YIELD +## +## Ends in an error in state: 742. +## +## app_expr -> left_accessor_expr lparen option(comma) . rparen [ LPAREN LBRACK DOT ] +## partial_app_expr -> PARTIAL left_accessor_expr lparen option(comma) . rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LCARET INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 EOL EOF ELSE DASH COMMA COLON AND ] +## +## The known suffix of the stack is as follows: +## PARTIAL left_accessor_expr lparen option(comma) +## +## WARNING: This example involves spurious reductions. +## This implies that, although the LR(1) items shown above provide an +## accurate view of the past (what has been recognized so far), they +## may provide an INCOMPLETE view of the future (what was expected next). +## In state 39, spurious reduction of production comma -> COMMA +## In state 516, spurious reduction of production option(comma) -> comma +## + +Expected a comma-separated list of partial application arguments or `)` to complete the partial application. + +program: MODULE UIDENT EOL PARTIAL LIDENT LPAREN UIDENT YIELD +## +## Ends in an error in state: 744. +## +## app_expr -> left_accessor_expr lparen lseparated_nonempty_list_inner(comma,app_arg) . option(comma) rparen [ LPAREN LBRACK DOT ] +## lseparated_nonempty_list_inner(comma,app_arg) -> lseparated_nonempty_list_inner(comma,app_arg) . comma app_arg [ RPAREN EOL COMMA ] +## partial_app_expr -> PARTIAL left_accessor_expr lparen lseparated_nonempty_list_inner(comma,app_arg) . option(comma) rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LCARET INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 EOL EOF ELSE DASH COMMA COLON AND ] +## +## The known suffix of the stack is as follows: +## PARTIAL left_accessor_expr lparen lseparated_nonempty_list_inner(comma,app_arg) +## +## WARNING: This example involves spurious reductions. +## This implies that, although the LR(1) items shown above provide an +## accurate view of the past (what has been recognized so far), they +## may provide an INCOMPLETE view of the future (what was expected next). +## In state 265, spurious reduction of production qualified_uid -> lseparated_nonempty_list_inner(dot,type_id_str) +## In state 162, spurious reduction of production construct_expr -> qualified_uid +## In state 312, spurious reduction of production left_accessor_expr -> construct_expr +## In state 287, spurious reduction of production non_assign_expr -> left_accessor_expr +## In state 263, spurious reduction of production non_binop_expr -> non_assign_expr +## In state 194, spurious reduction of production annotated_expr -> non_binop_expr +## In state 321, spurious reduction of production non_stmt_expr -> annotated_expr +## In state 187, spurious reduction of production expr -> non_stmt_expr +## In state 514, spurious reduction of production app_arg -> expr +## In state 517, spurious reduction of production lseparated_nonempty_list_inner(comma,app_arg) -> app_arg +## + +Expected a comma or `)` to complete the partial application. + program: MODULE UIDENT EOL FOREIGN WASM LIDENT COLON UIDENT FROM YIELD ## ## Ends in an error in state: 753. @@ -6617,21 +6743,22 @@ program: MODULE UIDENT EOL WASMI64 COLON UIDENT LCARET UIDENT RPAREN Expected `>` to complete the type. -program: MODULE UIDENT EOL WASMI64 DOT LIDENT LPAREN UNDERSCORE +program: MODULE UIDENT EOL BIGINT LPAREN YIELD ## -## Ends in an error in state: 468. +## Ends in an error in state: 279. ## -## app_expr -> record_get lparen . option(comma) rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LPAREN LCARET LBRACK INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 GETS EOL EOF ELSE DOT DASH COMMA COLON ] -## app_expr -> record_get lparen . lseparated_nonempty_list_inner(comma,expr) option(comma) rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LPAREN LCARET LBRACK INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 GETS EOL EOF ELSE DOT DASH COMMA COLON ] +## app_expr -> left_accessor_expr lparen . option(comma) rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LPAREN LCARET LBRACK INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 GETS EOL EOF ELSE DOT DASH COMMA COLON AND ] +## app_expr -> left_accessor_expr lparen . lseparated_nonempty_list_inner(comma,app_arg) option(comma) rparen [ THICKARROW STAR SLASH SEMI RPAREN RCARET RBRACK RBRACE PIPE LPAREN LCARET LBRACK INFIX_90 INFIX_80 INFIX_70 INFIX_60 INFIX_50 INFIX_40 INFIX_30 INFIX_120 INFIX_110 INFIX_100 GETS EOL EOF ELSE DOT DASH COMMA COLON AND ] ## ## The known suffix of the stack is as follows: -## record_get lparen +## left_accessor_expr lparen ## ## WARNING: This example involves spurious reductions. ## This implies that, although the LR(1) items shown above provide an ## accurate view of the past (what has been recognized so far), they ## may provide an INCOMPLETE view of the future (what was expected next). -## In state 2, spurious reduction of production lparen -> LPAREN +## In state 1, spurious reduction of production nonempty_list(eol) -> EOL +## In state 5, spurious reduction of production eols -> nonempty_list(eol) ## program: MODULE UIDENT EOL LBRACKRCARET RBRACK LPAREN COMMA WHILE ## diff --git a/compiler/src/parsing/parser.mly b/compiler/src/parsing/parser.mly index d9161f198..6e5c7b3e4 100644 --- a/compiler/src/parsing/parser.mly +++ b/compiler/src/parsing/parser.mly @@ -29,7 +29,7 @@ module Grain_parsing = struct end %token TRUE FALSE VOID -%token LET MUT REC IF WHEN ELSE MATCH WHILE FOR CONTINUE BREAK RETURN +%token LET MUT REC IF WHEN ELSE MATCH WHILE FOR CONTINUE BREAK RETURN PARTIAL %token AT %token INFIX_10 INFIX_30 INFIX_40 INFIX_50 INFIX_60 INFIX_70 @@ -452,12 +452,16 @@ unop_expr: paren_expr: | lparen expr rparen { $2 } +%inline app_arg_item: + | UNDERSCORE { ArgumentHole (to_loc $loc) } + | expr { ArgumentGiven $1 } + app_arg: - | expr { {paa_label=Unlabeled; paa_expr=$1; paa_loc=to_loc $loc} } - | id_str EQUAL expr { {paa_label=(Labeled $1); paa_expr=$3; paa_loc=to_loc $loc} } + | app_arg_item { {ppaa_label=Unlabeled; ppaa_expr=$1; ppaa_loc=to_loc $loc} } + | id_str EQUAL app_arg_item { {ppaa_label=(Labeled $1); ppaa_expr=$3; ppaa_loc=to_loc $loc} } app_expr: - | left_accessor_expr lparen lseparated_list(comma, app_arg) comma? rparen { Expression.apply ~loc:(to_loc $loc) ~core_loc:(to_loc $loc) $1 $3 } + | left_accessor_expr lparen lseparated_list(comma, app_arg) comma? rparen { Expression.total_apply_args ~loc:(to_loc $loc) ~core_loc:(to_loc $loc) $1 $3 } rcaret_rcaret_op: | lnonempty_list(RCARET) RCARET { (String.init (1 + List.length $1) (fun _ -> '>')) } @@ -590,6 +594,9 @@ match_branches: match_expr: | MATCH lparen expr rparen lbrace match_branches rbrace { Expression.match_ ~loc:(to_loc $loc) ~core_loc:(to_loc $loc) $3 (mkloc $6 (to_loc (fst $loc($5), snd $loc($7)))) } + +partial_app_expr: + | PARTIAL left_accessor_expr lparen lseparated_list(comma, app_arg) comma? rparen { Expression.partial_apply ~loc:(to_loc $loc) ~core_loc:(to_loc $loc) $2 $4 } list_item: | ELLIPSIS expr { ListSpread ($2, to_loc $loc) } @@ -630,6 +637,7 @@ non_assign_expr: | while_expr { $1 } | for_expr { $1 } | match_expr { $1 } + | partial_app_expr { $1 } left_accessor_expr: | app_expr { $1 } diff --git a/compiler/src/parsing/parsetree.re b/compiler/src/parsing/parsetree.re index 4507eba8f..46458629f 100644 --- a/compiler/src/parsing/parsetree.re +++ b/compiler/src/parsing/parsetree.re @@ -552,6 +552,7 @@ and expression_desc = | PExpUse(loc(Identifier.t), use_items) | PExpLambda(list(lambda_argument), expression) | PExpApp(expression, list(application_argument)) + | PExpPartial(expression, list(partial_application_argument)) | PExpConstruct(loc(Identifier.t), constructor_expression) | PExpBlock(list(expression)) | PExpBoxAssign(expression, expression) @@ -578,6 +579,18 @@ and application_argument = { paa_loc: Location.t, } +[@deriving (sexp, yojson)] +and partial_application_expression = + | ArgumentHole(Location.t) + | ArgumentGiven(expression) + +[@deriving (sexp, yojson)] +and partial_application_argument = { + ppaa_label: argument_label, + ppaa_expr: partial_application_expression, + ppaa_loc: Location.t, +} + /** let-binding form */ [@deriving (sexp, yojson)] diff --git a/compiler/src/parsing/parsetree_iter.re b/compiler/src/parsing/parsetree_iter.re index bd79be2c2..912349cda 100644 --- a/compiler/src/parsing/parsetree_iter.re +++ b/compiler/src/parsing/parsetree_iter.re @@ -365,6 +365,18 @@ and iter_expression = }, el, ); + | PExpPartial(e, el) => + iter_expression(hooks, e); + List.iter( + arg => { + switch (arg.ppaa_expr) { + | ArgumentGiven(expr) => iter_expression(hooks, expr) + | ArgumentHole(loc) => iter_location(hooks, loc) + }; + iter_location(hooks, arg.ppaa_loc); + }, + el, + ); | PExpConstruct(c, e) => iter_ident(hooks, c); switch (e) { diff --git a/compiler/src/parsing/well_formedness.re b/compiler/src/parsing/well_formedness.re index 103edf655..454acdb9d 100644 --- a/compiler/src/parsing/well_formedness.re +++ b/compiler/src/parsing/well_formedness.re @@ -20,7 +20,8 @@ type wferr = | LocalIncludeStatement(Location.t) | ProvidedMultipleTimes(string, Location.t) | MutualRecTypesMissingRec(Location.t) - | MutualRecExtraneousNonfirstRec(Location.t); + | MutualRecExtraneousNonfirstRec(Location.t) + | PartialNoHoles(Location.t); exception Error(wferr); @@ -89,6 +90,11 @@ let prepare_error = ~loc, "The `rec` keyword should only appear on the first type in the mutually recursive type group.", ) + | PartialNoHoles(loc) => + errorf( + ~loc, + "A partial application must have at least one argument hole.", + ) ) ); @@ -877,6 +883,34 @@ let array_index_non_integer = (errs, super) => { }; }; +let improper_partial = (errs, super) => { + let enter_expression = ({pexp_desc: desc, pexp_loc: loc} as e) => { + switch (desc) { + | PExpPartial(_, args) + when + List.for_all( + arg => + switch (arg.ppaa_expr) { + | ArgumentGiven(_) => true + | ArgumentHole(_) => false + }, + args, + ) => + errs := [PartialNoHoles(loc), ...errs^] + | _ => () + }; + super.enter_expression(e); + }; + + { + errs, + iter_hooks: { + ...super, + enter_expression, + }, + }; +}; + let compose_well_formedness = ({errs, iter_hooks}, cur) => cur(errs, iter_hooks); @@ -893,6 +927,7 @@ let well_formedness_checks = [ provided_multiple_times, mutual_rec_type_improper_rec_keyword, array_index_non_integer, + improper_partial, ]; let well_formedness_checker = () => diff --git a/compiler/src/typed/typecore.re b/compiler/src/typed/typecore.re index 0b8bc43d3..fd11dcf83 100644 --- a/compiler/src/typed/typecore.re +++ b/compiler/src/typed/typecore.re @@ -762,10 +762,24 @@ let rec type_exp = (~in_function=?, ~recarg=?, env, sexp) => */ and type_expect = - (~in_function=?, ~recarg=?, env, sexp, ty_expected_explained) => { + ( + ~in_function=?, + ~in_partial_app=?, + ~recarg=?, + env, + sexp, + ty_expected_explained, + ) => { /*let previous_saved_types = Cmt_format.get_saved_types () in*/ let exp = - type_expect_(~in_function?, ~recarg?, env, sexp, ty_expected_explained); + type_expect_( + ~in_function?, + ~in_partial_app?, + ~recarg?, + env, + sexp, + ty_expected_explained, + ); /*Cmt_format.set_saved_types (Cmt_format.Partial_expression exp :: previous_saved_types);*/ @@ -784,7 +798,14 @@ and with_explanation = (explanation, f) => } and type_expect_ = - (~in_function=?, ~recarg=Rejected, env, sexp, ty_expected_explained) => { + ( + ~in_function=?, + ~in_partial_app=?, + ~recarg=Rejected, + env, + sexp, + ty_expected_explained, + ) => { let {ty: ty_expected, explanation} = ty_expected_explained; let loc = sexp.pexp_loc; let core_loc = sexp.pexp_core_loc; @@ -1394,7 +1415,14 @@ and type_expect_ = /*lower_args [] ty;*/ begin_def(); let (label_order, args, ty_res) = - type_application(~in_function?, ~loc, env, funct, args); + type_application( + ~in_function?, + ~in_partial_app?, + ~loc, + env, + funct, + args, + ); end_def(); unify_var(env, newvar(), funct.exp_type); rue({ @@ -1405,6 +1433,95 @@ and type_expect_ = exp_type: ty_res, exp_env: env, }); + | PExpPartial(func, part_args) => + begin_def(); /* one more level for non-returning functions */ + let funct = type_exp(env, func); + end_def(); + + let (_, _, labeled_args) = + process_application( + ~loc, + (part_sarg, label, _) => (label, part_sarg), + ~get_arg_loc=sarg => sarg.ppaa_loc, + ~get_arg_label=sarg => sarg.ppaa_label, + env, + funct, + part_args, + ); + open Ast_helper; + + let (app_args, new_func_params) = + List.split( + List.mapi( + (i, (label, arg)) => { + let (expr, param_pat) = + switch (arg.ppaa_expr) { + | ArgumentGiven(expr) => (expr, None) + | ArgumentHole(_) => + let name = + switch (label) { + | Labeled(name) + | Default(name) => name + | Unlabeled => mknoloc("$arg" ++ string_of_int(i)) + }; + + ( + Expression.ident( + ~loc=Location.dummy_loc, + ~core_loc=Location.dummy_loc, + mknoloc(Identifier.IdentName(name)), + ), + Some(Pattern.var(~loc=Location.dummy_loc, name)), + ); + }; + + ( + { + paa_label: arg.ppaa_label, + paa_expr: expr, + paa_loc: arg.ppaa_loc, + }, + param_pat, + ); + }, + labeled_args, + ), + ); + + let body = + Expression.apply( + ~loc=Location.dummy_loc, + ~core_loc=Location.dummy_loc, + func, + app_args, + ); + + let new_func_labels = + List.filter_map( + ((label, arg)) => + switch (arg.ppaa_expr) { + | ArgumentHole(_) => Some(label) + | ArgumentGiven(_) => None + }, + labeled_args, + ); + + let new_func_params_pat = + Pattern.tuple( + ~loc=Location.dummy_loc, + List.filter_map(Fun.id, new_func_params), + ); + + type_function( + ~in_function?, + ~in_partial_app=true, + loc, + attributes, + env, + ty_expected_explained, + new_func_labels, + [MatchBranch.mk(~loc, new_func_params_pat, body, None)], + ); | PExpConstruct(cstr, arg) => type_construct( env, @@ -1785,7 +1902,16 @@ and type_expect_ = } and type_function = - (~in_function=?, loc, attrs, env, ty_expected_explained, l, caselist) => { + ( + ~in_function=?, + ~in_partial_app=?, + loc, + attrs, + env, + ty_expected_explained, + l, + caselist, + ) => { let {ty: ty_expected, explanation} = ty_expected_explained; let (loc_fun, ty_fun) = (loc, instance(env, ty_expected)); @@ -1820,6 +1946,7 @@ and type_function = let (cases, partial) = type_cases( ~in_function=(loc_fun, ty_args, ty_res), + ~in_partial_app?, env, normalized_arg_type, ty_res, @@ -1856,13 +1983,12 @@ and type_argument = texp; } -and type_application = (~in_function=?, ~loc, env, funct, sargs) => { - /* funct.exp_type may be generic */ - let ty_fun = expand_head(env, funct.exp_type); - let (ty_args, ty_ret) = +and function_type_info: 'a. ('a => argument_label, _, _, list('a)) => _ = + (get_arg_label, env, funct, sargs) => { + let ty_fun = expand_head(env, funct.exp_type); switch (ty_fun.desc) { | TTyVar(_) => - let t_args = List.map(arg => (arg.paa_label, newvar()), sargs) + let t_args = List.map(arg => (get_arg_label(arg), newvar()), sargs) and t_ret = newvar(); unify( env, @@ -1880,184 +2006,222 @@ and type_application = (~in_function=?, ~loc, env, funct, sargs) => { ), ) }; + } - let ordered_labels = List.map(fst, ty_args); +and process_application: + 'a 'b. + ( + ~loc: _, + ('a, argument_label, type_expr) => 'b, + ~get_arg_loc: 'a => Ast_helper.loc, + ~get_arg_label: 'a => argument_label, + _, + _, + list('a) + ) => + (_, _, list('b)) + = + (~loc, fn, ~get_arg_loc, ~get_arg_label, env, funct, sargs) => { + let (ty_args, ty_ret) = + function_type_info(get_arg_label, env, funct, sargs); - let (labeled_sargs, unlabeled_sargs) = - List.partition( - sarg => { - switch (sarg.paa_label) { - | Labeled(_) => true - | _ => false - } - }, - sargs, - ); + let ordered_labels = List.map(fst, ty_args); - let (used_labeled_tyargs, unused_tyargs) = - List.partition( - ((l, _)) => { - List.exists( - sarg => same_label_name(l, sarg.paa_label), - labeled_sargs, - ) - }, - ty_args, - ); + let (labeled_sargs, unlabeled_sargs) = + List.partition( + sarg => { + switch (get_arg_label(sarg)) { + | Labeled(_) => true + | _ => false + } + }, + sargs, + ); - let rec type_args = - ( - args, - remaining_sargs, - remaining_used_labeled_tyargs, - remaining_unused_tyargs, - ) => { - let rec extract_label = (l, tyargs) => { - switch (tyargs) { - | [] => (None, []) - | [(tyl, _) as tyarg, ...rest_tyargs] when same_label_name(tyl, l) => ( - Some(tyarg), - rest_tyargs, - ) - | [tyarg, ...rest_tyargs] => - let (res, rest_tyargs) = extract_label(l, rest_tyargs); - (res, [tyarg, ...rest_tyargs]); - }; - }; - let rec next_tyarg = tyargs => { - switch (tyargs) { - | [] => (None, []) - | [(tyl, _) as tyarg, ...rest_tyargs] when !is_optional(tyl) => ( - Some(tyarg), - rest_tyargs, - ) - | [tyarg, ...rest_tyargs] => - let (res, rest_tyargs) = next_tyarg(rest_tyargs); - (res, [tyarg, ...rest_tyargs]); + let (used_labeled_tyargs, unused_tyargs) = + List.partition( + ((l, _)) => { + List.exists( + sarg => same_label_name(l, get_arg_label(sarg)), + labeled_sargs, + ) + }, + ty_args, + ); + + let rec type_args = + ( + result, + remaining_sargs, + remaining_used_labeled_tyargs, + remaining_unused_tyargs, + ) => { + let rec extract_label = (l, tyargs) => { + switch (tyargs) { + | [] => (None, []) + | [(tyl, _) as tyarg, ...rest_tyargs] when same_label_name(tyl, l) => ( + Some(tyarg), + rest_tyargs, + ) + | [tyarg, ...rest_tyargs] => + let (res, rest_tyargs) = extract_label(l, rest_tyargs); + (res, [tyarg, ...rest_tyargs]); + }; }; - }; - switch (remaining_sargs) { - | [] => (args, remaining_unused_tyargs) - | [sarg, ...remaining_sargs] => - let ( - corresponding_tyarg, - remaining_used_labeled_tyargs, - remaining_unused_tyargs, - ) = - switch (sarg.paa_label) { - | Default(_) => - failwith("Impossible: optional argument in application") - | Labeled(_) => - let (corresponding_tyarg, remaining_used_labeled_tyargs) = - extract_label(sarg.paa_label, remaining_used_labeled_tyargs); - ( - corresponding_tyarg, - remaining_used_labeled_tyargs, - remaining_unused_tyargs, - ); - | Unlabeled => - let (corresponding_tyarg, remaining_unused_tyargs) = - next_tyarg(remaining_unused_tyargs); - ( - corresponding_tyarg, - remaining_used_labeled_tyargs, - remaining_unused_tyargs, - ); + let rec next_tyarg = tyargs => { + switch (tyargs) { + | [] => (None, []) + | [(tyl, _) as tyarg, ...rest_tyargs] when !is_optional(tyl) => ( + Some(tyarg), + rest_tyargs, + ) + | [tyarg, ...rest_tyargs] => + let (res, rest_tyargs) = next_tyarg(rest_tyargs); + (res, [tyarg, ...rest_tyargs]); }; - switch (corresponding_tyarg) { - | Some((l, ty)) => - let arg = - if (!is_optional(l)) { + }; + switch (remaining_sargs) { + | [] => (result, remaining_unused_tyargs) + | [sarg, ...remaining_sargs] => + let ( + corresponding_tyarg, + remaining_used_labeled_tyargs, + remaining_unused_tyargs, + ) = + switch (get_arg_label(sarg)) { + | Default(_) => + failwith("Impossible: optional argument in application") + | Labeled(_) => + let (corresponding_tyarg, remaining_used_labeled_tyargs) = + extract_label( + get_arg_label(sarg), + remaining_used_labeled_tyargs, + ); ( - () => - type_argument( - ~in_function?, - env, - sarg.paa_expr, - ty, - instance(env, ty), - ) + corresponding_tyarg, + remaining_used_labeled_tyargs, + remaining_unused_tyargs, ); - } else { + | Unlabeled => + let (corresponding_tyarg, remaining_unused_tyargs) = + next_tyarg(remaining_unused_tyargs); ( - () => - option_some( - env, - type_argument( - ~in_function?, - env, - sarg.paa_expr, - extract_option_type(env, ty), - extract_option_type(env, instance(env, ty)), - ), - ) + corresponding_tyarg, + remaining_used_labeled_tyargs, + remaining_unused_tyargs, ); }; - type_args( - [(l, arg), ...args], - remaining_sargs, - remaining_used_labeled_tyargs, - remaining_unused_tyargs, - ); - | None => - switch (sarg.paa_label) { - | Unlabeled => - raise( - Error( - loc, - env, - Apply_too_many_arguments( - expand_head(env, funct.exp_type), - unused_tyargs, + switch (corresponding_tyarg) { + | Some((l, ty)) => + let res = fn(sarg, l, ty); + type_args( + [res, ...result], + remaining_sargs, + remaining_used_labeled_tyargs, + remaining_unused_tyargs, + ); + | None => + switch (get_arg_label(sarg)) { + | Unlabeled => + raise( + Error( + loc, + env, + Apply_too_many_arguments( + expand_head(env, funct.exp_type), + unused_tyargs, + ), ), - ), - ) - | _ => - raise( - Error( - sarg.paa_loc, - env, - Apply_unknown_label( - label_name(sarg.paa_label), - List.filter_map( - l => { - switch (l) { - | Unlabeled => None - | _ => Some(label_name(l)) - } - }, - ordered_labels, + ) + | _ => + raise( + Error( + get_arg_loc(sarg), + env, + Apply_unknown_label( + label_name(get_arg_label(sarg)), + List.filter_map( + l => { + switch (l) { + | Unlabeled => None + | _ => Some(label_name(l)) + } + }, + ordered_labels, + ), ), ), - ), - ) - } + ) + } + }; }; }; - }; - let (args, remaining_tyargs) = - type_args([], sargs, used_labeled_tyargs, unused_tyargs); + let (args, remaining_tyargs) = + type_args([], sargs, used_labeled_tyargs, unused_tyargs); - let omitted_args = - List.map( - ((l, ty)) => { - switch (l) { - | Default(_) => - // omitted optional argument - (l, option_none(env, instance(env, ty), Location.dummy_loc)) - | _ => - let missing_args = - List.filter(((l, _)) => !is_optional(l), remaining_tyargs); - raise(Error(loc, env, Apply_too_few_arguments(missing_args))); - } + let omitted_args = + List.map( + ((l, ty)) => { + switch (l) { + | Default(_) => + // omitted optional argument + (l, option_none(env, instance(env, ty), Location.dummy_loc)) + | _ => + let missing_args = + List.filter(((l, _)) => !is_optional(l), remaining_tyargs); + raise(Error(loc, env, Apply_too_few_arguments(missing_args))); + } + }, + remaining_tyargs, + ); + + (ordered_labels, omitted_args, List.rev(args)); + } + +and type_application = + (~in_function=?, ~in_partial_app=false, ~loc, env, funct, sargs) => { + let (_, ty_ret) = + function_type_info(sarg => sarg.paa_label, env, funct, sargs); + + let (ordered_labels, omitted_args, make_typed_args) = + process_application( + ~loc, + (sarg, l, ty) => { + let make_arg = + if (!is_optional(l) || in_partial_app) { + () => + type_argument( + ~in_function?, + env, + sarg.paa_expr, + ty, + instance(env, ty), + ); + } else { + () => + option_some( + env, + type_argument( + ~in_function?, + env, + sarg.paa_expr, + extract_option_type(env, ty), + extract_option_type(env, instance(env, ty)), + ), + ); + }; + (l, make_arg); }, - remaining_tyargs, + ~get_arg_loc=sarg => sarg.paa_loc, + ~get_arg_label=sarg => sarg.paa_label, + env, + funct, + sargs, ); // Typecheck all arguments. - // Order here is important; rev_map would be incorrect. - let typed_args = List.map(((l, argf)) => (l, argf()), List.rev(args)); + let typed_args = List.map(((l, argf)) => (l, argf()), make_typed_args); (ordered_labels, omitted_args @ typed_args, instance(env, ty_ret)); } @@ -2234,6 +2398,7 @@ and type_statement_expr = (~explanation=?, ~in_function=?, env, sexp) => { and type_cases = ( ~in_function=?, + ~in_partial_app=?, env, ty_arg: type_expr, ty_res, @@ -2357,7 +2522,13 @@ and type_cases = ) }; let exp = - type_expect(~in_function?, ext_env, sexp, mk_expected(ty_res)); + type_expect( + ~in_function?, + ~in_partial_app?, + ext_env, + sexp, + mk_expected(ty_res), + ); { mb_pat: pat, mb_body: { diff --git a/compiler/test/grainfmt/comments.expected.gr b/compiler/test/grainfmt/comments.expected.gr index 65c4e66c2..ff7581a04 100644 --- a/compiler/test/grainfmt/comments.expected.gr +++ b/compiler/test/grainfmt/comments.expected.gr @@ -660,3 +660,10 @@ let [/*foo */] = 5 2 1 /* abc */ /2 1 /* abc */ / /* xyz */ 2 + +partial /* a */ f(/* b */ + /* c */ + _, /* d */ + 1, /* e */ + a=/* f */ /* g */_ /* h */ +) // i diff --git a/compiler/test/grainfmt/comments.input.gr b/compiler/test/grainfmt/comments.input.gr index ea34a52cc..9fb6e7891 100644 --- a/compiler/test/grainfmt/comments.input.gr +++ b/compiler/test/grainfmt/comments.input.gr @@ -508,3 +508,5 @@ let [ /*foo */] = 5 2 1/* abc *//2 1/* abc */ / /* xyz */2 + +partial /* a */ f /* b */(/* c */_, /* d */1, /* e */a /* f */ = /* g */ _ /* h */) // i diff --git a/compiler/test/suites/functions.re b/compiler/test/suites/functions.re index 0d9f0136e..d3e3efad1 100644 --- a/compiler/test/suites/functions.re +++ b/compiler/test/suites/functions.re @@ -385,4 +385,164 @@ truc()|}, |}, "which has a default value, but the matching argument does not.", ); + + assertRun( + "partial1", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = partial f(1, _, _) + pf(2, 3) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial2", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = partial f(_, 2, _) + pf(1, 3) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial3", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = partial f(_, x=1, _) + pf(2, 3) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial4", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = partial f(_, x=1, _) + pf(2, 3) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial5", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = partial f(_, x=1, _) + pf(z=3, y=2) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial6", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = partial f(1, _, y=_) + pf(3, 2) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial6", + {| + let f = (x, y=2, z) => { print(x); print(y); print(z) } + let pf = partial f(1, _) + pf(3) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial7", + {| + let f = (x, y=2, z) => { print(x); print(y); print(z) } + let pf = partial f(1, y=_, _) + pf(3) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial8", + {| + let f = (x, y=0, z) => { print(x); print(y); print(z) } + let pf = partial f(1, y=_, _) + pf(y=2, 3) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial9", + {| + let f = (x, y, _) => { print(x); print(y); print(3) } + let pf = partial f(1, y=_, _) + pf(y=2, 10) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial10", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = (g, x) => partial g(x, _, _) + pf(f, 1)(2, 3) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial11", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = (g, x) => partial g(1, b=x, _) + pf(f, 2)(3) + |}, + "1\n2\n3\n", + ); + assertRun( + "partial12", + {| + let f = (x, y=2, z) => { print(x); print(y); print(z) } + let makeFn = (x=0) => { print(x); f } + let pf = partial makeFn()(1, y=_, _) + pf(3) + |}, + "0\n1\n2\n3\n", + ); + + assertCompileError( + "partial_err1", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = partial f(1, 2, 3) + |}, + "A partial application must have at least one argument hole.", + ); + assertCompileError( + "partial_err2", + {| + let f = () => print(1) + let pf = partial f() + |}, + "A partial application must have at least one argument hole.", + ); + assertCompileError( + "partial_err3", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = partial f(_, 2) + |}, + "This function call is missing an argument of type z: a", + ); + assertCompileError( + "partial_err4", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = partial f(_, 2, 3, 4) + |}, + "It is called with too many arguments.", + ); + assertCompileError( + "partial_err5", + {| + let f = (x, y, z) => { print(x); print(y); print(z) } + let pf = partial f(_, a=2) + |}, + "This argument cannot be supplied with label a.", + ); });