From 8baca4ba2eac3672df2afbbc71d52559ee95224f Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 14 Mar 2023 09:24:43 +0100 Subject: [PATCH] Proof of Concept: explore per-file custom infix operators. Remove infix.add and infix.remove infix.add should not affect the parser (only the printer) Implement per-module scoping mechanism The annotations only apply to the module they appear in. --- res_syntax/src/res_core.ml | 37 +++++- res_syntax/src/res_custom_infix.ml | 20 ++++ res_syntax/src/res_parens.ml | 32 ++--- res_syntax/src/res_parens.mli | 20 ++-- res_syntax/src/res_parser.ml | 2 + res_syntax/src/res_parsetree_viewer.ml | 16 +-- res_syntax/src/res_parsetree_viewer.mli | 8 +- res_syntax/src/res_printer.ml | 111 +++++++++++------- res_syntax/src/res_printer_state.ml | 21 ++++ res_syntax/src/res_scanner.ml | 34 +++++- res_syntax/src/res_scanner.mli | 2 + res_syntax/src/res_token.ml | 4 +- .../tests/printer/expr/expected/infix.res.txt | 7 ++ res_syntax/tests/printer/expr/infix.res | 7 ++ 14 files changed, 236 insertions(+), 85 deletions(-) create mode 100644 res_syntax/src/res_custom_infix.ml create mode 100644 res_syntax/src/res_printer_state.ml create mode 100644 res_syntax/tests/printer/expr/expected/infix.res.txt create mode 100644 res_syntax/tests/printer/expr/infix.res diff --git a/res_syntax/src/res_core.ml b/res_syntax/src/res_core.ml index 1e728ccaab..1ec8050ab7 100644 --- a/res_syntax/src/res_core.ml +++ b/res_syntax/src/res_core.ml @@ -2473,6 +2473,7 @@ and parseAttributesAndBinding (p : Parser.t) = let lineOffset = p.scanner.lineOffset in let lnum = p.scanner.lnum in let mode = p.scanner.mode in + let customInfix = p.scanner.customInfix in let token = p.token in let startPos = p.startPos in let endPos = p.endPos in @@ -2495,6 +2496,7 @@ and parseAttributesAndBinding (p : Parser.t) = p.scanner.lineOffset <- lineOffset; p.scanner.lnum <- lnum; p.scanner.mode <- mode; + p.scanner.customInfix <- customInfix; p.token <- token; p.startPos <- startPos; p.endPos <- endPos; @@ -5591,11 +5593,13 @@ and parseAtomicModuleExpr p = Ast_helper.Mod.ident ~loc:longident.loc longident | Lbrace -> Parser.next p; + let customInfix = p.scanner.customInfix in let structure = Ast_helper.Mod.structure (parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rbrace ~f:parseStructureItemRegion p) in + p.scanner.customInfix <- customInfix; Parser.expect Rbrace p; let endPos = p.prevEndPos in {structure with pmod_loc = mkLoc startPos endPos} @@ -6366,10 +6370,12 @@ and parsePayload p = Parser.eatBreadcrumb p; Parsetree.PPat (pattern, expr) | _ -> + let customInfix = p.scanner.customInfix in let items = parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rparen ~f:parseStructureItemRegion p in + p.scanner.customInfix <- customInfix; Parser.expect Rparen p; Parser.eatBreadcrumb p; Parsetree.PStr items) @@ -6407,15 +6413,44 @@ and parseStandaloneAttribute p = let startPos = p.startPos in Parser.expect AtAt p; let attrId = parseAttributeId ~startPos p in + let payload = parsePayload p in let attrId = match attrId.txt with | "uncurried" -> p.uncurried_config <- Res_uncurried.Default; attrId | "toUncurried" -> {attrId with txt = "uncurried"} + | "infix" -> ( + match payload with + | PStr + [ + { + pstr_desc = + Pstr_eval + ( { + pexp_desc = + Pexp_tuple + [ + {pexp_desc = Pexp_constant (Pconst_string (name, _))}; + { + pexp_desc = + Pexp_constant (Pconst_string (alias, _)); + }; + ]; + }, + _ ); + }; + ] -> + p.scanner.customInfix <- + p.scanner.customInfix |> Res_custom_infix.addSymbol ~name ~alias; + attrId + | _ -> + Parser.err ~startPos ~endPos:p.startPos p + (Diagnostics.message + ("Use the form @@" ^ attrId.txt ^ "((\"operator\", \"alias\"))")); + attrId) | _ -> attrId in - let payload = parsePayload p in (attrId, payload) (* extension ::= % attr-id attr-payload diff --git a/res_syntax/src/res_custom_infix.ml b/res_syntax/src/res_custom_infix.ml new file mode 100644 index 0000000000..e6cf346324 --- /dev/null +++ b/res_syntax/src/res_custom_infix.ml @@ -0,0 +1,20 @@ +type t = (string * string) list + +let addSymbol ~name ~alias x = + (* Put "++" before "+" *) + let cmp (n1, _) (n2, _) = String.length n2 - String.length n1 in + List.stable_sort cmp ((name, alias) :: x) + +let findAlias ~alias x = x |> List.find_opt (fun (_, a) -> alias = a) + +let lookupName ~name ~src ~srcLen ~offset = + let nameLen = String.length name in + let restLen = srcLen - offset in + if nameLen <= restLen then ( + let found = ref true in + for i = 0 to nameLen - 1 do + if (name.[i] [@doesNotRaise]) <> (src.[offset + i] [@doesNotRaise]) then + found := false + done; + !found) + else false diff --git a/res_syntax/src/res_parens.ml b/res_syntax/src/res_parens.ml index d6628c8728..af80a017f6 100644 --- a/res_syntax/src/res_parens.ml +++ b/res_syntax/src/res_parens.ml @@ -25,7 +25,7 @@ let exprRecordRowRhs e = | _ -> kind) | _ -> kind -let callExpr expr = +let callExpr ~state expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc @@ -38,7 +38,7 @@ let callExpr expr = Parenthesized | _ when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> + || ParsetreeViewer.isBinaryExpression ~state expr -> Parenthesized | { Parsetree.pexp_desc = @@ -77,7 +77,7 @@ let structureExpr expr = | {pexp_desc = Pexp_constraint _} -> Parenthesized | _ -> Nothing) -let unaryExprOperand expr = +let unaryExprOperand ~state expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc @@ -90,7 +90,7 @@ let unaryExprOperand expr = Parenthesized | expr when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> + || ParsetreeViewer.isBinaryExpression ~state expr -> Parenthesized | { pexp_desc = @@ -112,7 +112,7 @@ let unaryExprOperand expr = Parenthesized | _ -> Nothing) -let binaryExprOperand ~isLhs expr = +let binaryExprOperand ~isLhs ~state expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc @@ -131,7 +131,7 @@ let binaryExprOperand ~isLhs expr = Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _; } -> Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | expr when ParsetreeViewer.isBinaryExpression ~state expr -> Parenthesized | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized | {pexp_desc = Pexp_lazy _ | Pexp_assert _} when isLhs -> Parenthesized | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> @@ -149,7 +149,7 @@ let subBinaryExprOperand parentOperator childOperator = || (* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… *) (parentOperator = "||" && childOperator = "&&") -let rhsBinaryExprOperand parentOperator rhs = +let rhsBinaryExprOperand ~state parentOperator rhs = match rhs.Parsetree.pexp_desc with | Parsetree.Pexp_apply ( { @@ -158,14 +158,14 @@ let rhsBinaryExprOperand parentOperator rhs = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; }, [(_, _left); (_, _right)] ) - when ParsetreeViewer.isBinaryOperator operator + when ParsetreeViewer.isBinaryOperator ~state operator && not (operatorLoc.loc_ghost && operator = "^") -> let precParent = ParsetreeViewer.operatorPrecedence parentOperator in let precChild = ParsetreeViewer.operatorPrecedence operator in precParent == precChild | _ -> false -let flattenOperandRhs parentOperator rhs = +let flattenOperandRhs ~state parentOperator rhs = match rhs.Parsetree.pexp_desc with | Parsetree.Pexp_apply ( { @@ -173,7 +173,7 @@ let flattenOperandRhs parentOperator rhs = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; }, [(_, _left); (_, _right)] ) - when ParsetreeViewer.isBinaryOperator operator + when ParsetreeViewer.isBinaryOperator ~state operator && not (operatorLoc.loc_ghost && operator = "^") -> let precParent = ParsetreeViewer.operatorPrecedence parentOperator in let precChild = ParsetreeViewer.operatorPrecedence operator in @@ -189,7 +189,7 @@ let binaryOperatorInsideAwaitNeedsParens operator = ParsetreeViewer.operatorPrecedence operator < ParsetreeViewer.operatorPrecedence "|." -let lazyOrAssertOrAwaitExprRhs ?(inAwait = false) expr = +let lazyOrAssertOrAwaitExprRhs ?(inAwait = false) ~state expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc @@ -204,7 +204,7 @@ let lazyOrAssertOrAwaitExprRhs ?(inAwait = false) expr = pexp_desc = Pexp_apply ({pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, _); } - when ParsetreeViewer.isBinaryExpression expr -> + when ParsetreeViewer.isBinaryExpression ~state expr -> if inAwait && not (binaryOperatorInsideAwaitNeedsParens operator) then Nothing else Parenthesized @@ -238,7 +238,7 @@ let isNegativeConstant constant = | (Parsetree.Pconst_integer (i, _) | Pconst_float (i, _)) when isNeg i -> true | _ -> false -let fieldExpr expr = +let fieldExpr ~state expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc @@ -250,7 +250,7 @@ let fieldExpr expr = | [] -> false -> Parenthesized | expr - when ParsetreeViewer.isBinaryExpression expr + when ParsetreeViewer.isBinaryExpression ~state expr || ParsetreeViewer.isUnaryExpression expr -> Parenthesized | { @@ -394,14 +394,14 @@ let jsxChildExpr expr = | expr when ParsetreeViewer.isJsxExpression expr -> Nothing | _ -> Parenthesized)) -let binaryExpr expr = +let binaryExpr ~state expr = let optBraces, _ = ParsetreeViewer.processBracesAttr expr in match optBraces with | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc | None -> ( match expr with | {Parsetree.pexp_attributes = _ :: _} as expr - when ParsetreeViewer.isBinaryExpression expr -> + when ParsetreeViewer.isBinaryExpression ~state expr -> Parenthesized | _ -> Nothing) diff --git a/res_syntax/src/res_parens.mli b/res_syntax/src/res_parens.mli index 9b60b815f1..23070aa04d 100644 --- a/res_syntax/src/res_parens.mli +++ b/res_syntax/src/res_parens.mli @@ -3,17 +3,21 @@ type kind = Parenthesized | Braced of Location.t | Nothing val expr : Parsetree.expression -> kind val structureExpr : Parsetree.expression -> kind -val unaryExprOperand : Parsetree.expression -> kind +val unaryExprOperand : state:Res_printer_state.t -> Parsetree.expression -> kind -val binaryExprOperand : isLhs:bool -> Parsetree.expression -> kind +val binaryExprOperand : + isLhs:bool -> state:Res_printer_state.t -> Parsetree.expression -> kind val subBinaryExprOperand : string -> string -> bool -val rhsBinaryExprOperand : string -> Parsetree.expression -> bool -val flattenOperandRhs : string -> Parsetree.expression -> bool +val rhsBinaryExprOperand : + state:Res_printer_state.t -> string -> Parsetree.expression -> bool +val flattenOperandRhs : + state:Res_printer_state.t -> string -> Parsetree.expression -> bool val binaryOperatorInsideAwaitNeedsParens : string -> bool -val lazyOrAssertOrAwaitExprRhs : ?inAwait:bool -> Parsetree.expression -> kind +val lazyOrAssertOrAwaitExprRhs : + ?inAwait:bool -> state:Res_printer_state.t -> Parsetree.expression -> kind -val fieldExpr : Parsetree.expression -> kind +val fieldExpr : state:Res_printer_state.t -> Parsetree.expression -> kind val setFieldExprRhs : Parsetree.expression -> kind @@ -22,13 +26,13 @@ val ternaryOperand : Parsetree.expression -> kind val jsxPropExpr : Parsetree.expression -> kind val jsxChildExpr : Parsetree.expression -> kind -val binaryExpr : Parsetree.expression -> kind +val binaryExpr : state:Res_printer_state.t -> Parsetree.expression -> kind val modTypeFunctorReturn : Parsetree.module_type -> bool val modTypeWithOperand : Parsetree.module_type -> bool val modExprFunctorConstraint : Parsetree.module_type -> bool val bracedExpr : Parsetree.expression -> bool -val callExpr : Parsetree.expression -> kind +val callExpr : state:Res_printer_state.t -> Parsetree.expression -> kind val includeModExpr : Parsetree.module_expr -> bool diff --git a/res_syntax/src/res_parser.ml b/res_syntax/src/res_parser.ml index 387172a36e..2c1d282faf 100644 --- a/res_syntax/src/res_parser.ml +++ b/res_syntax/src/res_parser.ml @@ -161,6 +161,7 @@ let lookahead p callback = let offset = p.scanner.offset in let offset16 = p.scanner.offset16 in let lineOffset = p.scanner.lineOffset in + let customInfix = p.scanner.customInfix in let lnum = p.scanner.lnum in let mode = p.scanner.mode in let token = p.token in @@ -182,6 +183,7 @@ let lookahead p callback = p.scanner.lineOffset <- lineOffset; p.scanner.lnum <- lnum; p.scanner.mode <- mode; + p.scanner.customInfix <- customInfix; p.token <- token; p.startPos <- startPos; p.endPos <- endPos; diff --git a/res_syntax/src/res_parsetree_viewer.ml b/res_syntax/src/res_parsetree_viewer.ml index 1d2b438041..5796c7c485 100644 --- a/res_syntax/src/res_parsetree_viewer.ml +++ b/res_syntax/src/res_parsetree_viewer.ml @@ -293,15 +293,17 @@ let isUnaryExpression expr = | _ -> false (* TODO: tweak this to check for ghost ^ as template literal *) -let isBinaryOperator operator = +let isBinaryOperator ~(state : Res_printer_state.t) operator = match operator with | ":=" | "||" | "&&" | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>" | "+" | "+." | "-" | "-." | "^" | "*" | "*." | "/" | "/." | "**" | "|." | "|.u" | "<>" -> true - | _ -> false + | _ -> + state.customInfix <> [] + && state.customInfix |> Res_custom_infix.findAlias ~alias:operator <> None -let isBinaryExpression expr = +let isBinaryExpression ~state expr = match expr.pexp_desc with | Pexp_apply ( { @@ -309,7 +311,7 @@ let isBinaryExpression expr = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; }, [(Nolabel, _operand1); (Nolabel, _operand2)] ) - when isBinaryOperator operator + when isBinaryOperator ~state operator && not (operatorLoc.loc_ghost && operator = "^") (* template literal *) -> true @@ -502,7 +504,7 @@ let hasJsxAttribute attributes = in loop attributes -let shouldIndentBinaryExpr expr = +let shouldIndentBinaryExpr ~state expr = let samePrecedenceSubExpression operator subExpression = match subExpression with | { @@ -511,7 +513,7 @@ let shouldIndentBinaryExpr expr = ( {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}}, [(Nolabel, _lhs); (Nolabel, _rhs)] ); } - when isBinaryOperator subOperator -> + when isBinaryOperator ~state subOperator -> flattenableOperators operator subOperator | _ -> true in @@ -522,7 +524,7 @@ let shouldIndentBinaryExpr expr = ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, [(Nolabel, lhs); (Nolabel, _rhs)] ); } - when isBinaryOperator operator -> + when isBinaryOperator ~state operator -> isEqualityOperator operator || (not (samePrecedenceSubExpression operator lhs)) || operator = ":=" diff --git a/res_syntax/src/res_parsetree_viewer.mli b/res_syntax/src/res_parsetree_viewer.mli index 1cc0f5995d..eec381c308 100644 --- a/res_syntax/src/res_parsetree_viewer.mli +++ b/res_syntax/src/res_parsetree_viewer.mli @@ -75,8 +75,9 @@ val isHuggableRhs : Parsetree.expression -> bool val operatorPrecedence : string -> int val isUnaryExpression : Parsetree.expression -> bool -val isBinaryOperator : string -> bool -val isBinaryExpression : Parsetree.expression -> bool +val isBinaryOperator : state:Res_printer_state.t -> string -> bool +val isBinaryExpression : + state:Res_printer_state.t -> Parsetree.expression -> bool val isRhsBinaryOperator : string -> bool val flattenableOperators : string -> string -> bool @@ -100,7 +101,8 @@ val isJsxExpression : Parsetree.expression -> bool val hasJsxAttribute : Parsetree.attributes -> bool val hasOptionalAttribute : Parsetree.attributes -> bool -val shouldIndentBinaryExpr : Parsetree.expression -> bool +val shouldIndentBinaryExpr : + state:Res_printer_state.t -> Parsetree.expression -> bool val shouldInlineRhsBinaryExpr : Parsetree.expression -> bool val hasPrintableAttributes : Parsetree.attributes -> bool val filterPrintableAttributes : Parsetree.attributes -> Parsetree.attributes diff --git a/res_syntax/src/res_printer.ml b/res_syntax/src/res_printer.ml index 995d12c727..9c8fb7367a 100644 --- a/res_syntax/src/res_printer.ml +++ b/res_syntax/src/res_printer.ml @@ -4,6 +4,7 @@ module Comment = Res_comment module Token = Res_token module Parens = Res_parens module ParsetreeViewer = Res_parsetree_viewer +module State = Res_printer_state type callbackStyle = (* regular arrow function, example: `let f = x => x + 1` *) @@ -572,22 +573,11 @@ let printOptionalLabel attrs = if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" else Doc.nil -module State = struct - let customLayoutThreshold = 2 - - type t = {customLayout: int; mutable uncurried_config: Res_uncurried.config} - - let init = {customLayout = 0; uncurried_config = Res_uncurried.init} - - let nextCustomLayout t = {t with customLayout = t.customLayout + 1} - - let shouldBreakCallback t = t.customLayout > customLayoutThreshold -end - let rec printStructure ~state (s : Parsetree.structure) t = match s with | [] -> printCommentsInsideFile t | structure -> + let state = State.copy state in printList ~getLoc:(fun s -> s.Parsetree.pstr_loc) ~nodes:structure @@ -946,6 +936,7 @@ and printSignature ~state signature cmtTbl = match signature with | [] -> printCommentsInsideFile cmtTbl | signature -> + let state = State.copy state in printList ~getLoc:(fun s -> s.Parsetree.psig_loc) ~nodes:signature @@ -2057,14 +2048,14 @@ and printValueBinding ~state ~recFlag (vb : Parsetree.value_binding) cmtTbl i = match optBraces with | Some _ -> false | _ -> ( - ParsetreeViewer.isBinaryExpression expr + ParsetreeViewer.isBinaryExpression ~state expr || match vb.pvb_expr with | { pexp_attributes = [({Location.txt = "res.ternary"}, _)]; pexp_desc = Pexp_ifthenelse (ifExpr, _, _); } -> - ParsetreeViewer.isBinaryExpression ifExpr + ParsetreeViewer.isBinaryExpression ~state ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes | {pexp_desc = Pexp_newtype _} -> false | e -> @@ -3026,14 +3017,14 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = printUnaryExpression ~state e cmtTbl else if ParsetreeViewer.isTemplateLiteral e then printTemplateLiteral ~state e cmtTbl - else if ParsetreeViewer.isBinaryExpression e then + else if ParsetreeViewer.isBinaryExpression ~state e then printBinaryExpression ~state e cmtTbl else printPexpApply ~state e cmtTbl | Pexp_unreachable -> Doc.dot | Pexp_field (expr, longidentLoc) -> let lhs = let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.fieldExpr expr with + match Parens.fieldExpr ~state expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc @@ -3171,7 +3162,7 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = | Pexp_assert expr -> let rhs = let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with + match Parens.lazyOrAssertOrAwaitExprRhs ~state expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc @@ -3180,7 +3171,7 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = | Pexp_lazy expr -> let rhs = let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with + match Parens.lazyOrAssertOrAwaitExprRhs ~state expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc @@ -3244,7 +3235,7 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = | Pexp_send (parentExpr, label) -> let parentDoc = let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with + match Parens.unaryExprOperand ~state parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces | Nothing -> doc @@ -3264,7 +3255,7 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = if ParsetreeViewer.hasAwaitAttribute e.pexp_attributes then let rhs = match - Parens.lazyOrAssertOrAwaitExprRhs ~inAwait:true + Parens.lazyOrAssertOrAwaitExprRhs ~inAwait:true ~state { e with pexp_attributes = @@ -3395,12 +3386,12 @@ and printSetFieldExpr ~state attrs lhs longidentLoc rhs loc cmtTbl = in let lhsDoc = let doc = printExpressionWithComments ~state lhs cmtTbl in - match Parens.fieldExpr lhs with + match Parens.fieldExpr ~state lhs with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc lhs braces | Nothing -> doc in - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let shouldIndent = ParsetreeViewer.isBinaryExpression ~state rhs in let doc = Doc.group (Doc.concat @@ -3465,7 +3456,7 @@ and printUnaryExpression ~state expr cmtTbl = [(Nolabel, operand)] ) -> let printedOperand = let doc = printExpressionWithComments ~state operand cmtTbl in - match Parens.unaryExprOperand operand with + match Parens.unaryExprOperand ~state operand with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc operand braces | Nothing -> doc @@ -3474,7 +3465,8 @@ and printUnaryExpression ~state expr cmtTbl = printComments doc cmtTbl expr.pexp_loc | _ -> assert false -and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = +and printBinaryExpression ~(state : State.t) (expr : Parsetree.expression) + cmtTbl = let printBinaryOperator ~inlineRhs operator = let operatorTxt = match operator with @@ -3484,7 +3476,12 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = | "==" -> "===" | "<>" -> "!=" | "!=" -> "!==" - | txt -> txt + | txt -> + if state.customInfix <> [] then + match state.customInfix |> Res_custom_infix.findAlias ~alias:txt with + | Some (name, _) -> name + | None -> txt + else txt in let spacingBeforeOperator = if operator = "|." || operator = "|.u" then Doc.softLine @@ -3502,7 +3499,7 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = in let printOperand ~isLhs expr parentOperator = let rec flatten ~isLhs expr parentOperator = - if ParsetreeViewer.isBinaryExpression expr then + if ParsetreeViewer.isBinaryExpression ~state expr then match expr with | { pexp_desc = @@ -3526,7 +3523,7 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = cmtTbl in let doc = - if Parens.flattenOperandRhs parentOperator right then + if Parens.flattenOperandRhs parentOperator ~state right then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in @@ -3567,8 +3564,8 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = in let doc = - if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then - Doc.concat [Doc.lparen; doc; Doc.rparen] + if (not isLhs) && Parens.rhsBinaryExprOperand ~state operator expr + then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in printComments doc cmtTbl expr.pexp_loc @@ -3585,7 +3582,7 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = if Parens.subBinaryExprOperand parentOperator operator || printeableAttrs <> [] - && (ParsetreeViewer.isBinaryExpression expr + && (ParsetreeViewer.isBinaryExpression ~state expr || ParsetreeViewer.isTernaryExpr expr) then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc @@ -3612,7 +3609,7 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = let rhsDoc = printExpressionWithComments ~state rhs cmtTbl in let lhsDoc = printExpressionWithComments ~state lhs cmtTbl in (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let shouldIndent = ParsetreeViewer.isBinaryExpression ~state rhs in let doc = Doc.group (Doc.concat @@ -3633,7 +3630,7 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = if isLhs then addParens doc else doc | _ -> ( let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.binaryExprOperand ~isLhs expr with + match Parens.binaryExprOperand ~isLhs ~state expr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc expr braces | Nothing -> doc) @@ -3648,8 +3645,8 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = }, [(Nolabel, lhs); (Nolabel, rhs)] ) when not - (ParsetreeViewer.isBinaryExpression lhs - || ParsetreeViewer.isBinaryExpression rhs + (ParsetreeViewer.isBinaryExpression ~state lhs + || ParsetreeViewer.isBinaryExpression ~state rhs || printAttributes ~state expr.pexp_attributes cmtTbl <> Doc.nil) -> let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in let lhsDoc = printOperand ~isLhs:true lhs op in @@ -3685,7 +3682,7 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = rhsDoc; ] in - if ParsetreeViewer.shouldIndentBinaryExpr expr then + if ParsetreeViewer.shouldIndentBinaryExpr ~state expr then Doc.group (Doc.indent operatorWithRhs) else operatorWithRhs in @@ -3704,7 +3701,7 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = [ printAttributes ~state expr.pexp_attributes cmtTbl; (match - Parens.binaryExpr + Parens.binaryExpr ~state { expr with pexp_attributes = @@ -3781,7 +3778,7 @@ and printPexpApply ~state expr cmtTbl = [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> let parentDoc = let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with + match Parens.unaryExprOperand ~state parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces | Nothing -> doc @@ -3817,7 +3814,7 @@ and printPexpApply ~state expr cmtTbl = (* TODO: unify indentation of "=" *) let shouldIndent = (not (ParsetreeViewer.isBracedExpr rhs)) - && ParsetreeViewer.isBinaryExpression rhs + && ParsetreeViewer.isBinaryExpression ~state rhs in let doc = Doc.group @@ -3859,7 +3856,7 @@ and printPexpApply ~state expr cmtTbl = in let parentDoc = let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with + match Parens.unaryExprOperand ~state parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces | Nothing -> doc @@ -3898,14 +3895,14 @@ and printPexpApply ~state expr cmtTbl = let shouldIndentTargetExpr = if ParsetreeViewer.isBracedExpr targetExpr then false else - ParsetreeViewer.isBinaryExpression targetExpr + ParsetreeViewer.isBinaryExpression ~state targetExpr || match targetExpr with | { pexp_attributes = [({Location.txt = "res.ternary"}, _)]; pexp_desc = Pexp_ifthenelse (ifExpr, _, _); } -> - ParsetreeViewer.isBinaryExpression ifExpr + ParsetreeViewer.isBinaryExpression ~state ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes | {pexp_desc = Pexp_newtype _} -> false | e -> @@ -3921,7 +3918,7 @@ and printPexpApply ~state expr cmtTbl = in let parentDoc = let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with + match Parens.unaryExprOperand ~state parentExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc parentExpr braces | Nothing -> doc @@ -3955,7 +3952,7 @@ and printPexpApply ~state expr cmtTbl = let dotted = state.uncurried_config |> Res_uncurried.getDotted ~uncurried in let callExprDoc = let doc = printExpressionWithComments ~state callExpr cmtTbl in - match Parens.callExpr callExpr with + match Parens.callExpr ~state callExpr with | Parens.Parenthesized -> addParens doc | Braced braces -> printBraces doc callExpr braces | Nothing -> doc @@ -5282,6 +5279,34 @@ and printAttribute ?(standalone = false) ~state | "toUncurried" -> state.uncurried_config <- Res_uncurried.Default; {id with txt = "uncurried"} + | "infix" -> ( + match payload with + | PStr + [ + { + pstr_desc = + Pstr_eval + ( { + pexp_desc = + Pexp_tuple + [ + { + pexp_desc = + Pexp_constant (Pconst_string (name, _)); + }; + { + pexp_desc = + Pexp_constant (Pconst_string (alias, _)); + }; + ]; + }, + _ ); + }; + ] -> + state.customInfix <- + state.customInfix |> Res_custom_infix.addSymbol ~name ~alias; + id + | _ -> (* should never happpen *) id) | _ -> id in ( Doc.group diff --git a/res_syntax/src/res_printer_state.ml b/res_syntax/src/res_printer_state.ml new file mode 100644 index 0000000000..a39c748483 --- /dev/null +++ b/res_syntax/src/res_printer_state.ml @@ -0,0 +1,21 @@ +let customLayoutThreshold = 2 + +type t = { + customLayout: int; + mutable uncurried_config: Res_uncurried.config; + mutable customInfix: Res_custom_infix.t; +} + +let copy t = + { + customLayout = t.customLayout; + uncurried_config = t.uncurried_config; + customInfix = t.customInfix; + } + +let init = + {customLayout = 0; uncurried_config = Res_uncurried.init; customInfix = []} + +let nextCustomLayout t = {t with customLayout = t.customLayout + 1} + +let shouldBreakCallback t = t.customLayout > customLayoutThreshold diff --git a/res_syntax/src/res_scanner.ml b/res_syntax/src/res_scanner.ml index 371711796e..09244205db 100644 --- a/res_syntax/src/res_scanner.ml +++ b/res_syntax/src/res_scanner.ml @@ -13,6 +13,7 @@ type charEncoding = Char.t type t = { filename: string; src: string; + srcLen: int; mutable err: startPos:Lexing.position -> endPos:Lexing.position -> @@ -25,6 +26,7 @@ type t = { mutable lineOffset: int; (* current line offset *) mutable lnum: int; (* current line number *) mutable mode: mode list; + mutable customInfix: Res_custom_infix.t; } let setDiamondMode scanner = scanner.mode <- Diamond :: scanner.mode @@ -113,11 +115,11 @@ let next scanner = scanner.offset16 <- 0; scanner.lnum <- scanner.lnum + 1) else scanner.offset16 <- scanner.offset16 + utf16len; - if nextOffset < String.length scanner.src then ( + if nextOffset < scanner.srcLen then ( scanner.offset <- nextOffset; scanner.ch <- String.unsafe_get scanner.src nextOffset) else ( - scanner.offset <- String.length scanner.src; + scanner.offset <- scanner.srcLen; scanner.offset16 <- scanner.offset - scanner.lineOffset; scanner.ch <- hackyEOFChar) @@ -131,17 +133,17 @@ let next3 scanner = next scanner let peek scanner = - if scanner.offset + 1 < String.length scanner.src then + if scanner.offset + 1 < scanner.srcLen then String.unsafe_get scanner.src (scanner.offset + 1) else hackyEOFChar let peek2 scanner = - if scanner.offset + 2 < String.length scanner.src then + if scanner.offset + 2 < scanner.srcLen then String.unsafe_get scanner.src (scanner.offset + 2) else hackyEOFChar let peek3 scanner = - if scanner.offset + 3 < String.length scanner.src then + if scanner.offset + 3 < scanner.srcLen then String.unsafe_get scanner.src (scanner.offset + 3) else hackyEOFChar @@ -149,6 +151,7 @@ let make ~filename src = { filename; src; + srcLen = String.length src; err = (fun ~startPos:_ ~endPos:_ _ -> ()); ch = (if src = "" then hackyEOFChar else String.unsafe_get src 0); offset = 0; @@ -156,6 +159,7 @@ let make ~filename src = lineOffset = 0; lnum = 1; mode = []; + customInfix = []; } (* generic helpers *) @@ -636,13 +640,31 @@ let scanTemplateLiteralToken scanner = let endPos = position scanner in (startPos, endPos, token) +let scanCustomInfix scanner = + match + scanner.customInfix + |> List.find_opt (fun (name, _) -> + Res_custom_infix.lookupName ~name ~src:scanner.src + ~srcLen:scanner.srcLen ~offset:scanner.offset) + with + | Some (name, alias) -> + for _ = 1 to String.length name do + next scanner + done; + Some (Token.CustomInfix alias) + | _ -> None + let rec scan scanner = skipWhitespace scanner; let startPos = position scanner in - + let customInfixToken = + (* Called for each token: get a fast path out of here *) + if scanner.customInfix <> [] then scanCustomInfix scanner else None + in let token = match scanner.ch with (* peeking 0 char *) + | _ when customInfixToken <> None -> Option.get customInfixToken | 'A' .. 'Z' | 'a' .. 'z' -> scanIdentifier scanner | '0' .. '9' -> scanNumber scanner | '`' -> diff --git a/res_syntax/src/res_scanner.mli b/res_syntax/src/res_scanner.mli index cc002699fd..44119fff9f 100644 --- a/res_syntax/src/res_scanner.mli +++ b/res_syntax/src/res_scanner.mli @@ -5,6 +5,7 @@ type charEncoding type t = { filename: string; src: string; + srcLen: int; mutable err: startPos:Lexing.position -> endPos:Lexing.position -> @@ -17,6 +18,7 @@ type t = { mutable lineOffset: int; (* current line offset *) mutable lnum: int; (* current line number *) mutable mode: mode list; + mutable customInfix: Res_custom_infix.t; } val make : filename:string -> string -> t diff --git a/res_syntax/src/res_token.ml b/res_syntax/src/res_token.ml index f519af6f02..c4f049b496 100644 --- a/res_syntax/src/res_token.ml +++ b/res_syntax/src/res_token.ml @@ -96,6 +96,7 @@ type t = | Try | DocComment of Location.t * string | ModuleComment of Location.t * string + | CustomInfix of string let precedence = function | HashEqual | ColonEqual -> 1 @@ -104,7 +105,7 @@ let precedence = function | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> 4 - | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 + | Plus | PlusDot | Minus | MinusDot | PlusPlus | CustomInfix _ -> 5 | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 | Exponentiation -> 7 | MinusGreater -> 8 @@ -207,6 +208,7 @@ let toString = function | Try -> "try" | DocComment (_loc, s) -> "DocComment " ^ s | ModuleComment (_loc, s) -> "ModuleComment " ^ s + | CustomInfix s -> s let keywordTable = function | "and" -> And diff --git a/res_syntax/tests/printer/expr/expected/infix.res.txt b/res_syntax/tests/printer/expr/expected/infix.res.txt new file mode 100644 index 0000000000..f5dea22dce --- /dev/null +++ b/res_syntax/tests/printer/expr/expected/infix.res.txt @@ -0,0 +1,7 @@ +let plus = (x, y) => x + y +let minus = (x, y) => x - y + +@@infix(("πŸ˜€", "plus")) +@@infix(("πŸ’©πŸ’©", "minus")) + +let q = 3 πŸ˜€ 4 πŸ’©πŸ’© 5 diff --git a/res_syntax/tests/printer/expr/infix.res b/res_syntax/tests/printer/expr/infix.res new file mode 100644 index 0000000000..f5dea22dce --- /dev/null +++ b/res_syntax/tests/printer/expr/infix.res @@ -0,0 +1,7 @@ +let plus = (x, y) => x + y +let minus = (x, y) => x - y + +@@infix(("πŸ˜€", "plus")) +@@infix(("πŸ’©πŸ’©", "minus")) + +let q = 3 πŸ˜€ 4 πŸ’©πŸ’© 5