From 5925ee3abe2c2aa7933b2f498d6f818447b1465a Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 30 May 2024 12:59:41 +0200 Subject: [PATCH 1/3] wip pull latest parser and compiler helper files --- analysis/src/Codemod.ml | 4 +- analysis/src/Commands.ml | 10 +- analysis/src/CompletionFrontEnd.ml | 12 +- analysis/src/CreateInterface.ml | 4 +- analysis/src/Diagnostics.ml | 9 +- analysis/src/DocumentSymbol.ml | 20 +- analysis/src/DumpAst.ml | 2 +- analysis/src/Hint.ml | 22 +- analysis/src/Hover.ml | 2 +- analysis/src/PrintType.ml | 8 +- analysis/src/ProcessCmt.ml | 6 +- analysis/src/SemanticTokens.ml | 30 +- analysis/src/SignatureHelp.ml | 6 +- analysis/src/Utils.ml | 2 +- analysis/src/Xform.ml | 18 +- .../not_compiled/expected/Diagnostics.res.txt | 48 +- .../not_compiled/expected/DocTemplate.res.txt | 20 + .../expected/DocTemplate.resi.txt | 20 + analysis/tests/src/expected/Auto.res.txt | 4 + .../src/expected/BrokenParserCases.res.txt | 13 + analysis/tests/src/expected/CodeLens.res.txt | 11 + analysis/tests/src/expected/Codemod.res.txt | 9 + .../src/expected/CompletableComponent.res.txt | 15 + .../src/expected/CompletePrioritize1.res.txt | 7 + .../src/expected/CompletePrioritize2.res.txt | 14 + .../tests/src/expected/Completion.res.txt | 468 ++ .../src/expected/CompletionAttributes.res.txt | 39 + .../src/expected/CompletionDicts.res.txt | 16 + .../expected/CompletionExpressions.res.txt | 364 ++ .../CompletionFunctionArguments.res.txt | 125 + .../expected/CompletionInferValues.res.txt | 169 + .../tests/src/expected/CompletionJsx.res.txt | 91 + .../src/expected/CompletionJsxProps.res.txt | 46 + .../src/expected/CompletionPattern.res.txt | 232 + .../src/expected/CompletionPipeChain.res.txt | 105 + .../expected/CompletionPipeSubmodules.res.txt | 45 + .../src/expected/CompletionResolve.res.txt | 4 + .../src/expected/CompletionSupport.res.txt | 42 + .../src/expected/CompletionSupport2.res.txt | 17 + .../expected/CompletionTypeAnnotation.res.txt | 57 + .../src/expected/CompletionTypeT.res.txt | 9 + analysis/tests/src/expected/Component.res.txt | 2 + .../tests/src/expected/Component.resi.txt | 2 + .../src/expected/CreateInterface.res.txt | 145 + analysis/tests/src/expected/Cross.res.txt | 41 + analysis/tests/src/expected/Dce.res.txt | 4 + analysis/tests/src/expected/Debug.res.txt | 17 + .../tests/src/expected/Definition.res.txt | 28 + .../expected/DefinitionWithInterface.res.txt | 12 + .../expected/DefinitionWithInterface.resi.txt | 9 + .../tests/src/expected/Destructuring.res.txt | 34 + analysis/tests/src/expected/Div.res.txt | 5 + .../tests/src/expected/DocComments.res.txt | 49 + .../tests/src/expected/DocumentSymbol.res.txt | 38 +- .../tests/src/expected/EnvCompletion.res.txt | 63 + .../expected/EnvCompletionOtherFile.res.txt | 13 + .../src/expected/ExhaustiveSwitch.res.txt | 43 + analysis/tests/src/expected/Fragment.res.txt | 16 + analysis/tests/src/expected/Highlight.res.txt | 140 + analysis/tests/src/expected/Hover.res.txt | 267 + analysis/tests/src/expected/InlayHint.res.txt | 35 + analysis/tests/src/expected/Jsx2.res.txt | 183 + analysis/tests/src/expected/Jsx2.resi.txt | 12 + analysis/tests/src/expected/JsxV4.res.txt | 58 + .../tests/src/expected/LongIdentTest.res.txt | 7 + .../tests/src/expected/ModuleStuff.res.txt | 5 + analysis/tests/src/expected/Objects.res.txt | 11 + analysis/tests/src/expected/Patterns.res.txt | 29 +- analysis/tests/src/expected/PolyRec.res.txt | 14 + analysis/tests/src/expected/QueryFile.res.txt | 6 + .../tests/src/expected/RecModules.res.txt | 22 + .../src/expected/RecordCompletion.res.txt | 24 + .../tests/src/expected/RecoveryOnProp.res.txt | 12 + .../tests/src/expected/References.res.txt | 25 + .../expected/ReferencesWithInterface.res.txt | 2 + .../expected/ReferencesWithInterface.resi.txt | 2 + analysis/tests/src/expected/Rename.res.txt | 11 + .../src/expected/RenameWithInterface.res.txt | 2 + .../src/expected/RenameWithInterface.resi.txt | 2 + analysis/tests/src/expected/Reprod.res.txt | 56 + .../tests/src/expected/SchemaAssets.res.txt | 6 + .../tests/src/expected/ShadowedBelt.res.txt | 3 + .../tests/src/expected/SignatureHelp.res.txt | 163 + .../src/expected/TypeAtPosCompletion.res.txt | 25 + .../tests/src/expected/TypeDefinition.res.txt | 25 + analysis/tests/src/expected/Xform.res.txt | 145 + analysis/vendor/ext/.ocamlformat | 1 + analysis/vendor/ext/bsc_args.ml | 8 +- analysis/vendor/ext/bsc_warnings.ml | 1 + analysis/vendor/ext/ext_cmp.ml | 2 +- analysis/vendor/ext/ext_cmp.mli | 2 +- analysis/vendor/ext/ext_ident.ml | 21 + analysis/vendor/ext/ext_ident.mli | 4 + analysis/vendor/ext/ext_js_file_kind.ml | 4 +- analysis/vendor/ext/ext_js_suffix.ml | 28 - analysis/vendor/ext/ext_json_write.ml | 86 - analysis/vendor/ext/ext_json_write.mli | 28 - analysis/vendor/ext/ext_module_system.ml | 2 +- analysis/vendor/ext/ext_namespace.ml | 2 +- analysis/vendor/ext/ext_namespace.mli | 2 +- analysis/vendor/ext/ext_pp.ml | 4 +- analysis/vendor/ext/ext_pp.mli | 2 +- analysis/vendor/ext/ext_stack.ml | 41 - analysis/vendor/ext/ext_stack.mli | 35 - analysis/vendor/ext/ext_string.ml | 1 - analysis/vendor/ext/ext_string.mli | 2 +- analysis/vendor/ext/ext_string_array.ml | 42 +- analysis/vendor/ext/js_reserved_map.ml | 19 +- analysis/vendor/ext/js_runtime_modules.ml | 2 + analysis/vendor/ext/literals.ml | 14 +- analysis/vendor/ext/misc.ml | 1 - analysis/vendor/ext/misc.mli | 1 - analysis/vendor/ext/string_vec.ml | 29 - analysis/vendor/ext/string_vec.mli | 25 - analysis/vendor/ext/warnings.ml | 29 +- analysis/vendor/ext/warnings.mli | 5 +- analysis/vendor/ml/ast_async.ml | 18 +- analysis/vendor/ml/ast_await.ml | 2 +- analysis/vendor/ml/ast_payload.ml | 24 +- analysis/vendor/ml/ast_payload.mli | 10 +- analysis/vendor/ml/ast_uncurried.ml | 51 +- analysis/vendor/ml/ast_uncurried_utils.ml | 2 +- analysis/vendor/ml/ast_untagged_variants.ml | 127 +- analysis/vendor/ml/asttypes.ml | 2 +- analysis/vendor/ml/bigint_utils.ml | 84 + analysis/vendor/ml/bigint_utils.mli | 8 + analysis/vendor/ml/code_frame.ml | 14 +- analysis/vendor/ml/ctype.ml | 44 +- analysis/vendor/ml/error_message_utils.ml | 75 +- analysis/vendor/ml/includecore.ml | 27 +- analysis/vendor/ml/includecore.mli | 2 + analysis/vendor/ml/includemod.ml | 16 +- analysis/vendor/ml/lambda.ml | 100 +- analysis/vendor/ml/lambda.mli | 81 +- analysis/vendor/ml/location.ml | 8 +- analysis/vendor/ml/matching.ml | 10 +- analysis/vendor/ml/oprint.ml | 6 +- analysis/vendor/ml/parmatch.ml | 19 +- analysis/vendor/ml/parsetree.ml | 2 +- analysis/vendor/ml/predef.ml | 33 +- analysis/vendor/ml/predef.mli | 9 +- analysis/vendor/ml/primitive.ml | 2 +- analysis/vendor/ml/primitive.mli | 4 +- analysis/vendor/ml/printlambda.ml | 41 +- analysis/vendor/ml/printtyped.ml | 2 +- analysis/vendor/ml/transl_recmodule.ml | 24 +- analysis/vendor/ml/translattribute.ml | 2 +- analysis/vendor/ml/translcore.ml | 115 +- analysis/vendor/ml/translmod.ml | 5 +- analysis/vendor/ml/typecore.ml | 190 +- analysis/vendor/ml/typecore.mli | 2 +- analysis/vendor/ml/typedecl.ml | 52 +- analysis/vendor/ml/typeopt.ml | 2 +- analysis/vendor/ml/untypeast.ml | 3 +- analysis/vendor/ml/variant_coercion.ml | 73 +- analysis/vendor/res_syntax/jsx_common.ml | 52 +- analysis/vendor/res_syntax/jsx_ppx.ml | 122 +- analysis/vendor/res_syntax/jsx_ppx.mli | 12 +- analysis/vendor/res_syntax/jsx_v4.ml | 1200 ++--- analysis/vendor/res_syntax/reactjs_jsx_v3.ml | 862 +-- .../vendor/res_syntax/res_ast_conversion.ml | 283 +- .../vendor/res_syntax/res_ast_conversion.mli | 4 +- .../vendor/res_syntax/res_ast_debugger.ml | 561 +- .../vendor/res_syntax/res_ast_debugger.mli | 6 +- analysis/vendor/res_syntax/res_cli.ml | 108 +- analysis/vendor/res_syntax/res_comment.ml | 34 +- analysis/vendor/res_syntax/res_comment.mli | 24 +- .../vendor/res_syntax/res_comments_table.ml | 1952 +++---- analysis/vendor/res_syntax/res_core.ml | 4642 +++++++++-------- analysis/vendor/res_syntax/res_core.mli | 4 +- analysis/vendor/res_syntax/res_diagnostics.ml | 73 +- .../vendor/res_syntax/res_diagnostics.mli | 16 +- analysis/vendor/res_syntax/res_doc.ml | 195 +- analysis/vendor/res_syntax/res_doc.mli | 30 +- analysis/vendor/res_syntax/res_driver.ml | 113 +- analysis/vendor/res_syntax/res_driver.mli | 49 +- .../vendor/res_syntax/res_driver_binary.ml | 6 +- .../vendor/res_syntax/res_driver_binary.mli | 2 +- .../vendor/res_syntax/res_driver_ml_parser.ml | 52 +- .../res_syntax/res_driver_ml_parser.mli | 6 +- analysis/vendor/res_syntax/res_grammar.ml | 142 +- analysis/vendor/res_syntax/res_io.ml | 4 +- analysis/vendor/res_syntax/res_io.mli | 4 +- .../vendor/res_syntax/res_multi_printer.ml | 88 +- .../vendor/res_syntax/res_multi_printer.mli | 2 +- .../vendor/res_syntax/res_outcome_printer.ml | 667 ++- .../vendor/res_syntax/res_outcome_printer.mli | 6 +- analysis/vendor/res_syntax/res_parens.ml | 283 +- analysis/vendor/res_syntax/res_parens.mli | 47 +- analysis/vendor/res_syntax/res_parser.ml | 144 +- analysis/vendor/res_syntax/res_parser.mli | 32 +- .../vendor/res_syntax/res_parsetree_viewer.ml | 393 +- .../res_syntax/res_parsetree_viewer.mli | 128 +- analysis/vendor/res_syntax/res_printer.ml | 4344 +++++++-------- analysis/vendor/res_syntax/res_printer.mli | 28 +- analysis/vendor/res_syntax/res_reporting.ml | 2 +- analysis/vendor/res_syntax/res_scanner.ml | 425 +- analysis/vendor/res_syntax/res_scanner.mli | 22 +- analysis/vendor/res_syntax/res_string.ml | 12 +- analysis/vendor/res_syntax/res_token.ml | 23 +- analysis/vendor/res_syntax/res_uncurried.ml | 4 +- analysis/vendor/res_syntax/res_utf8.ml | 16 +- analysis/vendor/res_syntax/res_utf8.mli | 6 +- tools/src/tools.ml | 2 +- 204 files changed, 13610 insertions(+), 9314 deletions(-) create mode 100644 analysis/vendor/ext/.ocamlformat delete mode 100644 analysis/vendor/ext/ext_js_suffix.ml delete mode 100644 analysis/vendor/ext/ext_json_write.ml delete mode 100644 analysis/vendor/ext/ext_json_write.mli delete mode 100644 analysis/vendor/ext/ext_stack.ml delete mode 100644 analysis/vendor/ext/ext_stack.mli delete mode 100644 analysis/vendor/ext/string_vec.ml delete mode 100644 analysis/vendor/ext/string_vec.mli create mode 100644 analysis/vendor/ml/bigint_utils.ml create mode 100644 analysis/vendor/ml/bigint_utils.mli diff --git a/analysis/src/Codemod.ml b/analysis/src/Codemod.ml index cef82fac3..61d7318cc 100644 --- a/analysis/src/Codemod.ml +++ b/analysis/src/Codemod.ml @@ -11,8 +11,8 @@ let transform ~path ~pos ~debug ~typ ~hint = | AddMissingCases -> ( let source = "let " ^ hint ^ " = ()" in let {Res_driver.parsetree = hintStructure} = - Res_driver.parseImplementationFromSource ~forPrinter:false - ~displayFilename:"" ~source + Res_driver.parse_implementation_from_source ~for_printer:false + ~display_filename:"" ~source in match hintStructure with | [{pstr_desc = Pstr_value (_, [{pvb_pat = pattern}])}] -> ( diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index 3c6dbd84e..32bfe08ff 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -278,20 +278,20 @@ let rename ~path ~pos ~newName ~debug = let format ~path = if Filename.check_suffix path ".res" then let {Res_driver.parsetree = structure; comments; diagnostics} = - Res_driver.parsingEngine.parseImplementation ~forPrinter:true + Res_driver.parsing_engine.parse_implementation ~for_printer:true ~filename:path in if List.length diagnostics > 0 then "" else - Res_printer.printImplementation ~width:!Res_cli.ResClflags.width ~comments - structure + Res_printer.print_implementation ~width:!Res_cli.ResClflags.width + ~comments structure else if Filename.check_suffix path ".resi" then let {Res_driver.parsetree = signature; comments; diagnostics} = - Res_driver.parsingEngine.parseInterface ~forPrinter:true ~filename:path + Res_driver.parsing_engine.parse_interface ~for_printer:true ~filename:path in if List.length diagnostics > 0 then "" else - Res_printer.printInterface ~width:!Res_cli.ResClflags.width ~comments + Res_printer.print_interface ~width:!Res_cli.ResClflags.width ~comments signature else "" diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index 9702b2abe..a38015a86 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -77,7 +77,7 @@ let findArgCompletables ~(args : arg list) ~endPos ~posBeforeCursor if CursorPosition.locIsEmpty exp.pexp_loc ~pos:posBeforeCursor then someArgHadEmptyExprLoc := true; - if Res_parsetree_viewer.isTemplateLiteral exp then None + if Res_parsetree_viewer.is_template_literal exp then None else if exp.pexp_loc |> Loc.hasPos ~pos:posBeforeCursor then ( if Debug.verbose () then print_endline @@ -281,7 +281,7 @@ let rec exprToContextPathInner (e : Parsetree.expression) = and exprToContextPath (e : Parsetree.expression) = match - ( Res_parsetree_viewer.hasAwaitAttribute e.pexp_attributes, + ( Res_parsetree_viewer.has_await_attribute e.pexp_attributes, exprToContextPathInner e ) with | true, Some ctxPath -> Some (CPAwait ctxPath) @@ -1072,7 +1072,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor completionContext = (if isLikelyModulePath - && expr |> Res_parsetree_viewer.isBracedExpr + && expr |> Res_parsetree_viewer.is_braced_expr then ValueOrField else Value); })) @@ -1143,7 +1143,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor | Some contextPath -> setResult (Cpath (CPField (contextPath, ""))) | None -> ()) | Pexp_apply ({pexp_desc = Pexp_ident compName}, args) - when Res_parsetree_viewer.isJsxExpression expr -> + when Res_parsetree_viewer.is_jsx_expression expr -> inJsxContext := true; let jsxProps = CompletionJsx.extractJsxProps ~compName ~args in let compNamePath = flattenLidCheckDot ~jsx:true compName in @@ -1500,7 +1500,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor if Filename.check_suffix path ".res" then ( let parser = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false + Res_driver.parsing_engine.parse_implementation ~for_printer:false in let {Res_driver.parsetree = str} = parser ~filename:currentFile in iterator.structure iterator str |> ignore; @@ -1512,7 +1512,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor if !found = false then if debug then Printf.printf "XXX Not found!\n"; !result) else if Filename.check_suffix path ".resi" then ( - let parser = Res_driver.parsingEngine.parseInterface ~forPrinter:false in + let parser = Res_driver.parsing_engine.parse_interface ~for_printer:false in let {Res_driver.parsetree = signature} = parser ~filename:currentFile in iterator.signature iterator signature |> ignore; if blankAfterCursor = Some ' ' || blankAfterCursor = Some '\n' then ( diff --git a/analysis/src/CreateInterface.ml b/analysis/src/CreateInterface.ml index 023f38dc3..09fa7e0f9 100644 --- a/analysis/src/CreateInterface.ml +++ b/analysis/src/CreateInterface.ml @@ -147,8 +147,8 @@ let printSignature ~extractor ~signature = Printtyp.reset_names (); let sigItemToString (item : Outcometree.out_sig_item) = - item |> Res_outcome_printer.printOutSigItemDoc - |> Res_doc.toString ~width:!Res_cli.ResClflags.width + item |> Res_outcome_printer.print_out_sig_item_doc + |> Res_doc.to_string ~width:!Res_cli.ResClflags.width in let genSigStrForInlineAttr lines attributes id vd = diff --git a/analysis/src/Diagnostics.ml b/analysis/src/Diagnostics.ml index b4c073425..0b30d0e33 100644 --- a/analysis/src/Diagnostics.ml +++ b/analysis/src/Diagnostics.ml @@ -3,10 +3,10 @@ let document_syntax ~path = diagnostics |> List.map (fun diagnostic -> let _, startline, startcol = - Location.get_pos_info (Res_diagnostics.getStartPos diagnostic) + Location.get_pos_info (Res_diagnostics.get_start_pos diagnostic) in let _, endline, endcol = - Location.get_pos_info (Res_diagnostics.getEndPos diagnostic) + Location.get_pos_info (Res_diagnostics.get_end_pos diagnostic) in Protocol.stringifyDiagnostic { @@ -21,13 +21,14 @@ let document_syntax ~path = in if FindFiles.isImplementation path then let parseImplementation = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false + Res_driver.parsing_engine.parse_implementation ~for_printer:false ~filename:path in get_diagnostics parseImplementation.diagnostics else if FindFiles.isInterface path then let parseInterface = - Res_driver.parsingEngine.parseInterface ~forPrinter:false ~filename:path + Res_driver.parsing_engine.parse_interface ~for_printer:false + ~filename:path in get_diagnostics parseInterface.diagnostics else [] diff --git a/analysis/src/DocumentSymbol.ml b/analysis/src/DocumentSymbol.ml index 356541c5f..44580f1e6 100644 --- a/analysis/src/DocumentSymbol.ml +++ b/analysis/src/DocumentSymbol.ml @@ -135,15 +135,17 @@ let command ~path = in (if Filename.check_suffix path ".res" then - let parser = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false - in - let {Res_driver.parsetree = structure} = parser ~filename:path in - iterator.structure iterator structure |> ignore - else - let parser = Res_driver.parsingEngine.parseInterface ~forPrinter:false in - let {Res_driver.parsetree = signature} = parser ~filename:path in - iterator.signature iterator signature |> ignore); + let parser = + Res_driver.parsing_engine.parse_implementation ~for_printer:false + in + let {Res_driver.parsetree = structure} = parser ~filename:path in + iterator.structure iterator structure |> ignore + else + let parser = + Res_driver.parsing_engine.parse_interface ~for_printer:false + in + let {Res_driver.parsetree = signature} = parser ~filename:path in + iterator.signature iterator signature |> ignore); let isInside ({ range = diff --git a/analysis/src/DumpAst.ml b/analysis/src/DumpAst.ml index 60395a60b..0515dc9fc 100644 --- a/analysis/src/DumpAst.ml +++ b/analysis/src/DumpAst.ml @@ -313,7 +313,7 @@ let printStructItem structItem ~pos ~source = let dump ~currentFile ~pos = let {Res_driver.parsetree = structure; source} = - Res_driver.parsingEngine.parseImplementation ~forPrinter:true + Res_driver.parsing_engine.parse_implementation ~for_printer:true ~filename:currentFile in diff --git a/analysis/src/Hint.ml b/analysis/src/Hint.ml index 227d70f38..9f553d063 100644 --- a/analysis/src/Hint.ml +++ b/analysis/src/Hint.ml @@ -15,7 +15,7 @@ let locItemToTypeHint ~full:{file; package} locItem = | Const_float _ -> "float" | Const_int32 _ -> "int32" | Const_int64 _ -> "int64" - | Const_nativeint _ -> "int") + | Const_bigint _ -> "bigint") | Typed (_, t, locKind) -> let fromType typ = typ |> Shared.typeToString @@ -71,11 +71,11 @@ let inlay ~path ~pos ~maxLength ~debug = in let iterator = {Ast_iterator.default_iterator with value_binding} in (if Files.classifySourceFile path = Res then - let parser = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false - in - let {Res_driver.parsetree = structure} = parser ~filename:path in - iterator.structure iterator structure |> ignore); + let parser = + Res_driver.parsing_engine.parse_implementation ~for_printer:false + in + let {Res_driver.parsetree = structure} = parser ~filename:path in + iterator.structure iterator structure |> ignore); match Cmt.loadFullCmtFromPath ~path with | None -> None | Some full -> @@ -135,11 +135,11 @@ let codeLens ~path ~debug = (* We only print code lenses in implementation files. This is because they'd be redundant in interface files, where the definition itself will be the same thing as what would've been printed in the code lens. *) (if Files.classifySourceFile path = Res then - let parser = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false - in - let {Res_driver.parsetree = structure} = parser ~filename:path in - iterator.structure iterator structure |> ignore); + let parser = + Res_driver.parsing_engine.parse_implementation ~for_printer:false + in + let {Res_driver.parsetree = structure} = parser ~filename:path in + iterator.structure iterator structure |> ignore); match Cmt.loadFullCmtFromPath ~path with | None -> None | Some full -> diff --git a/analysis/src/Hover.ml b/analysis/src/Hover.ml index 7bcab0cd5..d01d49873 100644 --- a/analysis/src/Hover.ml +++ b/analysis/src/Hover.ml @@ -227,7 +227,7 @@ let newHover ~full:{file; package} ~supportsMarkdownLinks locItem = | Const_float _ -> "float" | Const_int32 _ -> "int32" | Const_int64 _ -> "int64" - | Const_nativeint _ -> "int")) + | Const_bigint _ -> "bigint")) | Typed (_, t, locKind) -> let fromType ~docstring typ = ( hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks typ, diff --git a/analysis/src/PrintType.ml b/analysis/src/PrintType.ml index 3fe104398..3234d11b4 100644 --- a/analysis/src/PrintType.ml +++ b/analysis/src/PrintType.ml @@ -1,11 +1,11 @@ let printExpr ?(lineWidth = 60) typ = Printtyp.reset_names (); Printtyp.reset_and_mark_loops typ; - Res_doc.toString ~width:lineWidth - (Res_outcome_printer.printOutTypeDoc (Printtyp.tree_of_typexp false typ)) + Res_doc.to_string ~width:lineWidth + (Res_outcome_printer.print_out_type_doc (Printtyp.tree_of_typexp false typ)) let printDecl ?printNameAsIs ~recStatus name decl = Printtyp.reset_names (); - Res_doc.toString ~width:60 - (Res_outcome_printer.printOutSigItemDoc ?printNameAsIs + Res_doc.to_string ~width:60 + (Res_outcome_printer.print_out_sig_item_doc ?print_name_as_is:printNameAsIs (Printtyp.tree_of_type_declaration (Ident.create name) decl recStatus)) diff --git a/analysis/src/ProcessCmt.ml b/analysis/src/ProcessCmt.ml index c54e625ca..e0748a28e 100644 --- a/analysis/src/ProcessCmt.ml +++ b/analysis/src/ProcessCmt.ml @@ -22,7 +22,7 @@ let mapRecordField {Types.ld_id; ld_type; ld_attributes} = stamp = astamp; fname = Location.mknoloc name; typ = ld_type; - optional = Res_parsetree_viewer.hasOptionalAttribute ld_attributes; + optional = Res_parsetree_viewer.has_optional_attribute ld_attributes; docstring = (match ProcessAttributes.findDocAttribute ld_attributes with | None -> [] @@ -255,7 +255,7 @@ let forTypeDeclaration ~env ~(exported : Exported.t) typ = f.ld_type.ctyp_type; optional = Res_parsetree_viewer - .hasOptionalAttribute + .has_optional_attribute f.ld_attributes; docstring = (match @@ -302,7 +302,7 @@ let forTypeDeclaration ~env ~(exported : Exported.t) fname; typ = ctyp_type; optional = - Res_parsetree_viewer.hasOptionalAttribute + Res_parsetree_viewer.has_optional_attribute ld_attributes; docstring = attrsToDocstring ld_attributes; deprecated = diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 41fb70353..58564aa1f 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -247,7 +247,7 @@ let command ~debug ~emitter ~path = ~lid ~debug; Ast_iterator.default_iterator.expr iterator e | Pexp_apply ({pexp_desc = Pexp_ident lident; pexp_loc}, args) - when Res_parsetree_viewer.isJsxExpression e -> + when Res_parsetree_viewer.is_jsx_expression e -> (* Angled brackets: - These are handled in the grammar: <> @@ -283,18 +283,18 @@ let command ~debug ~emitter ~path = (* there's an off-by one somehow in the AST *) in (if not selfClosing then - let lineStart, colStart = Loc.start pexp_loc in - let lineEnd, colEnd = Loc.end_ pexp_loc in - let length = if lineStart = lineEnd then colEnd - colStart else 0 in - let lineEndWhole, colEndWhole = Loc.end_ e.pexp_loc in - if length > 0 && colEndWhole > length then ( - emitter - |> emitJsxClose ~debug ~lid:lident.txt - ~pos:(lineEndWhole, colEndWhole - 1); - emitter (* <-- *) - |> emitJsxTag ~debug ~name:">" ~pos:posOfGreatherthanAfterProps; - emitter (* ... <-- *) - |> emitJsxTag ~debug ~name:">" ~pos:posOfFinalGreatherthan)); + let lineStart, colStart = Loc.start pexp_loc in + let lineEnd, colEnd = Loc.end_ pexp_loc in + let length = if lineStart = lineEnd then colEnd - colStart else 0 in + let lineEndWhole, colEndWhole = Loc.end_ e.pexp_loc in + if length > 0 && colEndWhole > length then ( + emitter + |> emitJsxClose ~debug ~lid:lident.txt + ~pos:(lineEndWhole, colEndWhole - 1); + emitter (* <-- *) + |> emitJsxTag ~debug ~name:">" ~pos:posOfGreatherthanAfterProps; + emitter (* ... <-- *) + |> emitJsxTag ~debug ~name:">" ~pos:posOfFinalGreatherthan)); args |> List.iter (fun (_lbl, arg) -> iterator.expr iterator arg) | Pexp_apply @@ -440,7 +440,7 @@ let command ~debug ~emitter ~path = if Files.classifySourceFile path = Res then ( let parser = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false + Res_driver.parsing_engine.parse_implementation ~for_printer:false in let {Res_driver.parsetree = structure; diagnostics} = parser ~filename:path @@ -450,7 +450,7 @@ let command ~debug ~emitter ~path = (List.length structure) (List.length diagnostics); iterator.structure iterator structure |> ignore) else - let parser = Res_driver.parsingEngine.parseInterface ~forPrinter:false in + let parser = Res_driver.parsing_engine.parse_interface ~for_printer:false in let {Res_driver.parsetree = signature; diagnostics} = parser ~filename:path in diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index 489c070b2..c2e148de8 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -427,7 +427,7 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = in let iterator = {Ast_iterator.default_iterator with expr; pat} in let parser = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false + Res_driver.parsing_engine.parse_implementation ~for_printer:false in let {Res_driver.parsetree = structure} = parser ~filename:currentFile in iterator.structure iterator structure |> ignore; @@ -456,8 +456,8 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = let fnTypeStr = Shared.typeToString type_expr in let typeStrForParser = labelPrefix ^ fnTypeStr in let {Res_driver.parsetree = signature} = - Res_driver.parseInterfaceFromSource ~forPrinter:false - ~displayFilename:"" ~source:typeStrForParser + Res_driver.parse_interface_from_source ~for_printer:false + ~display_filename:"" ~source:typeStrForParser in let parameters = diff --git a/analysis/src/Utils.ml b/analysis/src/Utils.ml index bb9f94a2e..d136c181a 100644 --- a/analysis/src/Utils.ml +++ b/analysis/src/Utils.ml @@ -259,7 +259,7 @@ let printMaybeExoticIdent ?(allowUident = false) txt = | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '\'' | '_' -> loop (i + 1) | _ -> "\"" ^ txt ^ "\"" in - if Res_token.isKeywordTxt txt then "\"" ^ txt ^ "\"" else loop 0 + if Res_token.is_keyword_txt txt then "\"" ^ txt ^ "\"" else loop 0 let findPackageJson root = let path = Uri.toPath root in diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml index cc0cb63fb..d396b4cd5 100644 --- a/analysis/src/Xform.ml +++ b/analysis/src/Xform.ml @@ -1,6 +1,6 @@ (** Code transformations using the parser/printer and ast operations *) -let isBracedExpr = Res_parsetree_viewer.isBracedExpr +let isBracedExpr = Res_parsetree_viewer.is_braced_expr let mkPosition (pos : Pos.t) = let line, character = pos in @@ -453,7 +453,7 @@ module ExpandCatchAllForVariants = struct let newText = missingConstructors |> List.map (fun (c : SharedTypes.polyVariantConstructor) -> - Res_printer.polyVarIdentToString c.name + Res_printer.polyvar_ident_to_string c.name ^ match c.args with | [] -> "" @@ -510,7 +510,7 @@ module ExpandCatchAllForVariants = struct (fun (c : SharedTypes.polyVariantConstructor) -> if currentConstructorNames |> List.mem c.name = false then Some - ( Res_printer.polyVarIdentToString c.name, + ( Res_printer.polyvar_ident_to_string c.name, match c.args with | [] -> false | _ -> true ) @@ -847,7 +847,7 @@ end let parseImplementation ~filename = let {Res_driver.parsetree = structure; comments} = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false ~filename + Res_driver.parsing_engine.parse_implementation ~for_printer:false ~filename in let filterComments ~loc comments = (* Relevant comments in the range of the expression *) @@ -859,7 +859,7 @@ let parseImplementation ~filename = let printExpr ~(range : Protocol.range) (expr : Parsetree.expression) = let structure = [Ast_helper.Str.eval ~loc:expr.pexp_loc expr] in structure - |> Res_printer.printImplementation ~width:!Res_cli.ResClflags.width + |> Res_printer.print_implementation ~width:!Res_cli.ResClflags.width ~comments:(comments |> filterComments ~loc:expr.pexp_loc) |> Utils.indent range.start.character in @@ -867,20 +867,20 @@ let parseImplementation ~filename = (item : Parsetree.structure_item) = let structure = [item] in structure - |> Res_printer.printImplementation ~width:!Res_cli.ResClflags.width + |> Res_printer.print_implementation ~width:!Res_cli.ResClflags.width ~comments:(comments |> filterComments ~loc:item.pstr_loc) |> Utils.indent range.start.character in let printStandaloneStructure ~(loc : Location.t) structure = structure - |> Res_printer.printImplementation ~width:!Res_cli.ResClflags.width + |> Res_printer.print_implementation ~width:!Res_cli.ResClflags.width ~comments:(comments |> filterComments ~loc) in (structure, printExpr, printStructureItem, printStandaloneStructure) let parseInterface ~filename = let {Res_driver.parsetree = structure; comments} = - Res_driver.parsingEngine.parseInterface ~forPrinter:false ~filename + Res_driver.parsing_engine.parse_interface ~for_printer:false ~filename in let filterComments ~loc comments = (* Relevant comments in the range of the expression *) @@ -893,7 +893,7 @@ let parseInterface ~filename = (item : Parsetree.signature_item) = let signature_item = [item] in signature_item - |> Res_printer.printInterface ~width:!Res_cli.ResClflags.width + |> Res_printer.print_interface ~width:!Res_cli.ResClflags.width ~comments:(comments |> filterComments ~loc:item.psig_loc) |> Utils.indent range.start.character in diff --git a/analysis/tests/not_compiled/expected/Diagnostics.res.txt b/analysis/tests/not_compiled/expected/Diagnostics.res.txt index a5df33b71..f9e063a84 100644 --- a/analysis/tests/not_compiled/expected/Diagnostics.res.txt +++ b/analysis/tests/not_compiled/expected/Diagnostics.res.txt @@ -1,17 +1,33 @@ -[{ - "range": {"start": {"line": 2, "character": 4}, "end": {"line": 2, "character": 6}}, - "message": "consecutive statements on a line must be separated by ';' or a newline", - "severity": 1, - "source": "ReScript" -}, { - "range": {"start": {"line": 1, "character": 9}, "end": {"line": 1, "character": 11}}, - "message": "This let-binding misses an expression", - "severity": 1, - "source": "ReScript" -}, { - "range": {"start": {"line": 0, "character": 4}, "end": {"line": 0, "character": 5}}, - "message": "I was expecting a name for this let-binding. Example: `let message = \"hello\"`", - "severity": 1, - "source": "ReScript" -}] + + Syntax error! + not_compiled/Diagnostics.res:1:5 + + 1 │ let = 1 + 1.0 + 2 │ let add = =2 + 3 │ lett a = 2 + + I was expecting a name for this let-binding. Example: `let message = "hello"` + + + Syntax error! + not_compiled/Diagnostics.res:2:10-11 + + 1 │ let = 1 + 1.0 + 2 │ let add = =2 + 3 │ lett a = 2 + 4 │ + + This let-binding misses an expression + + + Syntax error! + not_compiled/Diagnostics.res:3:5-6 + + 1 │ let = 1 + 1.0 + 2 │ let add = =2 + 3 │ lett a = 2 + 4 │ + 5 │ //^dia + + consecutive statements on a line must be separated by ';' or a newline diff --git a/analysis/tests/not_compiled/expected/DocTemplate.res.txt b/analysis/tests/not_compiled/expected/DocTemplate.res.txt index ce8487127..a26747100 100644 --- a/analysis/tests/not_compiled/expected/DocTemplate.res.txt +++ b/analysis/tests/not_compiled/expected/DocTemplate.res.txt @@ -1,3 +1,23 @@ +type a = {a: int} +// ^xfm + +type rec t = A | B +// ^xfm +and e = C +@unboxed type name = Name(string) +// ^xfm +let a = 1 +// ^xfm +let inc = x => x + 1 +// ^xfm +module T = { + // ^xfm + let b = 1 + // ^xfm +} +@module("path") +external dirname: string => string = "dirname" +//^xfm Xform not_compiled/DocTemplate.res 3:3 can't find module DocTemplate Hit: Add Documentation template diff --git a/analysis/tests/not_compiled/expected/DocTemplate.resi.txt b/analysis/tests/not_compiled/expected/DocTemplate.resi.txt index ef4987a7c..a6e2b1d6d 100644 --- a/analysis/tests/not_compiled/expected/DocTemplate.resi.txt +++ b/analysis/tests/not_compiled/expected/DocTemplate.resi.txt @@ -1,3 +1,23 @@ +type a = {a: int} +// ^xfm + +type rec t = A | B +// ^xfm +and e = C +@unboxed type name = Name(string) +// ^xfm +let a: int +// ^xfm +let inc: int => int +// ^xfm +module T: { + // ^xfm + let b: int + // ^xfm +} +@module("path") +external dirname: string => string = "dirname" +//^xfm Xform not_compiled/DocTemplate.resi 3:3 Hit: Add Documentation template diff --git a/analysis/tests/src/expected/Auto.res.txt b/analysis/tests/src/expected/Auto.res.txt index 78ec26d7f..55e440c05 100644 --- a/analysis/tests/src/expected/Auto.res.txt +++ b/analysis/tests/src/expected/Auto.res.txt @@ -1,3 +1,7 @@ +open! ShadowedBelt + +let m = List.map +// ^hov Hover src/Auto.res 2:13 {"contents": {"kind": "markdown", "value": "```rescript\n(list<'a>, 'a => 'b) => list<'b>\n```"}} diff --git a/analysis/tests/src/expected/BrokenParserCases.res.txt b/analysis/tests/src/expected/BrokenParserCases.res.txt index 8a4494a65..9cf22529c 100644 --- a/analysis/tests/src/expected/BrokenParserCases.res.txt +++ b/analysis/tests/src/expected/BrokenParserCases.res.txt @@ -1,3 +1,16 @@ +// --- BROKEN PARSER CASES --- +// This below demonstrates an issue when what you're completing is the _last_ labelled argument, and there's a unit application after it. The parser wrongly merges the unit argument as the expression of the labelled argument assignment, where is should really let the trailing unit argument be, and set a %rescript.exprhole as the expression of the assignment, just like it normally does. +// let _ = someFn(~isOff=, ()) +// ^com + +// This should parse as a single item tuple when in a pattern? +// switch s { | (t) } +// ^com + +// Here the parser eats the arrow and considers the None in the expression part of the pattern. +// let _ = switch x { | None | => None } +// ^com + Complete src/BrokenParserCases.res 2:24 posCursor:[2:24] posNoWhite:[2:23] Found expr:[2:11->2:30] Pexp_apply ...[2:11->2:17] (~isOff2:19->2:24=...[2:27->2:29]) diff --git a/analysis/tests/src/expected/CodeLens.res.txt b/analysis/tests/src/expected/CodeLens.res.txt index 06472d5e4..0d527f00c 100644 --- a/analysis/tests/src/expected/CodeLens.res.txt +++ b/analysis/tests/src/expected/CodeLens.res.txt @@ -1,3 +1,14 @@ +let add = (x, y) => x + y + +let foo = (~age, ~name) => name ++ string_of_int(age) + +let ff = (~opt1=0, ~a, ~b, (), ~opt2=0, (), ~c) => a + b + c + opt1 + opt2 + +let compFF = Completion.ff + +@react.component +let make = (~name) => React.string(name) +//^cle Code Lens src/CodeLens.res [{ "range": {"start": {"line": 9, "character": 4}, "end": {"line": 9, "character": 8}}, diff --git a/analysis/tests/src/expected/Codemod.res.txt b/analysis/tests/src/expected/Codemod.res.txt index 5e4783d5d..12e02f4e4 100644 --- a/analysis/tests/src/expected/Codemod.res.txt +++ b/analysis/tests/src/expected/Codemod.res.txt @@ -1,3 +1,12 @@ +type someTyp = [#valid | #invalid] + +let ff = (v1: someTyp, v2: someTyp) => { + let x = switch (v1, v2) { + // ^c-a (#valid, #valid) | (#invalid, _) + | (#valid, #invalid) => () + } + x +} Codemod AddMissingCasessrc/Codemod.res 3:10 switch (v1, v2) { // ^c-a (#valid, #valid) | (#invalid, _) diff --git a/analysis/tests/src/expected/CompletableComponent.res.txt b/analysis/tests/src/expected/CompletableComponent.res.txt index e69de29bb..50522a3d5 100644 --- a/analysis/tests/src/expected/CompletableComponent.res.txt +++ b/analysis/tests/src/expected/CompletableComponent.res.txt @@ -0,0 +1,15 @@ +type status = On | Off + +@@jsxConfig({version: 4, mode: "automatic"}) +type props<'status, 'name> = {status: 'status, name: 'name} + +let make = ({status, name, _}: props) => { + ignore(status) + ignore(name) + React.null +} +let make = { + let \"CompletableComponent" = (props: props<_>) => make(props) + + \"CompletableComponent" +} diff --git a/analysis/tests/src/expected/CompletePrioritize1.res.txt b/analysis/tests/src/expected/CompletePrioritize1.res.txt index b520a84a2..df38c76f7 100644 --- a/analysis/tests/src/expected/CompletePrioritize1.res.txt +++ b/analysis/tests/src/expected/CompletePrioritize1.res.txt @@ -1,3 +1,10 @@ +module Test = { + type t = {name: int} + let add = (a: float) => a +. 1.0 +} +let a: Test.t = {name: 4} +// a-> +// ^com Complete src/CompletePrioritize1.res 5:6 posCursor:[5:6] posNoWhite:[5:5] Found expr:[5:3->0:-1] Completable: Cpath Value[a]-> diff --git a/analysis/tests/src/expected/CompletePrioritize2.res.txt b/analysis/tests/src/expected/CompletePrioritize2.res.txt index b6bea71f9..5115ae72b 100644 --- a/analysis/tests/src/expected/CompletePrioritize2.res.txt +++ b/analysis/tests/src/expected/CompletePrioritize2.res.txt @@ -1,3 +1,17 @@ +let ax = 4 +let _ = ax +let ax = "" +let _ = ax +module Test = { + type t = {name: int} + let add = (ax: t) => ax.name + 1 +} +let ax: Test.t = {name: 4} +// ax-> +// ^com + +// ax +// ^com Complete src/CompletePrioritize2.res 9:7 posCursor:[9:7] posNoWhite:[9:6] Found expr:[9:3->0:-1] Completable: Cpath Value[ax]-> diff --git a/analysis/tests/src/expected/Completion.res.txt b/analysis/tests/src/expected/Completion.res.txt index ccadf462f..d155e1f76 100644 --- a/analysis/tests/src/expected/Completion.res.txt +++ b/analysis/tests/src/expected/Completion.res.txt @@ -1,3 +1,471 @@ +module MyList = Belt.List +// MyList.m +// ^com +// Array. +// ^com +// Array.m +// ^com + +module Dep: { + @ocaml.doc("Some doc comment") @deprecated("Use customDouble instead") + let customDouble: int => int +} = { + let customDouble = foo => foo * 2 +} + +// let cc = Dep.c +// ^com + +module Lib = { + let foo = (~age, ~name) => name ++ string_of_int(age) + let next = (~number=0, ~year) => number + year +} + +// let x = Lib.foo(~ +// ^com + +// [1,2,3]->m +// ^com + +// "abc"->toU +// ^com + +let op = Some(3) + +// op->e +// ^com + +module ForAuto = { + type t = int + let abc = (x: t, _y: int) => x + let abd = (x: t, _y: int) => x +} + +let fa: ForAuto.t = 34 +// fa-> +// ^com + +// "hello"->Js.Dict.u +// ^com + +module O = { + module Comp = { + @react.component + let make = (~first="", ~zoo=3, ~second) => React.string(first ++ second ++ string_of_int(zoo)) + } +} + +let zzz = 11 + +// let comp = x + y + +@react.component +let make = () => { + // my + // ^com + <> +} + +// Objects.object[" +// ^com + +let foo = { + let x = { + 3 + } + let y = 4 + let add = (a, b) => + switch a { + | 3 => a + b + | _ => 42 + } + let z = assert(false) + let _ = z + module Inner = { + type z = int + let v = 44 + } + exception MyException(int, string, float, array) + let _ = raise(MyException(2, "", 1.0, [])) + add((x: Inner.z), Inner.v + y) +} + +exception MyOtherException + +// children +} +// } + let forAutoRecord: forAutoRecord = assert(false) +} + +module FAO = { + let forAutoObject = {"forAutoLabel": FAR.forAutoRecord, "age": 32} +} + +// FAO.forAutoObject[" +// ^com + +// FAO.forAutoObject["forAutoLabel"]. +// ^com + +// FAO.forAutoObject["forAutoLabel"].forAuto-> +// ^com + +// FAO.forAutoObject["forAutoLabel"].forAuto->ForAuto.a +// ^com + +let name = "abc" +// let template = `My name is ${na}` +// ^com + +let notHere = " " +// ^com + +let someR = Some(r) +let _ = switch someR { +| Some(_z) => 1 +// + _z. +// ^com +| _ => 3 +} + +module SomeLocalModule = { + let aa = 10 + let bb = 20 + type zz = int +} + +// let _ = SomeLo +// ^com +// type zz = SomeLocalModule. +// ^com + +type record = { + someProp: string, + // otherProp: SomeLocalModule. + // ^com + thirdProp: string, +} + +type someLocalVariant = SomeLocalVariantItem + +// type t = SomeLocal +// ^com + +// let _ : SomeLocal +// ^com + +let _foo = _world => { + // let _ = _w + // ^com + 3 +} + +type someType = {hello: string} +// type t = SomeType(s) +// ^com + +type funRecord = { + someFun: (~name: string) => unit, + stuff: string, +} + +let funRecord: funRecord = assert(false) + +// let _ = funRecord.someFun(~ ) +// ^com + +let retAA = () => {x: 3, name: ""} + +// retAA(). +// ^com + +let ff = (~opt1=0, ~a, ~b, (), ~opt2=0, (), ~c) => a + b + c + opt1 + opt2 + +// ff(~c=1)(~ +// ^com + +// ff(~c=1)()(~ +// ^com + +// ff(~c=1, ())(~ +// ^com + +// ff(~c=1, (), ())(~ +// ^com + +// ff(~c=1, (), ~b=1)(~ +// ^com + +// ff(~opt2=1)(~ +// ^com + +type callback = (~a: int) => int + +let withCallback: (~b: int) => callback = (~b) => { + () + (~a) => a + b +} + +// withCallback(~ +// ^com + +// withCallback(~a)(~ +// ^com + +// withCallback(~b)(~ +// ^com + +let _ = +
{ + () + // let _: Res + // ^com + }} + name="abc"> + {React.string(name)} +
+ +//let _ = switch Some(3) { | Some(thisIsNotSaved) -> this +// ^com + +let _ =
+// ^hov + +// let _ = FAO.forAutoObject["age"] +// ^hov + +// let _ = ff(~opt1=3) +// ^hov + +// (let _ = ff(~opt1=3)) +// ^com + +type v = This | That + +let _ = x => + switch x { + // | T + // ^com + | _ => 4 + } + +module AndThatOther = { + type v = And | ThatOther +} + +let _ = x => + switch x { + // | AndThatOther.T + // ^com + | _ => 4 + } + +// let _ = ` ${ForAuto.}` +// ^com + +// let _ = `abc ${FAO.forAutoObject[""}` +// ^com + +// let _ = `${funRecord.}` +// ^com + +let _ = _ => { + open Js + // []->ma + // ^com + () +} + +let red = "#ff0000" + +let header1 = ` + color: ${red}; ` +// ^com + +let header2 = ` + color: ${red}; + background-color: ${red}; ` +// ^com + +// let _ = `color: ${r +// ^com + +let onClick = evt => { + // SomeLocalModule. + // ^com + evt->ReactEvent.Synthetic.preventDefault + // SomeLocalModule. + // ^com + Js.log("Hello") +} + +// let _ = 123->t +// ^com + +// let _ = 123.0->t +// ^com + +let ok = Ok(true) + +// ok->g +// ^com + +type someRecordWithDeprecatedField = { + name: string, + @deprecated + someInt: int, + @deprecated("Use 'someInt'.") + someFloat: float, +} + +let rWithDepr: someRecordWithDeprecatedField = { + name: "hej", + someInt: 12, + someFloat: 12., +} + +// Should show deprecated status +// rWithDepr.so +// ^com + +type someVariantWithDeprecated = + | @deprecated DoNotUseMe | UseMeInstead | @deprecated("Use 'UseMeInstead'") AndNotMe + +// Should show deprecated status +// let v: someVariantWithDeprecated = +// ^com + +let uncurried = (. num) => num + 2 + +// let _ = uncurried(. 1)->toS +// ^com + +type withUncurried = {fn: (. int) => unit} + +// let f: withUncurried = {fn: } +// ^com + +// let someRecord = { FAR. } +// ^com Complete src/Completion.res 1:11 posCursor:[1:11] posNoWhite:[1:10] Found expr:[1:3->1:11] Pexp_ident MyList.m:[1:3->1:11] diff --git a/analysis/tests/src/expected/CompletionAttributes.res.txt b/analysis/tests/src/expected/CompletionAttributes.res.txt index 3fa299ef7..ae0cbabce 100644 --- a/analysis/tests/src/expected/CompletionAttributes.res.txt +++ b/analysis/tests/src/expected/CompletionAttributes.res.txt @@ -1,3 +1,42 @@ +// @modu +// ^com + +// @module("") external doStuff: t = "test" +// ^com + +// @@js +// ^com + +// @@jsxConfig({}) +// ^com + +// @@jsxConfig({m}) +// ^com + +// @@jsxConfig({module_: }) +// ^com + +// @@jsxConfig({module_: "", }) +// ^com + +// @module({}) external doStuff: t = "default" +// ^com + +// @module({with: }) external doStuff: t = "default" +// ^com + +// @module({with: {}}) external doStuff: t = "default" +// ^com + +// @module({from: "" }) external doStuff: t = "default" +// ^com + +// @module({from: }) external doStuff: t = "default" +// ^com + +// let dd = %t +// ^com + Complete src/CompletionAttributes.res 0:8 Attribute id:modu:[0:3->0:8] label:modu Completable: Cdecorator(modu) diff --git a/analysis/tests/src/expected/CompletionDicts.res.txt b/analysis/tests/src/expected/CompletionDicts.res.txt index c3a423d50..0755fdb8e 100644 --- a/analysis/tests/src/expected/CompletionDicts.res.txt +++ b/analysis/tests/src/expected/CompletionDicts.res.txt @@ -1,3 +1,19 @@ +// let dict = Js.Dict.fromArray([]) +// ^com + +// let dict = Js.Dict.fromArray([()]) +// ^com + +// let dict = Js.Dict.fromArray([("key", )]) +// ^com + +// ^in+ +let dict = Js.Dict.fromArray([ + ("key", true), + // ("key2", ) + // ^com +]) +// ^in- Complete src/CompletionDicts.res 0:33 posCursor:[0:33] posNoWhite:[0:32] Found expr:[0:14->0:35] Pexp_apply ...[0:14->0:31] (...[0:32->0:34]) diff --git a/analysis/tests/src/expected/CompletionExpressions.res.txt b/analysis/tests/src/expected/CompletionExpressions.res.txt index 1cddba3b7..343473fa3 100644 --- a/analysis/tests/src/expected/CompletionExpressions.res.txt +++ b/analysis/tests/src/expected/CompletionExpressions.res.txt @@ -1,3 +1,367 @@ +let s = true +let f = Some([false]) + +// switch (s, f) { | } +// ^com + +type otherRecord = { + someField: int, + otherField: string, +} + +type rec someRecord = { + age: int, + offline: bool, + online: option, + variant: someVariant, + polyvariant: somePolyVariant, + nested: option, +} +and someVariant = One | Two | Three(int, string) +and somePolyVariant = [#one | #two(bool) | #three(someRecord, bool)] + +let fnTakingRecord = (r: someRecord) => { + ignore(r) +} + +// let _ = fnTakingRecord({}) +// ^com + +// let _ = fnTakingRecord({n}) +// ^com + +// let _ = fnTakingRecord({offline: }) +// ^com + +// let _ = fnTakingRecord({age: 123, }) +// ^com + +// let _ = fnTakingRecord({age: 123, offline: true}) +// ^com + +// let _ = fnTakingRecord({age: 123, nested: }) +// ^com + +// let _ = fnTakingRecord({age: 123, nested: {}}) +// ^com + +// let _ = fnTakingRecord({age: 123, nested: Some({})}) +// ^com + +// let _ = fnTakingRecord({age: 123, variant: }) +// ^com + +// let _ = fnTakingRecord({age: 123, variant: O }) +// ^com + +// let _ = fnTakingRecord({age: 123, polyvariant: #three() }) +// ^com + +// let _ = fnTakingRecord({age: 123, polyvariant: #three({}, ) }) +// ^com + +// let _ = fnTakingRecord({age: 123, polyvariant: #three({}, t) }) +// ^com + +let fnTakingArray = (arr: array>) => { + ignore(arr) +} + +// let _ = fnTakingArray() +// ^com + +// let _ = fnTakingArray([]) +// ^com + +// let _ = fnTakingArray(s) +// ^com + +// let _ = fnTakingArray([Some()]) +// ^com + +// let _ = fnTakingArray([None, ]) +// ^com + +// let _ = fnTakingArray([None, , None]) +// ^com + +let someBoolVar = true + +// let _ = fnTakingRecord({offline: so }) +// ^com + +let fnTakingOtherRecord = (r: otherRecord) => { + ignore(r) +} + +// let _ = fnTakingOtherRecord({otherField: }) +// ^com + +type recordWithOptionalField = { + someField: int, + someOptField?: bool, +} + +let fnTakingRecordWithOptionalField = (r: recordWithOptionalField) => { + ignore(r) +} + +// let _ = fnTakingRecordWithOptionalField({someOptField: }) +// ^com +type recordWithOptVariant = {someVariant: option} + +let fnTakingRecordWithOptVariant = (r: recordWithOptVariant) => { + ignore(r) +} + +// let _ = fnTakingRecordWithOptVariant({someVariant: }) +// ^com + +type variantWithInlineRecord = + WithInlineRecord({someBoolField: bool, otherField: option, nestedRecord: otherRecord}) + +let fnTakingInlineRecord = (r: variantWithInlineRecord) => { + ignore(r) +} + +// let _ = fnTakingInlineRecord(WithInlineRecord()) +// ^com + +// let _ = fnTakingInlineRecord(WithInlineRecord({})) +// ^com + +// let _ = fnTakingInlineRecord(WithInlineRecord({s})) +// ^com + +// let _ = fnTakingInlineRecord(WithInlineRecord({nestedRecord: })) +// ^com + +// let _ = fnTakingInlineRecord(WithInlineRecord({nestedRecord: {} })) +// ^com + +type variant = First | Second(bool) + +let fnTakingCallback = ( + cb: unit => unit, + cb2: bool => unit, + cb3: ReactEvent.Mouse.t => unit, + cb4: (~on: bool, ~off: bool=?, variant) => int, + cb5: (bool, option, bool) => unit, + cb6: (~on: bool=?, ~off: bool=?, unit) => int, +) => { + let _ = cb + let _ = cb2 + let _ = cb3 + let _ = cb4 + let _ = cb5 + let _ = cb6 +} + +// fnTakingCallback() +// ^com + +// fnTakingCallback(a) +// ^com + +// fnTakingCallback(a, ) +// ^com + +// fnTakingCallback(a, b, ) +// ^com + +// fnTakingCallback(a, b, c, ) +// ^com + +// fnTakingCallback(a, b, c, d, ) +// ^com + +// fnTakingCallback(a, b, c, d, e, ) +// ^com + +let something = { + let second = true + let second2 = 1 + ignore(second) + ignore(second2) + Js.log(s) + // ^com +} + +let fff: recordWithOptionalField = { + someField: 123, + someOptField: true, +} + +ignore(fff) + +// fff.someOpt +// ^com + +type someTyp = {test: bool} + +let takesCb = cb => { + cb({test: true}) +} + +// takesCb() +// ^com + +module Environment = { + type t = {hello: bool} +} + +let takesCb2 = cb => { + cb({Environment.hello: true}) +} + +// takesCb2() +// ^com + +type apiCallResult = {hi: bool} + +let takesCb3 = cb => { + cb({hi: true}) +} + +// takesCb3() +// ^com + +let takesCb4 = cb => { + cb(Some({hi: true})) +} + +// takesCb4() +// ^com + +let takesCb5 = cb => { + cb([Some({hi: true})]) +} + +// takesCb5() +// ^com + +module RecordSourceSelectorProxy = { + type t +} + +@val +external commitLocalUpdate: (~updater: RecordSourceSelectorProxy.t => unit) => unit = + "commitLocalUpdate" + +// commitLocalUpdate(~updater=) +// ^com + +let fnTakingAsyncCallback = (cb: unit => promise) => { + let _ = cb +} + +// fnTakingAsyncCallback() +// ^com + +let arr = ["hello"] + +// arr->Belt.Array.map() +// ^com + +type exoticPolyvariant = [#"some exotic"] + +let takesExotic = (e: exoticPolyvariant) => { + ignore(e) +} + +// takesExotic() +// ^com + +let fnTakingPolyVariant = (a: somePolyVariant) => { + ignore(a) +} + +// fnTakingPolyVariant() +// ^com + +// fnTakingPolyVariant(#) +// ^com + +// fnTakingPolyVariant(#o) +// ^com + +// fnTakingPolyVariant(o) +// ^com + +module SuperInt: { + type t + let increment: (t, int) => t + let decrement: (t, int => int) => t + let make: int => t + let toInt: t => int +} = { + type t = int + let increment = (t, num) => t + num + let decrement = (t, decrementer) => decrementer(t) + let make = t => t + let toInt = t => t +} + +type withIntLocal = {superInt: SuperInt.t} + +// let withInt: withIntLocal = {superInt: } +// ^com + +// CompletionSupport.makeTestHidden() +// ^com + +open CompletionSupport +// CompletionSupport.makeTestHidden() +// ^com + +let mkStuff = (r: Js.Re.t) => { + ignore(r) + "hello" +} + +// mkStuff() +// ^com + +module Money: { + type t + + let zero: t + + let nonTType: string + + let make: unit => t + + let fromInt: int => t + + let plus: (t, t) => t +} = { + type t = string + + let zero: t = "0" + + let nonTType = "0" + + let make = (): t => zero + + let fromInt = (int): t => int->Js.Int.toString + + let plus = (m1, _) => m1 +} + +let tArgCompletionTestFn = (_tVal: Money.t) => () + +// tArgCompletionTestFn() +// ^com + +let labeledTArgCompletionTestFn = (~tVal as _: Money.t) => () + +// labeledTArgCompletionTestFn(~tVal=) +// ^com + +let someTyp: someTyp = {test: true} + +// switch someTyp. { | _ => () } +// ^com Complete src/CompletionExpressions.res 3:20 XXX Not found! Completable: Cpattern CTuple(Value[s], Value[f]) diff --git a/analysis/tests/src/expected/CompletionFunctionArguments.res.txt b/analysis/tests/src/expected/CompletionFunctionArguments.res.txt index b84d25a27..98dd8dc1d 100644 --- a/analysis/tests/src/expected/CompletionFunctionArguments.res.txt +++ b/analysis/tests/src/expected/CompletionFunctionArguments.res.txt @@ -1,3 +1,128 @@ +let someFn = (~isOn, ~isOff=false, ()) => { + if isOn && !isOff { + "on" + } else { + "off" + } +} + +let tLocalVar = false + +// let _ = someFn(~isOn=) +// ^com + +// let _ = someFn(~isOn=t) +// ^com + +// let _ = someFn(~isOff=) +// ^com + +let _ = + someFn( + ~isOn={ + // switch someFn(~isOn=) + // ^com + true + }, + ... + ) + +let someOtherFn = (includeName, age, includeAge) => { + "Hello" ++ + (includeName ? " Some Name" : "") ++ + ", you are age " ++ + Belt.Int.toString(includeAge ? age : 0) +} + +// let _ = someOtherFn(f) +// ^com + +module OIncludeMeInCompletions = {} + +type someVariant = One | Two | Three(int, string) + +let someFnTakingVariant = ( + configOpt: option, + ~configOpt2=One, + ~config: someVariant, +) => { + ignore(config) + ignore(configOpt) + ignore(configOpt2) +} + +// let _ = someFnTakingVariant(~config=) +// ^com + +// let _ = someFnTakingVariant(~config=O) +// ^com + +// let _ = someFnTakingVariant(So) +// ^com + +// let _ = someFnTakingVariant(~configOpt2=O) +// ^com + +// let _ = someOtherFn() +// ^com + +// let _ = someOtherFn(1, 2, ) +// ^com + +// let _ = 1->someOtherFn(1, t) +// ^com + +let fnTakingTuple = (arg: (int, int, float)) => { + ignore(arg) +} + +// let _ = fnTakingTuple() +// ^com + +type someRecord = { + age: int, + offline: bool, + online: option, +} + +let fnTakingRecord = (r: someRecord) => { + ignore(r) +} + +// let _ = fnTakingRecord({}) +// ^com + +module FineModule = { + type t = { + online: bool, + somethingElse: string, + } + + let setToFalse = (t: t) => { + ...t, + online: false, + } +} + +let _ = +
{ + let reassignedWorks = thisGetsBrokenLoc + ignore(reassignedWorks) + // thisGetsBrokenLoc->a + // ^com + // reassignedWorks->a + // ^com + }} + /> + +let fineModuleVal = { + FineModule.online: true, + somethingElse: "", +} + +// makeItem(~changefreq=Monthly, ~lastmod=fineModuleVal->, ~priority=Low) +// ^com Complete src/CompletionFunctionArguments.res 10:24 posCursor:[10:24] posNoWhite:[10:23] Found expr:[10:11->10:25] Pexp_apply ...[10:11->10:17] (~isOn10:19->10:23=...__ghost__[0:-1->0:-1]) diff --git a/analysis/tests/src/expected/CompletionInferValues.res.txt b/analysis/tests/src/expected/CompletionInferValues.res.txt index 356a23819..493c6b217 100644 --- a/analysis/tests/src/expected/CompletionInferValues.res.txt +++ b/analysis/tests/src/expected/CompletionInferValues.res.txt @@ -1,3 +1,172 @@ +let getBool = () => true +let getInt = () => 123 + +type someRecord = {name: string, age: int} + +let someFnWithCallback = (cb: (~num: int, ~someRecord: someRecord, ~isOn: bool) => unit) => { + let _ = cb +} + +let reactEventFn = (cb: ReactEvent.Mouse.t => unit) => { + let _ = cb +} + +@val external getSomeRecord: unit => someRecord = "getSomeRecord" + +// let x = 123; let aliased = x; aliased->f +// ^com + +// let x = getSomeRecord(); x. +// ^com + +// let x = getSomeRecord(); let aliased = x; aliased. +// ^com + +// someFnWithCallback((~someRecord, ~num, ~isOn) => someRecord.) +// ^com + +// let aliasedFn = someFnWithCallback; aliasedFn((~num, ~someRecord, ~isOn) => someRecord.) +// ^com + +// reactEventFn(event => { event->pr }); +// ^com + +module Div = { + @react.component + let make = (~onMouseEnter: option unit>=?) => { + let _ = onMouseEnter + React.null + } +} + +// let _ =
{ event->pr }} /> +// ^com + +// let _ =
{ event->pr }} /> +// ^com + +// let _ =
{ let btn = event->JsxEvent.Mouse.button; btn->t }} /> +// ^com + +// let _ =
{ let btn = event->JsxEvent.Mouse.button->Belt.Int.toString; btn->spl }} /> +// ^com + +// let _ =
{ let btn = event->JsxEvent.Mouse.button->Belt.Int.toString->Js.String2.split("/"); btn->ma }} /> +// ^com + +// let x: someRecord = {name: "Hello", age: 123}; x. +// ^com + +type someVariant = One | Two | Three(int, string) +type somePolyVariant = [#one | #two | #three(int, string)] +type someNestedRecord = {someRecord: someRecord} + +type someRecordWithNestedStuff = { + things: string, + someInt: int, + srecord: someRecord, + nested: someNestedRecord, + someStuff: bool, +} + +type otherNestedRecord = { + someRecord: someRecord, + someTuple: (someVariant, int, somePolyVariant), + optRecord: option, +} + +// Destructure record +// let x: someRecordWithNestedStuff = Obj.magic(); let {srecord} = x; srecord. +// ^com + +// Follow aliased +// let x: someRecordWithNestedStuff = Obj.magic(); let {nested: aliased} = x; aliased. +// ^com + +// Follow nested record +// let x: someRecordWithNestedStuff = Obj.magic(); let {srecord, nested: {someRecord}} = x; someRecord. +// ^com + +// Destructure string +// let x: someRecordWithNestedStuff = Obj.magic(); let {things} = x; things->slic +// ^com + +// Destructure int +// let x: someRecordWithNestedStuff = Obj.magic(); let {someInt} = x; someInt->toS +// ^com + +// Follow tuples +// let x: otherNestedRecord = Obj.magic(); let {someTuple} = x; let (_, someInt, _) = someTuple; someInt->toS +// ^com + +// Same as above, but follow in switch case +// let x: otherNestedRecord; switch x { | {someTuple} => let (_, someInt, _) = someTuple; someInt->toS } +// ^com + +// Follow variant payloads +// let x: otherNestedRecord; switch x { | {someTuple:(Three(_, str), _, _)} => str->slic } +// ^com + +// Follow polyvariant payloads +// let x: otherNestedRecord; switch x { | {someTuple:(_, _, #three(_, str))} => str->slic } +// ^com + +// Follow options +// let x: otherNestedRecord; switch x { | {optRecord:Some({name})} => name->slic } +// ^com + +// Follow arrays +// let x: array; switch x { | [inner] => inner.s } +// ^com + +// Infer top level return +// let x = 123; switch x { | 123 => () | v => v->toSt } +// ^com + +let fnWithRecordCallback = (cb: someRecord => unit) => { + let _ = cb +} + +// Complete pattern of function parameter +// fnWithRecordCallback(({}) => {()}) +// ^com + +let fn2 = (~cb: CompletionSupport.Nested.config => unit) => { + let _ = cb +} + +// fn2(~cb=({root}) => {root-> }) +// ^com + +type sameFileRecord = {root: CompletionSupport.Test.t, test: int} + +let fn3 = (~cb: sameFileRecord => unit) => { + let _ = cb +} + +// fn3(~cb=({root}) => {root-> }) +// ^com + +// Handles pipe chains as input for switch +// let x = 123; switch x->Belt.Int.toString { | } +// ^com + +// Handles pipe chains as input for switch +// let x = 123; switch x->Belt.Int.toString->Js.String2.split("/") { | } +// ^com + +// Regular completion works +// let renderer = CompletionSupport2.makeRenderer(~prepare=() => "hello",~render=({support}) => {support.},()) +// ^com + +// But pipe completion gets the wrong completion path. Should be `ReactDOM.Client.Root.t`, but ends up being `CompletionSupport2.ReactDOM.Client.Root.t`. +// let renderer = CompletionSupport2.makeRenderer(~prepare=() => "hello",~render=({support:{root}}) => {root->},()) +// ^com + +// Handles reusing the same name already in scope for bindings +let res = 1 +// switch res { | res => res } +// ^hov Complete src/CompletionInferValues.res 15:43 posCursor:[15:43] posNoWhite:[15:42] Found expr:[15:33->15:43] Completable: Cpath Value[aliased]->f diff --git a/analysis/tests/src/expected/CompletionJsx.res.txt b/analysis/tests/src/expected/CompletionJsx.res.txt index 65c5e9e89..f6da05726 100644 --- a/analysis/tests/src/expected/CompletionJsx.res.txt +++ b/analysis/tests/src/expected/CompletionJsx.res.txt @@ -1,3 +1,94 @@ +let someString = "hello" +ignore(someString) + +// someString->st +// ^com + +module SomeComponent = { + @react.component + let make = (~someProp) => { + let someInt = 12 + let someArr = [React.null] + ignore(someInt) + ignore(someArr) + // someString->st + // ^com +
+ {React.string(someProp)} +
{React.null}
+ // {someString->st} + // ^com + // {"Some string"->st} + // ^com + // {"Some string"->Js.String2.trim->st} + // ^com + // {someInt->} + // ^com + // {12->} + // ^com + // {someArr->a} + // ^com + // + } +} + +module CompWithoutJsxPpx = { + type props = {name: string} + + let make = ({name}) => { + ignore(name) + React.null + } +} + +// +// ^com + +//

Jsx.element = "createElement" +} + +// { + ignore(time) + name ++ age + } +} + +// { + React.string((_type :> string)) + } +} + +// +// ^com Complete src/CompletionJsx.res 3:17 posCursor:[3:17] posNoWhite:[3:16] Found expr:[3:3->3:17] Completable: Cpath Value[someString]->st diff --git a/analysis/tests/src/expected/CompletionJsxProps.res.txt b/analysis/tests/src/expected/CompletionJsxProps.res.txt index 7175c70e4..69d6ba6e0 100644 --- a/analysis/tests/src/expected/CompletionJsxProps.res.txt +++ b/analysis/tests/src/expected/CompletionJsxProps.res.txt @@ -1,3 +1,49 @@ +// let _ = +// ^com + +// let _ =
+// ^com + +// Should wrap in {} +// let _ = Js.import(CompletableComponent.make) + let make = React.lazy_(loadComponent) +} + +// let _ = 0:47] JSX 0:43] on[0:44->0:46]=...__ghost__[0:-1->0:-1]> _children:None diff --git a/analysis/tests/src/expected/CompletionPattern.res.txt b/analysis/tests/src/expected/CompletionPattern.res.txt index 99b8b188d..2c61e7dc4 100644 --- a/analysis/tests/src/expected/CompletionPattern.res.txt +++ b/analysis/tests/src/expected/CompletionPattern.res.txt @@ -1,3 +1,235 @@ +let v = (true, Some(false), (true, true)) + +let _ = switch v { +| (true, _, _) => 1 +| _ => 2 +} + +// switch v { +// ^com + +// switch v { | } +// ^com + +// switch v { | (t, _) } +// ^com + +// switch v { | (_, _, (f, _)) } +// ^com + +let x = true + +// switch x { | +// ^com + +// switch x { | t +// ^com + +type nestedRecord = {nested: bool} + +type rec someRecord = { + first: int, + second: (bool, option), + optThird: option<[#first | #second(someRecord)]>, + nest: nestedRecord, +} + +let f: someRecord = { + first: 123, + second: (true, None), + optThird: None, + nest: {nested: true}, +} + +let z = (f, true) +ignore(z) + +// switch f { | } +// ^com + +// switch f { | {}} +// ^com + +// switch f { | {first, , second }} +// ^com + +// switch f { | {fi}} +// ^com + +// switch z { | ({o}, _)} +// ^com + +// switch f { | {nest: }} +// ^com + +// switch f { | {nest: {}}} +// ^com + +let _ = switch f { +| {first: 123, nest} => + () + // switch nest { | {}} + // ^com + nest.nested +| _ => false +} + +// let {} = f +// ^com + +// let {nest: {n}}} = f +// ^com + +type someVariant = One | Two(bool) | Three(someRecord, bool) + +let z = Two(true) +ignore(z) + +// switch z { | Two()} +// ^com + +// switch z { | Two(t)} +// ^com + +// switch z { | Three({})} +// ^com + +// switch z { | Three({}, t)} +// ^com + +type somePolyVariant = [#one | #two(bool) | #three(someRecord, bool)] +let b: somePolyVariant = #two(true) +ignore(b) + +// switch b { | #two()} +// ^com + +// switch b { | #two(t)} +// ^com + +// switch b { | #three({})} +// ^com + +// switch b { | #three({}, t)} +// ^com + +let c: array = [] +ignore(c) + +// switch c { | } +// ^com + +// switch c { | [] } +// ^com + +let o = Some(true) +ignore(o) + +// switch o { | Some() } +// ^com + +type multiPayloadVariant = Test(int, bool, option, array) + +let p = Test(1, true, Some(false), []) + +// switch p { | Test(1, )} +// ^com + +// switch p { | Test(1, true, )} +// ^com + +// switch p { | Test(1, , None)} +// ^com + +// switch p { | Test(1, true, None, )} +// ^com + +type multiPayloadPolyVariant = [#test(int, bool, option, array)] + +let v: multiPayloadPolyVariant = #test(1, true, Some(false), []) + +// switch v { | #test(1, )} +// ^com + +// switch v { | #test(1, true, )} +// ^com + +// switch v { | #test(1, , None)} +// ^com + +// switch v { | #test(1, true, None, )} +// ^com + +let s = (true, Some(true), [false]) + +// switch s { | () } +// ^com + +// switch s { | (true, ) } +// ^com + +// switch s { | (true, , []) } +// ^com + +// switch s { | (true, []) => () | } +// ^com + +// switch s { | (true, []) => () | (true, , []) } +// ^com + +// switch z { | One | } +// ^com + +// switch z { | One | Two(true | ) } +// ^com + +// switch z { | One | Three({test: true}, true | ) } +// ^com + +// switch b { | #one | #two(true | ) } +// ^com + +// switch b { | #one | #three({test: true}, true | ) } +// ^com + +// switch s { | (true, _, []) } +// ^com + +type recordWithFn = {someFn: unit => unit} + +let ff: recordWithFn = {someFn: () => ()} + +// switch ff { | {someFn: }} +// ^com + +let xn: exn = Obj.magic() + +// switch xn { | } +// ^com + +let getThing = async () => One + +// switch await getThing() { | } +// ^com + +let res: result = Ok(One) + +// switch res { | Ok() } +// ^com + +// switch res { | Error() } +// ^com + +@react.component +let make = (~thing: result) => { + switch thing { + | Ok(Three(r, _)) => + let _x = r + // switch r { | {first, }} + // ^com + | _ => () + } +} Complete src/CompletionPattern.res 7:13 posCursor:[7:13] posNoWhite:[7:12] Found expr:[7:3->7:13] [] diff --git a/analysis/tests/src/expected/CompletionPipeChain.res.txt b/analysis/tests/src/expected/CompletionPipeChain.res.txt index 91f6ca0e1..bf583c6e0 100644 --- a/analysis/tests/src/expected/CompletionPipeChain.res.txt +++ b/analysis/tests/src/expected/CompletionPipeChain.res.txt @@ -1,3 +1,108 @@ +module Integer: { + type t + let increment: (t, int) => t + let decrement: (t, int => int) => t + let make: int => t + let toInt: t => int +} = { + type t = int + let increment = (t, num) => t + num + let decrement = (t, decrementer) => decrementer(t) + let make = t => t + let toInt = t => t +} + +module SuperFloat: { + type t + let fromInteger: Integer.t => t + let toInteger: t => Integer.t +} = { + type t = float + let fromInteger = t => t->Integer.toInt->Belt.Float.fromInt + let toInteger = t => t->Belt.Float.toInt->Integer.make +} + +let toFlt = i => i->SuperFloat.fromInteger +let int = Integer.make(1) +let f = int->Integer.increment(2) +// let _ = int-> +// ^com + +// let _ = int->toFlt-> +// ^com + +// let _ = int->Integer.increment(2)-> +// ^com + +// let _ = Integer.increment(int, 2)-> +// ^com + +// let _ = int->Integer.decrement(t => t - 1)-> +// ^com + +// let _ = int->Integer.increment(2)->Integer.decrement(t => t - 1)-> +// ^com + +// let _ = int->Integer.increment(2)->SuperFloat.fromInteger-> +// ^com + +// let _ = int->Integer.increment(2)->SuperFloat.fromInteger->t +// ^com + +// let _ = int->Integer.increment(2)->Integer.toInt->CompletionSupport.Test.make-> +// ^com + +// let _ = CompletionSupport.Test.make(1)->CompletionSupport.Test.addSelf(2)-> +// ^com + +let _ = [123]->Js.Array2.forEach(v => Js.log(v)) +// -> +// ^com + +let _ = [123]->Belt.Array.reduce(0, (acc, curr) => acc + curr) +// ->t +// ^com + +type aliasedType = CompletionSupport.Test.t + +let aliased: aliasedType = {name: 123} +let notAliased: CompletionSupport.Test.t = {name: 123} + +// aliased-> +// ^com + +// notAliased-> +// ^com + +let renderer = CompletionSupport2.makeRenderer( + ~prepare=() => "hello", + ~render=props => { + ignore(props) + + // Doesn't work when tried through this chain. Presumably because it now goes through multiple different files. + // props.support.root->ren + // ^com + let root = props.support.root + ignore(root) + + // Works here though when it's lifted out. Probably because it only goes through one file...? + // root->ren + // ^com + React.null + }, + (), +) + +// Console.log(int->) +// ^com + +// Console.log(int->t) +// ^com + +let r = %re("/t/g") + +// r->la +// ^com Complete src/CompletionPipeChain.res 27:16 posCursor:[27:16] posNoWhite:[27:15] Found expr:[27:11->0:-1] Completable: Cpath Value[int]-> diff --git a/analysis/tests/src/expected/CompletionPipeSubmodules.res.txt b/analysis/tests/src/expected/CompletionPipeSubmodules.res.txt index 73f9ab4a5..98f964fe1 100644 --- a/analysis/tests/src/expected/CompletionPipeSubmodules.res.txt +++ b/analysis/tests/src/expected/CompletionPipeSubmodules.res.txt @@ -1,3 +1,48 @@ +module A = { + module B1 = { + type b1 = B1 + let xx = B1 + } + module B2 = { + let yy = 20 + } + type t = {v: B1.b1} + let x = {v: B1.B1} +} + +// let _ = A.B1.xx-> +// ^com +// b1 seen from B1 is A.B1.b1 + +// let _ = A.x.v-> +// ^com +// B1.b1 seen from A is A.B1.b1 + +module C = { + type t = C +} + +module D = { + module C2 = { + type t2 = C2 + } + + type d = {v: C.t, v2: C2.t2} + let d = {v: C.C, v2: C2.C2} +} + +module E = { + type e = {v: D.d} + let e = {v: D.d} +} + +// let _ = E.e.v.v-> +// ^com +// C.t seen from D is C.t + +// let _ = E.e.v.v2-> +// ^com +// C2.t2 seen from D is D.C2.t2 Complete src/CompletionPipeSubmodules.res 12:20 posCursor:[12:20] posNoWhite:[12:19] Found expr:[12:11->20:8] Completable: Cpath Value[A, B1, xx]-> diff --git a/analysis/tests/src/expected/CompletionResolve.res.txt b/analysis/tests/src/expected/CompletionResolve.res.txt index d0492d217..b242f0f81 100644 --- a/analysis/tests/src/expected/CompletionResolve.res.txt +++ b/analysis/tests/src/expected/CompletionResolve.res.txt @@ -1,3 +1,7 @@ +// ^cre Belt_Array + +// ^cre ModuleStuff + Completion resolve: Belt_Array "\nUtilities for `Array` functions.\n\n### Note about index syntax\n\nCode like `arr[0]` does *not* compile to JavaScript `arr[0]`. Reason transforms\nthe `[]` index syntax into a function: `Array.get(arr, 0)`. By default, this\nuses the default standard library's `Array.get` function, which may raise an\nexception if the index isn't found. If you `open Belt`, it will use the\n`Belt.Array.get` function which returns options instead of raising exceptions. \n[See this for more information](../belt.mdx#array-access-runtime-safety).\n" diff --git a/analysis/tests/src/expected/CompletionSupport.res.txt b/analysis/tests/src/expected/CompletionSupport.res.txt index e69de29bb..3c15a0a97 100644 --- a/analysis/tests/src/expected/CompletionSupport.res.txt +++ b/analysis/tests/src/expected/CompletionSupport.res.txt @@ -0,0 +1,42 @@ +module Test = { + type t = {name: int} + let add = (ax: t) => ax.name + 1 + let addSelf = (ax: t) => {name: ax.name + 1} + let make = (name: int): t => {name: name} +} + +module TestHidden: { + type t + let make: int => t + let self: t => t +} = { + type t = {name: int} + let make = (name: int): t => {name: name} + let self = t => t +} + +type testVariant = One | Two | Three(int) + +module TestComponent = { + @react.component + let make = ( + ~on: bool, + ~test: testVariant, + ~testArr: array, + ~polyArg: option<[#one | #two | #two2 | #three(int, bool)]>=?, + ) => { + ignore(on) + ignore(test) + ignore(testArr) + ignore(polyArg) + React.null + } +} + +module Nested = { + type config = {root: ReactDOM.Client.Root.t} +} + +type options = {test: TestHidden.t} + +let makeTestHidden = t => TestHidden.self(t) diff --git a/analysis/tests/src/expected/CompletionSupport2.res.txt b/analysis/tests/src/expected/CompletionSupport2.res.txt index e69de29bb..925fc5d57 100644 --- a/analysis/tests/src/expected/CompletionSupport2.res.txt +++ b/analysis/tests/src/expected/CompletionSupport2.res.txt @@ -0,0 +1,17 @@ +module Internal = { + type prepareProps<'prepared> = { + someName: string, + support: CompletionSupport.Nested.config, + prepared: 'prepared, + } +} + +let makeRenderer = ( + ~prepare: unit => 'prepared, + ~render: Internal.prepareProps<'prepared> => React.element, + (), +) => { + let _ = prepare + let _ = render + "123" +} diff --git a/analysis/tests/src/expected/CompletionTypeAnnotation.res.txt b/analysis/tests/src/expected/CompletionTypeAnnotation.res.txt index b00084e7f..84bbce9f7 100644 --- a/analysis/tests/src/expected/CompletionTypeAnnotation.res.txt +++ b/analysis/tests/src/expected/CompletionTypeAnnotation.res.txt @@ -1,3 +1,60 @@ +type someRecord = { + age: int, + name: string, +} + +type someVariant = One | Two(bool) + +type somePolyVariant = [#one | #two(bool)] + +// let x: someRecord = +// ^com + +// let x: someRecord = {} +// ^com + +// let x: someVariant = +// ^com + +// let x: someVariant = O +// ^com + +// let x: somePolyVariant = +// ^com + +// let x: somePolyVariant = #o +// ^com + +type someFunc = (int, string) => bool + +// let x: someFunc = +// ^com + +type someTuple = (bool, option) + +// let x: someTuple = +// ^com + +// let x: someTuple = (true, ) +// ^com + +// let x: option = +// ^com + +// let x: option = Some() +// ^com + +// let x: array = +// ^com + +// let x: array = [] +// ^com + +// let x: array> = +// ^com + +// let x: option> = Some([]) +// ^com Complete src/CompletionTypeAnnotation.res 9:22 XXX Not found! Completable: Cexpression Type[someRecord] diff --git a/analysis/tests/src/expected/CompletionTypeT.res.txt b/analysis/tests/src/expected/CompletionTypeT.res.txt index 30c972299..8c7160939 100644 --- a/analysis/tests/src/expected/CompletionTypeT.res.txt +++ b/analysis/tests/src/expected/CompletionTypeT.res.txt @@ -1,3 +1,12 @@ +let date = Some(Js.Date.make()) + +type withDate = {date: Js.Date.t} + +// let x = switch date { | } +// ^com + +// let x: withDate = {date: } +// ^com Complete src/CompletionTypeT.res 4:26 XXX Not found! Completable: Cpattern Value[date] diff --git a/analysis/tests/src/expected/Component.res.txt b/analysis/tests/src/expected/Component.res.txt index e69de29bb..aa3f50cb0 100644 --- a/analysis/tests/src/expected/Component.res.txt +++ b/analysis/tests/src/expected/Component.res.txt @@ -0,0 +1,2 @@ +@react.component +let make = () => React.null diff --git a/analysis/tests/src/expected/Component.resi.txt b/analysis/tests/src/expected/Component.resi.txt index e69de29bb..1ca44ce26 100644 --- a/analysis/tests/src/expected/Component.resi.txt +++ b/analysis/tests/src/expected/Component.resi.txt @@ -0,0 +1,2 @@ +@react.component +let make: unit => React.element diff --git a/analysis/tests/src/expected/CreateInterface.res.txt b/analysis/tests/src/expected/CreateInterface.res.txt index 4e1212948..b7ae7894b 100644 --- a/analysis/tests/src/expected/CreateInterface.res.txt +++ b/analysis/tests/src/expected/CreateInterface.res.txt @@ -1,3 +1,148 @@ +// ^int + +type r = {name: string, age: int} + +let add = (~x, ~y) => x + y + +@react.component +let make = (~name) => React.string(name) + +module Other = { + @react.component + let otherComponentName = (~name) => React.string(name) +} + +module Mod = { + @react.component + let make = (~name) => React.string(name) +} + +module type ModTyp = { + @react.component + let make: (~name: string) => React.element +} + +@module("path") external dirname: string => string = "dirname" + +@module("path") @variadic +external join: array => string = "join" + +@val +external padLeft: ( + string, + @unwrap + [ + | #Str(string) + | #Int(int) + ], +) => string = "padLeft" + +@inline +let f1 = 10 + +@inline let f2 = "some string" + +@genType @inline +let f3 = 10 + +@genType @inline +let f4 = "some string" + +@genType @inline let f5 = 5.5 + +module RFS = { + @module("fs") + external readFileSync: ( + ~name: string, + @string + [ + | #utf8 + | @as("ascii") #useAscii + ], + ) => string = "readFileSync" +} + +module Functor = () => { + @react.component + let make = () => React.null +} + +module type FT = { + module Functor: ( + X: { + let a: int + @react.component + let make: (~name: string) => React.element + let b: int + }, + Y: ModTyp, + ) => + { + @react.component + let make: (~name: string) => React.element + } +} + +module NormaList = List +open Belt +module BeltList = List + +module type MT2 = ModTyp + +module rec RM: ModTyp = D +and D: ModTyp = Mod + +module type OptT = { + @react.component + let withOpt1: (~x: int=?, ~y: int) => int + + module type Opt2 = { + @react.component + let withOpt2: (~x: int=?, ~y: int) => int + } + + module type Opt3 = { + @react.component + let withOpt3: (~x: option, ~y: int) => int + } +} + +module Opt = { + @react.component + let withOpt1 = (~x=3, ~y) => x + y + + module Opt2 = { + @react.component + let withOpt2 = (~x: option=?, ~y: int) => + switch x { + | None => 0 + | Some(x) => x + } + + y + } + module type Opt2 = module type of Opt2 + + module Opt3 = { + @react.component + let withOpt3 = (~x: option, ~y: int) => + switch x { + | None => 0 + | Some(x) => x + } + + y + } + module type Opt3 = module type of Opt3 +} + +module Opt2: OptT = Opt +module Opt3 = Opt + +module Memo = { + @react.component + let make = (~name) => React.string(name) + + let make = React.memo(make) +} Create Interface src/CreateInterface.res type r = {name: string, age: int} let add: (~x: int, ~y: int) => int diff --git a/analysis/tests/src/expected/Cross.res.txt b/analysis/tests/src/expected/Cross.res.txt index 6f5ad3e43..ee0e6d11c 100644 --- a/analysis/tests/src/expected/Cross.res.txt +++ b/analysis/tests/src/expected/Cross.res.txt @@ -1,3 +1,44 @@ +let crossRef = References.x +// ^ref + +let crossRef2 = References.x + +module Ref = References + +let crossRef3 = References.x + +let crossRefWithInterface = ReferencesWithInterface.x +// ^ref + +let crossRefWithInterface2 = ReferencesWithInterface.x + +module RefWithInterface = ReferencesWithInterface + +let crossRefWithInterface3 = ReferencesWithInterface.x + +let _ = RenameWithInterface.x +// ^ren RenameWithInterfacePrime + +let _ = RenameWithInterface.x +// ^ren xPrime + +let typeDef = {TypeDefinition.item: "foobar"} +// ^typ + +let _ = DefinitionWithInterface.y +// ^def + +type defT = DefinitionWithInterface.t +// ^def + +type defT2 = DefinitionWithInterface.t +// ^typ + +// DefinitionWithInterface.a +// ^com + +let yy = DefinitionWithInterface.Inner.y +// ^def References src/Cross.res 0:17 [ {"uri": "Cross.res", "range": {"start": {"line": 0, "character": 15}, "end": {"line": 0, "character": 25}}}, diff --git a/analysis/tests/src/expected/Dce.res.txt b/analysis/tests/src/expected/Dce.res.txt index 58c835d7a..9ccb29cb4 100644 --- a/analysis/tests/src/expected/Dce.res.txt +++ b/analysis/tests/src/expected/Dce.res.txt @@ -1,3 +1,7 @@ +// Note: in test mode this only reports on src/dce + +// ^dce + DCE src/Dce.res issues:1 diff --git a/analysis/tests/src/expected/Debug.res.txt b/analysis/tests/src/expected/Debug.res.txt index 2f684865b..0e79eb379 100644 --- a/analysis/tests/src/expected/Debug.res.txt +++ b/analysis/tests/src/expected/Debug.res.txt @@ -1,3 +1,20 @@ +// turn on by adding this comment // ^db+ + +let _ = ShadowedBelt.List.map +// ^def + +open Js +module Before = { + open Belt + let _ = Id.getCmpInternal +} +module Inner = { + // eqN + // ^com + open List + let _ = map +} +// ^db- Definition src/Debug.res 2:27 {"uri": "ShadowedBelt.res", "range": {"start": {"line": 1, "character": 6}, "end": {"line": 1, "character": 9}}} diff --git a/analysis/tests/src/expected/Definition.res.txt b/analysis/tests/src/expected/Definition.res.txt index 69f87b41e..05eba14f8 100644 --- a/analysis/tests/src/expected/Definition.res.txt +++ b/analysis/tests/src/expected/Definition.res.txt @@ -1,3 +1,31 @@ +let xx = 10 + +let y = xx +// ^def + +module Inner = { + type tInner = int + let vInner = 34 +} + +type typeInner = Inner.tInner +// ^def + +// open Belt +let m1 = List.map +// ^hov + +open ShadowedBelt +let m2 = List.map +// ^hov + +let uncurried = (. x, y) => x + y + +uncurried(. 3, 12)->ignore +// ^hov + +uncurried(. 3, 12)->ignore +// ^def Definition src/Definition.res 2:8 {"uri": "Definition.res", "range": {"start": {"line": 0, "character": 4}, "end": {"line": 0, "character": 6}}} diff --git a/analysis/tests/src/expected/DefinitionWithInterface.res.txt b/analysis/tests/src/expected/DefinitionWithInterface.res.txt index f8d85032d..4a288ca1d 100644 --- a/analysis/tests/src/expected/DefinitionWithInterface.res.txt +++ b/analysis/tests/src/expected/DefinitionWithInterface.res.txt @@ -1,3 +1,15 @@ +let y = 4 +// ^def + +type t = int + +let aabbcc = 3 +let _ = aabbcc + +module Inner = { + let y = 100 + // ^def +} Definition src/DefinitionWithInterface.res 0:4 {"uri": "DefinitionWithInterface.resi", "range": {"start": {"line": 0, "character": 4}, "end": {"line": 0, "character": 5}}} diff --git a/analysis/tests/src/expected/DefinitionWithInterface.resi.txt b/analysis/tests/src/expected/DefinitionWithInterface.resi.txt index 10bc34339..c37da22b3 100644 --- a/analysis/tests/src/expected/DefinitionWithInterface.resi.txt +++ b/analysis/tests/src/expected/DefinitionWithInterface.resi.txt @@ -1,3 +1,12 @@ +let y: int +// ^def + +type t + +module Inner: { + let y: int + // ^def +} Definition src/DefinitionWithInterface.resi 0:4 {"uri": "DefinitionWithInterface.res", "range": {"start": {"line": 0, "character": 4}, "end": {"line": 0, "character": 5}}} diff --git a/analysis/tests/src/expected/Destructuring.res.txt b/analysis/tests/src/expected/Destructuring.res.txt index 86b03c313..76d78f933 100644 --- a/analysis/tests/src/expected/Destructuring.res.txt +++ b/analysis/tests/src/expected/Destructuring.res.txt @@ -1,3 +1,37 @@ +type x = {name: string, age: int} + +let x = {name: "123", age: 12} + +let {name} = x +// ^com + +// let {} = x +// ^com + +let f = (x: x) => { + let {name} = x + + // ^com + name +} + +let f2 = (x: x) => { + // let {} = x + // ^com + ignore(x) +} + +type recordWithOptField = { + someField: int, + someOptField?: bool, +} + +let x: recordWithOptField = { + someField: 123, +} + +// let {} = x +// ^com Complete src/Destructuring.res 4:11 posCursor:[4:11] posNoWhite:[4:9] Found pattern:[4:4->4:12] Completable: Cpattern Value[x]->recordBody diff --git a/analysis/tests/src/expected/Div.res.txt b/analysis/tests/src/expected/Div.res.txt index b5af0d5f6..f1f30190d 100644 --- a/analysis/tests/src/expected/Div.res.txt +++ b/analysis/tests/src/expected/Div.res.txt @@ -1,3 +1,8 @@ +let q =
+// ^hov + +//
{"contents": {"kind": "markdown", "value": "```rescript\n(\n string,\n ~props: ReactDOM_V3.domProps=?,\n array,\n) => React.element\n```\n\n---\n\n```\n \n```\n```rescript\ntype ReactDOM_V3.domProps = Props.domProps\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22ReactDOM_V3.res%22%2C57%2C2%5D)\n\n\n---\n\n```\n \n```\n```rescript\ntype React.element = Jsx.element\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22React.res%22%2C0%2C0%5D)\n"}} diff --git a/analysis/tests/src/expected/DocComments.res.txt b/analysis/tests/src/expected/DocComments.res.txt index 1f8ab304d..68943d50e 100644 --- a/analysis/tests/src/expected/DocComments.res.txt +++ b/analysis/tests/src/expected/DocComments.res.txt @@ -1,3 +1,52 @@ +@ns.doc(" Doc comment with a triple-backquote example + + ```res example + let a = 10 + /* + * stuff + */ + ``` +") +let docComment1 = 12 +// ^hov + +/** + Doc comment with a triple-backquote example + + ```res example + let a = 10 + /* + * stuff + */ + ``` +*/ +let docComment2 = 12 +// ^hov + +@ns.doc(" Doc comment with a triple-backquote example + + ```res example + let a = 10 + let b = 20 + ``` +") +let docCommentNoNested1 = 12 +// ^hov + +/** + Doc comment with a triple-backquote example + + ```res example + let a = 10 + let b = 20 + ``` +*/ +let docCommentNoNested2 = 12 +// ^hov + +/**New doc comment format*/ +let newDoc = 10 +// ^hov Hover src/DocComments.res 9:9 {"contents": {"kind": "markdown", "value": "```rescript\nint\n```\n---\n Doc comment with a triple-backquote example\\n \\n ```res example\\n let a = 10\\n /*\\n * stuff\\n */\\n ```\\n"}} diff --git a/analysis/tests/src/expected/DocumentSymbol.res.txt b/analysis/tests/src/expected/DocumentSymbol.res.txt index 5710a1d5e..b09cb65ac 100644 --- a/analysis/tests/src/expected/DocumentSymbol.res.txt +++ b/analysis/tests/src/expected/DocumentSymbol.res.txt @@ -1,3 +1,37 @@ +module MyList = Belt.List + +module Dep: { + @ocaml.doc("Some doc comment") @deprecated("Use customDouble instead") + let customDouble: int => int +} = { + let customDouble = foo => foo * 2 +} + +module Lib = { + let foo = (~age, ~name) => name ++ string_of_int(age) + let next = (~number=0, ~year) => number + year +} + +let op = Some(3) + +module ForAuto = { + type t = int + let abc = (x: t, _y: int) => x + let abd = (x: t, _y: int) => x +} + +let fa: ForAuto.t = 34 + +module O = { + module Comp = { + @react.component + let make = (~first="", ~zoo=3, ~second) => React.string(first ++ second ++ string_of_int(zoo)) + } +} + +let zzz = 11 + +//^doc DocumentSymbol src/DocumentSymbol.res [ { @@ -90,8 +124,8 @@ DocumentSymbol src/DocumentSymbol.res { "name": "make", "kind": 12, - "range": {"start": {"line": 27, "character": 4}, "end": {"line": 27, "character": 98}}, - "selectionRange": {"start": {"line": 27, "character": 4}, "end": {"line": 27, "character": 98}} + "range": {"start": {"line": 26, "character": 4}, "end": {"line": 27, "character": 98}}, + "selectionRange": {"start": {"line": 26, "character": 4}, "end": {"line": 27, "character": 98}} }] }] }, diff --git a/analysis/tests/src/expected/EnvCompletion.res.txt b/analysis/tests/src/expected/EnvCompletion.res.txt index 0c8ebef34..f03c50dda 100644 --- a/analysis/tests/src/expected/EnvCompletion.res.txt +++ b/analysis/tests/src/expected/EnvCompletion.res.txt @@ -1,3 +1,66 @@ +type things = One | Two +type things2 = Four | Five + +let res: EnvCompletionOtherFile.someResult = Okay(One) + +let use = (): EnvCompletionOtherFile.response => { + stuff: First, + res: Failure(""), +} + +// switch res { | } +// ^com + +// switch res { | Okay() } +// ^com + +// switch res { | Failure() } +// ^com + +// switch use() { | } +// ^com + +// switch use() { | {} } +// ^com + +// switch use() { | {stuff: } } +// ^com + +// switch use() { | {stuff: Second() } } +// ^com + +// switch use() { | {stuff: Second({}) } } +// ^com + +// switch use() { | {res: } } +// ^com + +// switch use() { | {res: Okay() } } +// ^com + +// switch use() { | {res: Okay(Second()) } } +// ^com + +// switch use() { | {res: Okay(Second({})) } } +// ^com + +let res2: EnvCompletionOtherFile.someRecord = { + name: "string", + theThing: Four, + theVariant: First, +} + +// switch res2 { | } +// ^com + +// switch res2 { | {} } +// ^com + +// switch res2 { | {theThing: } } +// ^com + +// switch res2 { | {theVariant: } } +// ^com Complete src/EnvCompletion.res 10:17 XXX Not found! Completable: Cpattern Value[res] diff --git a/analysis/tests/src/expected/EnvCompletionOtherFile.res.txt b/analysis/tests/src/expected/EnvCompletionOtherFile.res.txt index e69de29bb..1218b0010 100644 --- a/analysis/tests/src/expected/EnvCompletionOtherFile.res.txt +++ b/analysis/tests/src/expected/EnvCompletionOtherFile.res.txt @@ -0,0 +1,13 @@ +type someResult<'a, 'b> = Okay('a) | Failure('b) + +type r1 = {age: int} + +type theVariant = First | Second(r1) + +type someRecord<'thing> = { + name: string, + theThing: 'thing, + theVariant: theVariant, +} + +type response = {stuff: theVariant, res: someResult} diff --git a/analysis/tests/src/expected/ExhaustiveSwitch.res.txt b/analysis/tests/src/expected/ExhaustiveSwitch.res.txt index bf1cc8447..4e17fc809 100644 --- a/analysis/tests/src/expected/ExhaustiveSwitch.res.txt +++ b/analysis/tests/src/expected/ExhaustiveSwitch.res.txt @@ -1,3 +1,46 @@ +type someVariant = One | Two | Three(option) +type somePolyVariant = [#one | #two | #three(option) | #"exotic ident" | #"switch"] + +let withSomeVariant = One +let withSomePoly: somePolyVariant = #one +let someBool = true +let someOpt = Some(true) + +// switch withSomeVarian +// ^com + +// switch withSomePol +// ^com + +// switch someBoo +// ^com + +// switch someOp +// ^com + +type rcrd = {someVariant: someVariant} + +let getV = r => r.someVariant + +let x: rcrd = { + someVariant: One, +} + +let vvv = Some(x->getV) + +// switch x->getV +// ^xfm + +// x->getV +// ^xfm ^ + +// vvv +// ^xfm + +// ^ve+ 11.1 +// switch withSomeVarian +// ^com +// ^ve- Complete src/ExhaustiveSwitch.res 8:24 XXX Not found! Completable: CexhaustiveSwitch Value[withSomeVarian] diff --git a/analysis/tests/src/expected/Fragment.res.txt b/analysis/tests/src/expected/Fragment.res.txt index ae23ede19..fcf639615 100644 --- a/analysis/tests/src/expected/Fragment.res.txt +++ b/analysis/tests/src/expected/Fragment.res.txt @@ -1,3 +1,19 @@ +module SectionHeader = { + @react.component + let make = (~children) => children +} + +let z1 = + <> + {React.string("abc")} + +// ^hov + +let z2 = + <> + {React.string("abc")} + +// ^hov Hover src/Fragment.res 6:19 getLocItem #4: heuristic for within fragments: take make as makeProps does not work the type is not great but jump to definition works diff --git a/analysis/tests/src/expected/Highlight.res.txt b/analysis/tests/src/expected/Highlight.res.txt index a4ab8e142..d8cb8b146 100644 --- a/analysis/tests/src/expected/Highlight.res.txt +++ b/analysis/tests/src/expected/Highlight.res.txt @@ -1,3 +1,143 @@ +module M = { + module C = Component +} + +let _c = + +let _mc = + +let _d =
+ +let _d2 = +
+ {React.string("abc")} +
{React.string("abc")}
+ {React.string("abc")} + {React.string("abc")} +
+ +type pair<'x, 'y> = ('x, 'y) + +type looooooooooooooooooooooooooooooooooooooong_int = int + +type looooooooooooooooooooooooooooooooooooooong_string = string + +type pairIntString = list< + pair< + looooooooooooooooooooooooooooooooooooooong_int, + looooooooooooooooooooooooooooooooooooooong_string, + >, +> + +let _ = !(3 < 4) || 3 > 4 + +module type MT = { + module DDF: { + + } +} + +module DDF: MT = { + module DDF = {} +} + +module XX = { + module YY = { + type t = int + } +} + +open XX.YY + +type tt = t + +// ^hig + +module T = { + type someRecord<'typeParameter> = { + someField: int, + someOtherField: string, + theParam: 'typeParameter, + } + + type someEnum = A | B | C +} + +let foo = x => x.T.someField + +let add = (~hello as x, ~world) => x + world + +let _ = add(~hello=3, ...) + +let _ = +
+
+
+ +module SomeComponent = { + module Nested = { + @react.component + let make = (~children) => { + <> {children} + } + } +} + +let _ = + +
+ + +// true/false +let _ = true || false + +// to/downto as label +let toAs = (~to as x) => x +let _toEquals = toAs(~to=10) + +let to = 1 +for _ in to + to to to + to { + () +} + +module ToAsProp = { + @react.component + let make = (~to) => { + <> {React.int(to)} + } +} +let _ = + +// quoted identifiers +let \"true" = 4 +let _ = \"true" + +let enumInModule = T.A + +type typeInModule = XX.YY.t + +module QQ = { + type somePolyEnumType = [ + | #someMember + | #AnotherMember + | #SomeMemberWithPayload(list) + | #"fourth Member" + ] +} + +let _ = x => + switch x { + | #stuff => 3 + | #...QQ.somePolyEnumType => 4 + } + +let _ = 3 == 3 || 3 === 3 + +let _ = (~_type_ as _) => () + +let _ = {"abc": 34} + +let _ = {"Key": 2} Highlight src/Highlight.res structure items:39 diagnostics:0 Lident: M 0:7 Namespace diff --git a/analysis/tests/src/expected/Hover.res.txt b/analysis/tests/src/expected/Hover.res.txt index 725c5a93a..f6b65e68e 100644 --- a/analysis/tests/src/expected/Hover.res.txt +++ b/analysis/tests/src/expected/Hover.res.txt @@ -1,3 +1,270 @@ +let abc = 22 + 34 +// ^hov + +type t = (int, float) +// ^hov + +module Id = { + // ^hov + type x = int +} + +@ocaml.doc("This module is commented") +module Dep: { + @ocaml.doc("Some doc comment") + let customDouble: int => int +} = { + let customDouble = foo => foo * 2 +} + +module D = Dep +// ^hov + +let cd = D.customDouble +// ^hov + +module HoverInsideModuleWithComponent = { + let x = 2 // check that hover on x works + // ^hov + @react.component + let make = () => React.null +} + +@ocaml.doc("Doc comment for functionWithTypeAnnotation") +let functionWithTypeAnnotation: unit => int = () => 1 +// ^hov + +@react.component +let make = (~name) => React.string(name) +// ^hov + +module C2 = { + @react.component + let make2 = (~name: string) => React.string(name) + // ^hov +} + +let num = 34 +// ^hov + +module type Logger = { + // ^hov + let log: string => unit +} + +module JsLogger: Logger = { + // ^hov + let log = (msg: string) => Js.log(msg) + let _oneMore = 3 +} + +module JJ = JsLogger +// ^def + +module IdDefinedTwice = { + // ^hov + let _x = 10 + let y = 20 + let _x = 10 +} + +module A = { + let x = 13 +} + +module B = A +// ^hov + +module C = B +// ^hov + +module Comp = { + @react.component + let make = (~children: React.element) => children +} + +module Comp1 = Comp + +let _ = + +
+
+ +// ^hov + +let _ = + +
+
+ +// ^hov + +type r<'a> = {i: 'a, f: float} + +let _get = r => r.f +. r.i +// ^hov + +let withAs = (~xx as yyy) => yyy + 1 +// ^hov + +module AA = { + type cond<'a> = [< #str(string)] as 'a + let fnnxx = (b: cond<_>) => true ? b : b +} + +let funAlias = AA.fnnxx + +let typeOk = funAlias +// ^hov + +let typeDuplicate = AA.fnnxx +// ^hov + +@live let dd = 34 +// ^hov + +let arity0a = (. ()) => { + //^hov + let f = () => 3 + f +} + +let arity0b = (. ()) => (. ()) => 3 +// ^hov + +let arity0c = (. (), ()) => 3 +// ^hov + +let arity0d = (. ()) => { + // ^hov + let f = () => 3 + f +} + +/**doc comment 1*/ +let docComment1 = 12 +// ^hov + +/** doc comment 2 */ +let docComment2 = 12 +// ^hov + +module ModWithDocComment = { + /*** module level doc comment 1 */ + + /** doc comment for x */ + let x = 44 + + /*** module level doc comment 2 */ +} + +module TypeSubstitutionRecords = { + type foo<'a> = {content: 'a, zzz: string} + type bar = {age: int} + type foobar = foo + + let x1: foo = {content: {age: 42}, zzz: ""} + // ^hov + let x2: foobar = {content: {age: 42}, zzz: ""} + // ^hov + + // x1.content. + // ^com + + // x2.content. + // ^com + + type foo2<'b> = foo<'b> + type foobar2 = foo2 + + let y1: foo2 = {content: {age: 42}, zzz: ""} + let y2: foobar2 = {content: {age: 42}, zzz: ""} + + // y1.content. + // ^com + + // y2.content. + // ^com +} + +module CompV4 = { + type props<'n, 's> = {n?: 'n, s: 's} + let make = props => { + let _ = props.n == Some(10) + React.string(props.s) + } +} + +let mk = CompV4.make +// ^hov + +type useR = {x: int, y: list>>} + +let testUseR = (v: useR) => v +// ^hov + +let usr: useR = { + x: 123, + y: list{}, +} + +// let f = usr +// ^hov + +module NotShadowed = { + /** Stuff */ + let xx_ = 10 + + /** More Stuff */ + let xx = xx_ +} + +module Shadowed = { + /** Stuff */ + let xx = 10 + + /** More Stuff */ + let xx = xx +} + +let _ = NotShadowed.xx +// ^hov + +let _ = Shadowed.xx +// ^hov + +type recordWithDocstringField = { + /** Mighty fine field here. */ + someField: bool, +} + +let x: recordWithDocstringField = { + someField: true, +} + +// x.someField +// ^hov + +let someField = x.someField +// ^hov + +type variant = | /** Cool variant! */ CoolVariant | /** Other cool variant */ OtherCoolVariant + +let coolVariant = CoolVariant +// ^hov + +// Hover on unsaved +// let fff = "hello"; fff +// ^hov + +// switch x { | {someField} => someField } +// ^hov + +module Arr = Belt.Array +// ^hov + +type aliased = variant +// ^hov Hover src/Hover.res 0:4 {"contents": {"kind": "markdown", "value": "```rescript\nint\n```"}} diff --git a/analysis/tests/src/expected/InlayHint.res.txt b/analysis/tests/src/expected/InlayHint.res.txt index db88d23bb..9ef5802c3 100644 --- a/analysis/tests/src/expected/InlayHint.res.txt +++ b/analysis/tests/src/expected/InlayHint.res.txt @@ -1,3 +1,38 @@ +let not_include = "Not Include" +let string = "ReScript" +let number = 1 +let float = 1.1 +let char = 'c' + +let add = (x, y) => x + y + +let my_sum = 3->add(1)->add(1)->add(1)->add(8) + +let withAs = (~xx as yyy) => yyy + 1 + +@react.component +let make = (~name) => React.string(name) + +let tuple = ("ReScript", "lol") + +let (lang, _) = tuple + +type foo = { + name: string, + age: int, +} + +let bar = () => ({name: "ReScript", age: 2}, tuple) +let ({name: _, age: _}, t) = bar() + +let alice = { + name: "Alice", + age: 42, +} + +let {name, age} = alice + +//^hin Inlay Hint src/InlayHint.res 1:34 [{ "position": {"line": 33, "character": 14}, diff --git a/analysis/tests/src/expected/Jsx2.res.txt b/analysis/tests/src/expected/Jsx2.res.txt index d566a3bdd..a8d18a3fd 100644 --- a/analysis/tests/src/expected/Jsx2.res.txt +++ b/analysis/tests/src/expected/Jsx2.res.txt @@ -1,3 +1,186 @@ +module M = { + @react.component + let make = (~first, ~fun="", ~second="") => React.string(first ++ fun ++ second) +} + +let _ = +// ^def + +// React.string(first) + +let y = 44 + +// k +// ^com + +// +// ^def + +module Ext = { + @react.component @module("@material-ui/core") + external make: (~align: string=?) => React.element = "Typography" +} + +let _ = Ext.make + +// +// ^com + +module WithChildren = { + @react.component + let make = (~name as _: string, ~children) => children +} + +let _ = + +
+ +// x.DefineSomeFields.thisField + DefineSomeFields.thisValue + +module Outer = { + module Inner = { + let hello = 3 + } +} +let _ = Outer.Inner.hello + +let _ = +
+ +let _ = +
+ +let _ = +
+ +module Nested = { + module Comp = { + @react.component + let make = (~name) => React.string(name) + } +} + +let _ = + +// let _ = +// ^com + +// let _ = +// ^com + +module Comp = { + @react.component + let make = (~age) => React.int(age) +} + +let _ = { + <> + + + // ^hov +} + +let _ = { + <> + {<> + + } + + // ^hov +} + +module type ExtT = module type of Ext + +let _ = module(Ext: ExtT) Definition src/Jsx2.res 5:9 getLocItem #4: heuristic for within fragments: take make as makeProps does not work the type is not great but jump to definition works diff --git a/analysis/tests/src/expected/Jsx2.resi.txt b/analysis/tests/src/expected/Jsx2.resi.txt index 5c2c276de..dd568ee3d 100644 --- a/analysis/tests/src/expected/Jsx2.resi.txt +++ b/analysis/tests/src/expected/Jsx2.resi.txt @@ -1,3 +1,15 @@ +@react.component +let make: (~first: string) => React.element +// ^hov + +let y: int +// ^hov + +// type t = React.e +// ^com + +// let x : React.e +// ^com Hover src/Jsx2.resi 1:4 getLocItem #1: heuristic for makeProps in interface files n1:componentLike n2:unit n3:string diff --git a/analysis/tests/src/expected/JsxV4.res.txt b/analysis/tests/src/expected/JsxV4.res.txt index 339562bda..1eb3211c1 100644 --- a/analysis/tests/src/expected/JsxV4.res.txt +++ b/analysis/tests/src/expected/JsxV4.res.txt @@ -1,3 +1,61 @@ +@@jsxConfig({version: 4}) + +module M4 = { + type props<'first, 'fun, 'second> = {first: 'first, fun?: 'fun, second?: 'second} + + /** Doc Comment For M4 */ + let make = ({first, fun: ?__fun, second: ?__second, _}: props<_, _, _>) => { + let fun = switch __fun { + | Some(fun) => fun + | None => "" + } + let second = switch __second { + | Some(second) => second + | None => "" + } + + React.string(first ++ fun ++ second) + } + /** Doc Comment For M4 */ + let make = { + let \"JsxV4$M4" = (props: props<_>) => make(props) + + \"JsxV4$M4" + } +} + +let _ = React.jsx(M4.make, {first: "abc"}) +// ^def + +// React.null + let make = { + let \"JsxV4$MM" = props => make(props) + + \"JsxV4$MM" + } +} + +module Other = { + type props<'name> = {name: 'name} + + let make = ({name, _}: props<_>) => React.string(name) + let make = { + let \"JsxV4$Other" = (props: props<_>) => make(props) + + \"JsxV4$Other" + } +} + +// ^int Definition src/JsxV4.res 8:9 {"uri": "JsxV4.res", "range": {"start": {"line": 5, "character": 6}, "end": {"line": 5, "character": 10}}} diff --git a/analysis/tests/src/expected/LongIdentTest.res.txt b/analysis/tests/src/expected/LongIdentTest.res.txt index 1c12fccf8..4e26d9203 100644 --- a/analysis/tests/src/expected/LongIdentTest.res.txt +++ b/analysis/tests/src/expected/LongIdentTest.res.txt @@ -1,3 +1,10 @@ +module Map = TableclothMap + +let zz = Map.add +// ^hov +// Triggers the processing of `Of(M)._t` and Lident.Apply ends up in the AST +// even though it's not expressible in ReScript syntax. +// This simulates ReScript projects with OCaml dependencies containing ident apply. Hover src/LongIdentTest.res 2:13 {"contents": {"kind": "markdown", "value": "```rescript\nint\n```"}} diff --git a/analysis/tests/src/expected/ModuleStuff.res.txt b/analysis/tests/src/expected/ModuleStuff.res.txt index e69de29bb..13210ac76 100644 --- a/analysis/tests/src/expected/ModuleStuff.res.txt +++ b/analysis/tests/src/expected/ModuleStuff.res.txt @@ -0,0 +1,5 @@ +/*** This is a top level module doc. */ + +module Nested = { + /*** Module doc for nested. */ +} diff --git a/analysis/tests/src/expected/Objects.res.txt b/analysis/tests/src/expected/Objects.res.txt index e69de29bb..3b32ca8b9 100644 --- a/analysis/tests/src/expected/Objects.res.txt +++ b/analysis/tests/src/expected/Objects.res.txt @@ -0,0 +1,11 @@ +type objT = {"name": string, "age": int} + +type nestedObjT = {"y": objT} + +module Rec = { + type recordt = {xx: int, ss: string} + + let recordVal: recordt = assert(false) +} + +let object: objT = {"name": "abc", "age": 4} diff --git a/analysis/tests/src/expected/Patterns.res.txt b/analysis/tests/src/expected/Patterns.res.txt index 5c119ffb7..119e20c11 100644 --- a/analysis/tests/src/expected/Patterns.res.txt +++ b/analysis/tests/src/expected/Patterns.res.txt @@ -1,15 +1,24 @@ -Definition src/Patterns.res 20:10 -{"uri": "Patterns.res", "range": {"start": {"line": 3, "character": 7}, "end": {"line": 3, "character": 10}}} -Definition src/Patterns.res 25:11 -{"uri": "Patterns.res", "range": {"start": {"line": 9, "character": 7}, "end": {"line": 9, "character": 11}}} + Syntax error! + src/Patterns.res:18:11-16 -Definition src/Patterns.res 28:11 -{"uri": "Patterns.res", "range": {"start": {"line": 11, "character": 7}, "end": {"line": 11, "character": 8}}} + 16 │ let A([v1, _, _]) | _ as v1 = assert false + 17 │ + 18 │ let lazy lazyy = lazy 3 + 19 │ } + 20 │ -Definition src/Patterns.res 31:11 -{"uri": "Patterns.res", "range": {"start": {"line": 15, "character": 9}, "end": {"line": 15, "character": 11}}} + Did you forget a `=` here? -Definition src/Patterns.res 34:11 -{"uri": "Patterns.res", "range": {"start": {"line": 17, "character": 11}, "end": {"line": 17, "character": 16}}} + + Syntax error! + src/Patterns.res:18:24-25 + + 16 │ let A([v1, _, _]) | _ as v1 = assert false + 17 │ + 18 │ let lazy lazyy = lazy 3 + 19 │ } + 20 │ + + consecutive statements on a line must be separated by ';' or a newline diff --git a/analysis/tests/src/expected/PolyRec.res.txt b/analysis/tests/src/expected/PolyRec.res.txt index 64c790174..46d8a9c7d 100644 --- a/analysis/tests/src/expected/PolyRec.res.txt +++ b/analysis/tests/src/expected/PolyRec.res.txt @@ -1,3 +1,17 @@ +let rec sum = x => + switch x { + | #Leaf => 0 + | #Node(value, left, right) => value + left->sum + right->sum + } + +let myTree = #Node( + 1, + #Node(2, #Node(4, #Leaf, #Leaf), #Node(6, #Leaf, #Leaf)), + #Node(3, #Node(5, #Leaf, #Leaf), #Node(7, #Leaf, #Leaf)), +) + +let () = myTree->sum->Js.log +// ^hov Hover src/PolyRec.res 12:10 {"contents": {"kind": "markdown", "value": "```rescript\n([#Leaf | #Node(int, 'a, 'a)] as 'a)\n```"}} diff --git a/analysis/tests/src/expected/QueryFile.res.txt b/analysis/tests/src/expected/QueryFile.res.txt index e69de29bb..0ba6f3d1d 100644 --- a/analysis/tests/src/expected/QueryFile.res.txt +++ b/analysis/tests/src/expected/QueryFile.res.txt @@ -0,0 +1,6 @@ +module Types = { + type byAddress = SchemaAssets.input_ByAddress + type location = SchemaAssets.input_Location + + type variables = {location: location} +} diff --git a/analysis/tests/src/expected/RecModules.res.txt b/analysis/tests/src/expected/RecModules.res.txt index 62e3e825c..461860257 100644 --- a/analysis/tests/src/expected/RecModules.res.txt +++ b/analysis/tests/src/expected/RecModules.res.txt @@ -1,3 +1,25 @@ +module rec A: { + type t + + @send external child: t => B.t = "child" +} = A + +and B: { + type t + + @send external parent: t => A.t = "parent" +} = B + +module C = { + type t + + @send external createA: t => A.t = "createA" +} + +module MC = C +// ^hov +module MA = A +// ^hov Hover src/RecModules.res 18:12 {"contents": {"kind": "markdown", "value": "```rescript\nmodule C: {\n type t\n let createA: t => A.t\n}\n```"}} diff --git a/analysis/tests/src/expected/RecordCompletion.res.txt b/analysis/tests/src/expected/RecordCompletion.res.txt index 90787363b..05ef9e25b 100644 --- a/analysis/tests/src/expected/RecordCompletion.res.txt +++ b/analysis/tests/src/expected/RecordCompletion.res.txt @@ -1,3 +1,27 @@ +type t = {n: array} + +let t = {n: []} + +type t2 = {n2: t} + +let t2 = {n2: t} + +// t.n->m +// ^com + +// t2.n2.n->m +// ^com + +module R = { + type t = {name: string} +} + +let n = {R.name: ""} +// n.R. +// ^com + +// n.R. xx +// ^com Complete src/RecordCompletion.res 8:9 posCursor:[8:9] posNoWhite:[8:8] Found expr:[8:3->8:9] Completable: Cpath Value[t].n->m diff --git a/analysis/tests/src/expected/RecoveryOnProp.res.txt b/analysis/tests/src/expected/RecoveryOnProp.res.txt index 59b9e8f8e..1c16f7f77 100644 --- a/analysis/tests/src/expected/RecoveryOnProp.res.txt +++ b/analysis/tests/src/expected/RecoveryOnProp.res.txt @@ -1,3 +1,15 @@ +let name = "" + +let _ = +
{ + () + // let _: Res + // ^com + }} + name="abc"> + {React.string(name)} +
Complete src/RecoveryOnProp.res 6:26 posCursor:[6:26] posNoWhite:[6:25] Found expr:[3:3->11:8] JSX 3:6] onClick[4:4->4:11]=...[4:13->0:-1]> _children:None diff --git a/analysis/tests/src/expected/References.res.txt b/analysis/tests/src/expected/References.res.txt index ea3108dae..ef209d2a9 100644 --- a/analysis/tests/src/expected/References.res.txt +++ b/analysis/tests/src/expected/References.res.txt @@ -1,3 +1,28 @@ +let x = 12 +// ^ref + +let a = x + +let b = a + +let c = x + +let foo = (~xx) => xx + 1 +// ^ref + +module M: { + let aa: int +} = { + let aa = 10 +} + +let bb = M.aa +let cc = bb +let dd = M.aa +// ^ref + +let _ = +// ^ref References src/References.res 0:4 [ {"uri": "Cross.res", "range": {"start": {"line": 0, "character": 26}, "end": {"line": 0, "character": 27}}}, diff --git a/analysis/tests/src/expected/ReferencesWithInterface.res.txt b/analysis/tests/src/expected/ReferencesWithInterface.res.txt index 33f2d105d..2b8f27d3b 100644 --- a/analysis/tests/src/expected/ReferencesWithInterface.res.txt +++ b/analysis/tests/src/expected/ReferencesWithInterface.res.txt @@ -1,3 +1,5 @@ +let x = 2 +// ^ref References src/ReferencesWithInterface.res 0:4 [ {"uri": "Cross.res", "range": {"start": {"line": 9, "character": 52}, "end": {"line": 9, "character": 53}}}, diff --git a/analysis/tests/src/expected/ReferencesWithInterface.resi.txt b/analysis/tests/src/expected/ReferencesWithInterface.resi.txt index 3e96fbc75..fc7516ec3 100644 --- a/analysis/tests/src/expected/ReferencesWithInterface.resi.txt +++ b/analysis/tests/src/expected/ReferencesWithInterface.resi.txt @@ -1,3 +1,5 @@ +let x: int +// ^ref References src/ReferencesWithInterface.resi 0:4 [ {"uri": "Cross.res", "range": {"start": {"line": 9, "character": 52}, "end": {"line": 9, "character": 53}}}, diff --git a/analysis/tests/src/expected/Rename.res.txt b/analysis/tests/src/expected/Rename.res.txt index 5cd2adfee..a1a18d3e0 100644 --- a/analysis/tests/src/expected/Rename.res.txt +++ b/analysis/tests/src/expected/Rename.res.txt @@ -1,3 +1,14 @@ +let x = 12 +// ^ren y + +let a = x + +let b = a + +let c = x + +let foo = (~xx) => xx + 1 +// ^ren yy Rename src/Rename.res 0:4 y [ { diff --git a/analysis/tests/src/expected/RenameWithInterface.res.txt b/analysis/tests/src/expected/RenameWithInterface.res.txt index a13988fa9..641e23004 100644 --- a/analysis/tests/src/expected/RenameWithInterface.res.txt +++ b/analysis/tests/src/expected/RenameWithInterface.res.txt @@ -1,3 +1,5 @@ +let x = 2 +// ^ren y Rename src/RenameWithInterface.res 0:4 y [ { diff --git a/analysis/tests/src/expected/RenameWithInterface.resi.txt b/analysis/tests/src/expected/RenameWithInterface.resi.txt index 2a1dabb44..696b3c104 100644 --- a/analysis/tests/src/expected/RenameWithInterface.resi.txt +++ b/analysis/tests/src/expected/RenameWithInterface.resi.txt @@ -1,3 +1,5 @@ +let x: int +// ^ren y Rename src/RenameWithInterface.resi 0:4 y [ { diff --git a/analysis/tests/src/expected/Reprod.res.txt b/analysis/tests/src/expected/Reprod.res.txt index d0be9994c..c053377ca 100644 --- a/analysis/tests/src/expected/Reprod.res.txt +++ b/analysis/tests/src/expected/Reprod.res.txt @@ -1,3 +1,59 @@ +module Query = { + let use = (~variables: QueryFile.Types.variables) => { + ignore(variables) + "" + } +} + +// let x = Query.use(~variables={location: ByAddress()}) +// ^com + +type nestedRecord = {nested: bool} + +type rec someRecord = { + first: int, + second: (bool, option), + optThird: option<[#first | #second(someRecord)]>, + nest: nestedRecord, +} + +type somePolyVariant = [#one | #two(bool) | #three(someRecord, bool)] + +type someVariant = One | Two(bool) | Three(someRecord, bool) + +type paramRecord<'a, 'b> = { + first: 'a, + second: 'b, +} + +let record: paramRecord = { + first: One, + second: {city: "city"}, +} + +// switch record { | {first: }} +// ^com + +// switch record { | {second: }} +// ^com + +// TODO: Functions, aliases/definitions, records, variants, polyvariants, tuples + +let res: result = Ok(One) + +// switch res { | Ok() } +// ^com + +// switch res { | Error() } +// ^com + +let resOpt: result, unit> = Ok(None) + +// switch resOpt { | Ok() } +// ^com + +// switch resOpt { | Ok(Some()) } +// ^com Complete src/Reprod.res 7:53 posCursor:[7:53] posNoWhite:[7:52] Found expr:[7:11->7:56] Pexp_apply ...[7:11->7:20] (~variables7:22->7:31=...[7:32->7:55]) diff --git a/analysis/tests/src/expected/SchemaAssets.res.txt b/analysis/tests/src/expected/SchemaAssets.res.txt index e69de29bb..b83ff5c0d 100644 --- a/analysis/tests/src/expected/SchemaAssets.res.txt +++ b/analysis/tests/src/expected/SchemaAssets.res.txt @@ -0,0 +1,6 @@ +@live +type rec input_ByAddress = {city: string} +@tag("__$inputUnion") +and input_Location = + | @as("byAddress") ByAddress(input_ByAddress) + | @as("byId") ById(string) diff --git a/analysis/tests/src/expected/ShadowedBelt.res.txt b/analysis/tests/src/expected/ShadowedBelt.res.txt index e69de29bb..143c0e915 100644 --- a/analysis/tests/src/expected/ShadowedBelt.res.txt +++ b/analysis/tests/src/expected/ShadowedBelt.res.txt @@ -0,0 +1,3 @@ +module List = { + let map = (l, fn) => List.map(fn, l) +} diff --git a/analysis/tests/src/expected/SignatureHelp.res.txt b/analysis/tests/src/expected/SignatureHelp.res.txt index 580401264..29f6b3a8f 100644 --- a/analysis/tests/src/expected/SignatureHelp.res.txt +++ b/analysis/tests/src/expected/SignatureHelp.res.txt @@ -1,3 +1,166 @@ +type someVariant = One | Two | Three + +/** Does stuff. */ +let someFunc = (one: int, ~two: option=?, ~three: unit => unit, ~four: someVariant, ()) => { + ignore(one) + ignore(two) + ignore(three()) + ignore(four) +} + +let otherFunc = (first: string, second: int, third: float) => { + ignore(first) + ignore(second) + ignore(third) +} + +// let _ = someFunc( +// ^she + +// let _ = someFunc(1 +// ^she + +// let _ = someFunc(123, ~two +// ^she + +// let _ = someFunc(123, ~two="123" +// ^she + +// let _ = someFunc(123, ~two="123", ~four +// ^she + +// let _ = someFunc(123, ~two="123", ~four=O +// ^she + +// let _ = otherFunc( +// ^she + +// let _ = otherFunc("123" +// ^she + +// let _ = otherFunc("123", 123, 123.0) +// ^she + +// let _ = Completion.Lib.foo(~age +// ^she + +let iAmSoSpecial = (iJustHaveOneArg: string) => { + ignore(iJustHaveOneArg) +} + +// let _ = iAmSoSpecial( +// ^she + +// let _ = "hello"->otherFunc(1 +// ^she + +let fn = (age: int, name: string, year: int) => { + ignore(age) + ignore(name) + ignore(year) +} + +// let _ = fn(22, ) +// ^she + +// let _ = fn(22, , 2023) +// ^she + +// let _ = fn(12, "hello", ) +// ^she + +// let _ = fn({ iAmSoSpecial() }) +// ^she + +// let _ = fn({ iAmSoSpecial({ someFunc() }) }) +// ^she + +/** This is my own special thing. */ +type mySpecialThing = string + +type t = + | /** One is cool. */ One({miss?: bool, hit?: bool, stuff?: string}) + | /** Two is fun! */ Two(mySpecialThing) + | /** Three is... three */ Three(mySpecialThing, array>) + +let _one = One({}) +// ^she + +let _one = One({miss: true}) +// ^she + +let _one = One({hit: true, miss: true}) +// ^she + +let two = Two("true") +// ^she + +let three = Three("", []) +// ^she + +let three2 = Three("", []) +// ^she + +let _deepestTakesPrecedence = [12]->Js.Array2.map(v => + if v > 0 { + One({}) + // ^she + } else { + Two("") + } +) + +/** Main docstring here. */ +let map = (arr, mapper) => { + Array.map(mapper, arr) +} + +let _usesCorrectTypeInfo = [12]->map(v => v) +// ^she + +/** Type x... */ +type x = { + age?: int, + name?: string, +} + +/** Type tt! */ +type tt = One + +/** Some stuff */ +let stuffers = (x: x, y: tt) => { + ignore(x) + ignore(y) + "hello" +} + +let _ = stuffers({}, One) +// ^she + +let _ = stuffers({}, One) +// ^she + +let _ = switch _one { +| One({hit: _hit}) => "" +// ^she +| One(_a) => "" +// ^she +| Two(_ms) => "" +// ^she +| Three(_a, []) => "" +// ^she +| Three(_, _b) => "" +// ^she +} + +let _bb = Ok(true) +// ^she + +let _bbb = Error("err") +// ^she + +let _cc = Some(true) +// ^she Signature help src/SignatureHelp.res 16:20 posCursor:[16:19] posNoWhite:[16:18] Found expr:[16:11->16:20] Pexp_apply ...[16:11->16:19] (...[46:0->16:20]) diff --git a/analysis/tests/src/expected/TypeAtPosCompletion.res.txt b/analysis/tests/src/expected/TypeAtPosCompletion.res.txt index 377ec83f1..03f0876d1 100644 --- a/analysis/tests/src/expected/TypeAtPosCompletion.res.txt +++ b/analysis/tests/src/expected/TypeAtPosCompletion.res.txt @@ -1,3 +1,28 @@ +type optRecord = { + name: string, + age?: int, + online?: bool, +} + +let optRecord = { + name: "Hello", + // ^com +} + +type someVariant = One(int, optRecord) + +let x = One( + 1, + { + name: "What", + // ^com + }, +) + +let arr = [ + optRecord, + // ^com +] Complete src/TypeAtPosCompletion.res 7:17 posCursor:[7:17] posNoWhite:[7:15] Found expr:[6:16->9:1] Completable: Cexpression CTypeAtPos()->recordBody diff --git a/analysis/tests/src/expected/TypeDefinition.res.txt b/analysis/tests/src/expected/TypeDefinition.res.txt index 46a968e8f..fb164890b 100644 --- a/analysis/tests/src/expected/TypeDefinition.res.txt +++ b/analysis/tests/src/expected/TypeDefinition.res.txt @@ -1,3 +1,28 @@ +type variant = Foo | Bar + +type record = {item: string} +// ^typ + +let x = Foo +// ^typ + +let y = {item: "foo"} +// ^typ + +type obj = {"foo": string} + +let obj: obj = {"foo": "bar"} +// ^typ + +let f = r => r.item +// ^typ + +let g = v => + switch v { + // ^typ + | Foo => "Foo" + | Bar => "Bar" + } TypeDefinition src/TypeDefinition.res 2:9 {"uri": "TypeDefinition.res", "range": {"start": {"line": 2, "character": 5}, "end": {"line": 2, "character": 11}}} diff --git a/analysis/tests/src/expected/Xform.res.txt b/analysis/tests/src/expected/Xform.res.txt index 2b38ddf41..98737c1dc 100644 --- a/analysis/tests/src/expected/Xform.res.txt +++ b/analysis/tests/src/expected/Xform.res.txt @@ -1,3 +1,148 @@ +type kind = First | Second | Third | Fourth(int) +type r = {name: string, age: int} + +let ret = _ => assert(false) +let kind = assert(false) + +if kind == First { + // ^xfm + ret("First") +} else { + ret("Not First") +} + +#kind("First", {name: "abc", age: 3}) != kind ? ret("Not First") : ret("First") +// ^xfm + +let name = "hello" +// ^xfm + +let annotated: int = 34 +// ^xfm + +module T = { + type r = {a: int, x: string} +} + +let foo = x => + // ^xfm + switch x { + | None => 33 + | Some(q) => q.T.a + 1 + // ^xfm + } + +let withAs = (~x as name) => name + 1 +// ^xfm + +@react.component +let make = (~name) => React.string(name) +// ^xfm + +let _ = (~x) => x + 1 +// ^xfm + +// +// Add braces to the body of a function +// + +let noBraces = () => name +// ^xfm + +let nested = () => { + let _noBraces = (_x, _y, _z) => "someNewFunc" + // ^xfm +} + +let bar = () => { + module Inner = { + let foo = (_x, y, _z) => + switch y { + | #some => 3 + | #stuff => 4 + } + //^xfm + } + Inner.foo(1, ...) +} + +module ExtractableModule = { + /** Doc comment. */ + type t = int + // A comment here + let doStuff = a => a + 1 + // ^xfm +} + +let variant = First + +let _x = switch variant { +| First => "first" +| _ => "other" +// ^xfm +} + +let _x = switch variant { +| First | Second => "first" +| _ => "other" +// ^xfm +} + +let _x = switch variant { +| First if 1 > 2 => "first" +| Second => "second" +| _ => "other" +// ^xfm +} + +let polyvariant: [#first | #second | #"illegal identifier" | #third(int)] = #first + +let _y = switch polyvariant { +| #first => "first" +| _ => "other" +// ^xfm +} + +let _y = switch polyvariant { +| #first | #second => "first" +| _ => "other" +// ^xfm +} + +let variantOpt = Some(variant) + +let _x = switch variantOpt { +| Some(First) => "first" +| _ => "other" +// ^xfm +} + +let _x = switch variantOpt { +| Some(First) | Some(Second) => "first" +| _ => "other" +// ^xfm +} + +let _x = switch variantOpt { +| Some(First | Second) => "first" +| _ => "other" +// ^xfm +} + +let polyvariantOpt = Some(polyvariant) + +let _x = switch polyvariantOpt { +| Some(#first) => "first" +| None => "nothing" +| _ => "other" +// ^xfm +} + +let _x = switch polyvariantOpt { +| Some(#first | #second) => "first" +| _ => "other" +// ^xfm +} Xform src/Xform.res 6:5 posCursor:[6:3] posNoWhite:[6:1] Found expr:[6:0->11:1] Completable: Cpath Value[kind] diff --git a/analysis/vendor/ext/.ocamlformat b/analysis/vendor/ext/.ocamlformat new file mode 100644 index 000000000..593b6a1ff --- /dev/null +++ b/analysis/vendor/ext/.ocamlformat @@ -0,0 +1 @@ +disable diff --git a/analysis/vendor/ext/bsc_args.ml b/analysis/vendor/ext/bsc_args.ml index 721c191c6..5f1fd2e19 100644 --- a/analysis/vendor/ext/bsc_args.ml +++ b/analysis/vendor/ext/bsc_args.ml @@ -86,13 +86,13 @@ let stop_raise ~usage ~(error : error) (speclist : t) = Ext_buffer.output_buffer stdout b; exit 0 | Unknown s -> - b +> "unknown option: '"; + b +> "Unknown option \""; b +> s; - b +> "'.\n" + b +> "\".\n" | Missing s -> - b +> "option '"; + b +> "Option \""; b +> s; - b +> "' needs an argument.\n"); + b +> "\" needs an argument.\n"); usage_b b ~usage speclist; bad_arg (Ext_buffer.contents b) diff --git a/analysis/vendor/ext/bsc_warnings.ml b/analysis/vendor/ext/bsc_warnings.ml index 833b46443..976914284 100644 --- a/analysis/vendor/ext/bsc_warnings.ml +++ b/analysis/vendor/ext/bsc_warnings.ml @@ -69,6 +69,7 @@ - 102 Bs_polymorphic_comparison *) +(* If you change this, don't forget to adapt docs/docson/build-schema.json as well. *) let defaults_w = "+a-4-9-20-40-41-42-50-61-102" let defaults_warn_error = "-a+5+6+101+109" diff --git a/analysis/vendor/ext/ext_cmp.ml b/analysis/vendor/ext/ext_cmp.ml index e14746cea..86e966e15 100644 --- a/analysis/vendor/ext/ext_cmp.ml +++ b/analysis/vendor/ext/ext_cmp.ml @@ -2,7 +2,7 @@ type 'a compare = 'a -> 'a -> int type ('a, 'id) cmp = 'a compare -external getCmp : ('a, 'id) cmp -> 'a compare = "%identity" +external get_cmp : ('a, 'id) cmp -> 'a compare = "%identity" module type S = sig type id diff --git a/analysis/vendor/ext/ext_cmp.mli b/analysis/vendor/ext/ext_cmp.mli index 8588d120e..18fc84654 100644 --- a/analysis/vendor/ext/ext_cmp.mli +++ b/analysis/vendor/ext/ext_cmp.mli @@ -2,7 +2,7 @@ type 'a compare = 'a -> 'a -> int type ('a, 'id) cmp -external getCmp : ('a, 'id) cmp -> 'a compare = "%identity" +external get_cmp : ('a, 'id) cmp -> 'a compare = "%identity" (** only used for data structures, not exported for client usage *) module type S = sig diff --git a/analysis/vendor/ext/ext_ident.ml b/analysis/vendor/ext/ext_ident.ml index f04e01806..272a21b43 100644 --- a/analysis/vendor/ext/ext_ident.ml +++ b/analysis/vendor/ext/ext_ident.ml @@ -132,6 +132,27 @@ let [@inline] no_escape (c : char) = | '0' .. '9' | '_' | '$' -> true | _ -> false +let is_uident name = + let len = String.length name in + if len > 0 then + match name.[0] with + | 'A' .. 'Z' -> true + | _ -> false + else false + +let is_uppercase_exotic name = + let len = String.length name in + len >= 3 + && name.[0] = '\\' + && name.[1] = '\"' + && name.[len - 1] = '\"' + +let unwrap_uppercase_exotic name = + if is_uppercase_exotic name then + let len = String.length name in + String.sub name 2 (len - 3) + else name + exception Not_normal_letter of int let name_mangle name = let len = String.length name in diff --git a/analysis/vendor/ext/ext_ident.mli b/analysis/vendor/ext/ext_ident.mli index 290a635e0..27e7a0505 100644 --- a/analysis/vendor/ext/ext_ident.mli +++ b/analysis/vendor/ext/ext_ident.mli @@ -48,7 +48,11 @@ val create_tmp : ?name:string -> unit -> Ident.t val make_unused : unit -> Ident.t +val is_uident : string -> bool +val is_uppercase_exotic : string -> bool + +val unwrap_uppercase_exotic : string -> string (** Invariant: if name is not converted, the reference should be equal diff --git a/analysis/vendor/ext/ext_js_file_kind.ml b/analysis/vendor/ext/ext_js_file_kind.ml index 1688b3962..196ba3246 100644 --- a/analysis/vendor/ext/ext_js_file_kind.ml +++ b/analysis/vendor/ext/ext_js_file_kind.ml @@ -23,6 +23,4 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type case = Upper | Little -type [@warning "-69"] t = { case : case; suffix : Ext_js_suffix.t } - -let any_runtime_kind = { case = Little; suffix = Ext_js_suffix.Js } +type [@warning "-69"] t = { case : case; suffix : string } diff --git a/analysis/vendor/ext/ext_js_suffix.ml b/analysis/vendor/ext/ext_js_suffix.ml deleted file mode 100644 index ab09d7ec7..000000000 --- a/analysis/vendor/ext/ext_js_suffix.ml +++ /dev/null @@ -1,28 +0,0 @@ -type t = - | Js - | Mjs - | Cjs - | Bs_js - | Bs_mjs - | Bs_cjs - | Unknown_extension - -let to_string (x : t) = - match x with - | Js -> Literals.suffix_js - | Mjs -> Literals.suffix_mjs - | Cjs -> Literals.suffix_cjs - | Bs_js -> Literals.suffix_bs_js - | Bs_mjs -> Literals.suffix_bs_mjs - | Bs_cjs -> Literals.suffix_bs_cjs - | Unknown_extension -> assert false - -let of_string (x : string) : t = - match () with - | () when x = Literals.suffix_js -> Js - | () when x = Literals.suffix_mjs -> Mjs - | () when x = Literals.suffix_cjs -> Cjs - | () when x = Literals.suffix_bs_js -> Bs_js - | () when x = Literals.suffix_bs_mjs -> Bs_mjs - | () when x = Literals.suffix_bs_cjs -> Bs_cjs - | _ -> Unknown_extension diff --git a/analysis/vendor/ext/ext_json_write.ml b/analysis/vendor/ext/ext_json_write.ml deleted file mode 100644 index 965fe982e..000000000 --- a/analysis/vendor/ext/ext_json_write.ml +++ /dev/null @@ -1,86 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** poor man's serialization *) -(* - let quot x = - "\"" ^ String.escaped x ^ "\"" *) - -(* let rec encode_aux (x : Ext_json_types.t ) - (buf : Buffer.t) : unit = - let a str = Buffer.add_string buf str in - match x with - | Null _ -> a "null" - | Str {str = s } -> a (quot s) - | Flo {flo = s} -> - a s (* - since our parsing keep the original float representation, we just dump it as is, there is no cases like [nan] *) - | Arr {content} -> - begin match content with - | [||] -> a "[]" - | _ -> - a "[ "; - encode_aux - (Array.unsafe_get content 0) - buf ; - for i = 1 to Array.length content - 1 do - a " , "; - encode_aux - (Array.unsafe_get content i) - buf - done; - a " ]" - end - | True _ -> a "true" - | False _ -> a "false" - | Obj {map} -> - if Map_string.is_empty map then - a "{}" - else - begin - (*prerr_endline "WEIRD"; - prerr_endline (string_of_int @@ Map_string.cardinal map ); *) - a "{ "; - let _ : int = Map_string.fold map 0 (fun k v i -> - if i <> 0 then begin - a " , " - end; - a (quot k); - a " : "; - encode_aux v buf ; - i + 1 - ) in - a " }" - end -*) - -(* let to_string (x : Ext_json_types.t) = - let buf = Buffer.create 1024 in - encode_aux x buf ; - Buffer.contents buf - - let to_channel (oc : out_channel) x = - let buf = Buffer.create 1024 in - encode_aux x buf ; - Buffer.output_buffer oc buf *) diff --git a/analysis/vendor/ext/ext_json_write.mli b/analysis/vendor/ext/ext_json_write.mli deleted file mode 100644 index 5ccfab757..000000000 --- a/analysis/vendor/ext/ext_json_write.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(*val to_string : Ext_json_types.t -> string - - - val to_channel : out_channel -> Ext_json_types.t -> unit*) diff --git a/analysis/vendor/ext/ext_module_system.ml b/analysis/vendor/ext/ext_module_system.ml index b3178b0c9..9b06848f3 100644 --- a/analysis/vendor/ext/ext_module_system.ml +++ b/analysis/vendor/ext/ext_module_system.ml @@ -1 +1 @@ -type t = NodeJS | Es6 | Es6_global +type t = Commonjs | Esmodule | Es6_global diff --git a/analysis/vendor/ext/ext_namespace.ml b/analysis/vendor/ext/ext_namespace.ml index 7781b80c9..deccf1f96 100644 --- a/analysis/vendor/ext/ext_namespace.ml +++ b/analysis/vendor/ext/ext_namespace.ml @@ -45,7 +45,7 @@ let js_name_of_modulename s (case : Ext_js_file_kind.case) suffix : string = let s = match case with Little -> Ext_string.uncapitalize_ascii s | Upper -> s in - change_ext_ns_suffix s (Ext_js_suffix.to_string suffix) + change_ext_ns_suffix s suffix (* https://docs.npmjs.com/files/package.json Some rules: diff --git a/analysis/vendor/ext/ext_namespace.mli b/analysis/vendor/ext/ext_namespace.mli index 830e74cba..f562729d7 100644 --- a/analysis/vendor/ext/ext_namespace.mli +++ b/analysis/vendor/ext/ext_namespace.mli @@ -34,7 +34,7 @@ val try_split_module_name : string -> (string * string) option val change_ext_ns_suffix : string -> string -> string val js_name_of_modulename : - string -> Ext_js_file_kind.case -> Ext_js_suffix.t -> string + string -> Ext_js_file_kind.case -> string -> string (** [js_name_of_modulename ~little A-Ns] *) diff --git a/analysis/vendor/ext/ext_pp.ml b/analysis/vendor/ext/ext_pp.ml index 7ac050268..5b1e4a8b0 100644 --- a/analysis/vendor/ext/ext_pp.ml +++ b/analysis/vendor/ext/ext_pp.ml @@ -160,8 +160,8 @@ let paren_vgroup st n action = let paren_group st n action = group st n (fun _ -> paren st action) -let cond_paren_group st b n action = - if b then paren_group st n action else action () +let cond_paren_group st b action = + if b then paren_group st 0 action else action () let brace_group st n action = group st n (fun _ -> brace st action) diff --git a/analysis/vendor/ext/ext_pp.mli b/analysis/vendor/ext/ext_pp.mli index 6db5327aa..aaf217621 100644 --- a/analysis/vendor/ext/ext_pp.mli +++ b/analysis/vendor/ext/ext_pp.mli @@ -56,7 +56,7 @@ val brace : t -> (unit -> 'a) -> 'a val paren_group : t -> int -> (unit -> 'a) -> 'a -val cond_paren_group : t -> bool -> int -> (unit -> 'a) -> 'a +val cond_paren_group : t -> bool -> (unit -> 'a) -> 'a val paren_vgroup : t -> int -> (unit -> 'a) -> 'a diff --git a/analysis/vendor/ext/ext_stack.ml b/analysis/vendor/ext/ext_stack.ml deleted file mode 100644 index 0ecebca62..000000000 --- a/analysis/vendor/ext/ext_stack.ml +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type 'a t = 'a list ref - -let create_ref_empty () = ref [] - -let ref_top x = - match !x with y :: _ -> y | _ -> invalid_arg "Ext_list.ref_top" - -let ref_empty x = match !x with [] -> true | _ -> false - -let ref_push x refs = refs := x :: !refs - -let ref_pop refs = - match !refs with - | [] -> invalid_arg "Ext_list.ref_pop" - | x :: rest -> - refs := rest; - x diff --git a/analysis/vendor/ext/ext_stack.mli b/analysis/vendor/ext/ext_stack.mli deleted file mode 100644 index 2d85a3133..000000000 --- a/analysis/vendor/ext/ext_stack.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type 'a t = 'a list ref - -val create_ref_empty : unit -> 'a t - -val ref_top : 'a t -> 'a - -val ref_empty : 'a t -> bool - -val ref_push : 'a -> 'a t -> unit - -val ref_pop : 'a t -> 'a diff --git a/analysis/vendor/ext/ext_string.ml b/analysis/vendor/ext/ext_string.ml index 617f416d8..dcc7ab00e 100644 --- a/analysis/vendor/ext/ext_string.ml +++ b/analysis/vendor/ext/ext_string.ml @@ -528,4 +528,3 @@ let hash_number_as_i32_exn let first_marshal_char (x : string) = x <> "" && ( String.unsafe_get x 0 = '\132') - \ No newline at end of file diff --git a/analysis/vendor/ext/ext_string.mli b/analysis/vendor/ext/ext_string.mli index a1c6a66e9..7099464a2 100644 --- a/analysis/vendor/ext/ext_string.mli +++ b/analysis/vendor/ext/ext_string.mli @@ -223,4 +223,4 @@ val hash_number_as_i32_exn: val first_marshal_char: string -> - bool \ No newline at end of file + bool diff --git a/analysis/vendor/ext/ext_string_array.ml b/analysis/vendor/ext/ext_string_array.ml index 27b8c182d..94234d6d1 100644 --- a/analysis/vendor/ext/ext_string_array.ml +++ b/analysis/vendor/ext/ext_string_array.ml @@ -25,23 +25,23 @@ (* Invariant: the same as encoding Map_string.compare_key *) let cmp = Ext_string.compare -let rec binarySearchAux (arr : string array) (lo : int) (hi : int) +let rec binary_search_aux (arr : string array) (lo : int) (hi : int) (key : string) : _ option = let mid = (lo + hi) / 2 in - let midVal = Array.unsafe_get arr mid in - let c = cmp key midVal in + let mid_val = Array.unsafe_get arr mid in + let c = cmp key mid_val in if c = 0 then Some mid else if c < 0 then (* a[lo] =< key < a[mid] <= a[hi] *) if hi = mid then - let loVal = Array.unsafe_get arr lo in - if loVal = key then Some lo else None - else binarySearchAux arr lo mid key + let lo_val = Array.unsafe_get arr lo in + if lo_val = key then Some lo else None + else binary_search_aux arr lo mid key else if (* a[lo] =< a[mid] < key <= a[hi] *) lo = mid then - let hiVal = Array.unsafe_get arr hi in - if hiVal = key then Some hi else None - else binarySearchAux arr mid hi key + let hi_val = Array.unsafe_get arr hi in + if hi_val = key then Some hi else None + else binary_search_aux arr mid hi key let find_sorted sorted key : int option = let len = Array.length sorted in @@ -53,25 +53,25 @@ let find_sorted sorted key : int option = else let hi = Array.unsafe_get sorted (len - 1) in let c2 = cmp key hi in - if c2 > 0 then None else binarySearchAux sorted 0 (len - 1) key + if c2 > 0 then None else binary_search_aux sorted 0 (len - 1) key -let rec binarySearchAssoc (arr : (string * _) array) (lo : int) (hi : int) +let rec binary_search_assoc (arr : (string * _) array) (lo : int) (hi : int) (key : string) : _ option = let mid = (lo + hi) / 2 in - let midVal = Array.unsafe_get arr mid in - let c = cmp key (fst midVal) in - if c = 0 then Some (snd midVal) + let mid_val = Array.unsafe_get arr mid in + let c = cmp key (fst mid_val) in + if c = 0 then Some (snd mid_val) else if c < 0 then (* a[lo] =< key < a[mid] <= a[hi] *) if hi = mid then - let loVal = Array.unsafe_get arr lo in - if fst loVal = key then Some (snd loVal) else None - else binarySearchAssoc arr lo mid key + let lo_val = Array.unsafe_get arr lo in + if fst lo_val = key then Some (snd lo_val) else None + else binary_search_assoc arr lo mid key else if (* a[lo] =< a[mid] < key <= a[hi] *) lo = mid then - let hiVal = Array.unsafe_get arr hi in - if fst hiVal = key then Some (snd hiVal) else None - else binarySearchAssoc arr mid hi key + let hi_val = Array.unsafe_get arr hi in + if fst hi_val = key then Some (snd hi_val) else None + else binary_search_assoc arr mid hi key let find_sorted_assoc (type a) (sorted : (string * a) array) (key : string) : a option = @@ -84,4 +84,4 @@ let find_sorted_assoc (type a) (sorted : (string * a) array) (key : string) : else let hi = Array.unsafe_get sorted (len - 1) in let c2 = cmp key (fst hi) in - if c2 > 0 then None else binarySearchAssoc sorted 0 (len - 1) key + if c2 > 0 then None else binary_search_assoc sorted 0 (len - 1) key diff --git a/analysis/vendor/ext/js_reserved_map.ml b/analysis/vendor/ext/js_reserved_map.ml index 21cef5b3b..a5eaeeca9 100644 --- a/analysis/vendor/ext/js_reserved_map.ml +++ b/analysis/vendor/ext/js_reserved_map.ml @@ -169,6 +169,7 @@ let sorted_keywords = [| "DecompressionStream"; "DelayNode"; "DelegatedInkTrailPresenter"; + "Deno"; "Document"; "DocumentFragment"; "DocumentPictureInPictureEvent"; @@ -789,21 +790,21 @@ let sorted_keywords = [| type element = string -let rec binarySearchAux (arr : element array) (lo : int) (hi : int) key : bool = +let rec binary_search_aux (arr : element array) (lo : int) (hi : int) key : bool = let mid = (lo + hi)/2 in - let midVal = Array.unsafe_get arr mid in + let mid_val = Array.unsafe_get arr mid in (* let c = cmp key midVal [@bs] in *) - if key = midVal then true - else if key < midVal then (* a[lo] =< key < a[mid] <= a[hi] *) + if key = mid_val then true + else if key < mid_val then (* a[lo] =< key < a[mid] <= a[hi] *) if hi = mid then (Array.unsafe_get arr lo) = key - else binarySearchAux arr lo mid key + else binary_search_aux arr lo mid key else (* a[lo] =< a[mid] < key <= a[hi] *) if lo = mid then (Array.unsafe_get arr hi) = key - else binarySearchAux arr mid hi key + else binary_search_aux arr mid hi key -let binarySearch (sorted : element array) (key : element) : bool = +let binary_search (sorted : element array) (key : element) : bool = let len = Array.length sorted in if len = 0 then false else @@ -814,6 +815,6 @@ let binarySearch (sorted : element array) (key : element) : bool = let hi = Array.unsafe_get sorted (len - 1) in (* let c2 = cmp key hi [@bs]in *) if key > hi then false - else binarySearchAux sorted 0 (len - 1) key + else binary_search_aux sorted 0 (len - 1) key -let is_reserved s = binarySearch sorted_keywords s +let is_reserved s = binary_search sorted_keywords s diff --git a/analysis/vendor/ext/js_runtime_modules.ml b/analysis/vendor/ext/js_runtime_modules.ml index a962e1500..9c2b3b9ea 100644 --- a/analysis/vendor/ext/js_runtime_modules.ml +++ b/analysis/vendor/ext/js_runtime_modules.ml @@ -59,6 +59,8 @@ let md5 = "Caml_md5" let int32 = "Caml_int32" +let bigint = "Caml_bigint" + let option = "Caml_option" let module_ = "Caml_module" diff --git a/analysis/vendor/ext/literals.ml b/analysis/vendor/ext/literals.ml index ed410ee8d..b1aa1c2bc 100644 --- a/analysis/vendor/ext/literals.ml +++ b/analysis/vendor/ext/literals.ml @@ -121,25 +121,19 @@ let suffix_d = ".d" let suffix_js = ".js" -let suffix_bs_js = ".bs.js" - -let suffix_mjs = ".mjs" - -let suffix_bs_mjs = ".bs.mjs" - -let suffix_cjs = ".cjs" - -let suffix_bs_cjs = ".bs.cjs" - let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" +let esmodule = "esmodule" + let commonjs = "commonjs" let es6 = "es6" +[@@ocaml.deprecated "Will be removed in v12"] let es6_global = "es6-global" +[@@ocaml.deprecated "Will be removed in v12"] let unused_attribute = "Unused attribute " diff --git a/analysis/vendor/ext/misc.ml b/analysis/vendor/ext/misc.ml index eef6e4760..33ca3eee5 100644 --- a/analysis/vendor/ext/misc.ml +++ b/analysis/vendor/ext/misc.ml @@ -330,7 +330,6 @@ module Int_literal_converter = struct let int s = cvt_int_aux s (~-) int_of_string let int32 s = cvt_int_aux s Int32.neg Int32.of_string let int64 s = cvt_int_aux s Int64.neg Int64.of_string - let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string end (* String operations *) diff --git a/analysis/vendor/ext/misc.mli b/analysis/vendor/ext/misc.mli index 61dfdf0a7..33878bb1d 100644 --- a/analysis/vendor/ext/misc.mli +++ b/analysis/vendor/ext/misc.mli @@ -163,7 +163,6 @@ module Int_literal_converter : sig val int : string -> int val int32 : string -> int32 val int64 : string -> int64 - val nativeint : string -> nativeint end val chop_extensions: string -> string diff --git a/analysis/vendor/ext/string_vec.ml b/analysis/vendor/ext/string_vec.ml deleted file mode 100644 index 833ee8e9f..000000000 --- a/analysis/vendor/ext/string_vec.ml +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -include Vec.Make (struct - type t = string - - let null = "" -end) diff --git a/analysis/vendor/ext/string_vec.mli b/analysis/vendor/ext/string_vec.mli deleted file mode 100644 index c1b941146..000000000 --- a/analysis/vendor/ext/string_vec.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -include Vec_gen.S with type elt = string diff --git a/analysis/vendor/ext/warnings.ml b/analysis/vendor/ext/warnings.ml index a839f711f..f9f063d3f 100644 --- a/analysis/vendor/ext/warnings.ml +++ b/analysis/vendor/ext/warnings.ml @@ -26,7 +26,7 @@ type loc = { loc_ghost : bool; } -type topLevelUnitHelp = FunctionCall | Other +type top_level_unit_help = FunctionCall | Other type t = | Comment_start (* 1 *) @@ -85,7 +85,8 @@ type t = | Bs_unimplemented_primitive of string (* 106 *) | Bs_integer_literal_overflow (* 107 *) | Bs_uninterpreted_delimiters of string (* 108 *) - | Bs_toplevel_expression_unit of (string * topLevelUnitHelp) option (* 109 *) + | Bs_toplevel_expression_unit of (string * top_level_unit_help) option (* 109 *) + | Bs_todo of string option (* 110 *) (* If you remove a warning, leave a hole in the numbering. NEVER change the numbers of existing warnings. @@ -151,6 +152,7 @@ let number = function | Bs_integer_literal_overflow -> 107 | Bs_uninterpreted_delimiters _ -> 108 | Bs_toplevel_expression_unit _ -> 109 + | Bs_todo _ -> 110 let last_warning_number = 110 @@ -475,10 +477,10 @@ let message = function | Constraint_on_gadt -> "Type constraints do not apply to GADT cases of variant types." | Bs_unused_attribute s -> - "Unused attribute: " ^ s + "Unused attribute: @" ^ s ^ "\n\ - This means such annotation is not annotated properly. \n\ - for example, some annotations is only meaningful in externals \n" + This attribute has no effect here.\n\ + For example, some attributes are only meaningful in externals.\n" | Bs_polymorphic_comparison -> "Polymorphic comparison introduced (maybe unsafe)" | Bs_ffi_warning s -> "FFI warning: " ^ s @@ -499,16 +501,21 @@ let message = function | _ -> " ") (match help with - | Some (returnType, _) -> Printf.sprintf "`%s`" returnType + | Some (return_type, _) -> Printf.sprintf "`%s`" return_type | None -> "something that is not `unit`") (match help with - | Some (_, helpTyp) -> - let helpText = (match helpTyp with + | Some (_, help_typ) -> + let help_text = (match help_typ with | FunctionCall -> "yourFunctionCall()" | Other -> "yourExpression") in - Printf.sprintf "\n\n Possible solutions:\n - Assigning to a value that is then ignored: `let _ = %s`\n - Piping into the built-in ignore function to ignore the result: `%s->ignore`" helpText helpText + Printf.sprintf "\n\n Possible solutions:\n - Assigning to a value that is then ignored: `let _ = %s`\n - Piping into the built-in ignore function to ignore the result: `%s->ignore`" help_text help_text | _ -> "") + | Bs_todo maybe_text -> ( + match maybe_text with + | None -> "Todo found." + | Some todo -> "Todo found: " ^ todo + ) ^ "\n\n This code is not implemented yet and will crash at runtime. Make sure you implement this before running the code." let sub_locs = function | Deprecated (_, def, use) -> @@ -630,7 +637,7 @@ let descriptions = (101, "Unused bs attributes"); (102, "Polymorphic comparison introduced (maybe unsafe)"); (103, "Fragile FFI definitions"); - (104, "bs.deriving warning with customized message "); + (104, "@deriving warning with customized message "); ( 105, "External name is inferred from val name is unsafe from refactoring when \ changing value name" ); @@ -640,7 +647,7 @@ let descriptions = ); (108, "Uninterpreted delimiters (for unicode)"); (109, "Toplevel expression has unit type"); - (110, "Expression has nested promise type"); + (110, "Todo found"); ] let help_warnings () = diff --git a/analysis/vendor/ext/warnings.mli b/analysis/vendor/ext/warnings.mli index d5d8445c2..e72f4f980 100644 --- a/analysis/vendor/ext/warnings.mli +++ b/analysis/vendor/ext/warnings.mli @@ -19,7 +19,7 @@ type loc = { loc_ghost : bool; } -type topLevelUnitHelp = FunctionCall | Other +type top_level_unit_help = FunctionCall | Other type t = | Comment_start (* 1 *) @@ -78,7 +78,8 @@ type t = | Bs_unimplemented_primitive of string (* 106 *) | Bs_integer_literal_overflow (* 107 *) | Bs_uninterpreted_delimiters of string (* 108 *) - | Bs_toplevel_expression_unit of (string * topLevelUnitHelp) option (* 109 *) + | Bs_toplevel_expression_unit of (string * top_level_unit_help) option (* 109 *) + | Bs_todo of string option (* 110 *) val parse_options : bool -> string -> unit diff --git a/analysis/vendor/ml/ast_async.ml b/analysis/vendor/ml/ast_async.ml index d16b193a4..51dff6e4d 100644 --- a/analysis/vendor/ml/ast_async.ml +++ b/analysis/vendor/ml/ast_async.ml @@ -13,12 +13,18 @@ let add_promise_type ?(loc = Location.none) ~async let add_async_attribute ~async (body : Parsetree.expression) = if async then - { - body with - pexp_attributes = - ({txt = "res.async"; loc = Location.none}, PStr []) - :: body.pexp_attributes; - } + ( + match body.pexp_desc with + | Pexp_construct (x, Some e) when Ast_uncurried.expr_is_uncurried_fun body -> + {body with pexp_desc = Pexp_construct (x, Some {e with pexp_attributes = + ({txt = "res.async"; loc = Location.none}, PStr []) :: e.pexp_attributes} )} + | _ -> + { + body with + pexp_attributes = + ({txt = "res.async"; loc = Location.none}, PStr []) + :: body.pexp_attributes; + }) else body let rec add_promise_to_result ~loc (e : Parsetree.expression) = diff --git a/analysis/vendor/ml/ast_await.ml b/analysis/vendor/ml/ast_await.ml index 410f3b9c7..1393f04de 100644 --- a/analysis/vendor/ml/ast_await.ml +++ b/analysis/vendor/ml/ast_await.ml @@ -2,7 +2,7 @@ let is_await : Parsetree.attribute -> bool = fun ({txt}, _) -> txt = "await" || txt = "res.await" let create_await_expression (e : Parsetree.expression) = - let loc = e.pexp_loc in + let loc = {e.pexp_loc with loc_ghost = true} in let unsafe_await = Ast_helper.Exp.ident ~loc {txt = Ldot (Ldot (Lident "Js", "Promise"), "unsafe_await"); loc} diff --git a/analysis/vendor/ml/ast_payload.ml b/analysis/vendor/ml/ast_payload.ml index 0f973b9e1..0fe198d43 100644 --- a/analysis/vendor/ml/ast_payload.ml +++ b/analysis/vendor/ml/ast_payload.ml @@ -61,10 +61,10 @@ let is_single_int (x : t) : int option = { pstr_desc = Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_integer (name, _)); _}, _); + ({pexp_desc = Pexp_constant (Pconst_integer (name, char)); _}, _); _; }; - ] -> + ] when (match char with Some n when n = 'n' -> false | _ -> true) -> Some (int_of_string name) | _ -> None @@ -82,6 +82,20 @@ let is_single_float (x : t) : string option = Some name | _ -> None +let is_single_bigint (x : t) : string option = + match x with + | PStr + [ + { + pstr_desc = + Pstr_eval + ({pexp_desc = Pexp_constant (Pconst_integer (name, Some 'n')); _}, _); + _; + }; + ] -> + Some name + | _ -> None + let is_single_bool (x : t) : bool option = match x with | PStr @@ -170,7 +184,7 @@ type action = lid * Parsetree.expression option {[ { x = exp }]} *) -let unrecognizedConfigRecord loc text = +let unrecognized_config_record loc text = Location.prerr_warning loc (Warnings.Bs_derive_warning text) let ident_or_record_as_config loc (x : t) : @@ -197,7 +211,7 @@ let ident_or_record_as_config loc (x : t) : | {txt = Lident name; loc}, y -> ({Asttypes.txt = name; loc}, Some y) | _ -> Location.raise_errorf ~loc "Qualified label is not allowed") | Some _ -> - unrecognizedConfigRecord loc "`with` is not supported, discarding"; + unrecognized_config_record loc "`with` is not supported, discarding"; []) | PStr [ @@ -210,7 +224,7 @@ let ident_or_record_as_config loc (x : t) : [({Asttypes.txt; loc = lloc}, None)] | PStr [] -> [] | _ -> - unrecognizedConfigRecord loc "invalid attribute config-record, ignoring"; + unrecognized_config_record loc "invalid attribute config-record, ignoring"; [] let assert_strings loc (x : t) : string list = diff --git a/analysis/vendor/ml/ast_payload.mli b/analysis/vendor/ml/ast_payload.mli index addd8f911..493ad8efb 100644 --- a/analysis/vendor/ml/ast_payload.mli +++ b/analysis/vendor/ml/ast_payload.mli @@ -41,6 +41,8 @@ val is_single_int : t -> int option val is_single_float : t -> string option +val is_single_bigint : t -> string option + val is_single_bool : t -> bool option val is_single_ident : t -> Longident.t option @@ -63,11 +65,11 @@ val assert_strings : Location.t -> t -> string list (** as a record or empty it will accept - {[ [@@@bs.config ]]} + {[ [@@@config ]]} or - {[ [@@@bs.config no_export ] ]} + {[ [@@@config no_export ] ]} or - {[ [@@@bs.config { property .. } ]]} + {[ [@@@config { property .. } ]]} Note that we only {[ { flat_property} @@ -87,6 +89,6 @@ val empty : t val table_dispatch : (Parsetree.expression option -> 'a) Map_string.t -> action -> 'a -val unrecognizedConfigRecord : Location.t -> string -> unit +val unrecognized_config_record : Location.t -> string -> unit (** Report to the user, as a warning, that the bs-attribute parser is bailing out. (This is to allow external ppx, like ppx_deriving, to pick up where the builtin ppx leave off.) *) diff --git a/analysis/vendor/ml/ast_uncurried.ml b/analysis/vendor/ml/ast_uncurried.ml index 1a49b2743..ef7ad20c5 100644 --- a/analysis/vendor/ml/ast_uncurried.ml +++ b/analysis/vendor/ml/ast_uncurried.ml @@ -4,21 +4,21 @@ let encode_arity_string arity = "Has_arity" ^ string_of_int arity let decode_arity_string arity_s = int_of_string ((String.sub [@doesNotRaise]) arity_s 9 (String.length arity_s - 9)) -let arityType ~loc arity = +let arity_type ~loc arity = Ast_helper.Typ.variant ~loc [ Rtag ({ txt = encode_arity_string arity; loc }, [], true, []) ] Closed None -let arityFromType (typ : Parsetree.core_type) = +let arity_from_type (typ : Parsetree.core_type) = match typ.ptyp_desc with | Ptyp_variant ([Rtag ({txt}, _, _, _)], _, _) -> decode_arity_string txt | _ -> assert false -let uncurriedType ~loc ~arity tArg = - let tArity = arityType ~loc arity in +let uncurried_type ~loc ~arity t_arg = + let t_arity = arity_type ~loc arity in Ast_helper.Typ.constr ~loc { txt = Lident "function$"; loc } - [ tArg; tArity ] + [ t_arg; t_arity ] let arity_to_attributes arity = [ @@ -47,34 +47,40 @@ let rec attributes_to_arity (attrs : Parsetree.attributes) = | _ :: rest -> attributes_to_arity rest | _ -> assert false -let uncurriedFun ~loc ~arity funExpr = +let uncurried_fun ~loc ~arity fun_expr = Ast_helper.Exp.construct ~loc ~attrs:(arity_to_attributes arity) (Location.mknoloc (Longident.Lident "Function$")) - (Some funExpr) + (Some fun_expr) -let exprIsUncurriedFun (expr : Parsetree.expression) = +let expr_is_uncurried_fun (expr : Parsetree.expression) = match expr.pexp_desc with | Pexp_construct ({ txt = Lident "Function$" }, Some _) -> true | _ -> false -let exprExtractUncurriedFun (expr : Parsetree.expression) = +let expr_extract_uncurried_fun (expr : Parsetree.expression) = match expr.pexp_desc with | Pexp_construct ({ txt = Lident "Function$" }, Some e) -> e | _ -> assert false -let coreTypeIsUncurriedFun (typ : Parsetree.core_type) = +let core_type_is_uncurried_fun (typ : Parsetree.core_type) = match typ.ptyp_desc with | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow _}; _]) -> true | _ -> false -let typeIsUncurriedFun = Ast_uncurried_utils.typeIsUncurriedFun - -let typeExtractUncurriedFun (typ : Parsetree.core_type) = +let core_type_extract_uncurried_fun (typ : Parsetree.core_type) = match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident "function$"}, [tArg; tArity]) -> - (arityFromType tArity, tArg) + | Ptyp_constr ({txt = Lident "function$"}, [t_arg; t_arity]) -> + (arity_from_type t_arity, t_arg) + | _ -> assert false + +let type_is_uncurried_fun = Ast_uncurried_utils.type_is_uncurried_fun + +let type_extract_uncurried_fun (typ : Types.type_expr) = + match typ.desc with + | Tconstr (Pident {name = "function$"}, [t_arg; _], _) -> + t_arg | _ -> assert false (* Typed AST *) @@ -92,8 +98,8 @@ let arity_to_type arity = row_name = None; }) -let type_to_arity (tArity : Types.type_expr) = - match (Ctype.repr tArity).desc with +let type_to_arity (t_arity : Types.type_expr) = + match (Ctype.repr t_arity).desc with | Tvariant { row_fields = [ (label, _) ] } -> decode_arity_string label | _ -> assert false @@ -105,12 +111,15 @@ let make_uncurried_type ~env ~arity t = let uncurried_type_get_arity ~env typ = match (Ctype.expand_head env typ).desc with - | Tconstr (Pident { name = "function$" }, [ _t; tArity ], _) -> - type_to_arity tArity + | Tconstr (Pident { name = "function$" }, [ _t; t_arity ], _) -> + type_to_arity t_arity | _ -> assert false let uncurried_type_get_arity_opt ~env typ = match (Ctype.expand_head env typ).desc with - | Tconstr (Pident { name = "function$" }, [ _t; tArity ], _) -> - Some (type_to_arity tArity) + | Tconstr (Pident { name = "function$" }, [ _t; t_arity ], _) -> + Some (type_to_arity t_arity) | _ -> None + + + diff --git a/analysis/vendor/ml/ast_uncurried_utils.ml b/analysis/vendor/ml/ast_uncurried_utils.ml index ad18b01a6..d88459390 100644 --- a/analysis/vendor/ml/ast_uncurried_utils.ml +++ b/analysis/vendor/ml/ast_uncurried_utils.ml @@ -1,4 +1,4 @@ -let typeIsUncurriedFun (typ : Types.type_expr) = +let type_is_uncurried_fun (typ : Types.type_expr) = match typ.desc with | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) -> true diff --git a/analysis/vendor/ml/ast_untagged_variants.ml b/analysis/vendor/ml/ast_untagged_variants.ml index 7f4e85532..21944c6a1 100644 --- a/analysis/vendor/ml/ast_untagged_variants.ml +++ b/analysis/vendor/ml/ast_untagged_variants.ml @@ -15,13 +15,14 @@ module Instance = struct | RegExp -> "RegExp" end -type untaggedError = +type untagged_error = | OnlyOneUnknown of string | AtMostOneObject | AtMostOneInstance of Instance.t | AtMostOneFunction | AtMostOneString | AtMostOneNumber + | AtMostOneBigint | AtMostOneBoolean | DuplicateLiteral of string | ConstructorMoreThanOneArg of string @@ -29,7 +30,7 @@ type error = | InvalidVariantAsAnnotation | Duplicated_bs_as | InvalidVariantTagAnnotation - | InvalidUntaggedVariantDefinition of untaggedError + | InvalidUntaggedVariantDefinition of untagged_error exception Error of Location.t * error let report_error ppf = @@ -42,17 +43,20 @@ let report_error ppf = | Duplicated_bs_as -> fprintf ppf "duplicate @as " | InvalidVariantTagAnnotation -> fprintf ppf "A variant tag annotation @tag(...) must be a string" - | InvalidUntaggedVariantDefinition untaggedVariant -> + | InvalidUntaggedVariantDefinition untagged_variant -> fprintf ppf "This untagged variant definition is invalid: %s" - (match untaggedVariant with + (match untagged_variant with | OnlyOneUnknown name -> "Case " ^ name ^ " has a payload that is not of one of the recognized shapes (object, array, etc). Then it must be the only case with payloads." | AtMostOneObject -> "At most one case can be an object type." + | AtMostOneInstance Array -> "At most one case can be an array or tuple type." | AtMostOneInstance i -> "At most one case can be a " ^ (Instance.to_string i) ^ " type." | AtMostOneFunction -> "At most one case can be a function type." | AtMostOneString -> "At most one case can be a string type." | AtMostOneBoolean -> "At most one case can be a boolean type." | AtMostOneNumber -> "At most one case can be a number type (int or float)." + | AtMostOneBigint -> + "At most one case can be a bigint type." | DuplicateLiteral s -> "Duplicate literal " ^ s ^ "." | ConstructorMoreThanOneArg (name) -> "Constructor " ^ name ^ " has more than one argument.") @@ -61,6 +65,7 @@ type block_type = | IntType | StringType | FloatType + | BigintType | BooleanType | InstanceType of Instance.t | FunctionType @@ -76,6 +81,7 @@ type tag_type = | String of string | Int of int | Float of string + | BigInt of string | Bool of bool | Null | Undefined (* literal or tagged block *) @@ -107,7 +113,7 @@ let process_tag_type (attrs : Parsetree.attributes) = let st : tag_type option ref = ref None in Ext_list.iter attrs (fun ({txt; loc}, payload) -> match txt with - | "bs.as" | "as" -> + | "as" -> if !st = None then ( (match Ast_payload.is_single_string payload with | None -> () @@ -118,6 +124,9 @@ let process_tag_type (attrs : Parsetree.attributes) = (match Ast_payload.is_single_float payload with | None -> () | Some f -> st := Some (Float f)); + (match Ast_payload.is_single_bigint payload with + | None -> () + | Some i -> st := Some (BigInt i)); (match Ast_payload.is_single_bool payload with | None -> () | Some b -> st := Some (Bool b)); @@ -136,11 +145,12 @@ let () = | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) | _ -> None) -let reportConstructorMoreThanOneArg ~loc ~name = +let report_constructor_more_than_one_arg ~loc ~name = raise (Error (loc, InvalidUntaggedVariantDefinition (ConstructorMoreThanOneArg name))) let type_is_builtin_object (t : Types.type_expr) = match t.desc with + | Tconstr (Path.Pident ident, [_], _) when Ident.name ident = "dict" -> true | Tconstr (path, _, _) -> let name = Path.name path in name = "Js.Dict.t" || name = "Js_dict.t" @@ -170,9 +180,11 @@ let get_block_type_from_typ ~env (t: Types.type_expr) : block_type option = Some IntType | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_float -> Some FloatType + | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bigint -> + Some BigintType | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bool -> Some BooleanType - | ({desc = Tconstr _} as t) when Ast_uncurried_utils.typeIsUncurriedFun t -> + | ({desc = Tconstr _} as t) when Ast_uncurried_utils.type_is_uncurried_fun t -> Some FunctionType | {desc = Tarrow _} -> Some FunctionType | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string -> @@ -182,14 +194,15 @@ let get_block_type_from_typ ~env (t: Types.type_expr) : block_type option = | ({desc = Tconstr _} as t) when type_to_instanceof_backed_obj t |> Option.is_some -> (match type_to_instanceof_backed_obj t with | None -> None - | Some instanceType -> Some (InstanceType instanceType)) + | Some instance_type -> Some (InstanceType instance_type)) + | {desc = Ttuple _} -> Some (InstanceType Array) | _ -> None let get_block_type ~env (cstr : Types.constructor_declaration) : block_type option = match (process_untagged cstr.cd_attributes, cstr.cd_args) with | false, _ -> None - | true, Cstr_tuple [{desc = Tconstr _} as t] when get_block_type_from_typ ~env t |> Option.is_some -> get_block_type_from_typ ~env t + | true, Cstr_tuple [t] when get_block_type_from_typ ~env t |> Option.is_some -> get_block_type_from_typ ~env t | true, Cstr_tuple [ty] -> ( let default = Some UnknownType in match !extract_concrete_typedecl env ty with @@ -227,79 +240,84 @@ let is_nullary_variant (x : Types.constructor_arguments) = | Types.Cstr_tuple [] -> true | _ -> false -let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list) +let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) ~(blocks : (Location.t * block) list) = let module StringSet = Set.Make (String) in let string_literals = ref StringSet.empty in let nonstring_literals = ref StringSet.empty in - let instanceTypes = Hashtbl.create 1 in - let functionTypes = ref 0 in - let objectTypes = ref 0 in - let stringTypes = ref 0 in - let numberTypes = ref 0 in - let booleanTypes = ref 0 in - let unknownTypes = ref 0 in - let addStringLiteral ~loc s = + let instance_types = Hashtbl.create 1 in + let function_types = ref 0 in + let object_types = ref 0 in + let string_types = ref 0 in + let number_types = ref 0 in + let bigint_types = ref 0 in + let boolean_types = ref 0 in + let unknown_types = ref 0 in + let add_string_literal ~loc s = if StringSet.mem s !string_literals then raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); string_literals := StringSet.add s !string_literals in - let addNonstringLiteral ~loc s = + let add_nonstring_literal ~loc s = if StringSet.mem s !nonstring_literals then raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); nonstring_literals := StringSet.add s !nonstring_literals in let invariant loc name = - if !unknownTypes <> 0 && List.length blocks <> 1 then + if !unknown_types <> 0 && List.length blocks <> 1 then raise (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name))); - if !objectTypes > 1 then + if !object_types > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); Hashtbl.iter (fun i count -> if count > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition (AtMostOneInstance i)))) - instanceTypes; - if !functionTypes > 1 then + instance_types; + if !function_types > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction)); - if !stringTypes > 1 then + if !string_types > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString)); - if !numberTypes > 1 then + if !number_types > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber)); - if !booleanTypes > 1 then + if !bigint_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBigint)); + if !boolean_types > 1 then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); - if !booleanTypes > 0 && (StringSet.mem "true" !nonstring_literals || StringSet.mem "false" !nonstring_literals) then + if !boolean_types > 0 && (StringSet.mem "true" !nonstring_literals || StringSet.mem "false" !nonstring_literals) then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); () in Ext_list.rev_iter consts (fun (loc, literal) -> match literal.tag_type with - | Some (String s) -> addStringLiteral ~loc s - | Some (Int i) -> addNonstringLiteral ~loc (string_of_int i) - | Some (Float f) -> addNonstringLiteral ~loc f - | Some Null -> addNonstringLiteral ~loc "null" - | Some Undefined -> addNonstringLiteral ~loc "undefined" - | Some (Bool b) -> addNonstringLiteral ~loc (if b then "true" else "false") + | Some (String s) -> add_string_literal ~loc s + | Some (Int i) -> add_nonstring_literal ~loc (string_of_int i) + | Some (Float f) -> add_nonstring_literal ~loc f + | Some (BigInt i) -> add_nonstring_literal ~loc i + | Some Null -> add_nonstring_literal ~loc "null" + | Some Undefined -> add_nonstring_literal ~loc "undefined" + | Some (Bool b) -> add_nonstring_literal ~loc (if b then "true" else "false") | Some (Untagged _) -> () - | None -> addStringLiteral ~loc literal.name); - if isUntaggedDef then + | None -> add_string_literal ~loc literal.name); + if is_untagged_def then Ext_list.rev_iter blocks (fun (loc, block) -> match block.block_type with | Some block_type -> (match block_type with - | UnknownType -> incr unknownTypes; - | ObjectType -> incr objectTypes; + | UnknownType -> incr unknown_types; + | ObjectType -> incr object_types; | (InstanceType i) -> - let count = Hashtbl.find_opt instanceTypes i |> Option.value ~default:0 in - Hashtbl.replace instanceTypes i (count + 1); - | FunctionType -> incr functionTypes; - | (IntType | FloatType) -> incr numberTypes; - | BooleanType -> incr booleanTypes; - | StringType -> incr stringTypes; + let count = Hashtbl.find_opt instance_types i |> Option.value ~default:0 in + Hashtbl.replace instance_types i (count + 1); + | FunctionType -> incr function_types; + | (IntType | FloatType) -> incr number_types; + | BigintType -> incr bigint_types; + | BooleanType -> incr boolean_types; + | StringType -> incr string_types; ); invariant loc block.tag.name | None -> () ) -let names_from_type_variant ?(isUntaggedDef = false) ~env +let names_from_type_variant ?(is_untagged_def = false) ~env (cstrs : Types.constructor_declaration list) = let get_cstr_name (cstr : Types.constructor_declaration) = ( cstr.cd_loc, @@ -318,16 +336,16 @@ let names_from_type_variant ?(isUntaggedDef = false) ~env (get_cstr_name cstr :: consts, blocks) else (consts, (cstr.cd_loc, get_block cstr) :: blocks)) in - checkInvariant ~isUntaggedDef ~consts ~blocks; + check_invariant ~is_untagged_def ~consts ~blocks; let blocks = blocks |> List.map snd in let consts = consts |> List.map snd in let consts = Ext_array.reverse_of_list consts in let blocks = Ext_array.reverse_of_list blocks in Some {consts; blocks} -let check_well_formed ~env ~isUntaggedDef +let check_well_formed ~env ~is_untagged_def (cstrs : Types.constructor_declaration list) = - ignore (names_from_type_variant ~env ~isUntaggedDef cstrs) + ignore (names_from_type_variant ~env ~is_untagged_def cstrs) let has_undefined_literal attrs = process_tag_type attrs = Some Undefined @@ -356,6 +374,9 @@ module DynamicChecks = struct let function_ = Untagged FunctionType |> tag_type let string = Untagged StringType |> tag_type let number = Untagged IntType |> tag_type + + let bigint = Untagged BigintType |> tag_type + let boolean = Untagged BooleanType |> tag_type let ( == ) x y = bin EqEqEq x y @@ -375,6 +396,11 @@ module DynamicChecks = struct | Int _ | Float _ -> true | _ -> false) in + let literals_overlaps_with_bigint () = + Ext_list.exists literal_cases (function + | BigInt _ -> true + | _ -> false) + in let literals_overlaps_with_boolean () = Ext_list.exists literal_cases (function | Bool _ -> true @@ -395,6 +421,8 @@ module DynamicChecks = struct typeof e != number | FloatType when literals_overlaps_with_number () = false -> typeof e != number + | BigintType when literals_overlaps_with_bigint () = false -> + typeof e != bigint | BooleanType when literals_overlaps_with_boolean () = false -> typeof e != boolean | InstanceType i -> not (is_instance i e) @@ -405,6 +433,7 @@ module DynamicChecks = struct | StringType (* overlap *) | IntType (* overlap *) | FloatType (* overlap *) + | BigintType (* overlap *) | BooleanType (* overlap *) | UnknownType -> ( (* We don't know the type of unknown, so we need to express: @@ -446,7 +475,7 @@ module DynamicChecks = struct let add_runtime_type_check ~tag_type ~(block_cases : block_type list) x y = let instances = Ext_list.filter_map block_cases (function InstanceType i -> Some i | _ -> None) in match tag_type with - | Untagged (IntType | StringType | FloatType | BooleanType | FunctionType) -> + | Untagged (IntType | StringType | FloatType | BigintType | BooleanType | FunctionType) -> typeof y == x | Untagged ObjectType -> if instances <> [] then @@ -459,5 +488,5 @@ module DynamicChecks = struct | Untagged UnknownType -> (* This should not happen because unknown must be the only non-literal case *) assert false - | Bool _ | Float _ | Int _ | String _ | Null | Undefined -> x + | Bool _ | Float _ | Int _ | BigInt _ | String _ | Null | Undefined -> x end diff --git a/analysis/vendor/ml/asttypes.ml b/analysis/vendor/ml/asttypes.ml index 8fefc4528..5abbdaa0a 100644 --- a/analysis/vendor/ml/asttypes.ml +++ b/analysis/vendor/ml/asttypes.ml @@ -22,7 +22,7 @@ type constant = | Const_float of string | Const_int32 of int32 | Const_int64 of int64 - | Const_nativeint of nativeint + | Const_bigint of bool * string type rec_flag = Nonrecursive | Recursive diff --git a/analysis/vendor/ml/bigint_utils.ml b/analysis/vendor/ml/bigint_utils.ml new file mode 100644 index 000000000..e0f3fe9ac --- /dev/null +++ b/analysis/vendor/ml/bigint_utils.ml @@ -0,0 +1,84 @@ +let is_neg s = String.length s > 0 && s.[0] = '-' +let is_pos s = String.length s > 0 && s.[0] = '+' + +let to_string sign s = (if sign then "" else "-") ^ s + +let remove_leading_sign str : bool * string = + let len = String.length str in + if len = 0 then (false, str) + else + if is_neg str || is_pos str then (not (is_neg str), String.sub str 1 (len -1)) + else (true, str) + +(* + Removes leading zeros from the string only if the first non-zero character + encountered is a digit. Unlike int and float, bigint cannot be of_string, so + This function removes only leading 0s. Instead, values like 00x1 are not converted + and are intended to be syntax errors. + + 000n -> 0n + 001n -> 1n + 01_000_000n -> 1000000n + -00100n -> -100n + + The following values are syntax errors + + 00o1n -> 00o1n + 00x1_000_000n -> 00x1000000n +*) +let remove_leading_zeros str = + let aux str = + let len = String.length str in + if len = 0 then "" + else + let is_digit c = c >= '0' && c <= '9' in + let idx = ref 0 in + while !idx < len && str.[!idx] = '0' do + incr idx + done; + if !idx >= len then "0" (* If the string contains only '0's, return '0'. *) + else if (is_digit str.[!idx]) then String.sub str !idx (len - !idx) (* Remove leading zeros and return the rest of the string. *) + else str + in + (* Replace the delimiters '_' inside number *) + let str = String.concat "" (String.split_on_char '_' str) in + (* Check if negative *) + let starts_with_minus = str <> "" && str.[0] = '-' in + let str = if is_neg str || is_pos str then String.sub str 1 (String.length str - 1) else str in + let processed_str = aux str in + if starts_with_minus then "-" ^ processed_str else processed_str + +let parse_bigint s = + let sign, i = remove_leading_sign s in + (sign, remove_leading_zeros i) + +let is_valid s = + let len = String.length s in + if len = 0 then false + else + let is_digit c = (c >= '0' && c <= '9') || c = '_' in + let first_char = s.[0] in + if first_char <> '-' && first_char <> '+' && not (is_digit first_char) then false + else + let rec check idx = + if idx >= len then true + else + let c = s.[idx] in + if is_digit c then check (idx + 1) + else false + in + check 1 + +let compare (p0, s0) (p1, s1) = + match (p0, p1) with + | (false, true) -> -1 (* If only s1 is positive, s0 is smaller. *) + | (true, false) -> 1 (* If only s0 is positive, s0 is larger. *) + | _ -> + (* If both numbers are either negative or positive, compare their lengths. *) + let len0, len1 = (String.length s0, String.length s1) in + if len0 = len1 then + if p0 then String.compare s0 s1 else String.compare s1 s0 (* If lengths are equal, compare the strings directly. *) + else if len0 > len1 then + if p0 then 1 else -1 (* A longer s0 means it's larger unless it's negative. *) + else (* len0 < len1 *) + if p0 then -1 else 1 (* A longer s1 means s0 is smaller unless s1 is negative. *) diff --git a/analysis/vendor/ml/bigint_utils.mli b/analysis/vendor/ml/bigint_utils.mli new file mode 100644 index 000000000..34f9dfb62 --- /dev/null +++ b/analysis/vendor/ml/bigint_utils.mli @@ -0,0 +1,8 @@ +val is_neg: string -> bool +val is_pos: string -> bool +val to_string: bool -> string -> string +val remove_leading_sign : string -> bool * string +val remove_leading_zeros : string -> string +val parse_bigint: string -> bool * string +val is_valid : string -> bool +val compare : bool * string -> bool * string -> int diff --git a/analysis/vendor/ml/code_frame.ml b/analysis/vendor/ml/code_frame.ml index dc536152a..f0fdad120 100644 --- a/analysis/vendor/ml/code_frame.ml +++ b/analysis/vendor/ml/code_frame.ml @@ -119,12 +119,12 @@ type line = { - center snippet when it's heavily indented - ellide intermediate lines when the reported range is huge *) -let print ~is_warning ~src ~(startPos : Lexing.position) ~(endPos:Lexing.position) = +let print ~is_warning ~src ~(start_pos : Lexing.position) ~(end_pos:Lexing.position) = let indent = 2 in - let highlight_line_start_line = startPos.pos_lnum in - let highlight_line_end_line = endPos.pos_lnum in - let (start_line_line_offset, first_shown_line) = seek_2_lines_before src startPos in - let (end_line_line_end_offset, last_shown_line) = seek_2_lines_after src endPos in + let highlight_line_start_line = start_pos.pos_lnum in + let highlight_line_end_line = end_pos.pos_lnum in + let (start_line_line_offset, first_shown_line) = seek_2_lines_before src start_pos in + let (end_line_line_end_offset, last_shown_line) = seek_2_lines_after src end_pos in let more_than_5_highlighted_lines = highlight_line_end_line - highlight_line_start_line + 1 > 5 @@ -167,8 +167,8 @@ let print ~is_warning ~src ~(startPos : Lexing.position) ~(endPos:Lexing.positio match gutter with | Elided -> {s = line; start = 0; end_ = 0} | Number line_number -> - let highlight_line_start_offset = startPos.pos_cnum - startPos.pos_bol in - let highlight_line_end_offset = endPos.pos_cnum - endPos.pos_bol in + let highlight_line_start_offset = start_pos.pos_cnum - start_pos.pos_bol in + let highlight_line_end_offset = end_pos.pos_cnum - end_pos.pos_bol in let start = if i = 0 && line_number = highlight_line_start_line then highlight_line_start_offset - leading_space_to_cut diff --git a/analysis/vendor/ml/ctype.ml b/analysis/vendor/ml/ctype.ml index 89143f44b..9aa37f276 100644 --- a/analysis/vendor/ml/ctype.ml +++ b/analysis/vendor/ml/ctype.ml @@ -2396,9 +2396,9 @@ and unify3 env t1 t1' t2 t2' = link_type t2' t1; | (Tfield _, Tfield _) -> (* special case for GADTs *) unify_fields env t1' t2' - | (Tconstr (Pident {name="function$"}, [tFun; _], _), Tarrow _) when !Config.uncurried = Uncurried -> + | (Tconstr (Pident {name="function$"}, [t_fun; _], _), Tarrow _) when !Config.uncurried = Uncurried -> (* subtype: an uncurried function is cast to a curried one *) - unify2 env tFun t2 + unify2 env t_fun t2 | _ -> begin match !umode with | Expression -> @@ -3904,6 +3904,11 @@ let subtypes = TypePairs.create 17 let subtype_error env trace = raise (Subtype (expand_trace env (List.rev trace), [])) +let extract_concrete_typedecl_opt env t = + match extract_concrete_typedecl env t with + | v -> Some v + | exception Not_found -> None + let rec subtype_rec env trace t1 t2 cstrs = let t1 = repr t1 in let t2 = repr t2 in @@ -3939,8 +3944,14 @@ let rec subtype_rec env trace t1 t2 cstrs = let (co, cn) = Variance.get_upper v in if co then if cn then - (trace, newty2 t1.level (Ttuple[t1]), - newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs + (* Invariant type argument: check both ways *) + if + subtype_rec env ((t1, t2)::trace) t1 t2 [] = [] && + subtype_rec env ((t2, t1)::trace) t2 t1 [] = [] then + cstrs + else + (trace, newty2 t1.level (Ttuple[t1]), + newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs else subtype_rec env ((t1, t2)::trace) t1 t2 cstrs else if cn then subtype_rec env ((t2, t1)::trace) t2 t1 cstrs @@ -3951,13 +3962,28 @@ let rec subtype_rec env trace t1 t2 cstrs = end | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 -> subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs - | (Tconstr(_, [], _), Tconstr(path, [], _)) when Variant_coercion.can_coerce_path path && - extract_concrete_typedecl env t1 |> Variant_coercion.can_try_coerce_variant_to_primitive |> Option.is_some + | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 Predef.path_int && Path.same p2 Predef.path_float -> + cstrs + | (Tconstr(path, [], _), Tconstr(_, [], _)) when Variant_coercion.can_coerce_primitive path && + extract_concrete_typedecl_opt env t2 |> Variant_coercion.can_try_coerce_variant_to_primitive_opt |> Option.is_some + -> + (* type coercion for primitives (int/float/string) to elgible unboxed variants: + - must be unboxed + - must have a constructor case with a supported and matching primitive payload *) + (match Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t2) with + | Some (constructors, true) -> + if Variant_coercion.variant_has_catch_all_case constructors (fun p -> Path.same p path) then + cstrs + else + (trace, t1, t2, !univar_pairs)::cstrs + | _ -> (trace, t1, t2, !univar_pairs)::cstrs) + | (Tconstr(_, [], _), Tconstr(path, [], _)) when Variant_coercion.can_coerce_primitive path && + extract_concrete_typedecl_opt env t1 |> Variant_coercion.can_try_coerce_variant_to_primitive_opt |> Option.is_some -> (* type coercion for variants to primitives *) - (match Variant_coercion.can_try_coerce_variant_to_primitive (extract_concrete_typedecl env t1) with - | Some constructors -> - if constructors |> Variant_coercion.can_coerce_variant ~path then + (match Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t1) with + | Some (constructors, unboxed) -> + if constructors |> Variant_coercion.variant_has_same_runtime_representation_as_target ~target_path:path ~unboxed then cstrs else (trace, t1, t2, !univar_pairs)::cstrs diff --git a/analysis/vendor/ml/error_message_utils.ml b/analysis/vendor/ml/error_message_utils.ml index f0b47ecd5..2f5312916 100644 --- a/analysis/vendor/ml/error_message_utils.ml +++ b/analysis/vendor/ml/error_message_utils.ml @@ -1,5 +1,5 @@ -type typeClashStatement = FunctionCall -type typeClashContext = +type type_clash_statement = FunctionCall +type type_clash_context = | SetRecordField | ArrayValue | FunctionReturn @@ -10,20 +10,20 @@ type typeClashContext = | StringConcat | ComparisonOperator | MathOperator of { - forFloat: bool; + for_float: bool; operator: string; - isConstant: string option; + is_constant: string option; } | FunctionArgument - | Statement of typeClashStatement + | Statement of type_clash_statement let fprintf = Format.fprintf -let errorTypeText ppf typeClashContext = +let error_type_text ppf type_clash_context = let text = - match typeClashContext with + match type_clash_context with | Some (Statement FunctionCall) -> "This function call returns:" - | Some (MathOperator {isConstant = Some _}) -> "This value has type:" + | Some (MathOperator {is_constant = Some _}) -> "This value has type:" | Some ArrayValue -> "This array item has type:" | Some SetRecordField -> "You're assigning something to this field that has type:" @@ -31,8 +31,8 @@ let errorTypeText ppf typeClashContext = in fprintf ppf "%s" text -let errorExpectedTypeText ppf typeClashContext = - match typeClashContext with +let error_expected_type_text ppf type_clash_context = + match type_clash_context with | Some FunctionArgument -> fprintf ppf "But this function argument is expecting:" | Some ComparisonOperator -> @@ -54,10 +54,10 @@ let errorExpectedTypeText ppf typeClashContext = fprintf ppf "But this function is expecting you to return:" | _ -> fprintf ppf "But it's expected to have type:" -let printExtraTypeClashHelp ppf trace typeClashContext = - match (typeClashContext, trace) with - | Some (MathOperator {forFloat; operator; isConstant}), _ -> ( - let operatorForOtherType = +let print_extra_type_clash_help ppf trace type_clash_context = + match (type_clash_context, trace) with + | Some (MathOperator {for_float; operator; is_constant}), _ -> ( + let operator_for_other_type = match operator with | "+" -> "+." | "+." -> "+" @@ -68,7 +68,7 @@ let printExtraTypeClashHelp ppf trace typeClashContext = | "*." -> "*" | v -> v in - let operatorText = + let operator_text = match operator.[0] with | '+' -> "add" | '-' -> "subtract" @@ -100,11 +100,11 @@ let printExtraTypeClashHelp ppf trace typeClashContext = \ - Ensure all values in this calculation has the type @{%s@}. \ You can convert between floats and ints via \ @{Belt.Float.toInt@} and @{Belt.Int.fromFloat@}." - operatorText - (if forFloat then "float" else "int")); - match (isConstant, trace) with + operator_text + (if for_float then "float" else "int")); + match (is_constant, trace) with | Some constant, _ -> - if forFloat then + if for_float then fprintf ppf "\n\ \ - Make @{%s@} a @{float@} by adding a trailing dot: \ @@ -126,8 +126,8 @@ let printExtraTypeClashHelp ppf trace typeClashContext = fprintf ppf "\n\ \ - Change the operator to @{%s@}, which works on @{%s@}" - operatorForOtherType - (if forFloat then "int" else "float") + operator_for_other_type + (if for_float then "int" else "float") | _ -> ()) | _ -> ()) | Some Switch, _ -> @@ -164,8 +164,8 @@ let printExtraTypeClashHelp ppf trace typeClashContext = myTuple = (10, \"hello\", 15.5, true)" | _ -> () -let typeClashContextFromFunction sexp sfunct = - let isConstant = +let type_clash_context_from_function sexp sfunct = + let is_constant = match sexp.Parsetree.pexp_desc with | Pexp_constant (Pconst_integer (txt, _) | Pconst_float (txt, _)) -> Some txt @@ -177,38 +177,39 @@ let typeClashContextFromFunction sexp sfunct = Some ComparisonOperator | Pexp_ident {txt = Lident "++"} -> Some StringConcat | Pexp_ident {txt = Lident (("/." | "*." | "+." | "-.") as operator)} -> - Some (MathOperator {forFloat = true; operator; isConstant}) + Some (MathOperator {for_float = true; operator; is_constant}) | Pexp_ident {txt = Lident (("/" | "*" | "+" | "-") as operator)} -> - Some (MathOperator {forFloat = false; operator; isConstant}) + Some (MathOperator {for_float = false; operator; is_constant}) | _ -> Some FunctionArgument -let typeClashContextForFunctionArgument typeClashContext sarg0 = - match typeClashContext with - | Some (MathOperator {forFloat; operator}) -> +let type_clash_context_for_function_argument type_clash_context sarg0 = + match type_clash_context with + | Some (MathOperator {for_float; operator}) -> Some (MathOperator { - forFloat; + for_float; operator; - isConstant = + is_constant = (match sarg0.Parsetree.pexp_desc with | Pexp_constant (Pconst_integer (txt, _) | Pconst_float (txt, _)) -> Some txt | _ -> None); }) - | typeClashContext -> typeClashContext + | type_clash_context -> type_clash_context -let typeClashContextMaybeOption ty_expected ty_res = +let type_clash_context_maybe_option ty_expected ty_res = match (ty_expected, ty_res) with - | ( {Types.desc = Tconstr (expectedPath, _, _)}, - {Types.desc = Tconstr (typePath, _, _)} ) - when Path.same Predef.path_option typePath - && Path.same expectedPath Predef.path_option = false -> + | ( {Types.desc = Tconstr (expected_path, _, _)}, + {Types.desc = Tconstr (type_path, _, _)} ) + when Path.same Predef.path_option type_path + && Path.same expected_path Predef.path_option = false + && Path.same expected_path Predef.path_uncurried = false -> Some MaybeUnwrapOption | _ -> None -let typeClashContextInStatement sexp = +let type_clash_context_in_statement sexp = match sexp.Parsetree.pexp_desc with | Pexp_apply _ -> Some (Statement FunctionCall) | _ -> None diff --git a/analysis/vendor/ml/includecore.ml b/analysis/vendor/ml/includecore.ml index 2b8039f46..af4515be1 100644 --- a/analysis/vendor/ml/includecore.ml +++ b/analysis/vendor/ml/includecore.ml @@ -139,6 +139,8 @@ type type_mismatch = | Record_representation of record_representation * record_representation | Unboxed_representation of bool (* true means second one is unboxed *) | Immediate + | Tag_name + | Variant_representation of Ident.t let report_type_mismatch0 first second decl ppf err = let pr fmt = Format.fprintf ppf fmt in @@ -165,11 +167,11 @@ let report_type_mismatch0 first second decl ppf err = let default () = pr "Their internal representations differ" in ( match rep1, rep2 with | Record_optional_labels lbls1, Record_optional_labels lbls2 -> - let onlyInLhs = + let only_in_lhs = Ext_list.find_first lbls1 (fun l -> not (Ext_list.mem_string lbls2 l)) in - let onlyInRhs = + let only_in_rhs = Ext_list.find_first lbls2 (fun l -> not (Ext_list.mem_string lbls1 l)) in - (match onlyInLhs, onlyInRhs with + (match only_in_lhs, only_in_rhs with | Some l, _ -> pr "@optional label %s only in %s" l second | _, Some l -> @@ -183,6 +185,9 @@ let report_type_mismatch0 first second decl ppf err = (if b then second else first) decl "uses unboxed representation" | Immediate -> pr "%s is not an immediate type" first + | Tag_name -> pr "Their @tag annotations differ" + | Variant_representation s -> + pr "The internal representations for case %s are not equal" (Ident.name s) let report_type_mismatch first second decl ppf = List.iter @@ -232,6 +237,17 @@ and compare_variants ~loc env params1 params2 n compare_constructor_arguments ~loc env cd1.cd_id params1 params2 cd1.cd_args cd2.cd_args in + let r = + if r <> [] then r + else match Ast_untagged_variants.is_nullary_variant cd1.cd_args with + | true -> + let tag_type1 = Ast_untagged_variants.process_tag_type cd1.cd_attributes in + let tag_type2 = Ast_untagged_variants.process_tag_type cd2.cd_attributes in + if tag_type1 <> tag_type2 then [Variant_representation cd1.cd_id] + else [] + | false -> + r + in if r <> [] then r else compare_variants ~loc env params1 params2 (n+1) rem1 rem2 end @@ -320,6 +336,11 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = | _ -> [] in if err <> [] then err else + let err = + let tag1 = Ast_untagged_variants.process_tag_name decl1.type_attributes in + let tag2 = Ast_untagged_variants.process_tag_name decl2.type_attributes in + if tag1 <> tag2 then [Tag_name] else err in + if err <> [] then err else let err = match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract) -> [] | (Type_variant cstrs1, Type_variant cstrs2) -> diff --git a/analysis/vendor/ml/includecore.mli b/analysis/vendor/ml/includecore.mli index 1f4cffc31..2908a07b3 100644 --- a/analysis/vendor/ml/includecore.mli +++ b/analysis/vendor/ml/includecore.mli @@ -35,6 +35,8 @@ type type_mismatch = | Record_representation of record_representation * record_representation | Unboxed_representation of bool | Immediate + | Tag_name + | Variant_representation of Ident.t val value_descriptions: loc:Location.t -> Env.t -> Ident.t -> diff --git a/analysis/vendor/ml/includemod.ml b/analysis/vendor/ml/includemod.ml index 0fcfa8a50..1f7388091 100644 --- a/analysis/vendor/ml/includemod.ml +++ b/analysis/vendor/ml/includemod.ml @@ -533,14 +533,22 @@ let show_locs ppf (loc1, loc2) = show_loc "Expected declaration" ppf loc2; show_loc "Actual declaration" ppf loc1 -let include_err ppf = function +let include_err ~env ppf = function | Missing_field (id, loc, kind) -> fprintf ppf "The %s `%a' is required but not provided" kind ident id; show_loc "Expected declaration" ppf loc | Value_descriptions(id, d1, d2) -> + let curry_kind_1, curry_kind_2 = + match (Ctype.expand_head env d1.val_type, Ctype.expand_head env d2.val_type ) with + | { desc = Tarrow _ }, + { desc = Tconstr (Pident {name = "function$"},_,_)} -> (" (curried)", " (uncurried)") + | { desc = Tconstr (Pident {name = "function$"},_,_)}, + { desc = Tarrow _ } -> (" (uncurried)", " (curried)") + | _ -> ("", "") + in fprintf ppf - "@[Values do not match:@ %a@;<1 -2>is not included in@ %a@]" - (value_description id) d1 (value_description id) d2; + "@[Values do not match:@ %a%s@;<1 -2>is not included in@ %a%s@]" + (value_description id) d1 curry_kind_1 (value_description id) d2 curry_kind_2; show_locs ppf (d1.val_loc, d2.val_loc); | Type_declarations(id, d1, d2, errs) -> fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" @@ -633,7 +641,7 @@ let context ppf cxt = let include_err ppf (cxt, env, err) = Printtyp.wrap_printing_env env (fun () -> - fprintf ppf "@[%a%a@]" context (List.rev cxt) include_err err) + fprintf ppf "@[%a%a@]" context (List.rev cxt) (include_err ~env) err) let buffer = ref Bytes.empty let is_big obj = diff --git a/analysis/vendor/ml/lambda.ml b/analysis/vendor/ml/lambda.ml index 037502950..96f82c9e2 100644 --- a/analysis/vendor/ml/lambda.ml +++ b/analysis/vendor/ml/lambda.ml @@ -86,21 +86,47 @@ let mutable_flag_of_tag_info (tag : tag_info) = | Blk_some -> Immutable +type label = Types.label_description + +let find_name (attr : Parsetree.attribute) = + match attr with + | ( { txt = "as" }, + PStr + [ + { + pstr_desc = + Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (s, _)) }, _); + }; + ] ) -> + Some s + | _ -> None + +let blk_record (fields : (label * _) array) mut record_repr = + let all_labels_info = + Ext_array.map fields (fun (lbl, _) -> + Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + in + Blk_record + { fields = all_labels_info; mutable_flag = mut; record_repr } -let blk_record = ref (fun _ _ _ -> - assert false - ) - - -let blk_record_ext = ref (fun fields mutable_flag -> - let all_labels_info = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in - Blk_record_ext {fields = all_labels_info; mutable_flag } - ) -let blk_record_inlined = ref (fun fields name num_nonconst optional_labels ~tag ~attrs mutable_flag -> - let fields = fields |> Array.map (fun (x,_) -> x.Types.lbl_name) in +let blk_record_ext fields mutable_flag = + let all_labels_info = + Array.map + (fun ((lbl : label), _) -> + Ext_list.find_def lbl.Types.lbl_attributes find_name lbl.lbl_name) + fields + in + Blk_record_ext {fields = all_labels_info; mutable_flag } + +let blk_record_inlined fields name num_nonconst optional_labels ~tag ~attrs mutable_flag = + let fields = + Array.map + (fun ((lbl : label), _) -> + Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + fields + in Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; optional_labels; attrs } -) let ref_tag_info : tag_info = Blk_record {fields = [| "contents" |]; mutable_flag = Mutable; record_repr = Record_regular} @@ -117,9 +143,17 @@ type field_dbg_info = | Fld_variant | Fld_cons | Fld_array - -let fld_record = ref (fun (lbl : Types.label_description) -> - Fld_record {name = lbl.lbl_name; mutable_flag = Mutable}) + +let fld_record (lbl : label) = + Fld_record + { + name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name; + mutable_flag = lbl.lbl_mut; + } + +let fld_record_extension (lbl : label) = + Fld_record_extension + { name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name } let ref_field_info : field_dbg_info = Fld_record { name = "contents"; mutable_flag = Mutable} @@ -131,8 +165,21 @@ type set_field_dbg_info = | Fld_record_extension_set of string let ref_field_set_info : set_field_dbg_info = Fld_record_set "contents" -let fld_record_set = ref ( fun (lbl : Types.label_description) -> - Fld_record_set lbl.lbl_name ) +let fld_record_set (lbl : label) = + Fld_record_set + (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + +let fld_record_inline (lbl : label) = + Fld_record_inline + { name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name } + +let fld_record_inline_set (lbl : label) = + Fld_record_inline_set + (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + +let fld_record_extension_set (lbl : label) = + Fld_record_extension_set + (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) type immediate_or_pointer = | Immediate @@ -182,6 +229,12 @@ type primitive = | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat | Pfloatcomp of comparison + (* BigInt operations *) + | Pnegbigint | Paddbigint | Psubbigint | Ppowbigint + | Pmulbigint | Pdivbigint | Pmodbigint + | Pandbigint | Porbigint | Pxorbigint + | Plslbigint | Pasrbigint + | Pbigintcomp of comparison (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets @@ -226,7 +279,7 @@ and value_kind = and boxed_integer = Primitive.boxed_integer = - Pnativeint | Pint32 | Pint64 + Pbigint | Pint32 | Pint64 and raise_kind = @@ -267,10 +320,10 @@ type let_kind = Strict | Alias | StrictOpt | Variable type function_attribute = { inline : inline_attribute; is_a_functor: bool; - stub: bool; return_unit : bool; async : bool; - oneUnitArg : bool; + directive : string option; + one_unit_arg : bool; } type lambda = @@ -337,15 +390,12 @@ let lambda_unit = Lconst const_unit let default_function_attribute = { inline = Default_inline; is_a_functor = false; - stub = false; return_unit = false; async = false; - oneUnitArg = false; + one_unit_arg = false; + directive = None; } -let default_stub_attribute = - { default_function_attribute with stub = true } - (* Build sharing keys *) (* Those keys are later compared with Pervasives.compare. diff --git a/analysis/vendor/ml/lambda.mli b/analysis/vendor/ml/lambda.mli index af7b81e80..1bf6b802f 100644 --- a/analysis/vendor/ml/lambda.mli +++ b/analysis/vendor/ml/lambda.mli @@ -63,34 +63,34 @@ type tag_info = | Blk_record_ext of {fields : string array; mutable_flag : mutable_flag} | Blk_lazy_general +val find_name : + Parsetree.attribute -> Asttypes.label option + val tag_of_tag_info : tag_info -> int val mutable_flag_of_tag_info : tag_info -> mutable_flag -val blk_record : - ( - (Types.label_description* Typedtree.record_label_definition) array -> - mutable_flag -> - record_repr -> - tag_info - ) ref +val blk_record : + (Types.label_description* Typedtree.record_label_definition) array -> + mutable_flag -> + record_repr -> + tag_info + val blk_record_ext : - ( - (Types.label_description* Typedtree.record_label_definition) array -> - mutable_flag -> - tag_info - ) ref + (Types.label_description* Typedtree.record_label_definition) array -> + mutable_flag -> + tag_info + val blk_record_inlined : - ( - (Types.label_description* Typedtree.record_label_definition) array -> - string -> - int -> - string list -> - tag:int -> - attrs:Parsetree.attributes -> - mutable_flag -> - tag_info - ) ref + (Types.label_description* Typedtree.record_label_definition) array -> + string -> + int -> + string list -> + tag:int -> + attrs:Parsetree.attributes -> + mutable_flag -> + tag_info + @@ -110,8 +110,16 @@ type field_dbg_info = | Fld_array val fld_record : - (Types.label_description -> - field_dbg_info) ref + Types.label_description -> + field_dbg_info + +val fld_record_inline : + Types.label_description -> + field_dbg_info + +val fld_record_extension : + Types.label_description -> + field_dbg_info val ref_field_info : field_dbg_info @@ -125,8 +133,16 @@ type set_field_dbg_info = val ref_field_set_info : set_field_dbg_info val fld_record_set : - (Types.label_description -> - set_field_dbg_info) ref + Types.label_description -> + set_field_dbg_info + +val fld_record_inline_set : + Types.label_description -> + set_field_dbg_info + +val fld_record_extension_set : + Types.label_description -> + set_field_dbg_info type immediate_or_pointer = | Immediate @@ -179,6 +195,12 @@ type primitive = | Pnegfloat | Pabsfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat | Pfloatcomp of comparison + (* BigInt operations *) + | Pnegbigint | Paddbigint | Psubbigint | Ppowbigint + | Pmulbigint | Pdivbigint | Pmodbigint + | Pandbigint | Porbigint | Pxorbigint + | Plslbigint | Pasrbigint + | Pbigintcomp of comparison (* String operations *) | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets @@ -224,7 +246,7 @@ and value_kind = and boxed_integer = Primitive.boxed_integer = - Pnativeint | Pint32 | Pint64 + Pbigint | Pint32 | Pint64 and raise_kind = @@ -268,10 +290,10 @@ type let_kind = Strict | Alias | StrictOpt | Variable type function_attribute = { inline : inline_attribute; is_a_functor: bool; - stub: bool; return_unit : bool; async : bool; - oneUnitArg : bool; + directive : string option; + one_unit_arg : bool; } type lambda = @@ -364,7 +386,6 @@ val commute_comparison : comparison -> comparison val negate_comparison : comparison -> comparison val default_function_attribute : function_attribute -val default_stub_attribute : function_attribute (***********************) (* For static failures *) diff --git a/analysis/vendor/ml/location.ml b/analysis/vendor/ml/location.ml index 561a04522..4ca193cfd 100644 --- a/analysis/vendor/ml/location.ml +++ b/analysis/vendor/ml/location.ml @@ -170,7 +170,7 @@ let print ?(src = None) ~message_kind intro ppf (loc : t) = let (_, end_line, end_char) = get_pos_info loc.loc_end in (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *) (* start_char is inclusive, end_char is exclusive *) - let normalizedRange = + let normalized_range = (* TODO: lots of the handlings here aren't needed anymore because the new rescript syntax has much stronger invariants regarding positions, e.g. no -1 *) @@ -189,7 +189,7 @@ let print ?(src = None) ~message_kind intro ppf (loc : t) = Some ((start_line, start_char + 1), (end_line, end_char)) in fprintf ppf " @[%a@]@," print_loc loc; - match normalizedRange with + match normalized_range with | None -> () | Some _ -> begin try @@ -206,8 +206,8 @@ let print ?(src = None) ~message_kind intro ppf (loc : t) = (Code_frame.print ~is_warning:(message_kind=`warning) ~src - ~startPos:loc.loc_start - ~endPos:loc.loc_end + ~start_pos:loc.loc_start + ~end_pos:loc.loc_end ) with (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. diff --git a/analysis/vendor/ml/matching.ml b/analysis/vendor/ml/matching.ml index 575e11891..ff213fac6 100644 --- a/analysis/vendor/ml/matching.ml +++ b/analysis/vendor/ml/matching.ml @@ -1599,11 +1599,11 @@ let make_record_matching loc all_labels def = function match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular | Record_optional_labels _ -> - Lprim (Pfield (lbl.lbl_pos, !Lambda.fld_record lbl), [arg], loc) + Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) | Record_inlined _ -> - Lprim (Pfield (lbl.lbl_pos, Fld_record_inline {name = lbl.lbl_name}), [arg], loc) + Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc) | Record_unboxed _ -> arg - | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1, Fld_record_extension {name = lbl.lbl_name}), [arg], loc) + | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [arg], loc) in let str = match lbl.lbl_mut with @@ -2236,10 +2236,10 @@ let combine_constant names loc arg cst partial ctx def fail (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt)) arg const_lambda_list - | Const_nativeint _ -> + | Const_bigint _ -> make_test_sequence loc fail - (Pbintcomp(Pnativeint, Cneq)) (Pbintcomp(Pnativeint, Clt)) + (Pbigintcomp Cneq) (Pbigintcomp Clt) arg const_lambda_list in lambda1,jumps_union local_jumps total diff --git a/analysis/vendor/ml/oprint.ml b/analysis/vendor/ml/oprint.ml index 26ff1bcdf..a4ee54dd1 100644 --- a/analysis/vendor/ml/oprint.ml +++ b/analysis/vendor/ml/oprint.ml @@ -288,11 +288,11 @@ and print_simple_out_type ppf = Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []),tyl) else tyl in - fprintf ppf "@[<0>(%a@ [@bs.meth])@]" print_out_type_1 res + fprintf ppf "@[<0>(%a@ [@meth])@]" print_out_type_1 res | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js_OO", "Callback" ), _), [tyl]) -> - fprintf ppf "@[<0>(%a@ [@bs.this])@]" print_out_type_1 tyl + fprintf ppf "@[<0>(%a@ [@this])@]" print_out_type_1 tyl | Otyp_constr (id, tyl) -> pp_open_box ppf 0; print_typargs ppf tyl; @@ -562,7 +562,7 @@ and print_out_sig_item ppf = fprintf ppf "@ = \"%s\"" s; List.iter (fun s -> (* TODO: in general, we should print bs attributes, some attributes like - bs.splice does need it *) + variadic do need it *) fprintf ppf "@ \"%s\"" (!map_primitive_name s) ) sl in diff --git a/analysis/vendor/ml/parmatch.ml b/analysis/vendor/ml/parmatch.ml index e06991290..7c9888377 100644 --- a/analysis/vendor/ml/parmatch.ml +++ b/analysis/vendor/ml/parmatch.ml @@ -150,14 +150,14 @@ let all_coherent column = | Const_int _, Const_int _ | Const_int32 _, Const_int32 _ | Const_int64 _, Const_int64 _ - | Const_nativeint _, Const_nativeint _ + | Const_bigint _, Const_bigint _ | Const_float _, Const_float _ | Const_string _, Const_string _ -> true | ( Const_char _ | Const_int _ | Const_int32 _ | Const_int64 _ - | Const_nativeint _ + | Const_bigint _ | Const_float _ | Const_string _), _ -> false end @@ -264,6 +264,8 @@ let const_compare x y = match x,y with | Const_float f1, Const_float f2 -> compare (float_of_string f1) (float_of_string f2) + | Const_bigint (s1, b1), Const_bigint (s2, b2) -> + Bigint_utils.compare (s1, b1) (s2, b2) | Const_string (s1, _), Const_string (s2, _) -> String.compare s1 s2 | _, _ -> compare x y @@ -384,7 +386,7 @@ let pretty_const c = match c with | Const_float f -> Printf.sprintf "%s" f | Const_int32 i -> Printf.sprintf "%ldl" i | Const_int64 i -> Printf.sprintf "%LdL" i -| Const_nativeint i -> Printf.sprintf "%ndn" i +| Const_bigint (sign, i) -> Printf.sprintf "%s" (Bigint_utils.to_string sign i) let rec pretty_val ppf v = match v.pat_extra with @@ -1102,11 +1104,11 @@ let build_other ext env : Typedtree.pattern = match env with (function Tpat_constant(Const_int64 i) -> i | _ -> assert false) (function i -> Tpat_constant(Const_int64 i)) 0L Int64.succ p env -| ({pat_desc=(Tpat_constant (Const_nativeint _))} as p,_) :: _ -> +| ({pat_desc=(Tpat_constant (Const_bigint _))} as p,_) :: _ -> build_other_constant - (function Tpat_constant(Const_nativeint i) -> i | _ -> assert false) - (function i -> Tpat_constant(Const_nativeint i)) - 0n Nativeint.succ p env + (function Tpat_constant(Const_bigint (sign, i)) -> String.length (Bigint_utils.to_string sign i) | _ -> assert false) + (function i -> Tpat_constant(Const_bigint (true, (string_of_int i)))) + 0 succ p env | ({pat_desc=(Tpat_constant (Const_string _))} as p,_) :: _ -> build_other_constant (function Tpat_constant(Const_string (s, _)) -> String.length s @@ -2099,6 +2101,7 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with let errmsg = try let buf = Buffer.create 16 in + Buffer.add_string buf "| "; Buffer.add_string buf (!print_res_pat v); begin match check_partial_all v casel with | None -> () @@ -2292,7 +2295,7 @@ let inactive ~partial pat = match c with | Const_string _ -> true (*Config.safe_string*) | Const_int _ | Const_char _ | Const_float _ - | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true + | Const_int32 _ | Const_int64 _ | Const_bigint _ -> true end | Tpat_tuple ps | Tpat_construct (_, _, ps) -> List.for_all (fun p -> loop p) ps diff --git a/analysis/vendor/ml/parsetree.ml b/analysis/vendor/ml/parsetree.ml index d4ad85cba..f81703e5a 100644 --- a/analysis/vendor/ml/parsetree.ml +++ b/analysis/vendor/ml/parsetree.ml @@ -22,7 +22,7 @@ type constant = (* 3 3l 3L 3n Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker + Suffixes except 'l', 'L' are rejected by the typechecker *) | Pconst_char of int (* 'c' *) diff --git a/analysis/vendor/ml/predef.ml b/analysis/vendor/ml/predef.ml index c9516c19d..fb45e343d 100644 --- a/analysis/vendor/ml/predef.ml +++ b/analysis/vendor/ml/predef.ml @@ -39,8 +39,11 @@ and ident_exn = ident_create "exn" and ident_array = ident_create "array" and ident_list = ident_create "list" and ident_option = ident_create "option" +and ident_result = ident_create "result" +and ident_dict = ident_create "dict" and ident_int64 = ident_create "int64" +and ident_bigint = ident_create "bigint" and ident_lazy_t = ident_create "lazy_t" and ident_string = ident_create "string" and ident_extension_constructor = ident_create "extension_constructor" @@ -80,9 +83,12 @@ and path_exn = Pident ident_exn and path_array = Pident ident_array and path_list = Pident ident_list and path_option = Pident ident_option +and path_result = Pident ident_result +and path_dict = Pident ident_dict and path_int64 = Pident ident_int64 +and path_bigint = Pident ident_bigint and path_lazy_t = Pident ident_lazy_t and path_string = Pident ident_string @@ -91,6 +97,7 @@ and path_extension_constructor = Pident ident_extension_constructor and path_floatarray = Pident ident_floatarray and path_promise = Pident ident_promise +and path_uncurried = Pident ident_uncurried let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) @@ -102,9 +109,11 @@ and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil)) and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil)) and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil)) and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil)) - +and type_result t1 t2 = newgenty (Tconstr(path_result, [t1; t2], ref Mnil)) +and type_dict t = newgenty (Tconstr(path_dict, [t], ref Mnil)) and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil)) +and type_bigint = newgenty (Tconstr(path_bigint, [], ref Mnil)) and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil)) and type_string = newgenty (Tconstr(path_string, [], ref Mnil)) @@ -117,6 +126,8 @@ let ident_match_failure = ident_create_predef_exn "Match_failure" and ident_invalid_argument = ident_create_predef_exn "Invalid_argument" and ident_failure = ident_create_predef_exn "Failure" +and ident_ok = ident_create_predef_exn "Ok" +and ident_error = ident_create_predef_exn "Error" and ident_js_error = ident_create_predef_exn "JsError" and ident_not_found = ident_create_predef_exn "Not_found" @@ -213,6 +224,21 @@ let common_initial_env add_type add_extension empty_env = type_arity = 1; type_kind = Type_variant([cstr ident_none []; cstr ident_some [tvar]]); type_variance = [Variance.covariant]} + and decl_result = + let tvar1, tvar2 = newgenvar(), newgenvar() in + {decl_abstr with + type_params = [tvar1; tvar2]; + type_arity = 2; + type_kind = + Type_variant([cstr ident_ok [tvar1]; + cstr ident_error [tvar2]]); + type_variance = [Variance.covariant; Variance.covariant]} + and decl_dict = + let tvar = newgenvar() in + {decl_abstr with + type_params = [tvar]; + type_arity = 1; + type_variance = [Variance.full]} and decl_uncurried = let tvar1, tvar2 = newgenvar(), newgenvar() in {decl_abstr with @@ -275,9 +301,12 @@ let common_initial_env add_type add_extension empty_env = add_extension ident_undefined_recursive_module [newgenty (Ttuple[type_string; type_int; type_int])] ( add_type ident_int64 decl_abstr ( + add_type ident_bigint decl_abstr ( add_type ident_lazy_t decl_lazy_t ( add_type ident_option decl_option ( + add_type ident_result decl_result ( + add_type ident_dict decl_dict ( add_type ident_list decl_list ( add_type ident_array decl_array ( add_type ident_exn decl_exn ( @@ -291,7 +320,7 @@ let common_initial_env add_type add_extension empty_env = add_type ident_extension_constructor decl_abstr ( add_type ident_floatarray decl_abstr ( add_type ident_promise decl_promise ( - empty_env))))))))))))))))))))))))) + empty_env)))))))))))))))))))))))))))) let build_initial_env add_type add_exception empty_env = let common = common_initial_env add_type add_exception empty_env in diff --git a/analysis/vendor/ml/predef.mli b/analysis/vendor/ml/predef.mli index d6f82144e..a8049b532 100644 --- a/analysis/vendor/ml/predef.mli +++ b/analysis/vendor/ml/predef.mli @@ -28,9 +28,11 @@ val type_exn: type_expr val type_array: type_expr -> type_expr val type_list: type_expr -> type_expr val type_option: type_expr -> type_expr - +val type_result: type_expr -> type_expr -> type_expr +val type_dict: type_expr -> type_expr val type_int64: type_expr +val type_bigint: type_expr val type_lazy_t: type_expr -> type_expr val type_extension_constructor:type_expr val type_floatarray:type_expr @@ -46,13 +48,16 @@ val path_exn: Path.t val path_array: Path.t val path_list: Path.t val path_option: Path.t - +val path_result: Path.t +val path_dict: Path.t val path_int64: Path.t +val path_bigint: Path.t val path_lazy_t: Path.t val path_extension_constructor: Path.t val path_floatarray: Path.t val path_promise: Path.t +val path_uncurried: Path.t val path_match_failure: Path.t val path_assert_failure : Path.t diff --git a/analysis/vendor/ml/primitive.ml b/analysis/vendor/ml/primitive.ml index ad0504a09..0fff0ccc7 100644 --- a/analysis/vendor/ml/primitive.ml +++ b/analysis/vendor/ml/primitive.ml @@ -18,7 +18,7 @@ open Misc open Parsetree -type boxed_integer = Pnativeint | Pint32 | Pint64 +type boxed_integer = Pbigint | Pint32 | Pint64 type native_repr = | Same_as_ocaml_repr diff --git a/analysis/vendor/ml/primitive.mli b/analysis/vendor/ml/primitive.mli index ecc224562..c364c4cc0 100644 --- a/analysis/vendor/ml/primitive.mli +++ b/analysis/vendor/ml/primitive.mli @@ -15,7 +15,7 @@ (* Description of primitive functions *) -type boxed_integer = Pnativeint | Pint32 | Pint64 +type boxed_integer = Pbigint | Pint32 | Pint64 (* Representation of arguments/result for the native code version of a primitive *) @@ -62,4 +62,4 @@ val byte_name: description -> string val coerce : - (description -> description -> bool ) ref \ No newline at end of file + (description -> description -> bool ) ref diff --git a/analysis/vendor/ml/printlambda.ml b/analysis/vendor/ml/printlambda.ml index 854223859..540ab3684 100644 --- a/analysis/vendor/ml/printlambda.ml +++ b/analysis/vendor/ml/printlambda.ml @@ -27,7 +27,7 @@ let rec struct_const ppf = function | Const_base(Const_float f) -> fprintf ppf "%s" f | Const_base(Const_int32 n) -> fprintf ppf "%lil" n | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n - | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n + | Const_base(Const_bigint (sign, n)) -> fprintf ppf "%sn" (Bigint_utils.to_string sign n) | Const_pointer (n,_) -> fprintf ppf "%ia" n | Const_block(tag_info, []) -> let tag = Lambda.tag_of_tag_info tag_info in @@ -47,7 +47,7 @@ let rec struct_const ppf = function | Const_false -> fprintf ppf "false" | Const_true -> fprintf ppf "true" let boxed_integer_name = function - | Pnativeint -> "nativeint" + | Pbigint -> "bigint" | Pint32 -> "int32" | Pint64 -> "int64" @@ -64,7 +64,7 @@ let print_boxed_integer_conversion ppf bi1 bi2 = fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) let boxed_integer_mark name = function - | Pnativeint -> Printf.sprintf "Nativeint.%s" name + | Pbigint -> Printf.sprintf "BigInt.%s" name | Pint32 -> Printf.sprintf "Int32.%s" name | Pint64 -> Printf.sprintf "Int64.%s" name @@ -177,6 +177,24 @@ let primitive ppf = function | Pfloatcomp(Cle) -> fprintf ppf "<=." | Pfloatcomp(Cgt) -> fprintf ppf ">." | Pfloatcomp(Cge) -> fprintf ppf ">=." + | Pnegbigint -> fprintf ppf "~" + | Paddbigint -> fprintf ppf "+" + | Psubbigint -> fprintf ppf "-" + | Pmulbigint -> fprintf ppf "*" + | Ppowbigint -> fprintf ppf "**" + | Pandbigint -> fprintf ppf "and" + | Porbigint -> fprintf ppf "or" + | Pxorbigint -> fprintf ppf "xor" + | Plslbigint -> fprintf ppf "lsl" + | Pasrbigint -> fprintf ppf "asr" + | Pdivbigint -> fprintf ppf "/" + | Pmodbigint -> fprintf ppf "mod" + | Pbigintcomp(Ceq) -> fprintf ppf "==," + | Pbigintcomp(Cneq) -> fprintf ppf "!=," + | Pbigintcomp(Clt) -> fprintf ppf "<," + | Pbigintcomp(Cle) -> fprintf ppf "<=," + | Pbigintcomp(Cgt) -> fprintf ppf ">," + | Pbigintcomp(Cge) -> fprintf ppf ">=," | Pstringlength -> fprintf ppf "string.length" | Pstringrefu -> fprintf ppf "string.unsafe_get" | Pstringrefs -> fprintf ppf "string.get" @@ -278,6 +296,19 @@ let name_of_primitive = function | Pmulfloat -> "Pmulfloat" | Pdivfloat -> "Pdivfloat" | Pfloatcomp _ -> "Pfloatcomp" + | Pnegbigint -> "Pnegbigint" + | Paddbigint -> "Paddbigint" + | Psubbigint -> "Psubbigint" + | Pmulbigint -> "Pmulbigint" + | Pdivbigint -> "Pdivbigint" + | Pmodbigint -> "Pmodbigint" + | Ppowbigint -> "Ppowbigint" + | Pandbigint -> "Pandbigint" + | Porbigint -> "Porbigint" + | Pxorbigint -> "Pxorbigint" + | Plslbigint -> "Plslbigint" + | Pasrbigint -> "Pasrbigint" + | Pbigintcomp _ -> "Pbigintcomp" | Pstringlength -> "Pstringlength" | Pstringrefu -> "Pstringrefu" | Pstringrefs -> "Pstringrefs" @@ -314,11 +345,9 @@ let name_of_primitive = function | Popaque -> "Popaque" | Pcreate_extension _ -> "Pcreate_extension" -let function_attribute ppf { inline; is_a_functor; stub; return_unit } = +let function_attribute ppf { inline; is_a_functor; return_unit } = if is_a_functor then fprintf ppf "is_a_functor@ "; - if stub then - fprintf ppf "stub@ "; if return_unit then fprintf ppf "void@ "; begin match inline with diff --git a/analysis/vendor/ml/printtyped.ml b/analysis/vendor/ml/printtyped.ml index f6243f6c6..e38d17d2d 100644 --- a/analysis/vendor/ml/printtyped.ml +++ b/analysis/vendor/ml/printtyped.ml @@ -65,7 +65,7 @@ let fmt_constant f x = | Const_float (s) -> fprintf f "Const_float %s" s; | Const_int32 (i) -> fprintf f "Const_int32 %ld" i; | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i; - | Const_nativeint (i) -> fprintf f "Const_nativeint %nd" i; + | Const_bigint (sign, i) -> fprintf f "Const_bigint %s" (Bigint_utils.to_string sign i); ;; let fmt_mutable_flag f x = diff --git a/analysis/vendor/ml/transl_recmodule.ml b/analysis/vendor/ml/transl_recmodule.ml index 3e709b6dc..cfef64ec7 100644 --- a/analysis/vendor/ml/transl_recmodule.ml +++ b/analysis/vendor/ml/transl_recmodule.ml @@ -51,18 +51,22 @@ let init_shape modl = match sg with | [] -> [] | Sig_value (id, { val_kind = Val_reg; val_type = ty }) :: rem -> + let is_function t = + Ast_uncurried_utils.type_is_uncurried_fun t || match t.desc with + | Tarrow _ -> true + | _ -> false in let init_v = match Ctype.expand_head env ty with - | { desc = Tarrow (_, _, _, _) } -> - Const_pointer - ( 0, - Pt_constructor - { - name = "Function"; - const = cstr_const; - non_const = cstr_non_const; - attrs = []; - } ) + | t when is_function t -> + Const_pointer + ( 0, + Pt_constructor + { + name = "Function"; + const = cstr_const; + non_const = cstr_non_const; + attrs = []; + } ) | { desc = Tconstr (p, _, _) } when Path.same p Predef.path_lazy_t -> Const_pointer ( 1, diff --git a/analysis/vendor/ml/translattribute.ml b/analysis/vendor/ml/translattribute.ml index 4f7eca2b3..5b2f896d8 100644 --- a/analysis/vendor/ml/translattribute.ml +++ b/analysis/vendor/ml/translattribute.ml @@ -65,7 +65,7 @@ let get_inline_attribute l = let rec add_inline_attribute (expr : Lambda.lambda) loc attributes = match (expr, get_inline_attribute attributes) with | expr, Default_inline -> expr - | Lfunction ({ attr = { stub = false } as attr } as funct), inline -> + | Lfunction ({ attr } as funct), inline -> (match attr.inline with | Default_inline -> () | Always_inline | Never_inline -> diff --git a/analysis/vendor/ml/translcore.ml b/analysis/vendor/ml/translcore.ml index b4e4d1d92..0812b1554 100644 --- a/analysis/vendor/ml/translcore.ml +++ b/analysis/vendor/ml/translcore.ml @@ -57,6 +57,7 @@ type specialized = { stringcomp : Lambda.primitive; bytescomp : Lambda.primitive; int64comp : Lambda.primitive; + bigintcomp : Lambda.primitive; simplify_constant_constructor : bool; } @@ -82,6 +83,7 @@ let comparisons_table = Pccall (Primitive.simple ~name:"caml_bytes_equal" ~arity:2 ~alloc:false); int64comp = Pbintcomp (Pint64, Ceq); + bigintcomp = Pbigintcomp Ceq; simplify_constant_constructor = true; } ); ( "%notequal", @@ -102,6 +104,7 @@ let comparisons_table = (Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false); int64comp = Pbintcomp (Pint64, Cneq); + bigintcomp = Pbigintcomp Cneq; simplify_constant_constructor = true; } ); ( "%lessthan", @@ -122,6 +125,7 @@ let comparisons_table = (Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 ~alloc:false); int64comp = Pbintcomp (Pint64, Clt); + bigintcomp = Pbigintcomp Clt; simplify_constant_constructor = false; } ); ( "%greaterthan", @@ -144,6 +148,7 @@ let comparisons_table = (Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 ~alloc:false); int64comp = Pbintcomp (Pint64, Cgt); + bigintcomp = Pbigintcomp Cgt; simplify_constant_constructor = false; } ); ( "%lessequal", @@ -166,6 +171,7 @@ let comparisons_table = (Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 ~alloc:false); int64comp = Pbintcomp (Pint64, Cle); + bigintcomp = Pbigintcomp Cle; simplify_constant_constructor = false; } ); ( "%greaterequal", @@ -188,6 +194,7 @@ let comparisons_table = (Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 ~alloc:false); int64comp = Pbintcomp (Pint64, Cge); + bigintcomp = Pbigintcomp Cge; simplify_constant_constructor = false; } ); ( "%compare", @@ -214,6 +221,9 @@ let comparisons_table = int64comp = Pccall (Primitive.simple ~name:"caml_int64_compare" ~arity:2 ~alloc:false); + bigintcomp = + Pccall + (Primitive.simple ~name:"caml_bigint_compare" ~arity:2 ~alloc:false); simplify_constant_constructor = false; } ); ( "%bs_max", @@ -226,6 +236,7 @@ let comparisons_table = floatcomp = arity2 "caml_float_max"; stringcomp = arity2 "caml_string_max"; int64comp = arity2 "caml_int64_max"; + bigintcomp = arity2 "caml_bigint_max"; simplify_constant_constructor = false; } ); ( "%bs_min", @@ -237,6 +248,7 @@ let comparisons_table = floatcomp = arity2 "caml_float_min"; stringcomp = arity2 "caml_string_min"; int64comp = arity2 "caml_int64_min"; + bigintcomp = arity2 "caml_bigint_min"; simplify_constant_constructor = false; } ); ( "%bs_equal_null", @@ -249,6 +261,7 @@ let comparisons_table = floatcomp = arity2 "caml_float_equal_null"; stringcomp = arity2 "caml_string_equal_null"; int64comp = arity2 "caml_int64_equal_null"; + bigintcomp = arity2 "caml_bigint_equal_null"; simplify_constant_constructor = true; } ); ( "%bs_equal_undefined", @@ -261,6 +274,7 @@ let comparisons_table = floatcomp = arity2 "caml_float_equal_undefined"; stringcomp = arity2 "caml_string_equal_undefined"; int64comp = arity2 "caml_int64_equal_undefined"; + bigintcomp = arity2 "caml_bigint_equal_undefined"; simplify_constant_constructor = true; } ); ( "%bs_equal_nullable", @@ -273,6 +287,7 @@ let comparisons_table = floatcomp = arity2 "caml_float_equal_nullable"; stringcomp = arity2 "caml_string_equal_nullable"; int64comp = arity2 "caml_int64_equal_nullable"; + bigintcomp = arity2 "caml_bigint_equal_nullable"; simplify_constant_constructor = true; } ); ] @@ -330,6 +345,11 @@ let primitives_table = ("%lslint", Plslint); ("%lsrint", Plsrint); ("%asrint", Pasrint); + ("%andbigint", Pandbigint); + ("%orbigint", Porbigint); + ("%xorbigint", Pxorbigint); + ("%lslbigint", Plslbigint); + ("%asrbigint", Pasrbigint); ("%eq", Pintcomp Ceq); ("%noteq", Pintcomp Cneq); ("%ltint", Pintcomp Clt); @@ -350,6 +370,19 @@ let primitives_table = ("%lefloat", Pfloatcomp Cle); ("%gtfloat", Pfloatcomp Cgt); ("%gefloat", Pfloatcomp Cge); + ("%negbigint", Pnegbigint); + ("%addbigint", Paddbigint); + ("%subbigint", Psubbigint); + ("%mulbigint", Pmulbigint); + ("%divbigint", Pdivbigint); + ("%powbigint", Ppowbigint); + ("%modbigint", Pmodbigint); + ("%eqbigint", Pbigintcomp Ceq); + ("%noteqbigint", Pbigintcomp Cneq); + ("%ltbigint", Pbigintcomp Clt); + ("%lebigint", Pbigintcomp Cle); + ("%gtbigint", Pbigintcomp Cgt); + ("%gebigint", Pbigintcomp Cge); ("%string_length", Pstringlength); ("%string_safe_get", Pstringrefs); ("%string_unsafe_get", Pstringrefu); @@ -383,12 +416,12 @@ let primitives_table = ("%int64_lsl", Plslbint Pint64); ("%int64_lsr", Plsrbint Pint64); ("%int64_asr", Pasrbint Pint64); - ("%nativeint_of_int32", Pcvtbint (Pint32, Pnativeint)); - ("%nativeint_to_int32", Pcvtbint (Pnativeint, Pint32)); + ("%bigint_of_int32", Pcvtbint (Pint32, Pbigint)); + ("%bigint_to_int32", Pcvtbint (Pbigint, Pint32)); ("%int64_of_int32", Pcvtbint (Pint32, Pint64)); ("%int64_to_int32", Pcvtbint (Pint64, Pint32)); - ("%int64_of_nativeint", Pcvtbint (Pnativeint, Pint64)); - ("%int64_to_nativeint", Pcvtbint (Pint64, Pnativeint)); + ("%int64_of_bigint", Pcvtbint (Pbigint, Pint64)); + ("%int64_to_bigint", Pcvtbint (Pint64, Pbigint)); ("%opaque", Popaque); ("%uncurried_apply", Puncurried_apply); ] @@ -396,7 +429,7 @@ let primitives_table = let find_primitive prim_name = Hashtbl.find primitives_table prim_name let specialize_comparison - ({ gencomp; intcomp; floatcomp; stringcomp; bytescomp; int64comp; boolcomp } : + ({ gencomp; intcomp; floatcomp; stringcomp; bytescomp; int64comp; bigintcomp; boolcomp } : specialized) env ty = match () with | () @@ -408,6 +441,7 @@ let specialize_comparison | () when is_base_type env ty Predef.path_string -> stringcomp | () when is_base_type env ty Predef.path_bytes -> bytescomp | () when is_base_type env ty Predef.path_int64 -> int64comp + | () when is_base_type env ty Predef.path_bigint -> bigintcomp | () when is_base_type env ty Predef.path_bool -> boolcomp | () -> gencomp @@ -437,7 +471,7 @@ let transl_primitive loc p env ty = params = [ parm ]; body = Matching.inline_lazy_force (Lvar parm) Location.none; loc; - attr = default_stub_attribute; + attr = default_function_attribute; } | Ploc kind -> ( let lam = lam_of_loc kind loc in @@ -449,7 +483,7 @@ let transl_primitive loc p env ty = Lfunction { params = [ param ]; - attr = default_stub_attribute; + attr = default_function_attribute; loc; body = Lprim (Pmakeblock Blk_tuple, [ lam; Lvar param ], loc); } @@ -471,7 +505,7 @@ let transl_primitive loc p env ty = Lfunction { params; - attr = default_stub_attribute; + attr = default_function_attribute; loc; body = Lprim (prim, List.map (fun id -> Lvar id) params, loc); } @@ -683,6 +717,11 @@ let try_ids = Hashtbl.create 8 let has_async_attribute exp = exp.exp_attributes |> List.exists (fun ({txt}, _payload) -> txt = "res.async") +let extract_directive_for_fn exp = + exp.exp_attributes |> List.find_map ( + fun ({txt}, payload) -> if txt = "directive" then Ast_payload.is_single_string payload else None) + + let rec transl_exp e = List.iter (Translattribute.check_attribute e) e.exp_attributes; transl_exp0 e @@ -698,6 +737,11 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = transl_let rec_flag pat_expr_list (transl_exp body) | Texp_function { arg_label = _; param; cases; partial } -> let async = has_async_attribute e in + let directive = ( + match extract_directive_for_fn e with + | None -> None + | Some (directive, _) -> Some directive + ) in let params, body, return_unit = let pl = push_defaults e.exp_loc [] cases partial in transl_function e.exp_loc partial param pl @@ -708,6 +752,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = inline = Translattribute.get_inline_attribute e.exp_attributes; async; return_unit; + directive; } in let loc = e.exp_loc in @@ -763,10 +808,18 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Translattribute.get_and_remove_inlined_attribute funct in let uncurried_partial_application = + (* In case of partial application foo(args, ...) when some args are missing, + get the arity *) let uncurried_partial_app = Ext_list.exists e.exp_attributes (fun ({txt },_) -> txt = "res.partial") in if uncurried_partial_app then - let arity_opt = Ast_uncurried.uncurried_type_get_arity_opt ~env:funct.exp_env funct.exp_type in - arity_opt + let arity_opt = Ast_uncurried.uncurried_type_get_arity_opt ~env:funct.exp_env funct.exp_type in + match arity_opt with + | Some arity -> + let real_args = List.filter (fun (_, x) -> Option.is_some x) oargs in + if arity > List.length real_args then + Some arity + else None + | None -> None else None in transl_apply ~inlined ~uncurried_partial_application (transl_exp funct) oargs e.exp_loc @@ -886,17 +939,17 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Record_float_unused -> assert false | Record_regular | Record_optional_labels _ -> Lprim - (Pfield (lbl.lbl_pos, !Lambda.fld_record lbl), [ targ ], e.exp_loc) + (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [ targ ], e.exp_loc) | Record_inlined _ -> Lprim - ( Pfield (lbl.lbl_pos, Fld_record_inline { name = lbl.lbl_name }), + ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [ targ ], e.exp_loc ) | Record_unboxed _ -> targ | Record_extension -> Lprim ( Pfield - (lbl.lbl_pos + 1, Fld_record_extension { name = lbl.lbl_name }), + (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [ targ ], e.exp_loc )) | Texp_setfield (arg, _, lbl, newval) -> @@ -904,12 +957,12 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular | Record_optional_labels _ -> - Psetfield (lbl.lbl_pos, !Lambda.fld_record_set lbl) + Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) | Record_inlined _ -> - Psetfield (lbl.lbl_pos, Fld_record_inline_set lbl.lbl_name) + Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) | Record_unboxed _ -> assert false | Record_extension -> - Psetfield (lbl.lbl_pos + 1, Fld_record_extension_set lbl.lbl_name) + Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in Lprim (access, [ transl_exp arg; transl_exp newval ], e.exp_loc) | Texp_array expr_list -> @@ -1025,7 +1078,7 @@ and transl_apply ?(inlined = Default_inline) ?(uncurried_partial_application=Non { params = [ id_arg ]; body = lam; - attr = default_stub_attribute; + attr = default_function_attribute; loc; } in @@ -1036,7 +1089,7 @@ and transl_apply ?(inlined = Default_inline) ?(uncurried_partial_application=Non | [] -> lapply lam (List.rev_map fst args) in match uncurried_partial_application with - | Some arity when arity > List.length sargs -> + | Some arity -> let extra_arity = arity - List.length sargs in let none_ids = ref [] in let args = Ext_list.filter_map sargs (function @@ -1167,13 +1220,13 @@ and transl_record loc env fields repres opt_init_expr = match repres with | Record_float_unused -> assert false | Record_regular | Record_optional_labels _ -> - Pfield (i, !Lambda.fld_record lbl) + Pfield (i, Lambda.fld_record lbl) | Record_inlined _ -> - Pfield (i, Fld_record_inline { name = lbl.lbl_name }) + Pfield (i, Lambda.fld_record_inline lbl) | Record_unboxed _ -> assert false | Record_extension -> Pfield - (i + 1, Fld_record_extension { name = lbl.lbl_name }) + (i + 1, Lambda.fld_record_extension lbl) in Lprim (access, [ Lvar init_id ], loc) | Overridden (_lid, expr) -> transl_exp expr) @@ -1193,14 +1246,14 @@ and transl_record loc env fields repres opt_init_expr = | Record_float_unused -> assert false | Record_regular -> Lconst - (Const_block (!Lambda.blk_record fields mut Record_regular, cl)) + (Const_block (Lambda.blk_record fields mut Record_regular, cl)) | Record_optional_labels _ -> Lconst - (Const_block (!Lambda.blk_record fields mut Record_optional, cl)) + (Const_block (Lambda.blk_record fields mut Record_optional, cl)) | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } -> Lconst (Const_block - ( !Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag ~attrs + ( Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag ~attrs mut, cl )) | Record_unboxed _ -> @@ -1210,19 +1263,19 @@ and transl_record loc env fields repres opt_init_expr = match repres with | Record_regular -> Lprim - ( Pmakeblock (!Lambda.blk_record fields mut Record_regular), + ( Pmakeblock (Lambda.blk_record fields mut Record_regular), ll, loc ) | Record_optional_labels _ -> Lprim - ( Pmakeblock (!Lambda.blk_record fields mut Record_optional), + ( Pmakeblock (Lambda.blk_record fields mut Record_optional), ll, loc ) | Record_float_unused -> assert false | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } -> Lprim ( Pmakeblock - (!Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag ~attrs + (Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag ~attrs mut), ll, loc ) @@ -1237,7 +1290,7 @@ and transl_record loc env fields repres opt_init_expr = in let slot = transl_extension_path env path in Lprim - ( Pmakeblock (!Lambda.blk_record_ext fields mut), + ( Pmakeblock (Lambda.blk_record_ext fields mut), slot :: ll, loc )) in @@ -1257,13 +1310,13 @@ and transl_record loc env fields repres opt_init_expr = match repres with | Record_float_unused -> assert false | Record_regular | Record_optional_labels _ -> - Psetfield (lbl.lbl_pos, !Lambda.fld_record_set lbl) + Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) | Record_inlined _ -> - Psetfield (lbl.lbl_pos, Fld_record_inline_set lbl.lbl_name) + Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) | Record_unboxed _ -> assert false | Record_extension -> Psetfield - (lbl.lbl_pos + 1, Fld_record_extension_set lbl.lbl_name) + (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in Lsequence (Lprim (upd, [ Lvar copy_id; transl_exp expr ], loc), cont) diff --git a/analysis/vendor/ml/translmod.ml b/analysis/vendor/ml/translmod.ml index 881520977..7fea4909a 100644 --- a/analysis/vendor/ml/translmod.ml +++ b/analysis/vendor/ml/translmod.ml @@ -98,7 +98,6 @@ and apply_coercion_result loc strict funct params args cc_res = { Lambda.default_function_attribute with is_a_functor = true; - stub = true; }; loc; body = @@ -274,10 +273,10 @@ let rec compile_functor mexp coercion root_path loc = { inline = inline_attribute; is_a_functor = true; - stub = false; return_unit = false; async = false; - oneUnitArg = false; + one_unit_arg = false; + directive = None; }; loc; body; diff --git a/analysis/vendor/ml/typecore.ml b/analysis/vendor/ml/typecore.ml index 111ac9fe9..0e8f61f98 100644 --- a/analysis/vendor/ml/typecore.ml +++ b/analysis/vendor/ml/typecore.ml @@ -32,7 +32,7 @@ type error = | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list - | Expr_type_clash of (type_expr * type_expr) list * (typeClashContext option) + | Expr_type_clash of (type_expr * type_expr) list * (type_clash_context option) | Apply_non_function of type_expr | Apply_wrong_label of arg_label * type_expr | Label_multiply_defined of string @@ -239,8 +239,8 @@ let type_constant = function | Const_string _ -> instance_def Predef.type_string | Const_float _ -> instance_def Predef.type_float | Const_int64 _ -> instance_def Predef.type_int64 - | Const_int32 _ - | Const_nativeint _ -> assert false + | Const_bigint _ -> instance_def Predef.type_bigint + | Const_int32 _ -> assert false let constant : Parsetree.constant -> (Asttypes.constant, error) result = function @@ -260,10 +260,8 @@ let constant : Parsetree.constant -> (Asttypes.constant, error) result = with Failure _ -> Error (Literal_overflow "int64") end | Pconst_integer (i,Some 'n') -> - begin - try Ok (Const_nativeint (Misc.Int_literal_converter.nativeint i)) - with Failure _ -> Error (Literal_overflow "nativeint") - end + let sign, i = Bigint_utils.parse_bigint i in + Ok (Const_bigint (sign, i)) | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c)) | Pconst_char c -> Ok (Const_char c) | Pconst_string (s,d) -> Ok (Const_string (s,d)) @@ -307,7 +305,9 @@ let extract_concrete_record env ty = let extract_concrete_variant env ty = match extract_concrete_typedecl env ty with - (p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs) + (p0, p, {type_kind=Type_variant cstrs}) + when not (Ast_uncurried.type_is_uncurried_fun ty) + -> (p0, p, cstrs) | (p0, p, {type_kind=Type_open}) -> (p0, p, []) | _ -> raise Not_found @@ -336,14 +336,14 @@ let unify_pat_types loc env ty ty' = raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) (* unification inside type_exp and type_expect *) -let unify_exp_types ?typeClashContext loc env ty expected_ty = +let unify_exp_types ?type_clash_context loc env ty expected_ty = (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type Printtyp.raw_type_expr expected_ty; *) try unify env ty expected_ty with Unify trace -> - raise(Error(loc, env, Expr_type_clash(trace, typeClashContext))) + raise(Error(loc, env, Expr_type_clash(trace, type_clash_context))) | Tags(l1,l2) -> raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) @@ -642,11 +642,11 @@ let print_simple_message ppf = function let show_extra_help ppf _env trace = begin match bottom_aliases trace with - | Some ({Types.desc = Tconstr (actualPath, actualArgs, _)}, {desc = Tconstr (expectedPath, expextedArgs, _)}) -> begin - match (actualPath, actualArgs, expectedPath, expextedArgs) with - | (Pident {name = actualName}, [], Pident {name = expectedName}, []) -> begin - print_simple_conversion ppf (actualName, expectedName); - print_simple_message ppf (actualName, expectedName); + | Some ({Types.desc = Tconstr (actual_path, actual_args, _)}, {desc = Tconstr (expected_path, expexted_args, _)}) -> begin + match (actual_path, actual_args, expected_path, expexted_args) with + | (Pident {name = actual_name}, [], Pident {name = expected_name}, []) -> begin + print_simple_conversion ppf (actual_name, expected_name); + print_simple_message ppf (actual_name, expected_name); end | _ -> () end; @@ -662,9 +662,12 @@ let rec collect_missing_arguments env type1 type2 = match type1 with | Some res -> Some ((label, argtype) :: res) | None -> None end + | t when Ast_uncurried.type_is_uncurried_fun t -> + let typ = Ast_uncurried.type_extract_uncurried_fun t in + collect_missing_arguments env typ type2 | _ -> None -let print_expr_type_clash ?typeClashContext env trace ppf = begin +let print_expr_type_clash ?type_clash_context env trace ppf = begin (* this is the most frequent error. We should do whatever we can to provide specific guidance to this generic error before giving up *) let bottom_aliases_result = bottom_aliases trace in @@ -685,11 +688,11 @@ let print_expr_type_clash ?typeClashContext env trace ppf = begin ) in match missing_arguments with - | Some [singleArgument] -> + | Some [single_argument] -> (* btw, you can't say "final arguments". Intermediate labeled arguments might be the ones missing *) fprintf ppf "@[@{This call is missing an argument@} of type@ %a@]" - print_arguments [singleArgument] + print_arguments [single_argument] | Some arguments -> fprintf ppf "@[@{This call is missing arguments@} of type:@ %a@]" print_arguments arguments @@ -699,9 +702,9 @@ let print_expr_type_clash ?typeClashContext env trace ppf = begin | None -> assert false in begin match missing_parameters with - | Some [singleParameter] -> + | Some [single_parameter] -> fprintf ppf "@[This value might need to be @{wrapped in a function@ that@ takes@ an@ extra@ parameter@}@ of@ type@ %a@]@,@," - print_arguments [singleParameter]; + print_arguments [single_parameter]; fprintf ppf "@[@{Here's the original error message@}@]@," | Some arguments -> fprintf ppf "@[This value seems to @{need to be wrapped in a function that takes extra@ arguments@}@ of@ type:@ @[%a@]@]@,@," @@ -712,18 +715,18 @@ let print_expr_type_clash ?typeClashContext env trace ppf = begin Printtyp.super_report_unification_error ppf env trace (function ppf -> - errorTypeText ppf typeClashContext) + error_type_text ppf type_clash_context) (function ppf -> - errorExpectedTypeText ppf typeClashContext); - printExtraTypeClashHelp ppf trace typeClashContext; + error_expected_type_text ppf type_clash_context); + print_extra_type_clash_help ppf trace type_clash_context; show_extra_help ppf env trace; end -let reportArityMismatch ~arityA ~arityB ppf = +let report_arity_mismatch ~arity_a ~arity_b ppf = fprintf ppf "This function expected @{%s@} %s, but got @{%s@}" - arityB - (if arityB = "1" then "argument" else "arguments") - arityA + arity_b + (if arity_b = "1" then "argument" else "arguments") + arity_a (* Records *) let label_of_kind kind = @@ -1273,7 +1276,6 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env | _ -> k None end | Ppat_record(lid_sp_list, closed) -> - assert (lid_sp_list <> []); let opath, record_ty = try let (p0, p, _, _) = extract_concrete_record !env expected_ty in @@ -1282,12 +1284,12 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env in let process_optional_label (ld, pat) = let exp_optional_attr = check_optional_attr !env ld pat.ppat_attributes pat.ppat_loc in - let isFromPamatch = match pat.ppat_desc with + let is_from_pamatch = match pat.ppat_desc with | Ppat_construct ({txt = Lident s}, _) -> String.length s >= 2 && s.[0] = '#' && s.[1] = '$' | _ -> false in - if label_is_optional ld && not exp_optional_attr && not isFromPamatch then + if label_is_optional ld && not exp_optional_attr && not is_from_pamatch then let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in Ast_helper.Pat.construct ~loc:pat.ppat_loc lid (Some pat) else pat @@ -1934,9 +1936,9 @@ let rec name_pattern default = function (* Typing of expressions *) -let unify_exp ?typeClashContext env exp expected_ty = +let unify_exp ?type_clash_context env exp expected_ty = let loc = proper_exp_loc exp in - unify_exp_types ?typeClashContext loc env exp.exp_type expected_ty + unify_exp_types ?type_clash_context loc env exp.exp_type expected_ty let is_ignore funct env = @@ -1986,23 +1988,23 @@ let rec type_exp ?recarg env sexp = In the principal case, [type_expected'] may be at generic_level. *) -and type_expect ?typeClashContext ?in_function ?recarg env sexp ty_expected = +and type_expect ?type_clash_context ?in_function ?recarg env sexp ty_expected = let previous_saved_types = Cmt_format.get_saved_types () in let exp = Builtin_attributes.warning_scope sexp.pexp_attributes (fun () -> - type_expect_ ?typeClashContext ?in_function ?recarg env sexp ty_expected + type_expect_ ?type_clash_context ?in_function ?recarg env sexp ty_expected ) in Cmt_format.set_saved_types (Cmt_format.Partial_expression exp :: previous_saved_types); exp -and type_expect_ ?typeClashContext ?in_function ?(recarg=Rejected) env sexp ty_expected = +and type_expect_ ?type_clash_context ?in_function ?(recarg=Rejected) env sexp ty_expected = let loc = sexp.pexp_loc in (* Record the expression type before unifying it with the expected type *) let rue exp = - unify_exp ?typeClashContext env (re exp) (instance env ty_expected); + unify_exp ?type_clash_context env (re exp) (instance env ty_expected); exp in let process_optional_label (id, ld, e) = @@ -2140,8 +2142,8 @@ and type_expect_ ?typeClashContext ?in_function ?(recarg=Rejected) env sexp ty_e Ext_list.exists sexp.pexp_attributes (fun ({txt },_) -> txt = "res.uapp") && not @@ Ext_list.exists sexp.pexp_attributes (fun ({txt },_) -> txt = "res.partial") && not @@ is_automatic_curried_application env funct in - let typeClashContext = typeClashContextFromFunction sexp sfunct in - let (args, ty_res, fully_applied) = type_application ?typeClashContext uncurried env funct sargs in + let type_clash_context = type_clash_context_from_function sexp sfunct in + let (args, ty_res, fully_applied) = type_application ?type_clash_context uncurried env funct sargs in end_def (); unify_var env (newvar()) funct.exp_type; @@ -2193,9 +2195,9 @@ and type_expect_ ?typeClashContext ?in_function ?(recarg=Rejected) env sexp ty_e empty pattern matching can be generated by Camlp4 with its revised syntax. Let's accept it for backward compatibility. *) let val_cases, partial = - type_cases ~rootTypeClashContext:Switch env arg.exp_type ty_expected true loc val_caselist in + type_cases ~root_type_clash_context:Switch env arg.exp_type ty_expected true loc val_caselist in let exn_cases, _ = - type_cases ~rootTypeClashContext:Switch env Predef.type_exn ty_expected false loc exn_caselist in + type_cases ~root_type_clash_context:Switch env Predef.type_exn ty_expected false loc exn_caselist in re { exp_desc = Texp_match(arg, val_cases, exn_cases, partial); exp_loc = loc; exp_extra = []; @@ -2450,7 +2452,7 @@ and type_expect_ ?typeClashContext ?in_function ?(recarg=Rejected) env sexp ty_e let (record, label, opath) = type_label_access env srecord lid in let ty_record = if opath = None then newvar () else record.exp_type in let (label_loc, label, newval) = - type_label_exp ~typeClashContext:SetRecordField false env loc ty_record (lid, label, snewval) in + type_label_exp ~type_clash_context:SetRecordField false env loc ty_record (lid, label, snewval) in unify_exp env record ty_record; if label.lbl_mut = Immutable then raise(Error(loc, env, Label_not_mutable lid.txt)); @@ -2466,7 +2468,7 @@ and type_expect_ ?typeClashContext ?in_function ?(recarg=Rejected) env sexp ty_e let ty = newgenvar() in let to_unify = Predef.type_array ty in unify_exp_types loc env to_unify ty_expected; - let argl = List.map (fun sarg -> type_expect ~typeClashContext:ArrayValue env sarg ty) sargl in + let argl = List.map (fun sarg -> type_expect ~type_clash_context:ArrayValue env sarg ty) sargl in re { exp_desc = Texp_array argl; exp_loc = loc; exp_extra = []; @@ -2474,10 +2476,10 @@ and type_expect_ ?typeClashContext ?in_function ?(recarg=Rejected) env sexp ty_e exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_ifthenelse(scond, sifso, sifnot) -> - let cond = type_expect ~typeClashContext:IfCondition env scond Predef.type_bool in + let cond = type_expect ~type_clash_context:IfCondition env scond Predef.type_bool in begin match sifnot with None -> - let ifso = type_expect ~typeClashContext:IfReturn env sifso Predef.type_unit in + let ifso = type_expect ~type_clash_context:IfReturn env sifso Predef.type_unit in rue { exp_desc = Texp_ifthenelse(cond, ifso, None); exp_loc = loc; exp_extra = []; @@ -2485,10 +2487,10 @@ and type_expect_ ?typeClashContext ?in_function ?(recarg=Rejected) env sexp ty_e exp_attributes = sexp.pexp_attributes; exp_env = env } | Some sifnot -> - let ifso = type_expect ~typeClashContext:IfReturn env sifso ty_expected in - let ifnot = type_expect ~typeClashContext:IfReturn env sifnot ty_expected in + let ifso = type_expect ~type_clash_context:IfReturn env sifso ty_expected in + let ifnot = type_expect ~type_clash_context:IfReturn env sifnot ty_expected in (* Keep sharing *) - unify_exp ~typeClashContext:IfReturn env ifnot ifso.exp_type; + unify_exp ~type_clash_context:IfReturn env ifnot ifso.exp_type; re { exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); exp_loc = loc; exp_extra = []; @@ -2576,7 +2578,7 @@ and type_expect_ ?typeClashContext ?in_function ?(recarg=Rejected) env sexp ty_e let tv = newvar () in let gen = generalizable tv.level arg.exp_type in (try unify_var env tv arg.exp_type with Unify trace -> - raise(Error(arg.exp_loc, env, Expr_type_clash (trace, typeClashContext)))); + raise(Error(arg.exp_loc, env, Expr_type_clash (trace, type_clash_context)))); gen end else true in @@ -2966,7 +2968,7 @@ and type_label_access env srecord lid = (* Typing format strings for printing or reading. These formats are used by functions in modules Printf, Format, and Scanf. (Handling of * modifiers contributed by Thorsten Ohl.) *) -and type_label_exp ?typeClashContext create env loc ty_expected +and type_label_exp ?type_clash_context create env loc ty_expected (lid, label, sarg) = (* Here also ty_expected may be at generic_level *) begin_def (); @@ -2998,7 +3000,7 @@ and type_label_exp ?typeClashContext create env loc ty_expected raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected))); let arg = let snap = if vars = [] then None else Some (Btype.snapshot ()) in - let arg = type_argument ?typeClashContext env sarg ty_arg (instance env ty_arg) in + let arg = type_argument ?type_clash_context env sarg ty_arg (instance env ty_arg) in end_def (); try check_univars env (vars <> []) "field value" arg label.lbl_arg vars; @@ -3018,7 +3020,7 @@ and type_label_exp ?typeClashContext create env loc ty_expected in (lid, label, {arg with exp_type = instance env arg.exp_type}) -and type_argument ?typeClashContext ?recarg env sarg ty_expected' ty_expected = +and type_argument ?type_clash_context ?recarg env sarg ty_expected' ty_expected = (* ty_expected' may be generic *) let no_labels ty = let ls, tvar = list_labels env ty in @@ -3098,8 +3100,8 @@ and type_argument ?typeClashContext ?recarg env sarg ty_expected' ty_expected = func let_var) } end | _ -> - let texp = type_expect ?typeClashContext ?recarg env sarg ty_expected' in - unify_exp ?typeClashContext env texp ty_expected; + let texp = type_expect ?type_clash_context ?recarg env sarg ty_expected' in + unify_exp ?type_clash_context env texp ty_expected; texp and is_automatic_curried_application env funct = (* When a curried function is used with uncurried application, treat it as a curried application *) @@ -3107,7 +3109,7 @@ and is_automatic_curried_application env funct = match (expand_head env funct.exp_type).desc with | Tarrow _ -> true | _ -> false -and type_application ?typeClashContext uncurried env funct (sargs : sargs) : targs * Types.type_expr * bool = +and type_application ?type_clash_context uncurried env funct (sargs : sargs) : targs * Types.type_expr * bool = (* funct.exp_type may be generic *) let result_type omitted ty_fun = List.fold_left @@ -3121,8 +3123,8 @@ and type_application ?typeClashContext uncurried env funct (sargs : sargs) : tar let ignored = ref [] in let has_uncurried_type t = match (expand_head env t).desc with - | Tconstr (Pident {name = "function$"},[t; tArity],_) -> - let arity = Ast_uncurried.type_to_arity tArity in + | Tconstr (Pident {name = "function$"},[t; t_arity],_) -> + let arity = Ast_uncurried.type_to_arity t_arity in Some (arity, t) | _ -> None in let force_uncurried_type funct = @@ -3146,7 +3148,7 @@ and type_application ?typeClashContext uncurried env funct (sargs : sargs) : tar Uncurried_arity_mismatch (t, arity, List.length sargs))); t1, arity | None -> t, max_int in - let update_uncurried_arity ~nargs t newT = + let update_uncurried_arity ~nargs t new_t = match has_uncurried_type t with | Some (arity, _) -> let newarity = arity - nargs in @@ -3154,9 +3156,9 @@ and type_application ?typeClashContext uncurried env funct (sargs : sargs) : tar if uncurried && not fully_applied then raise(Error(funct.exp_loc, env, Uncurried_arity_mismatch (t, arity, List.length sargs))); - let newT = if fully_applied then newT else Ast_uncurried.make_uncurried_type ~env ~arity:newarity newT in - (fully_applied, newT) - | _ -> (false, newT) + let new_t = if fully_applied then new_t else Ast_uncurried.make_uncurried_type ~env ~arity:newarity new_t in + (fully_applied, new_t) + | _ -> (false, new_t) in let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun (syntax_args : sargs) : targs * _ = @@ -3222,7 +3224,7 @@ and type_application ?typeClashContext uncurried env funct (sargs : sargs) : tar in type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 sargl in - let rec type_args ?typeClashContext max_arity args omitted ~ty_fun ty_fun0 ~(sargs : sargs) = + let rec type_args ?type_clash_context max_arity args omitted ~ty_fun ty_fun0 ~(sargs : sargs) = match expand_head env ty_fun, expand_head env ty_fun0 with {desc=Tarrow (l, ty, ty_fun, com); level=lv} , {desc=Tarrow (_, ty0, ty_fun0, _)} @@ -3245,13 +3247,13 @@ and type_application ?typeClashContext uncurried env funct (sargs : sargs) : tar sargs, omitted , Some ( if not optional || is_optional l' then - (fun () -> type_argument ?typeClashContext:(typeClashContextForFunctionArgument typeClashContext sarg0) env sarg0 ty ty0) + (fun () -> type_argument ?type_clash_context:(type_clash_context_for_function_argument type_clash_context sarg0) env sarg0 ty ty0) else - (fun () -> option_some (type_argument ?typeClashContext env sarg0 + (fun () -> option_some (type_argument ?type_clash_context env sarg0 (extract_option_type env ty) (extract_option_type env ty0)))) in - type_args ?typeClashContext max_arity ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs + type_args ?type_clash_context max_arity ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs | _ -> type_unknown_args max_arity ~args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*) in @@ -3287,7 +3289,7 @@ and type_application ?typeClashContext uncurried env funct (sargs : sargs) : tar | _ -> if uncurried then force_uncurried_type funct; let ty, max_arity = extract_uncurried_type funct.exp_type in - let targs, ret_t = type_args ?typeClashContext max_arity [] [] ~ty_fun:ty (instance env ty) ~sargs in + let targs, ret_t = type_args ?type_clash_context max_arity [] [] ~ty_fun:ty (instance env ty) ~sargs in let fully_applied, ret_t = update_uncurried_arity funct.exp_type ~nargs:(List.length !ignored + List.length sargs) ret_t in targs, ret_t, fully_applied @@ -3326,11 +3328,11 @@ and type_construct env loc lid sarg ty_expected attrs = exp_type = ty_res; exp_attributes = attrs; exp_env = env } in - let typeClashContext = typeClashContextMaybeOption ty_expected ty_res in + let type_clash_context = type_clash_context_maybe_option ty_expected ty_res in if separate then begin end_def (); generalize_structure ty_res; - unify_exp ?typeClashContext env {texp with exp_type = instance_def ty_res} + unify_exp ?type_clash_context env {texp with exp_type = instance_def ty_res} (instance env ty_expected); end_def (); List.iter generalize_structure ty_args; @@ -3342,7 +3344,7 @@ and type_construct env loc lid sarg ty_expected attrs = | _ -> assert false in let texp = {texp with exp_type = ty_res} in - if not separate then unify_exp ?typeClashContext env texp (instance env ty_expected); + if not separate then unify_exp ?type_clash_context env texp (instance env ty_expected); let recarg = match constr.cstr_inlined with | None -> Rejected @@ -3376,13 +3378,13 @@ and type_statement env sexp = if is_Tvar ty && ty.level > tv.level then Location.prerr_warning loc Warnings.Nonreturning_statement; let expected_ty = instance_def Predef.type_unit in - let typeClashContext = typeClashContextInStatement sexp in - unify_exp ?typeClashContext env exp expected_ty; + let type_clash_context = type_clash_context_in_statement sexp in + unify_exp ?type_clash_context env exp expected_ty; exp (* Typing of match cases *) -and type_cases ?rootTypeClashContext ?in_function env ty_arg ty_res partial_flag loc caselist : _ * Typedtree.partial = +and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res partial_flag loc caselist : _ * Typedtree.partial = (* ty_arg is _fully_ generalized *) let patterns = List.map (fun {pc_lhs=p} -> p) caselist in let contains_polyvars = List.exists contains_polymorphic_variant patterns in @@ -3489,10 +3491,10 @@ and type_cases ?rootTypeClashContext ?in_function env ty_arg ty_res partial_flag | None -> None | Some scond -> Some - (type_expect ?typeClashContext:(if Option.is_some rootTypeClashContext then Some IfCondition else None) ext_env (wrap_unpacks scond unpacks) + (type_expect ?type_clash_context:(if Option.is_some root_type_clash_context then Some IfCondition else None) ext_env (wrap_unpacks scond unpacks) Predef.type_bool) in - let exp = type_expect ?typeClashContext:rootTypeClashContext ?in_function ext_env sexp ty_res' in + let exp = type_expect ?type_clash_context:root_type_clash_context ?in_function ext_env sexp ty_res' in { c_lhs = pat; c_guard = guard; @@ -3756,11 +3758,11 @@ let type_expression env sexp = let formatter = Format.formatter_of_buffer buffer in Printtyp.type_expr formatter exp.exp_type; Format.pp_print_flush formatter (); - let returnType = Buffer.contents buffer in + let return_type = Buffer.contents buffer in Location.prerr_warning sexp.pexp_loc (Bs_toplevel_expression_unit ( match sexp.pexp_desc with - | Pexp_apply _ -> Some (returnType, FunctionCall) - | _ -> Some (returnType, Other) + | Pexp_apply _ -> Some (return_type, FunctionCall) + | _ -> Some (return_type, Other) )) | Tags _ -> Location.prerr_warning sexp.pexp_loc (Bs_toplevel_expression_unit None)); end_def(); @@ -3834,38 +3836,38 @@ let report_error env ppf = function ), _) -> fprintf ppf "This function is an uncurried function where a curried function is expected" | Expr_type_clash (( - (_, {desc = Tconstr (Pident {name = "function$"},[_; tA],_)}) :: - (_, {desc = Tconstr (Pident {name = "function$"},[_; tB],_)}) :: _ - ), _) when Ast_uncurried.type_to_arity tA <> Ast_uncurried.type_to_arity tB -> - let arityA = Ast_uncurried.type_to_arity tA |> string_of_int in - let arityB = Ast_uncurried.type_to_arity tB |> string_of_int in - reportArityMismatch ~arityA ~arityB ppf + (_, {desc = Tconstr (Pident {name = "function$"},[_; t_a],_)}) :: + (_, {desc = Tconstr (Pident {name = "function$"},[_; t_b],_)}) :: _ + ), _) when Ast_uncurried.type_to_arity t_a <> Ast_uncurried.type_to_arity t_b -> + let arity_a = Ast_uncurried.type_to_arity t_a |> string_of_int in + let arity_b = Ast_uncurried.type_to_arity t_b |> string_of_int in + report_arity_mismatch ~arity_a ~arity_b ppf | Expr_type_clash (( (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),a,_),_,_)}) :: (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),b,_),_,_)}) :: _ ), _) when a <> b -> fprintf ppf "This method has %s but was expected %s" a b - | Expr_type_clash (trace, typeClashContext) -> + | Expr_type_clash (trace, type_clash_context) -> (* modified *) fprintf ppf "@["; - print_expr_type_clash ?typeClashContext env trace ppf; + print_expr_type_clash ?type_clash_context env trace ppf; fprintf ppf "@]" | Apply_non_function typ -> (* modified *) reset_and_mark_loops typ; begin match (repr typ).desc with - Tarrow (_, _inputType, returnType, _) -> - let rec countNumberOfArgs count {Types.desc} = match desc with - | Tarrow (_, _inputType, returnType, _) -> countNumberOfArgs (count + 1) returnType + Tarrow (_, _inputType, return_type, _) -> + let rec count_number_of_args count {Types.desc} = match desc with + | Tarrow (_, _inputType, return_type, _) -> count_number_of_args (count + 1) return_type | _ -> count in - let countNumberOfArgs = countNumberOfArgs 1 in - let acceptsCount = countNumberOfArgs returnType in + let count_number_of_args = count_number_of_args 1 in + let accepts_count = count_number_of_args return_type in fprintf ppf "@[@[<2>This function has type@ @{%a@}@]" type_expr typ; fprintf ppf "@ @[It only accepts %i %s; here, it's called with more.@]@]" - acceptsCount (if acceptsCount == 1 then "argument" else "arguments") + accepts_count (if accepts_count == 1 then "argument" else "arguments") | _ -> fprintf ppf "@[@[<2>This expression has type@ %a@]@ %s@]" type_expr typ @@ -4057,9 +4059,13 @@ let report_error env ppf = function | Illegal_letrec_pat -> fprintf ppf "Only variables are allowed as left-hand side of `let rec'" + | Labels_omitted [label] -> + fprintf ppf "Label ~%s was omitted in the application of this labeled function." + label | Labels_omitted labels -> - fprintf ppf "For labeled function, labels %s were omitted in the application of this function." - (String.concat ", " labels) + let labels_string = labels |> List.map(fun label -> "~" ^ label) |> String.concat ", " in + fprintf ppf "Labels %s were omitted in the application of this labeled function." + labels_string | Empty_record_literal -> fprintf ppf "Empty record literal {} should be type annotated or used in a record context." | Uncurried_arity_mismatch (typ, arity, args) -> diff --git a/analysis/vendor/ml/typecore.mli b/analysis/vendor/ml/typecore.mli index 650bae0d5..23cbeedb2 100644 --- a/analysis/vendor/ml/typecore.mli +++ b/analysis/vendor/ml/typecore.mli @@ -68,7 +68,7 @@ type error = | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list - | Expr_type_clash of (type_expr * type_expr) list * (Error_message_utils.typeClashContext option) + | Expr_type_clash of (type_expr * type_expr) list * (Error_message_utils.type_clash_context option) | Apply_non_function of type_expr | Apply_wrong_label of arg_label * type_expr | Label_multiply_defined of string diff --git a/analysis/vendor/ml/typedecl.ml b/analysis/vendor/ml/typedecl.ml index 344cdd246..f6fb1627b 100644 --- a/analysis/vendor/ml/typedecl.ml +++ b/analysis/vendor/ml/typedecl.ml @@ -207,17 +207,17 @@ let make_params env params = in List.map make_param params -let transl_labels ?recordName env closed lbls = +let transl_labels ?record_name env closed lbls = if !Config.bs_only then match !Builtin_attributes.check_duplicated_labels lbls with | None -> () - | Some {loc;txt=name} -> raise (Error(loc,Duplicate_label (name, recordName))) + | Some {loc;txt=name} -> raise (Error(loc,Duplicate_label (name, record_name))) else ( let all_labels = ref StringSet.empty in List.iter (fun {pld_name = {txt=name; loc}} -> if StringSet.mem name !all_labels then - raise(Error(loc, Duplicate_label (name, recordName))); + raise(Error(loc, Duplicate_label (name, record_name))); all_labels := StringSet.add name !all_labels) lbls); let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc; @@ -292,7 +292,7 @@ let make_constructor env type_path type_params sargs sret_type = *) -let transl_declaration ~typeRecordAsObject env sdecl id = +let transl_declaration ~type_record_as_object env sdecl id = (* Bind type parameters *) reset_type_variables(); Ctype.begin_def (); @@ -306,19 +306,19 @@ let transl_declaration ~typeRecordAsObject env sdecl id = in let raw_status = get_unboxed_from_attributes sdecl in - let checkUntaggedVariant() = match sdecl.ptype_kind with + let check_untagged_variant() = match sdecl.ptype_kind with | Ptype_variant cds -> Ext_list.for_all cds (function | {pcd_args = Pcstr_tuple ([] | [_])} -> (* at most one payload allowed for untagged variants *) true | {pcd_args = Pcstr_tuple (_::_::_); pcd_name={txt=name}} -> - Ast_untagged_variants.reportConstructorMoreThanOneArg ~loc:sdecl.ptype_loc ~name + Ast_untagged_variants.report_constructor_more_than_one_arg ~loc:sdecl.ptype_loc ~name | {pcd_args = Pcstr_record _} -> true ) | _ -> false in - if raw_status.unboxed && not raw_status.default && not (checkUntaggedVariant()) then begin + if raw_status.unboxed && not raw_status.default && not (check_untagged_variant()) then begin match sdecl.ptype_kind with | Ptype_abstract -> raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute @@ -337,6 +337,8 @@ let transl_declaration ~typeRecordAsObject env sdecl id = end; let unboxed_status = match sdecl.ptype_kind with + | Ptype_variant [{pcd_args = Pcstr_tuple []; _}] -> + unboxed_false_default_false | Ptype_variant [{pcd_args = Pcstr_tuple _; _}] | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable = Immutable; _}]; _}] @@ -484,16 +486,16 @@ let transl_declaration ~typeRecordAsObject env sdecl id = (fun () -> make_cstr scstr) in let tcstrs, cstrs = List.split (List.filter_map make_cstr scstrs) in - let isUntaggedDef = Ast_untagged_variants.has_untagged sdecl.ptype_attributes in - Ast_untagged_variants.check_well_formed ~env ~isUntaggedDef cstrs; + let is_untagged_def = Ast_untagged_variants.has_untagged sdecl.ptype_attributes in + Ast_untagged_variants.check_well_formed ~env ~is_untagged_def cstrs; Ttype_variant tcstrs, Type_variant cstrs, sdecl | Ptype_record lbls_ -> let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "res.optional") in - let optionalLabels = + let optional_labels = Ext_list.filter_map lbls_ (fun lbl -> if has_optional lbl.pld_attributes then Some lbl.pld_name.txt else None) in let lbls = - if optionalLabels = [] then lbls_ + if optional_labels = [] then lbls_ else Ext_list.map lbls_ (fun lbl -> let typ = lbl.pld_type in let typ = @@ -501,13 +503,13 @@ let transl_declaration ~typeRecordAsObject env sdecl id = {typ with ptyp_desc = Ptyp_constr ({txt = Lident "option"; loc=typ.ptyp_loc}, [typ])} else typ in {lbl with pld_type = typ }) in - let lbls, lbls' = transl_labels ~recordName:(sdecl.ptype_name.txt) env true lbls in + let lbls, lbls' = transl_labels ~record_name:(sdecl.ptype_name.txt) env true lbls in let lbls_opt = match Record_type_spread.has_type_spread lbls with | true -> let rec extract t = match t.desc with | Tpoly(t, []) -> extract t | _ -> Ctype.repr t in - let mkLbl (l: Types.label_declaration) (ld_type: Typedtree.core_type) (type_vars: (string * Types.type_expr) list) : Typedtree.label_declaration = + let mk_lbl (l: Types.label_declaration) (ld_type: Typedtree.core_type) (type_vars: (string * Types.type_expr) list) : Typedtree.label_declaration = { ld_id = l.ld_id; ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc}; @@ -524,7 +526,7 @@ let transl_declaration ~typeRecordAsObject env sdecl id = process_lbls ( fst acc @ (Ext_list.map fields (fun l -> - mkLbl l ld_type type_vars)) + mk_lbl l ld_type type_vars)) , snd acc @ (Ext_list.map fields (fun l -> @@ -550,18 +552,18 @@ let transl_declaration ~typeRecordAsObject env sdecl id = (match lbls_opt with | Some (lbls, lbls') -> check_duplicates sdecl.ptype_loc lbls StringSet.empty; - let optionalLabels = + let optional_labels = Ext_list.filter_map lbls (fun lbl -> if has_optional lbl.ld_attributes then Some lbl.ld_name.txt else None) in Ttype_record lbls, Type_record(lbls', if unbox then Record_unboxed false - else if optionalLabels <> [] then - Record_optional_labels optionalLabels + else if optional_labels <> [] then + Record_optional_labels optional_labels else Record_regular), sdecl | None -> (* Could not find record type decl for ...t: assume t is an object type and this is syntax ambiguity *) - typeRecordAsObject := true; + type_record_as_object := true; let fields = Ext_list.map lbls_ (fun ld -> match ld.pld_name.txt with | "..." -> Parsetree.Oinherit ld.pld_type @@ -681,7 +683,7 @@ let check_constraints_labels env visited l pl = check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) l -let check_constraints ~typeRecordAsObject env sdecl (_, decl) = +let check_constraints ~type_record_as_object env sdecl (_, decl) = let visited = ref TypeSet.empty in begin match decl.type_kind with | Type_abstract -> () @@ -730,7 +732,7 @@ let check_constraints ~typeRecordAsObject env sdecl (_, decl) = begin match decl.type_manifest with | None -> () | Some ty -> - if not !typeRecordAsObject then + if not !type_record_as_object then let sty = match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false in @@ -1395,12 +1397,12 @@ let transl_type_decl env rec_flag sdecl_list = | Asttypes.Recursive | Asttypes.Nonrecursive -> id, None in - let typeRecordAsObject = ref false in + let type_record_as_object = ref false in let transl_declaration name_sdecl (id, slot) = current_slot := slot; Builtin_attributes.warning_scope name_sdecl.ptype_attributes - (fun () -> transl_declaration ~typeRecordAsObject temp_env name_sdecl id) + (fun () -> transl_declaration ~type_record_as_object temp_env name_sdecl id) in let tdecls = List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in @@ -1452,7 +1454,7 @@ let transl_type_decl env rec_flag sdecl_list = | None -> ()) sdecl_list tdecls; (* Check that constraints are enforced *) - List.iter2 (check_constraints ~typeRecordAsObject newenv) sdecl_list decls; + List.iter2 (check_constraints ~type_record_as_object newenv) sdecl_list decls; (* Name recursion *) let decls = List.map2 (fun sdecl (id, decl) -> id, name_recursion sdecl id decl) @@ -2000,8 +2002,8 @@ let report_error ppf = function fprintf ppf "Two constructors are named %s" s | Duplicate_label (s, None) -> fprintf ppf "The field @{%s@} is defined several times in this record. Fields can only be added once to a record." s - | Duplicate_label (s, Some recordName) -> - fprintf ppf "The field @{%s@} is defined several times in the record @{%s@}. Fields can only be added once to a record." s recordName + | Duplicate_label (s, Some record_name) -> + fprintf ppf "The field @{%s@} is defined several times in the record @{%s@}. Fields can only be added once to a record." s record_name | Recursive_abbrev s -> fprintf ppf "The type abbreviation %s is cyclic" s | Cycle_in_def (s, ty) -> diff --git a/analysis/vendor/ml/typeopt.ml b/analysis/vendor/ml/typeopt.ml index 4513f4fbf..565cc3b79 100644 --- a/analysis/vendor/ml/typeopt.ml +++ b/analysis/vendor/ml/typeopt.ml @@ -186,7 +186,7 @@ let classify_lazy_argument : Typedtree.expression -> fun e -> match e.exp_desc with | Texp_constant ( Const_int _ | Const_char _ | Const_string _ - | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) + | Const_int32 _ | Const_int64 _ | Const_bigint _ ) | Texp_function _ | Texp_construct (_, {cstr_arity = 0}, _) -> `Constant_or_function diff --git a/analysis/vendor/ml/untypeast.ml b/analysis/vendor/ml/untypeast.ml index 1372832e5..17203b03d 100644 --- a/analysis/vendor/ml/untypeast.ml +++ b/analysis/vendor/ml/untypeast.ml @@ -114,7 +114,8 @@ let constant = function | Const_int i -> Pconst_integer (string_of_int i, None) | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l') | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L') - | Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n') + | Const_bigint (sign, i) -> + Pconst_integer (Bigint_utils.to_string sign i, Some 'n') | Const_float f -> Pconst_float (f,None) let attribute sub (s, p) = (map_loc sub s, p) diff --git a/analysis/vendor/ml/variant_coercion.ml b/analysis/vendor/ml/variant_coercion.ml index f174313ad..86f525ad2 100644 --- a/analysis/vendor/ml/variant_coercion.ml +++ b/analysis/vendor/ml/variant_coercion.ml @@ -1,35 +1,74 @@ (* TODO: Improve error messages? Say why we can't coerce. *) (* Right now we only allow coercing to primitives string/int/float *) -let can_coerce_path (path : Path.t) = +let can_coerce_primitive (path : Path.t) = Path.same path Predef.path_string || Path.same path Predef.path_int || Path.same path Predef.path_float + || Path.same path Predef.path_bigint -let can_coerce_variant ~(path : Path.t) - (constructors : Types.constructor_declaration list) = - constructors - |> List.for_all (fun (c : Types.constructor_declaration) -> - let args = c.cd_args in - let payload = Ast_untagged_variants.process_tag_type c.cd_attributes in - match args with - | Cstr_tuple [] -> ( - match payload with - | None | Some (String _) -> Path.same path Predef.path_string - | Some (Int _) -> Path.same path Predef.path_int - | Some (Float _) -> Path.same path Predef.path_float - | Some (Null | Undefined | Bool _ | Untagged _) -> false) - | _ -> false) +let check_paths_same p1 p2 target_path = + Path.same p1 target_path && Path.same p2 target_path + +let variant_has_catch_all_case (constructors : Types.constructor_declaration list) path_is_same = + let has_catch_all_string_case (c : Types.constructor_declaration) = + let args = c.cd_args in + match args with + | Cstr_tuple [{desc = Tconstr (p, [], _)}] -> + path_is_same p + | _ -> false + in + + constructors |> List.exists has_catch_all_string_case + +let variant_has_relevant_primitive_catch_all (constructors : Types.constructor_declaration list) = + variant_has_catch_all_case constructors can_coerce_primitive + +(* Checks if every case of the variant has the same runtime representation as the target type. *) +let variant_has_same_runtime_representation_as_target ~(target_path : Path.t) + ~unboxed (constructors : Types.constructor_declaration list) = + (* Helper function to check if a constructor has the same runtime representation as the target type *) + let has_same_runtime_representation (c : Types.constructor_declaration) = + let args = c.cd_args in + let as_payload = Ast_untagged_variants.process_tag_type c.cd_attributes in + + match args with + | Cstr_tuple [{desc = Tconstr (p, [], _)}] when unboxed -> + let path_same = check_paths_same p target_path in + (* unboxed String(string) :> string *) + path_same Predef.path_string + || (* unboxed Number(float) :> float *) + path_same Predef.path_float + || (* unboxed BigInt(bigint) :> bigint *) + path_same Predef.path_bigint + | Cstr_tuple [] -> ( + (* Check that @as payloads match with the target path to coerce to. + No @as means the default encoding, which is string *) + match as_payload with + | None | Some (String _) -> Path.same target_path Predef.path_string + | Some (Int _) -> Path.same target_path Predef.path_int + | Some (Float _) -> Path.same target_path Predef.path_float + | Some (BigInt _) -> Path.same target_path Predef.path_bigint + | Some (Null | Undefined | Bool _ | Untagged _) -> false) + | _ -> false + in + + List.for_all has_same_runtime_representation constructors let can_try_coerce_variant_to_primitive ((_, p, typedecl) : Path.t * Path.t * Types.type_declaration) = match typedecl with - | {type_kind = Type_variant constructors; type_params = []} + | {type_kind = Type_variant constructors; type_params = []; type_attributes} when Path.name p <> "bool" -> (* bool is represented as a variant internally, so we need to account for that *) - Some constructors + Some (constructors, type_attributes |> Ast_untagged_variants.has_untagged) | _ -> None +let can_try_coerce_variant_to_primitive_opt p = + match p with + | None -> None + | Some p -> can_try_coerce_variant_to_primitive p + let variant_representation_matches (c1_attrs : Parsetree.attributes) (c2_attrs : Parsetree.attributes) = match diff --git a/analysis/vendor/res_syntax/jsx_common.ml b/analysis/vendor/res_syntax/jsx_common.ml index 4281f0580..fa55a802e 100644 --- a/analysis/vendor/res_syntax/jsx_common.ml +++ b/analysis/vendor/res_syntax/jsx_common.ml @@ -1,71 +1,73 @@ open Asttypes open Parsetree -type jsxConfig = { +type jsx_config = { mutable version: int; mutable module_: string; mutable mode: string; - mutable nestedModules: string list; - mutable hasComponent: bool; + mutable nested_modules: string list; + mutable has_component: bool; } (* Helper method to look up the [@react.component] attribute *) -let hasAttr (loc, _) = +let has_attr (loc, _) = match loc.txt with | "react.component" | "jsx.component" -> true | _ -> false (* Iterate over the attributes and try to find the [@react.component] attribute *) -let hasAttrOnBinding {pvb_attributes} = - List.find_opt hasAttr pvb_attributes <> None +let has_attr_on_binding {pvb_attributes} = + List.find_opt has_attr pvb_attributes <> None -let coreTypeOfAttrs attributes = +let core_type_of_attrs attributes = List.find_map (fun ({txt}, payload) -> match (txt, payload) with - | ("react.component" | "jsx.component"), PTyp coreType -> Some coreType + | ("react.component" | "jsx.component"), PTyp core_type -> Some core_type | _ -> None) attributes -let typVarsOfCoreType {ptyp_desc} = +let typ_vars_of_core_type {ptyp_desc} = match ptyp_desc with - | Ptyp_constr (_, coreTypes) -> + | Ptyp_constr (_, core_types) -> List.filter (fun {ptyp_desc} -> match ptyp_desc with | Ptyp_var _ -> true | _ -> false) - coreTypes + core_types | _ -> [] -let raiseError ~loc msg = Location.raise_errorf ~loc msg +let raise_error ~loc msg = Location.raise_errorf ~loc msg -let raiseErrorMultipleComponent ~loc = - raiseError ~loc +let raise_error_multiple_component ~loc = + raise_error ~loc "Only one component definition is allowed for each module. Move to a \ submodule or other file if necessary." -let optionalAttr = ({txt = "res.optional"; loc = Location.none}, PStr []) +let optional_attr = ({txt = "res.optional"; loc = Location.none}, PStr []) -let extractUncurried typ = - if Ast_uncurried.coreTypeIsUncurriedFun typ then - let _arity, t = Ast_uncurried.typeExtractUncurriedFun typ in +let extract_uncurried typ = + if Ast_uncurried.core_type_is_uncurried_fun typ then + let _arity, t = Ast_uncurried.core_type_extract_uncurried_fun typ in t else typ -let removeArity binding = - let rec removeArityRecord expr = +let remove_arity binding = + let rec remove_arity_record expr = match expr.pexp_desc with - | _ when Ast_uncurried.exprIsUncurriedFun expr -> - Ast_uncurried.exprExtractUncurriedFun expr - | Pexp_apply (forwardRef, [(label, e)]) -> + | _ when Ast_uncurried.expr_is_uncurried_fun expr -> + Ast_uncurried.expr_extract_uncurried_fun expr + | Pexp_newtype (label, e) -> + {expr with pexp_desc = Pexp_newtype (label, remove_arity_record e)} + | Pexp_apply (forward_ref, [(label, e)]) -> { expr with - pexp_desc = Pexp_apply (forwardRef, [(label, removeArityRecord e)]); + pexp_desc = Pexp_apply (forward_ref, [(label, remove_arity_record e)]); } | _ -> expr in - {binding with pvb_expr = removeArityRecord binding.pvb_expr} + {binding with pvb_expr = remove_arity_record binding.pvb_expr} let async_component ~async expr = if async then diff --git a/analysis/vendor/res_syntax/jsx_ppx.ml b/analysis/vendor/res_syntax/jsx_ppx.ml index e0e1cac10..baf3da544 100644 --- a/analysis/vendor/res_syntax/jsx_ppx.ml +++ b/analysis/vendor/res_syntax/jsx_ppx.ml @@ -3,20 +3,20 @@ open Asttypes open Parsetree open Longident -let getPayloadFields payload = +let get_payload_fields payload = match payload with | PStr ({ pstr_desc = - Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _); + Pstr_eval ({pexp_desc = Pexp_record (record_fields, None)}, _); } :: _rest) -> - recordFields + record_fields | _ -> [] -type configKey = Int | String +type config_key = Int | String -let getJsxConfigByKey ~key ~type_ recordFields = +let get_jsx_config_by_key ~key ~type_ record_fields = let values = List.filter_map (fun ((lid, expr) : Longident.t Location.loc * expression) -> @@ -33,50 +33,56 @@ let getJsxConfigByKey ~key ~type_ recordFields = when k = key -> Some value | _ -> None) - recordFields + record_fields in match values with | [] -> None | [v] | v :: _ -> Some v -let getInt ~key fields = - match fields |> getJsxConfigByKey ~key ~type_:Int with +let get_int ~key fields = + match fields |> get_jsx_config_by_key ~key ~type_:Int with | None -> None | Some s -> int_of_string_opt s -let getString ~key fields = fields |> getJsxConfigByKey ~key ~type_:String +let get_string ~key fields = fields |> get_jsx_config_by_key ~key ~type_:String -let updateConfig config payload = - let fields = getPayloadFields payload in - let moduleRaw = getString ~key:"module_" fields in - let isGeneric = - match moduleRaw |> Option.map (fun m -> String.lowercase_ascii m) with +let update_config config payload = + let fields = get_payload_fields payload in + let module_raw = get_string ~key:"module_" fields in + let is_generic = + match module_raw |> Option.map (fun m -> String.lowercase_ascii m) with | Some "react" | None -> false | Some _ -> true in - (match (isGeneric, getInt ~key:"version" fields) with + (match (is_generic, get_int ~key:"version" fields) with | true, _ -> config.Jsx_common.version <- 4 | false, Some i -> config.Jsx_common.version <- i | _ -> ()); - (match moduleRaw with + (match module_raw with | None -> () | Some s -> config.module_ <- s); - match (isGeneric, getString ~key:"mode" fields) with + match (is_generic, get_string ~key:"mode" fields) with | true, _ -> config.mode <- "automatic" | false, Some s -> config.mode <- s | _ -> () -let isJsxConfigAttr ((loc, _) : attribute) = loc.txt = "jsxConfig" +let is_jsx_config_attr ((loc, _) : attribute) = loc.txt = "jsxConfig" -let processConfigAttribute attribute config = - if isJsxConfigAttr attribute then updateConfig config (snd attribute) +let process_config_attribute attribute config = + if is_jsx_config_attr attribute then update_config config (snd attribute) -let getMapper ~config = - let expr3, module_binding3, transformSignatureItem3, transformStructureItem3 = - Reactjs_jsx_v3.jsxMapper ~config +let get_mapper ~config = + let ( expr3, + module_binding3, + transform_signature_item3, + transform_structure_item3 ) = + Reactjs_jsx_v3.jsx_mapper ~config in - let expr4, module_binding4, transformSignatureItem4, transformStructureItem4 = - Jsx_v4.jsxMapper ~config + let ( expr4, + module_binding4, + transform_signature_item4, + transform_structure_item4 ) = + Jsx_v4.jsx_mapper ~config in let expr mapper e = @@ -91,86 +97,86 @@ let getMapper ~config = | 4 -> module_binding4 mapper mb | _ -> default_mapper.module_binding mapper mb in - let saveConfig () = + let save_config () = { config with version = config.version; module_ = config.module_; mode = config.mode; - hasComponent = config.hasComponent; + has_component = config.has_component; } in - let restoreConfig oldConfig = - config.version <- oldConfig.Jsx_common.version; - config.module_ <- oldConfig.module_; - config.mode <- oldConfig.mode; - config.hasComponent <- oldConfig.hasComponent + let restore_config old_config = + config.version <- old_config.Jsx_common.version; + config.module_ <- old_config.module_; + config.mode <- old_config.mode; + config.has_component <- old_config.has_component in let signature mapper items = - let oldConfig = saveConfig () in - config.hasComponent <- false; + let old_config = save_config () in + config.has_component <- false; let result = List.map (fun item -> (match item.psig_desc with - | Psig_attribute attr -> processConfigAttribute attr config + | Psig_attribute attr -> process_config_attribute attr config | _ -> ()); let item = default_mapper.signature_item mapper item in - if config.version = 3 then transformSignatureItem3 item - else if config.version = 4 then transformSignatureItem4 item + if config.version = 3 then transform_signature_item3 item + else if config.version = 4 then transform_signature_item4 item else [item]) items |> List.flatten in - restoreConfig oldConfig; + restore_config old_config; result in let structure mapper items = - let oldConfig = saveConfig () in - config.hasComponent <- false; + let old_config = save_config () in + config.has_component <- false; let result = List.map (fun item -> (match item.pstr_desc with - | Pstr_attribute attr -> processConfigAttribute attr config + | Pstr_attribute attr -> process_config_attribute attr config | _ -> ()); let item = default_mapper.structure_item mapper item in - if config.version = 3 then transformStructureItem3 item - else if config.version = 4 then transformStructureItem4 item + if config.version = 3 then transform_structure_item3 item + else if config.version = 4 then transform_structure_item4 item else [item]) items |> List.flatten in - restoreConfig oldConfig; + restore_config old_config; result in {default_mapper with expr; module_binding; signature; structure} -let rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode +let rewrite_implementation ~jsx_version ~jsx_module ~jsx_mode (code : Parsetree.structure) : Parsetree.structure = let config = { - Jsx_common.version = jsxVersion; - module_ = jsxModule; - mode = jsxMode; - nestedModules = []; - hasComponent = false; + Jsx_common.version = jsx_version; + module_ = jsx_module; + mode = jsx_mode; + nested_modules = []; + has_component = false; } in - let mapper = getMapper ~config in + let mapper = get_mapper ~config in mapper.structure mapper code -let rewrite_signature ~jsxVersion ~jsxModule ~jsxMode +let rewrite_signature ~jsx_version ~jsx_module ~jsx_mode (code : Parsetree.signature) : Parsetree.signature = let config = { - Jsx_common.version = jsxVersion; - module_ = jsxModule; - mode = jsxMode; - nestedModules = []; - hasComponent = false; + Jsx_common.version = jsx_version; + module_ = jsx_module; + mode = jsx_mode; + nested_modules = []; + has_component = false; } in - let mapper = getMapper ~config in + let mapper = get_mapper ~config in mapper.signature mapper code diff --git a/analysis/vendor/res_syntax/jsx_ppx.mli b/analysis/vendor/res_syntax/jsx_ppx.mli index 36a846868..0f7c808c6 100644 --- a/analysis/vendor/res_syntax/jsx_ppx.mli +++ b/analysis/vendor/res_syntax/jsx_ppx.mli @@ -9,15 +9,15 @@ *) val rewrite_implementation : - jsxVersion:int -> - jsxModule:string -> - jsxMode:string -> + jsx_version:int -> + jsx_module:string -> + jsx_mode:string -> Parsetree.structure -> Parsetree.structure val rewrite_signature : - jsxVersion:int -> - jsxModule:string -> - jsxMode:string -> + jsx_version:int -> + jsx_module:string -> + jsx_mode:string -> Parsetree.signature -> Parsetree.signature diff --git a/analysis/vendor/res_syntax/jsx_v4.ml b/analysis/vendor/res_syntax/jsx_v4.ml index 2fb74c8cc..ad5a99d4f 100644 --- a/analysis/vendor/res_syntax/jsx_v4.ml +++ b/analysis/vendor/res_syntax/jsx_v4.ml @@ -4,7 +4,7 @@ open Asttypes open Parsetree open Longident -let moduleAccessName config value = +let module_access_name config value = String.capitalize_ascii config.Jsx_common.module_ ^ "." ^ value |> Longident.parse @@ -12,56 +12,58 @@ let nolabel = Nolabel let labelled str = Labelled str -let isOptional str = +let is_optional str = match str with | Optional _ -> true | _ -> false -let isLabelled str = +let is_labelled str = match str with | Labelled _ -> true | _ -> false -let isForwardRef = function +let is_forward_ref = function | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} -> true | _ -> false -let getLabel str = +let get_label str = match str with | Optional str | Labelled str -> str | Nolabel -> "" -let optionalAttrs = [Jsx_common.optionalAttr] +let optional_attrs = [Jsx_common.optional_attr] -let constantString ~loc str = +let constant_string ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) (* {} empty record *) -let emptyRecord ~loc = Exp.record ~loc [] None +let empty_record ~loc = Exp.record ~loc [] None -let unitExpr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) None +let unit_expr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) None -let safeTypeFromValue valueStr = - let valueStr = getLabel valueStr in - if valueStr = "" || (valueStr.[0] [@doesNotRaise]) <> '_' then valueStr - else "T" ^ valueStr +let safe_type_from_value value_str = + let value_str = get_label value_str in + if value_str = "" || (value_str.[0] [@doesNotRaise]) <> '_' then value_str + else "T" ^ value_str -let refType loc = +let ref_type_var loc = Typ.var ~loc "ref" + +let ref_type loc = Typ.constr ~loc - {loc; txt = Ldot (Ldot (Lident "ReactDOM", "Ref"), "currentDomRef")} - [] + {loc; txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")} + [ref_type_var loc] type 'a children = ListLiteral of 'a | Exact of 'a (* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) -let transformChildrenIfListUpper ~mapper theList = - let rec transformChildren_ theList accum = +let transform_children_if_list_upper ~mapper the_list = + let rec transformChildren_ the_list accum = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) - match theList with + match the_list with | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> ( match accum with - | [singleElement] -> Exact singleElement + | [single_element] -> Exact single_element | accum -> ListLiteral (Exp.array (List.rev accum))) | { pexp_desc = @@ -69,15 +71,15 @@ let transformChildrenIfListUpper ~mapper theList = ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); } -> transformChildren_ acc (mapper.expr mapper v :: accum) - | notAList -> Exact (mapper.expr mapper notAList) + | not_a_list -> Exact (mapper.expr mapper not_a_list) in - transformChildren_ theList [] + transformChildren_ the_list [] -let transformChildrenIfList ~mapper theList = - let rec transformChildren_ theList accum = +let transform_children_if_list ~mapper the_list = + let rec transformChildren_ the_list accum = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) - match theList with + match the_list with | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> Exp.array (List.rev accum) | { @@ -86,95 +88,97 @@ let transformChildrenIfList ~mapper theList = ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); } -> transformChildren_ acc (mapper.expr mapper v :: accum) - | notAList -> mapper.expr mapper notAList + | not_a_list -> mapper.expr mapper not_a_list in - transformChildren_ theList [] + transformChildren_ the_list [] -let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = +let extract_children ?(remove_last_position_unit = false) ~loc + props_and_children = let rec allButLast_ lst acc = match lst with | [] -> [] | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> acc | (Nolabel, {pexp_loc}) :: _rest -> - Jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raise_error ~loc:pexp_loc "JSX: found non-labelled argument before the last position" | arg :: rest -> allButLast_ rest (arg :: acc) in - let allButLast lst = allButLast_ lst [] |> List.rev in + let all_but_last lst = allButLast_ lst [] |> List.rev in match List.partition (fun (label, _) -> label = labelled "children") - propsAndChildren + props_and_children with | [], props -> (* no children provided? Place a placeholder list *) ( Exp.construct {loc = Location.none; txt = Lident "[]"} None, - if removeLastPositionUnit then allButLast props else props ) - | [(_, childrenExpr)], props -> - (childrenExpr, if removeLastPositionUnit then allButLast props else props) + if remove_last_position_unit then all_but_last props else props ) + | [(_, children_expr)], props -> + ( children_expr, + if remove_last_position_unit then all_but_last props else props ) | _ -> - Jsx_common.raiseError ~loc + Jsx_common.raise_error ~loc "JSX: somehow there's more than one `children` label" -let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) +let merlin_focus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) (* Helper method to filter out any attribute that isn't [@react.component] *) -let otherAttrsPure (loc, _) = +let other_attrs_pure (loc, _) = match loc.txt with | "react.component" | "jsx.component" -> false | _ -> true (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) -let rec getFnName binding = +let rec get_fn_name binding = match binding with | {ppat_desc = Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat + | {ppat_desc = Ppat_constraint (pat, _)} -> get_fn_name pat | {ppat_loc} -> - Jsx_common.raiseError ~loc:ppat_loc + Jsx_common.raise_error ~loc:ppat_loc "JSX component calls cannot be destructured." -let makeNewBinding binding expression newName = +let make_new_binding binding expression new_name = match binding with | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> { binding with pvb_pat = - {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = newName}}; + {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = new_name}}; pvb_expr = expression; - pvb_attributes = [merlinFocus]; + pvb_attributes = [merlin_focus]; } | {pvb_loc} -> - Jsx_common.raiseError ~loc:pvb_loc + Jsx_common.raise_error ~loc:pvb_loc "JSX component calls cannot be destructured." (* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) -let filenameFromLoc (pstr_loc : Location.t) = - let fileName = +let filename_from_loc (pstr_loc : Location.t) = + let file_name = match pstr_loc.loc_start.pos_fname with | "" -> !Location.input_name - | fileName -> fileName + | file_name -> file_name in - let fileName = - try Filename.chop_extension (Filename.basename fileName) - with Invalid_argument _ -> fileName + let file_name = + try Filename.chop_extension (Filename.basename file_name) + with Invalid_argument _ -> file_name in - let fileName = String.capitalize_ascii fileName in - fileName + let file_name = String.capitalize_ascii file_name in + file_name (* Build a string representation of a module name with segments separated by $ *) -let makeModuleName fileName nestedModules fnName = - let fullModuleName = - match (fileName, nestedModules, fnName) with +let make_module_name file_name nested_modules fn_name = + let full_module_name = + match (file_name, nested_modules, fn_name) with (* TODO: is this even reachable? It seems like the fileName always exists *) - | "", nestedModules, "make" -> nestedModules - | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) - | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules - | fileName, nestedModules, fnName -> - fileName :: List.rev (fnName :: nestedModules) + | "", nested_modules, "make" -> nested_modules + | "", nested_modules, fn_name -> List.rev (fn_name :: nested_modules) + | file_name, nested_modules, "make" -> file_name :: List.rev nested_modules + | file_name, nested_modules, fn_name -> + file_name :: List.rev (fn_name :: nested_modules) in - let fullModuleName = String.concat "$" fullModuleName in - fullModuleName + let full_module_name = String.concat "$" full_module_name in + full_module_name (* AST node builders @@ -183,118 +187,120 @@ let makeModuleName fileName nestedModules fnName = *) (* make record from props and spread props if exists *) -let recordFromProps ~loc ~removeKey callArguments = - let spreadPropsLabel = "_spreadProps" in - let rec removeLastPositionUnitAux props acc = +let record_from_props ~loc ~remove_key call_arguments = + let spread_props_label = "_spreadProps" in + let rec remove_last_position_unit_aux props acc = match props with | [] -> acc | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> acc | (Nolabel, {pexp_loc}) :: _rest -> - Jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raise_error ~loc:pexp_loc "JSX: found non-labelled argument before the last position" | ((Labelled txt, {pexp_loc}) as prop) :: rest | ((Optional txt, {pexp_loc}) as prop) :: rest -> - if txt = spreadPropsLabel then + if txt = spread_props_label then match acc with - | [] -> removeLastPositionUnitAux rest (prop :: acc) + | [] -> remove_last_position_unit_aux rest (prop :: acc) | _ -> - Jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raise_error ~loc:pexp_loc "JSX: use {...p} {x: v} not {x: v} {...p} \n\ \ multiple spreads {...p} {...p} not allowed." - else removeLastPositionUnitAux rest (prop :: acc) + else remove_last_position_unit_aux rest (prop :: acc) in - let props, propsToSpread = - removeLastPositionUnitAux callArguments [] + let props, props_to_spread = + remove_last_position_unit_aux call_arguments [] |> List.rev |> List.partition (fun (label, _) -> label <> labelled "_spreadProps") in let props = - if removeKey then - props |> List.filter (fun (arg_label, _) -> "key" <> getLabel arg_label) + if remove_key then + props |> List.filter (fun (arg_label, _) -> "key" <> get_label arg_label) else props in - let processProp (arg_label, ({pexp_loc} as pexpr)) = + let process_prop (arg_label, ({pexp_loc} as pexpr)) = (* In case filed label is "key" only then change expression to option *) - let id = getLabel arg_label in - if isOptional arg_label then + let id = get_label arg_label in + if is_optional arg_label then ( {txt = Lident id; loc = pexp_loc}, - {pexpr with pexp_attributes = optionalAttrs} ) + {pexpr with pexp_attributes = optional_attrs} ) else ({txt = Lident id; loc = pexp_loc}, pexpr) in - let fields = props |> List.map processProp in - let spreadFields = - propsToSpread |> List.map (fun (_, expression) -> expression) + let fields = props |> List.map process_prop in + let spread_fields = + props_to_spread |> List.map (fun (_, expression) -> expression) in - match (fields, spreadFields) with - | [], [spreadProps] | [], spreadProps :: _ -> spreadProps + match (fields, spread_fields) with + | [], [spread_props] | [], spread_props :: _ -> spread_props | _, [] -> { pexp_desc = Pexp_record (fields, None); pexp_loc = loc; pexp_attributes = []; } - | _, [spreadProps] + | _, [spread_props] (* take the first spreadProps only *) - | _, spreadProps :: _ -> + | _, spread_props :: _ -> { - pexp_desc = Pexp_record (fields, Some spreadProps); + pexp_desc = Pexp_record (fields, Some spread_props); pexp_loc = loc; pexp_attributes = []; } (* make type params for make fn arguments *) (* let make = ({id, name, children}: props<'id, 'name, 'children>) *) -let makePropsTypeParamsTvar namedTypeList = - namedTypeList +let make_props_type_params_tvar named_type_list = + named_type_list |> List.filter_map (fun (_isOptional, label, _, loc, _interiorType) -> if label = "key" then None - else Some (Typ.var ~loc @@ safeTypeFromValue (Labelled label))) + else Some (Typ.var ~loc @@ safe_type_from_value (Labelled label))) -let stripOption coreType = - match coreType with - | {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, coreTypes)} -> - List.nth_opt coreTypes 0 [@doesNotRaise] - | _ -> Some coreType +let strip_option core_type = + match core_type with + | {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, core_types)} -> + List.nth_opt core_types 0 [@doesNotRaise] + | _ -> Some core_type -let stripJsNullable coreType = - match coreType with +let strip_js_nullable core_type = + match core_type with | { ptyp_desc = - Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")}, coreTypes); + Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")}, core_types); } -> - List.nth_opt coreTypes 0 [@doesNotRaise] - | _ -> Some coreType + List.nth_opt core_types 0 [@doesNotRaise] + | _ -> Some core_type (* Make type params of the props type *) (* (Sig) let make: React.componentLike, React.element> *) (* (Str) let make = ({x, _}: props<'x>) => body *) (* (Str) external make: React.componentLike, React.element> = "default" *) -let makePropsTypeParams ?(stripExplicitOption = false) - ?(stripExplicitJsNullableOfRef = false) namedTypeList = - namedTypeList - |> List.filter_map (fun (isOptional, label, _, loc, interiorType) -> +let make_props_type_params ?(strip_explicit_option = false) + ?(strip_explicit_js_nullable_of_ref = false) named_type_list = + named_type_list + |> List.filter_map (fun (is_optional, label, _, loc, interior_type) -> if label = "key" then None (* TODO: Worth thinking how about "ref_" or "_ref" usages *) else if label = "ref" then (* - If ref has a type annotation then use it, else `ReactDOM.Ref.currentDomRef. + If ref has a type annotation then use it, else 'ref. For example, if JSX ppx is used for React Native, type would be different. *) - match interiorType with - | {ptyp_desc = Ptyp_any} -> Some (refType loc) + match interior_type with + | {ptyp_desc = Ptyp_any} -> Some (ref_type_var loc) | _ -> (* Strip explicit Js.Nullable.t in case of forwardRef *) - if stripExplicitJsNullableOfRef then stripJsNullable interiorType - else Some interiorType + if strip_explicit_js_nullable_of_ref then + strip_js_nullable interior_type + else Some interior_type (* Strip the explicit option type in implementation *) (* let make = (~x: option=?) => ... *) - else if isOptional && stripExplicitOption then stripOption interiorType - else Some interiorType) + else if is_optional && strip_explicit_option then + strip_option interior_type + else Some interior_type) -let makeLabelDecls namedTypeList = - let rec checkDuplicatedLabel l = +let make_label_decls named_type_list = + let rec check_duplicated_label l = let rec mem_label ((_, (la : string), _, _, _) as x) = function | [] -> false | (_, (lb : string), _, _, _) :: l -> lb = la || mem_label x l @@ -304,89 +310,92 @@ let makeLabelDecls namedTypeList = | hd :: tl -> if mem_label hd tl then let _, label, _, loc, _ = hd in - Jsx_common.raiseError ~loc "JSX: found the duplicated prop `%s`" label - else checkDuplicatedLabel tl + Jsx_common.raise_error ~loc "JSX: found the duplicated prop `%s`" label + else check_duplicated_label tl in - let () = namedTypeList |> List.rev |> checkDuplicatedLabel in + let () = named_type_list |> List.rev |> check_duplicated_label in - namedTypeList - |> List.map (fun (isOptional, label, attrs, loc, interiorType) -> + named_type_list + |> List.map (fun (is_optional, label, attrs, loc, interior_type) -> if label = "key" then - Type.field ~loc ~attrs:(optionalAttrs @ attrs) {txt = label; loc} - interiorType - else if isOptional then - Type.field ~loc ~attrs:(optionalAttrs @ attrs) {txt = label; loc} - (Typ.var @@ safeTypeFromValue @@ Labelled label) + Type.field ~loc ~attrs:(optional_attrs @ attrs) {txt = label; loc} + interior_type + else if is_optional then + Type.field ~loc ~attrs:(optional_attrs @ attrs) {txt = label; loc} + (Typ.var @@ safe_type_from_value @@ Labelled label) else Type.field ~loc ~attrs {txt = label; loc} - (Typ.var @@ safeTypeFromValue @@ Labelled label)) + (Typ.var @@ safe_type_from_value @@ Labelled label)) -let makeTypeDecls propsName loc namedTypeList = - let labelDeclList = makeLabelDecls namedTypeList in +let make_type_decls props_name loc named_type_list = + let label_decl_list = make_label_decls named_type_list in (* 'id, 'className, ... *) let params = - makePropsTypeParamsTvar namedTypeList - |> List.map (fun coreType -> (coreType, Invariant)) + make_props_type_params_tvar named_type_list + |> List.map (fun core_type -> (core_type, Invariant)) in [ - Type.mk ~loc ~params {txt = propsName; loc} - ~kind:(Ptype_record labelDeclList); + Type.mk ~loc ~params {txt = props_name; loc} + ~kind:(Ptype_record label_decl_list); ] -let makeTypeDeclsWithCoreType propsName loc coreType typVars = +let make_type_decls_with_core_type props_name loc core_type typ_vars = [ - Type.mk ~loc {txt = propsName; loc} ~kind:Ptype_abstract - ~params:(typVars |> List.map (fun v -> (v, Invariant))) - ~manifest:coreType; + Type.mk ~loc {txt = props_name; loc} ~kind:Ptype_abstract + ~params:(typ_vars |> List.map (fun v -> (v, Invariant))) + ~manifest:core_type; ] (* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) -let makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType propsName loc - namedTypeList = +let make_props_record_type ~core_type_of_attr ~typ_vars_of_core_type props_name + loc named_type_list = Str.type_ Nonrecursive - (match coreTypeOfAttr with - | None -> makeTypeDecls propsName loc namedTypeList - | Some coreType -> - makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) + (match core_type_of_attr with + | None -> make_type_decls props_name loc named_type_list + | Some core_type -> + make_type_decls_with_core_type props_name loc core_type + typ_vars_of_core_type) (* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) -let makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType propsName loc - namedTypeList = +let make_props_record_type_sig ~core_type_of_attr ~typ_vars_of_core_type + props_name loc named_type_list = Sig.type_ Nonrecursive - (match coreTypeOfAttr with - | None -> makeTypeDecls propsName loc namedTypeList - | Some coreType -> - makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) + (match core_type_of_attr with + | None -> make_type_decls props_name loc named_type_list + | Some core_type -> + make_type_decls_with_core_type props_name loc core_type + typ_vars_of_core_type) -let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc - attrs callArguments = - let children, argsWithLabels = - extractChildren ~removeLastPositionUnit:true ~loc:jsxExprLoc callArguments +let transform_uppercase_call3 ~config module_path mapper jsx_expr_loc + call_expr_loc attrs call_arguments = + let children, args_with_labels = + extract_children ~remove_last_position_unit:true ~loc:jsx_expr_loc + call_arguments in - let argsForMake = argsWithLabels in - let childrenExpr = transformChildrenIfListUpper ~mapper children in - let recursivelyTransformedArgsForMake = - argsForMake + let args_for_make = args_with_labels in + let children_expr = transform_children_if_list_upper ~mapper children in + let recursively_transformed_args_for_make = + args_for_make |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) in - let childrenArg = ref None in + let children_arg = ref None in let args = - recursivelyTransformedArgsForMake + recursively_transformed_args_for_make @ - match childrenExpr with + match children_expr with | Exact children -> [(labelled "children", children)] | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] | ListLiteral expression -> ( (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; + children_arg := Some expression; match config.Jsx_common.mode with | "automatic" -> [ ( labelled "children", Exp.apply (Exp.ident - {txt = moduleAccessName config "array"; loc = Location.none}) + {txt = module_access_name config "array"; loc = Location.none}) [(Nolabel, expression)] ); ] | _ -> @@ -397,121 +406,123 @@ let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc ]) in - let isCap str = String.capitalize_ascii str = str in + let is_cap str = String.capitalize_ascii str = str in let ident ~suffix = - match modulePath with - | Lident _ -> Ldot (modulePath, suffix) - | Ldot (_modulePath, value) as fullPath when isCap value -> - Ldot (fullPath, suffix) - | modulePath -> modulePath + match module_path with + | Lident _ -> Ldot (module_path, suffix) + | Ldot (_modulePath, value) as full_path when is_cap value -> + Ldot (full_path, suffix) + | module_path -> module_path in - let isEmptyRecord {pexp_desc} = + let is_empty_record {pexp_desc} = match pexp_desc with - | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true + | Pexp_record (label_decls, _) when List.length label_decls = 0 -> true | _ -> false in (* handle key, ref, children *) (* React.createElement(Component.make, props, ...children) *) - let record = recordFromProps ~loc:jsxExprLoc ~removeKey:true args in + let record = record_from_props ~loc:jsx_expr_loc ~remove_key:true args in let props = - if isEmptyRecord record then emptyRecord ~loc:jsxExprLoc else record + if is_empty_record record then empty_record ~loc:jsx_expr_loc else record in - let keyProp = - args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) + let key_prop = + args |> List.filter (fun (arg_label, _) -> "key" = get_label arg_label) in - let makeID = - Exp.ident ~loc:callExprLoc {txt = ident ~suffix:"make"; loc = callExprLoc} + let make_i_d = + Exp.ident ~loc:call_expr_loc + {txt = ident ~suffix:"make"; loc = call_expr_loc} in match config.mode with (* The new jsx transform *) | "automatic" -> - let jsxExpr, keyAndUnit = - match (!childrenArg, keyProp) with + let jsx_expr, key_and_unit = + match (!children_arg, key_prop) with | None, key :: _ -> ( Exp.ident - {loc = Location.none; txt = moduleAccessName config "jsxKeyed"}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) + {loc = Location.none; txt = module_access_name config "jsxKeyed"}, + [key; (nolabel, unit_expr ~loc:Location.none)] ) | None, [] -> - ( Exp.ident {loc = Location.none; txt = moduleAccessName config "jsx"}, + ( Exp.ident {loc = Location.none; txt = module_access_name config "jsx"}, [] ) | Some _, key :: _ -> ( Exp.ident - {loc = Location.none; txt = moduleAccessName config "jsxsKeyed"}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) + {loc = Location.none; txt = module_access_name config "jsxsKeyed"}, + [key; (nolabel, unit_expr ~loc:Location.none)] ) | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = moduleAccessName config "jsxs"}, + ( Exp.ident {loc = Location.none; txt = module_access_name config "jsxs"}, [] ) in - Exp.apply ~loc:jsxExprLoc ~attrs jsxExpr - ([(nolabel, makeID); (nolabel, props)] @ keyAndUnit) + Exp.apply ~loc:jsx_expr_loc ~attrs jsx_expr + ([(nolabel, make_i_d); (nolabel, props)] @ key_and_unit) | _ -> ( - match (!childrenArg, keyProp) with + match (!children_arg, key_prop) with | None, key :: _ -> - Exp.apply ~loc:jsxExprLoc ~attrs + Exp.apply ~loc:jsx_expr_loc ~attrs (Exp.ident { loc = Location.none; txt = Ldot (Lident "JsxPPXReactSupport", "createElementWithKey"); }) - [key; (nolabel, makeID); (nolabel, props)] + [key; (nolabel, make_i_d); (nolabel, props)] | None, [] -> - Exp.apply ~loc:jsxExprLoc ~attrs + Exp.apply ~loc:jsx_expr_loc ~attrs (Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "createElement")}) - [(nolabel, makeID); (nolabel, props)] + [(nolabel, make_i_d); (nolabel, props)] | Some children, key :: _ -> - Exp.apply ~loc:jsxExprLoc ~attrs + Exp.apply ~loc:jsx_expr_loc ~attrs (Exp.ident { loc = Location.none; txt = Ldot (Lident "JsxPPXReactSupport", "createElementVariadicWithKey"); }) - [key; (nolabel, makeID); (nolabel, props); (nolabel, children)] + [key; (nolabel, make_i_d); (nolabel, props); (nolabel, children)] | Some children, [] -> - Exp.apply ~loc:jsxExprLoc ~attrs + Exp.apply ~loc:jsx_expr_loc ~attrs (Exp.ident { loc = Location.none; txt = Ldot (Lident "React", "createElementVariadic"); }) - [(nolabel, makeID); (nolabel, props); (nolabel, children)]) + [(nolabel, make_i_d); (nolabel, props); (nolabel, children)]) -let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs - callArguments id = - let componentNameExpr = constantString ~loc:callExprLoc id in +let transform_lowercase_call3 ~config mapper jsx_expr_loc call_expr_loc attrs + call_arguments id = + let component_name_expr = constant_string ~loc:call_expr_loc id in match config.Jsx_common.mode with (* the new jsx transform *) | "automatic" -> - let elementBinding = + let element_binding = match config.module_ |> String.lowercase_ascii with | "react" -> Lident "ReactDOM" - | _generic -> moduleAccessName config "Elements" + | _generic -> module_access_name config "Elements" in - let children, nonChildrenProps = - extractChildren ~removeLastPositionUnit:true ~loc:jsxExprLoc callArguments + let children, non_children_props = + extract_children ~remove_last_position_unit:true ~loc:jsx_expr_loc + call_arguments in - let argsForMake = nonChildrenProps in - let childrenExpr = transformChildrenIfListUpper ~mapper children in - let recursivelyTransformedArgsForMake = - argsForMake + let args_for_make = non_children_props in + let children_expr = transform_children_if_list_upper ~mapper children in + let recursively_transformed_args_for_make = + args_for_make |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) in - let childrenArg = ref None in + let children_arg = ref None in let args = - recursivelyTransformedArgsForMake + recursively_transformed_args_for_make @ - match childrenExpr with + match children_expr with | Exact children -> [ ( labelled "children", - Exp.apply ~attrs:optionalAttrs + Exp.apply ~attrs:optional_attrs (Exp.ident { - txt = Ldot (elementBinding, "someElement"); + txt = Ldot (element_binding, "someElement"); loc = Location.none; }) [(Nolabel, children)] ); @@ -519,51 +530,52 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] | ListLiteral expression -> (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; + children_arg := Some expression; [ ( labelled "children", Exp.apply (Exp.ident - {txt = moduleAccessName config "array"; loc = Location.none}) + {txt = module_access_name config "array"; loc = Location.none}) [(Nolabel, expression)] ); ] in - let isEmptyRecord {pexp_desc} = + let is_empty_record {pexp_desc} = match pexp_desc with - | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true + | Pexp_record (label_decls, _) when List.length label_decls = 0 -> true | _ -> false in - let record = recordFromProps ~loc:jsxExprLoc ~removeKey:true args in + let record = record_from_props ~loc:jsx_expr_loc ~remove_key:true args in let props = - if isEmptyRecord record then emptyRecord ~loc:jsxExprLoc else record + if is_empty_record record then empty_record ~loc:jsx_expr_loc else record in - let keyProp = - args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) + let key_prop = + args |> List.filter (fun (arg_label, _) -> "key" = get_label arg_label) in - let jsxExpr, keyAndUnit = - match (!childrenArg, keyProp) with + let jsx_expr, key_and_unit = + match (!children_arg, key_prop) with | None, key :: _ -> ( Exp.ident - {loc = Location.none; txt = Ldot (elementBinding, "jsxKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) + {loc = Location.none; txt = Ldot (element_binding, "jsxKeyed")}, + [key; (nolabel, unit_expr ~loc:Location.none)] ) | None, [] -> - (Exp.ident {loc = Location.none; txt = Ldot (elementBinding, "jsx")}, []) + ( Exp.ident {loc = Location.none; txt = Ldot (element_binding, "jsx")}, + [] ) | Some _, key :: _ -> ( Exp.ident - {loc = Location.none; txt = Ldot (elementBinding, "jsxsKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) + {loc = Location.none; txt = Ldot (element_binding, "jsxsKeyed")}, + [key; (nolabel, unit_expr ~loc:Location.none)] ) | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (elementBinding, "jsxs")}, + ( Exp.ident {loc = Location.none; txt = Ldot (element_binding, "jsxs")}, [] ) in - Exp.apply ~loc:jsxExprLoc ~attrs jsxExpr - ([(nolabel, componentNameExpr); (nolabel, props)] @ keyAndUnit) + Exp.apply ~loc:jsx_expr_loc ~attrs jsx_expr + ([(nolabel, component_name_expr); (nolabel, props)] @ key_and_unit) | _ -> - let children, nonChildrenProps = - extractChildren ~loc:jsxExprLoc callArguments + let children, non_children_props = + extract_children ~loc:jsx_expr_loc call_arguments in - let childrenExpr = transformChildrenIfList ~mapper children in - let createElementCall = + let children_expr = transform_children_if_list ~mapper children in + let create_element_call = match children with (* [@JSX] div(~children=[a]), coming from
a
*) | { @@ -574,61 +586,61 @@ let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs "createDOMElementVariadic" (* [@JSX] div(~children= value), coming from
...(value)
*) | {pexp_loc} -> - Jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raise_error ~loc:pexp_loc "A spread as a DOM element's children don't make sense written \ together. You can simply remove the spread." in let args = - match nonChildrenProps with + match non_children_props with | [_justTheUnitArgumentAtEnd] -> [ (* "div" *) - (nolabel, componentNameExpr); + (nolabel, component_name_expr); (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); + (nolabel, children_expr); ] - | nonEmptyProps -> - let propsRecord = - recordFromProps ~loc:Location.none ~removeKey:false nonEmptyProps + | non_empty_props -> + let props_record = + record_from_props ~loc:Location.none ~remove_key:false non_empty_props in [ (* "div" *) - (nolabel, componentNameExpr); + (nolabel, component_name_expr); (* ReactDOM.domProps(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsRecord); + (labelled "props", props_record); (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); + (nolabel, children_expr); ] in - Exp.apply ~loc:jsxExprLoc ~attrs + Exp.apply ~loc:jsx_expr_loc ~attrs (* ReactDOM.createElement *) (Exp.ident { loc = Location.none; - txt = Ldot (Lident "ReactDOM", createElementCall); + txt = Ldot (Lident "ReactDOM", create_element_call); }) args -let rec recursivelyTransformNamedArgsForMake expr args newtypes coreType = +let rec recursively_transform_named_args_for_make expr args newtypes core_type = match expr.pexp_desc with (* TODO: make this show up with a loc. *) | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - Jsx_common.raiseError ~loc:expr.pexp_loc + Jsx_common.raise_error ~loc:expr.pexp_loc "Key cannot be accessed inside of a component. Don't worry - you can \ always key a component from its parent!" | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> - Jsx_common.raiseError ~loc:expr.pexp_loc + Jsx_common.raise_error ~loc:expr.pexp_loc "Ref cannot be passed as a normal prop. Please use `forwardRef` API \ instead." | Pexp_fun (arg, default, pattern, expression) - when isOptional arg || isLabelled arg -> + when is_optional arg || is_labelled arg -> let () = - match (isOptional arg, pattern, default) with + match (is_optional arg, pattern, default) with | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( match ptyp_desc with | Ptyp_constr ({txt = Lident "option"}, [_]) -> () | _ -> - let currentType = + let current_type = match ptyp_desc with | Ptyp_constr ({txt}, []) -> String.concat "." (Longident.flatten txt) @@ -641,7 +653,7 @@ let rec recursivelyTransformNamedArgsForMake expr args newtypes coreType = (Printf.sprintf "React: optional argument annotations must have explicit \ `option`. Did you mean `option<%s>=?`?" - currentType))) + current_type))) | _ -> () in let alias = @@ -654,7 +666,7 @@ let rec recursivelyTransformNamedArgsForMake expr args newtypes coreType = } -> txt | {ppat_desc = Ppat_any} -> "_" - | _ -> getLabel arg + | _ -> get_label arg in let type_ = match pattern with @@ -663,15 +675,15 @@ let rec recursivelyTransformNamedArgsForMake expr args newtypes coreType = | _ -> None in - recursivelyTransformNamedArgsForMake expression + recursively_transform_named_args_for_make expression ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) - newtypes coreType + newtypes core_type | Pexp_fun ( Nolabel, _, {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, _expression ) -> - (args, newtypes, coreType) + (args, newtypes, core_type) | Pexp_fun ( Nolabel, _, @@ -689,102 +701,103 @@ let rec recursivelyTransformNamedArgsForMake expr args newtypes coreType = (* The ref arguement of forwardRef should be optional *) ( (Optional "ref", None, pattern, txt, pattern.ppat_loc, type_) :: args, newtypes, - coreType ) - else (args, newtypes, coreType) + core_type ) + else (args, newtypes, core_type) | Pexp_fun (Nolabel, _, pattern, _expression) -> Location.raise_errorf ~loc:pattern.ppat_loc "React: react.component refs only support plain arguments and type \ annotations." | Pexp_newtype (label, expression) -> - recursivelyTransformNamedArgsForMake expression args (label :: newtypes) - coreType - | Pexp_constraint (expression, coreType) -> - recursivelyTransformNamedArgsForMake expression args newtypes - (Some coreType) - | _ -> (args, newtypes, coreType) + recursively_transform_named_args_for_make expression args + (label :: newtypes) core_type + | Pexp_constraint (expression, core_type) -> + recursively_transform_named_args_for_make expression args newtypes + (Some core_type) + | _ -> (args, newtypes, core_type) -let argToType types +let arg_to_type types ((name, default, {ppat_attributes = attrs}, _alias, loc, type_) : arg_label * expression option * pattern * label * 'loc * core_type option) = match (type_, name, default) with - | Some type_, name, _ when isOptional name -> - (true, getLabel name, attrs, loc, type_) :: types - | Some type_, name, _ -> (false, getLabel name, attrs, loc, type_) :: types - | None, name, _ when isOptional name -> - (true, getLabel name, attrs, loc, Typ.any ~loc ()) :: types - | None, name, _ when isLabelled name -> - (false, getLabel name, attrs, loc, Typ.any ~loc ()) :: types + | Some type_, name, _ when is_optional name -> + (true, get_label name, attrs, loc, type_) :: types + | Some type_, name, _ -> (false, get_label name, attrs, loc, type_) :: types + | None, name, _ when is_optional name -> + (true, get_label name, attrs, loc, Typ.any ~loc ()) :: types + | None, name, _ when is_labelled name -> + (false, get_label name, attrs, loc, Typ.any ~loc ()) :: types | _ -> types -let hasDefaultValue nameArgList = - nameArgList +let has_default_value name_arg_list = + name_arg_list |> List.exists (fun (name, default, _, _, _, _) -> - Option.is_some default && isOptional name) + Option.is_some default && is_optional name) -let argToConcreteType types (name, attrs, loc, type_) = +let arg_to_concrete_type types (name, attrs, loc, type_) = match name with - | name when isLabelled name -> - (false, getLabel name, attrs, loc, type_) :: types - | name when isOptional name -> - (true, getLabel name, attrs, loc, type_) :: types + | name when is_labelled name -> + (false, get_label name, attrs, loc, type_) :: types + | name when is_optional name -> + (true, get_label name, attrs, loc, type_) :: types | _ -> types let check_string_int_attribute_iter = let attribute _ ({txt; loc}, _) = if txt = "string" || txt = "int" then - Jsx_common.raiseError ~loc + Jsx_common.raise_error ~loc "@string and @int attributes not supported. See \ https://github.com/rescript-lang/rescript-compiler/issues/5724" in {Ast_iterator.default_iterator with attribute} -let checkMultipleComponents ~config ~loc = +let check_multiple_components ~config ~loc = (* If there is another component, throw error *) - if config.Jsx_common.hasComponent then - Jsx_common.raiseErrorMultipleComponent ~loc - else config.hasComponent <- true + if config.Jsx_common.has_component then + Jsx_common.raise_error_multiple_component ~loc + else config.has_component <- true -let modifiedBindingOld binding = +let modified_binding_old binding = let expression = binding.pvb_expr in (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = + let rec spelunk_for_fun_expression expression = match expression with (* let make = (~prop) => ... *) | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> expression (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (_recursive, _vbs, returnExpression)} -> + | {pexp_desc = Pexp_let (_recursive, _vbs, return_expression)} -> (* here's where we spelunk! *) - spelunkForFunExpression returnExpression + spelunk_for_fun_expression return_expression (* let make = React.forwardRef((~prop) => ...) *) | { pexp_desc = - Pexp_apply (_wrapperExpression, [(Nolabel, innerFunctionExpression)]); + Pexp_apply (_wrapperExpression, [(Nolabel, inner_function_expression)]); } -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_sequence (_wrapperExpression, innerFunctionExpression)} - -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> - spelunkForFunExpression innerFunctionExpression + spelunk_for_fun_expression inner_function_expression + | { + pexp_desc = Pexp_sequence (_wrapperExpression, inner_function_expression); + } -> + spelunk_for_fun_expression inner_function_expression + | {pexp_desc = Pexp_constraint (inner_function_expression, _typ)} -> + spelunk_for_fun_expression inner_function_expression | {pexp_loc} -> - Jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raise_error ~loc:pexp_loc "JSX component calls can only be on function definitions or component \ wrappers (forwardRef, memo)." in - spelunkForFunExpression expression + spelunk_for_fun_expression expression -let modifiedBinding ~bindingLoc ~bindingPatLoc ~fnName binding = - let hasApplication = ref false in - let wrapExpressionWithBinding expressionFn expression = - Vb.mk ~loc:bindingLoc ~attrs:binding.pvb_attributes - (Pat.var ~loc:bindingPatLoc {loc = bindingPatLoc; txt = fnName}) - (expressionFn expression) +let modified_binding ~binding_loc ~binding_pat_loc ~fn_name binding = + let has_application = ref false in + let wrap_expression_with_binding expression_fn expression = + Vb.mk ~loc:binding_loc ~attrs:binding.pvb_attributes + (Pat.var ~loc:binding_pat_loc {loc = binding_pat_loc; txt = fn_name}) + (expression_fn expression) in let expression = binding.pvb_expr in (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = + let rec spelunk_for_fun_expression expression = match expression with (* let make = (~prop) => ... with no final unit *) | { @@ -793,13 +806,13 @@ let modifiedBinding ~bindingLoc ~bindingPatLoc ~fnName binding = ( ((Labelled _ | Optional _) as label), default, pattern, - ({pexp_desc = Pexp_fun _} as internalExpression) ); + ({pexp_desc = Pexp_fun _} as internal_expression) ); } -> - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression + let wrap, has_forward_ref, exp = + spelunk_for_fun_expression internal_expression in ( wrap, - hasForwardRef, + has_forward_ref, {expression with pexp_desc = Pexp_fun (label, default, pattern, exp)} ) (* let make = (()) => ... *) (* let make = (_) => ... *) @@ -822,7 +835,7 @@ let modifiedBinding ~bindingLoc ~bindingPatLoc ~fnName binding = (* let make = (prop) => ... *) | {pexp_desc = Pexp_fun (_nolabel, _default, pattern, _internalExpression)} -> - if !hasApplication then ((fun a -> a), false, expression) + if !has_application then ((fun a -> a), false, expression) else Location.raise_errorf ~loc:pattern.ppat_loc "React: props need to be labelled arguments.\n\ @@ -830,40 +843,41 @@ let modifiedBinding ~bindingLoc ~bindingPatLoc ~fnName binding = \ If your component doesn't have any props use () or _ instead of a \ name." (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> + | {pexp_desc = Pexp_let (recursive, vbs, internal_expression)} -> (* here's where we spelunk! *) - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression + let wrap, has_forward_ref, exp = + spelunk_for_fun_expression internal_expression in ( wrap, - hasForwardRef, + has_forward_ref, {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} ) (* let make = React.forwardRef((~prop) => ...) *) | { - pexp_desc = Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); + pexp_desc = + Pexp_apply (wrapper_expression, [(Nolabel, internal_expression)]); } -> - let () = hasApplication := true in - let _, _, exp = spelunkForFunExpression internalExpression in - let hasForwardRef = isForwardRef wrapperExpression in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasForwardRef, + let () = has_application := true in + let _, _, exp = spelunk_for_fun_expression internal_expression in + let has_forward_ref = is_forward_ref wrapper_expression in + ( (fun exp -> Exp.apply wrapper_expression [(nolabel, exp)]), + has_forward_ref, exp ) - | {pexp_desc = Pexp_sequence (wrapperExpression, internalExpression)} -> - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression + | {pexp_desc = Pexp_sequence (wrapper_expression, internal_expression)} -> + let wrap, has_forward_ref, exp = + spelunk_for_fun_expression internal_expression in ( wrap, - hasForwardRef, - {expression with pexp_desc = Pexp_sequence (wrapperExpression, exp)} ) + has_forward_ref, + {expression with pexp_desc = Pexp_sequence (wrapper_expression, exp)} ) | e -> ((fun a -> a), false, e) in - let wrapExpression, hasForwardRef, expression = - spelunkForFunExpression expression + let wrap_expression, has_forward_ref, expression = + spelunk_for_fun_expression expression in - (wrapExpressionWithBinding wrapExpression, hasForwardRef, expression) + (wrap_expression_with_binding wrap_expression, has_forward_ref, expression) -let vbMatch ~expr (name, default, _, alias, loc, _) = - let label = getLabel name in +let vb_match ~expr (name, default, _, alias, loc, _) = + let label = get_label name in match default with | Some default -> let value_binding = @@ -885,124 +899,128 @@ let vbMatch ~expr (name, default, _, alias, loc, _) = Exp.let_ Nonrecursive [value_binding] expr | None -> expr -let vbMatchExpr namedArgList expr = - let rec aux namedArgList = - match namedArgList with +let vb_match_expr named_arg_list expr = + let rec aux named_arg_list = + match named_arg_list with | [] -> expr - | namedArg :: rest -> vbMatch namedArg ~expr:(aux rest) + | named_arg :: rest -> vb_match named_arg ~expr:(aux rest) in - aux (List.rev namedArgList) + aux (List.rev named_arg_list) -let mapBinding ~config ~emptyLoc ~pstr_loc ~fileName ~recFlag binding = - if Jsx_common.hasAttrOnBinding binding then ( - checkMultipleComponents ~config ~loc:pstr_loc; - let binding = Jsx_common.removeArity binding in - let coreTypeOfAttr = Jsx_common.coreTypeOfAttrs binding.pvb_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map Jsx_common.typVarsOfCoreType +let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding = + if Jsx_common.has_attr_on_binding binding then ( + check_multiple_components ~config ~loc:pstr_loc; + let binding = Jsx_common.remove_arity binding in + let core_type_of_attr = + Jsx_common.core_type_of_attrs binding.pvb_attributes + in + let typ_vars_of_core_type = + core_type_of_attr + |> Option.map Jsx_common.typ_vars_of_core_type |> Option.value ~default:[] in - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding_loc = binding.pvb_loc in + let binding_pat_loc = binding.pvb_pat.ppat_loc in let binding = { binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; - pvb_attributes = binding.pvb_attributes |> List.filter otherAttrsPure; + pvb_pat = {binding.pvb_pat with ppat_loc = empty_loc}; + pvb_loc = empty_loc; + pvb_attributes = binding.pvb_attributes |> List.filter other_attrs_pure; } in - let fnName = getFnName binding.pvb_pat in - let internalFnName = fnName ^ "$Internal" in - let fullModuleName = makeModuleName fileName config.nestedModules fnName in - let bindingWrapper, hasForwardRef, expression = - modifiedBinding ~bindingLoc ~bindingPatLoc ~fnName binding + let fn_name = get_fn_name binding.pvb_pat in + let internal_fn_name = fn_name ^ "$Internal" in + let full_module_name = + make_module_name file_name config.nested_modules fn_name in - let isAsync = + let binding_wrapper, has_forward_ref, expression = + modified_binding ~binding_loc ~binding_pat_loc ~fn_name binding + in + let is_async = Ext_list.find_first binding.pvb_expr.pexp_attributes Ast_async.is_async |> Option.is_some in (* do stuff here! *) - let namedArgList, newtypes, _typeConstraints = - recursivelyTransformNamedArgsForMake - (modifiedBindingOld binding) + let named_arg_list, newtypes, _typeConstraints = + recursively_transform_named_args_for_make + (modified_binding_old binding) [] [] None in - let namedTypeList = List.fold_left argToType [] namedArgList in + let named_type_list = List.fold_left arg_to_type [] named_arg_list in (* type props = { ... } *) - let propsRecordType = - makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" pstr_loc - namedTypeList + let props_record_type = + make_props_record_type ~core_type_of_attr ~typ_vars_of_core_type "props" + pstr_loc named_type_list in - let innerExpression = + let inner_expression = Exp.apply (Exp.ident (Location.mknoloc @@ Lident - (match recFlag with - | Recursive -> internalFnName - | Nonrecursive -> fnName))) + (match rec_flag with + | Recursive -> internal_fn_name + | Nonrecursive -> fn_name))) ([(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] @ - match hasForwardRef with + match has_forward_ref with | true -> [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))] | false -> []) in - let makePropsPattern = function + let make_props_pattern = function | [] -> Pat.var @@ Location.mknoloc "props" | _ -> Pat.constraint_ (Pat.var @@ Location.mknoloc "props") (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()]) in - let innerExpression = - Jsx_common.async_component ~async:isAsync innerExpression + let inner_expression = + Jsx_common.async_component ~async:is_async inner_expression in - let fullExpression = + let full_expression = (* React component name should start with uppercase letter *) (* let make = { let \"App" = props => make(props); \"App" } *) (* let make = React.forwardRef({ let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) })*) Exp.fun_ nolabel None - (match coreTypeOfAttr with - | None -> makePropsPattern namedTypeList - | Some _ -> makePropsPattern typVarsOfCoreType) - (if hasForwardRef then + (match core_type_of_attr with + | None -> make_props_pattern named_type_list + | Some _ -> make_props_pattern typ_vars_of_core_type) + (if has_forward_ref then Exp.fun_ nolabel None (Pat.var @@ Location.mknoloc "ref") - innerExpression - else innerExpression) + inner_expression + else inner_expression) in - let fullExpression = + let full_expression = if !Config.uncurried = Uncurried then - fullExpression - |> Ast_uncurried.uncurriedFun ~loc:fullExpression.pexp_loc - ~arity:(if hasForwardRef then 2 else 1) - else fullExpression + full_expression + |> Ast_uncurried.uncurried_fun ~loc:full_expression.pexp_loc + ~arity:(if has_forward_ref then 2 else 1) + else full_expression in - let fullExpression = - match fullModuleName with - | "" -> fullExpression + let full_expression = + match full_module_name with + | "" -> full_expression | txt -> Exp.let_ Nonrecursive [ - Vb.mk ~loc:emptyLoc - (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt}) - fullExpression; + Vb.mk ~loc:empty_loc + (Pat.var ~loc:empty_loc {loc = empty_loc; txt}) + full_expression; ] - (Exp.ident ~loc:pstr_loc {loc = emptyLoc; txt = Lident txt}) + (Exp.ident ~loc:pstr_loc {loc = empty_loc; txt = Lident txt}) in - let rec stripConstraintUnpack ~label pattern = + let rec strip_constraint_unpack ~label pattern = match pattern with | {ppat_desc = Ppat_constraint (_, {ptyp_desc = Ptyp_package _})} -> pattern | {ppat_desc = Ppat_constraint (pattern, _)} -> - stripConstraintUnpack ~label pattern + strip_constraint_unpack ~label pattern | _ -> pattern in - let safePatternLabel pattern = + let safe_pattern_label pattern = match pattern with | {ppat_desc = Ppat_var {txt; loc}} -> {pattern with ppat_desc = Ppat_var {txt = "__" ^ txt; loc}} @@ -1010,128 +1028,140 @@ let mapBinding ~config ~emptyLoc ~pstr_loc ~fileName ~recFlag binding = {pattern with ppat_desc = Ppat_alias (p, {txt = "__" ^ txt; loc})} | _ -> pattern in - let rec returnedExpression patternsWithLabel patternsWithNolabel + let rec returned_expression patterns_with_label patterns_with_nolabel ({pexp_desc} as expr) = match pexp_desc with | Pexp_newtype (_, expr) -> - returnedExpression patternsWithLabel patternsWithNolabel expr + returned_expression patterns_with_label patterns_with_nolabel expr | Pexp_constraint (expr, _) -> - returnedExpression patternsWithLabel patternsWithNolabel expr + returned_expression patterns_with_label patterns_with_nolabel expr | Pexp_fun ( _arg_label, _default, {ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}, expr ) -> - (patternsWithLabel, patternsWithNolabel, expr) + (patterns_with_label, patterns_with_nolabel, expr) | Pexp_fun (arg_label, default, ({ppat_loc; ppat_desc} as pattern), expr) -> ( - let patternWithoutConstraint = - stripConstraintUnpack ~label:(getLabel arg_label) pattern + let pattern_without_constraint = + strip_constraint_unpack ~label:(get_label arg_label) pattern in (* If prop has the default value as Ident, it will get a build error when the referenced Ident value and the prop have the same name. So we add a "__" to label to resolve the build error. *) - let patternWithSafeLabel = + let pattern_with_safe_label = match default with - | Some _ -> safePatternLabel patternWithoutConstraint - | _ -> patternWithoutConstraint + | Some _ -> safe_pattern_label pattern_without_constraint + | _ -> pattern_without_constraint in - if isLabelled arg_label || isOptional arg_label then - returnedExpression - (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, + if is_labelled arg_label || is_optional arg_label then + returned_expression + (( {loc = ppat_loc; txt = Lident (get_label arg_label)}, { - patternWithSafeLabel with + pattern_with_safe_label with ppat_attributes = - (if isOptional arg_label then optionalAttrs else []) + (if is_optional arg_label then optional_attrs else []) @ pattern.ppat_attributes; } ) - :: patternsWithLabel) - patternsWithNolabel expr + :: patterns_with_label) + patterns_with_nolabel expr else (* Special case of nolabel arg "ref" in forwardRef fn *) (* let make = React.forwardRef(ref => body) *) match ppat_desc with | Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) -> - returnedExpression patternsWithLabel + returned_expression patterns_with_label (( {loc = ppat_loc; txt = Lident txt}, { pattern with - ppat_attributes = optionalAttrs @ pattern.ppat_attributes; + ppat_attributes = optional_attrs @ pattern.ppat_attributes; } ) - :: patternsWithNolabel) + :: patterns_with_nolabel) expr - | _ -> returnedExpression patternsWithLabel patternsWithNolabel expr) - | _ -> (patternsWithLabel, patternsWithNolabel, expr) + | _ -> + returned_expression patterns_with_label patterns_with_nolabel expr) + | _ -> (patterns_with_label, patterns_with_nolabel, expr) in - let patternsWithLabel, patternsWithNolabel, expression = - returnedExpression [] [] expression + let patterns_with_label, patterns_with_nolabel, expression = + returned_expression [] [] expression in (* add pattern matching for optional prop value *) let expression = - if hasDefaultValue namedArgList then vbMatchExpr namedArgList expression + if has_default_value named_arg_list then + vb_match_expr named_arg_list expression else expression in (* (ref) => expr *) let expression = List.fold_left - (fun expr (_, pattern) -> Exp.fun_ Nolabel None pattern expr) - expression patternsWithNolabel + (fun expr (_, pattern) -> + let pattern = + match pattern.ppat_desc with + | Ppat_var {txt} when txt = "ref" -> + Pat.constraint_ pattern (ref_type Location.none) + | _ -> pattern + in + Exp.fun_ Nolabel None pattern expr) + expression patterns_with_nolabel in (* ({a, b, _}: props<'a, 'b>) *) - let recordPattern = - match patternsWithLabel with + let record_pattern = + match patterns_with_label with | [] -> Pat.any () - | _ -> Pat.record (List.rev patternsWithLabel) Open + | _ -> Pat.record (List.rev patterns_with_label) Open in let expression = Exp.fun_ Nolabel None - (Pat.constraint_ recordPattern - (Typ.constr ~loc:emptyLoc - {txt = Lident "props"; loc = emptyLoc} - (match coreTypeOfAttr with + (Pat.constraint_ record_pattern + (Typ.constr ~loc:empty_loc + {txt = Lident "props"; loc = empty_loc} + (match core_type_of_attr with | None -> - makePropsTypeParams ~stripExplicitOption:true - ~stripExplicitJsNullableOfRef:hasForwardRef namedTypeList + make_props_type_params ~strip_explicit_option:true + ~strip_explicit_js_nullable_of_ref:has_forward_ref + named_type_list | Some _ -> ( - match typVarsOfCoreType with + match typ_vars_of_core_type with | [] -> [] | _ -> [Typ.any ()])))) expression in - let expression = Ast_async.add_async_attribute ~async:isAsync expression in + let expression = Ast_async.add_async_attribute ~async:is_async expression in let expression = (* Add new tupes (type a,b,c) to make's definition *) newtypes |> List.fold_left (fun e newtype -> Exp.newtype newtype e) expression in (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) - let binding, newBinding = - match recFlag with + let binding, new_binding = + match rec_flag with | Recursive -> - ( bindingWrapper - (Exp.let_ ~loc:emptyLoc Nonrecursive - [makeNewBinding binding expression internalFnName] - (Exp.let_ ~loc:emptyLoc Nonrecursive + ( binding_wrapper + (Exp.let_ ~loc:empty_loc Nonrecursive + [make_new_binding binding expression internal_fn_name] + (Exp.let_ ~loc:empty_loc Nonrecursive [ - Vb.mk (Pat.var {loc = emptyLoc; txt = fnName}) fullExpression; + Vb.mk + (Pat.var {loc = empty_loc; txt = fn_name}) + full_expression; ] - (Exp.ident {loc = emptyLoc; txt = Lident fnName}))), + (Exp.ident {loc = empty_loc; txt = Lident fn_name}))), None ) | Nonrecursive -> ( { binding with pvb_expr = expression; - pvb_pat = Pat.var {txt = fnName; loc = Location.none}; + pvb_pat = Pat.var {txt = fn_name; loc = Location.none}; }, - Some (bindingWrapper fullExpression) ) + Some (binding_wrapper full_expression) ) in - (Some propsRecordType, binding, newBinding)) + (Some props_record_type, binding, new_binding)) else (None, binding, None) -let transformStructureItem ~config item = +let transform_structure_item ~config item = match item with (* external *) | { @@ -1139,219 +1169,213 @@ let transformStructureItem ~config item = pstr_desc = Pstr_primitive ({pval_attributes; pval_type} as value_description); } as pstr -> ( - match List.filter Jsx_common.hasAttr pval_attributes with + match List.filter Jsx_common.has_attr pval_attributes with | [] -> [item] | [_] -> - checkMultipleComponents ~config ~loc:pstr_loc; + check_multiple_components ~config ~loc:pstr_loc; check_string_int_attribute_iter.structure_item check_string_int_attribute_iter item; - let pval_type = Jsx_common.extractUncurried pval_type in - let coreTypeOfAttr = Jsx_common.coreTypeOfAttrs pval_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map Jsx_common.typVarsOfCoreType + let pval_type = Jsx_common.extract_uncurried pval_type in + let core_type_of_attr = Jsx_common.core_type_of_attrs pval_attributes in + let typ_vars_of_core_type = + core_type_of_attr + |> Option.map Jsx_common.typ_vars_of_core_type |> Option.value ~default:[] in - let rec getPropTypes types - ({ptyp_loc; ptyp_desc; ptyp_attributes} as fullType) = + let rec get_prop_types types + ({ptyp_loc; ptyp_desc; ptyp_attributes} as full_type) = match ptyp_desc with | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_attributes, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - ( returnValue, - (name, ptyp_attributes, returnValue.ptyp_loc, type_) :: types ) - | _ -> (fullType, types) + when is_labelled name || is_optional name -> + get_prop_types + ((name, ptyp_attributes, ptyp_loc, type_) :: types) + rest + | Ptyp_arrow (Nolabel, _type, rest) -> get_prop_types types rest + | Ptyp_arrow (name, type_, return_value) + when is_labelled name || is_optional name -> + ( return_value, + (name, ptyp_attributes, return_value.ptyp_loc, type_) :: types ) + | _ -> (full_type, types) in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = + let inner_type, prop_types = get_prop_types [] pval_type in + let named_type_list = List.fold_left arg_to_concrete_type [] prop_types in + let ret_props_type = Typ.constr ~loc:pstr_loc (Location.mkloc (Lident "props") pstr_loc) - (match coreTypeOfAttr with - | None -> makePropsTypeParams namedTypeList + (match core_type_of_attr with + | None -> make_props_type_params named_type_list | Some _ -> ( - match typVarsOfCoreType with + match typ_vars_of_core_type with | [] -> [] | _ -> [Typ.any ()])) in (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) - let propsRecordType = - makePropsRecordType ~coreTypeOfAttr ~typVarsOfCoreType "props" pstr_loc - namedTypeList + let props_record_type = + make_props_record_type ~core_type_of_attr ~typ_vars_of_core_type "props" + pstr_loc named_type_list in (* can't be an arrow because it will defensively uncurry *) - let newExternalType = + let new_external_type = Ptyp_constr - ( {loc = pstr_loc; txt = moduleAccessName config "componentLike"}, - [retPropsType; innerType] ) + ( {loc = pstr_loc; txt = module_access_name config "componentLike"}, + [ret_props_type; inner_type] ) in - let newStructure = + let new_structure = { pstr with pstr_desc = Pstr_primitive { value_description with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; + pval_type = {pval_type with ptyp_desc = new_external_type}; + pval_attributes = List.filter other_attrs_pure pval_attributes; }; } in - [propsRecordType; newStructure] + [props_record_type; new_structure] | _ -> - Jsx_common.raiseError ~loc:pstr_loc + Jsx_common.raise_error ~loc:pstr_loc "Only one JSX component call can exist on a component at one time") (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let processBinding binding (newItems, bindings, newBindings) = - let newItem, binding, newBinding = - mapBinding ~config ~emptyLoc ~pstr_loc ~fileName ~recFlag binding + | {pstr_loc; pstr_desc = Pstr_value (rec_flag, value_bindings)} -> ( + let file_name = filename_from_loc pstr_loc in + let empty_loc = Location.in_file file_name in + let process_binding binding (new_items, bindings, new_bindings) = + let new_item, binding, new_binding = + map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding in - let newItems = - match newItem with - | Some item -> item :: newItems - | None -> newItems + let new_items = + match new_item with + | Some item -> item :: new_items + | None -> new_items in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings + let new_bindings = + match new_binding with + | Some new_binding -> new_binding :: new_bindings + | None -> new_bindings in - (newItems, binding :: bindings, newBindings) + (new_items, binding :: bindings, new_bindings) in - let newItems, bindings, newBindings = - List.fold_right processBinding valueBindings ([], [], []) + let new_items, bindings, new_bindings = + List.fold_right process_binding value_bindings ([], [], []) in - newItems - @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] + new_items + @ [{pstr_loc; pstr_desc = Pstr_value (rec_flag, bindings)}] @ - match newBindings with + match new_bindings with | [] -> [] - | newBindings -> - [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) + | new_bindings -> + [{pstr_loc = empty_loc; pstr_desc = Pstr_value (rec_flag, new_bindings)}]) | _ -> [item] -let transformSignatureItem ~config item = +let transform_signature_item ~config item = match item with | { psig_loc; psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc); } as psig -> ( - match List.filter Jsx_common.hasAttr pval_attributes with + match List.filter Jsx_common.has_attr pval_attributes with | [] -> [item] | [_] -> - checkMultipleComponents ~config ~loc:psig_loc; - let pval_type = Jsx_common.extractUncurried pval_type in + check_multiple_components ~config ~loc:psig_loc; + let pval_type = Jsx_common.extract_uncurried pval_type in check_string_int_attribute_iter.signature_item check_string_int_attribute_iter item; - let hasForwardRef = ref false in - let coreTypeOfAttr = Jsx_common.coreTypeOfAttrs pval_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map Jsx_common.typVarsOfCoreType + let core_type_of_attr = Jsx_common.core_type_of_attrs pval_attributes in + let typ_vars_of_core_type = + core_type_of_attr + |> Option.map Jsx_common.typ_vars_of_core_type |> Option.value ~default:[] in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + let rec get_prop_types types ({ptyp_loc; ptyp_desc} as full_type) = match ptyp_desc with | Ptyp_arrow ( name, ({ptyp_attributes = attrs} as type_), ({ptyp_desc = Ptyp_arrow _} as rest) ) - when isOptional name || isLabelled name -> - getPropTypes ((name, attrs, ptyp_loc, type_) :: types) rest + when is_optional name || is_labelled name -> + get_prop_types ((name, attrs, ptyp_loc, type_) :: types) rest | Ptyp_arrow (Nolabel, {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)}, rest) -> - getPropTypes types rest - | Ptyp_arrow (Nolabel, _type, rest) -> - hasForwardRef := true; - getPropTypes types rest - | Ptyp_arrow (name, ({ptyp_attributes = attrs} as type_), returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, attrs, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) + get_prop_types types rest + | Ptyp_arrow (Nolabel, _type, rest) -> get_prop_types types rest + | Ptyp_arrow (name, ({ptyp_attributes = attrs} as type_), return_value) + when is_optional name || is_labelled name -> + (return_value, (name, attrs, return_value.ptyp_loc, type_) :: types) + | _ -> (full_type, types) in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = + let inner_type, prop_types = get_prop_types [] pval_type in + let named_type_list = List.fold_left arg_to_concrete_type [] prop_types in + let ret_props_type = Typ.constr (Location.mkloc (Lident "props") psig_loc) - (match coreTypeOfAttr with - | None -> makePropsTypeParams namedTypeList + (match core_type_of_attr with + | None -> make_props_type_params named_type_list | Some _ -> ( - match typVarsOfCoreType with + match typ_vars_of_core_type with | [] -> [] | _ -> [Typ.any ()])) in - let propsRecordType = - makePropsRecordTypeSig ~coreTypeOfAttr ~typVarsOfCoreType "props" - psig_loc - ((* If there is Nolabel arg, regard the type as ref in forwardRef *) - (if !hasForwardRef then - [(true, "ref", [], Location.none, refType Location.none)] - else []) - @ namedTypeList) + let props_record_type = + make_props_record_type_sig ~core_type_of_attr ~typ_vars_of_core_type + "props" psig_loc named_type_list in (* can't be an arrow because it will defensively uncurry *) - let newExternalType = + let new_external_type = Ptyp_constr - ( {loc = psig_loc; txt = moduleAccessName config "componentLike"}, - [retPropsType; innerType] ) + ( {loc = psig_loc; txt = module_access_name config "componentLike"}, + [ret_props_type; inner_type] ) in - let newStructure = + let new_structure = { psig with psig_desc = Psig_value { psig_desc with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; + pval_type = {pval_type with ptyp_desc = new_external_type}; + pval_attributes = List.filter other_attrs_pure pval_attributes; }; } in - [propsRecordType; newStructure] + [props_record_type; new_structure] | _ -> - Jsx_common.raiseError ~loc:psig_loc + Jsx_common.raise_error ~loc:psig_loc "Only one JSX component call can exist on a component at one time") | _ -> [item] -let transformJsxCall ~config mapper callExpression callArguments jsxExprLoc - attrs = - match callExpression.pexp_desc with +let transform_jsx_call ~config mapper call_expression call_arguments + jsx_expr_loc attrs = + match call_expression.pexp_desc with | Pexp_ident caller -> ( match caller with | {txt = Lident "createElement"; loc} -> - Jsx_common.raiseError ~loc + Jsx_common.raise_error ~loc "JSX: `createElement` should be preceeded by a module name." (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> - transformUppercaseCall3 ~config modulePath mapper jsxExprLoc loc attrs - callArguments + | {loc; txt = Ldot (module_path, ("createElement" | "make"))} -> + transform_uppercase_call3 ~config module_path mapper jsx_expr_loc loc + attrs call_arguments (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) (* turn that into ReactDOM.createElement(~props=ReactDOM.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) | {loc; txt = Lident id} -> - transformLowercaseCall3 ~config mapper jsxExprLoc loc attrs callArguments - id - | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - Jsx_common.raiseError ~loc + transform_lowercase_call3 ~config mapper jsx_expr_loc loc attrs + call_arguments id + | {txt = Ldot (_, anything_not_create_element_or_make); loc} -> + Jsx_common.raise_error ~loc "JSX: the JSX attribute should be attached to a \ `YourModuleName.createElement` or `YourModuleName.make` call. We saw \ `%s` instead" - anythingNotCreateElementOrMake + anything_not_create_element_or_make | {txt = Lapply _; loc} -> (* don't think there's ever a case where this is reached *) - Jsx_common.raiseError ~loc + Jsx_common.raise_error ~loc "JSX: encountered a weird case while processing the code. Please \ report this!") | _ -> - Jsx_common.raiseError ~loc:callExpression.pexp_loc + Jsx_common.raise_error ~loc:call_expression.pexp_loc "JSX: `createElement` should be preceeded by a simple, direct module \ name." @@ -1359,21 +1383,21 @@ let expr ~config mapper expression = match expression with (* Does the function application have the @JSX attribute? *) | { - pexp_desc = Pexp_apply (callExpression, callArguments); + pexp_desc = Pexp_apply (call_expression, call_arguments); pexp_attributes; pexp_loc; } -> ( - let jsxAttribute, nonJSXAttributes = + let jsx_attribute, non_jsx_attributes = List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes in - match (jsxAttribute, nonJSXAttributes) with + match (jsx_attribute, non_jsx_attributes) with (* no JSX attribute *) | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - transformJsxCall ~config mapper callExpression callArguments pexp_loc - nonJSXAttributes) + | _, non_jsx_attributes -> + transform_jsx_call ~config mapper call_expression call_arguments pexp_loc + non_jsx_attributes) (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) | { pexp_desc = @@ -1381,73 +1405,73 @@ let expr ~config mapper expression = ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) | Pexp_construct ({txt = Lident "[]"; loc}, None) ); pexp_attributes; - } as listItems -> ( - let jsxAttribute, nonJSXAttributes = + } as list_items -> ( + let jsx_attribute, non_jsx_attributes = List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes in - match (jsxAttribute, nonJSXAttributes) with + match (jsx_attribute, non_jsx_attributes) with (* no JSX attribute *) | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> + | _, non_jsx_attributes -> let loc = {loc with loc_ghost = true} in let fragment = match config.mode with | "automatic" -> - Exp.ident ~loc {loc; txt = moduleAccessName config "jsxFragment"} + Exp.ident ~loc {loc; txt = module_access_name config "jsxFragment"} | "classic" | _ -> Exp.ident ~loc {loc; txt = Ldot (Lident "React", "fragment")} in - let childrenExpr = transformChildrenIfList ~mapper listItems in - let recordOfChildren children = + let children_expr = transform_children_if_list ~mapper list_items in + let record_of_children children = Exp.record [(Location.mknoloc (Lident "children"), children)] None in - let applyJsxArray expr = + let apply_jsx_array expr = Exp.apply (Exp.ident - {txt = moduleAccessName config "array"; loc = Location.none}) + {txt = module_access_name config "array"; loc = Location.none}) [(Nolabel, expr)] in - let countOfChildren = function + let count_of_children = function | {pexp_desc = Pexp_array children} -> List.length children | _ -> 0 in - let transformChildrenToProps childrenExpr = - match childrenExpr with + let transform_children_to_props children_expr = + match children_expr with | {pexp_desc = Pexp_array children} -> ( match children with - | [] -> emptyRecord ~loc:Location.none - | [child] -> recordOfChildren child + | [] -> empty_record ~loc:Location.none + | [child] -> record_of_children child | _ -> ( match config.mode with - | "automatic" -> recordOfChildren @@ applyJsxArray childrenExpr - | "classic" | _ -> emptyRecord ~loc:Location.none)) + | "automatic" -> record_of_children @@ apply_jsx_array children_expr + | "classic" | _ -> empty_record ~loc:Location.none)) | _ -> ( match config.mode with - | "automatic" -> recordOfChildren @@ applyJsxArray childrenExpr - | "classic" | _ -> emptyRecord ~loc:Location.none) + | "automatic" -> record_of_children @@ apply_jsx_array children_expr + | "classic" | _ -> empty_record ~loc:Location.none) in let args = (nolabel, fragment) - :: (nolabel, transformChildrenToProps childrenExpr) + :: (nolabel, transform_children_to_props children_expr) :: (match config.mode with - | "classic" when countOfChildren childrenExpr > 1 -> - [(nolabel, childrenExpr)] + | "classic" when count_of_children children_expr > 1 -> + [(nolabel, children_expr)] | _ -> []) in Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs:nonJSXAttributes + ~attrs:non_jsx_attributes (* ReactDOM.createElement *) (match config.mode with | "automatic" -> - if countOfChildren childrenExpr > 1 then - Exp.ident ~loc {loc; txt = moduleAccessName config "jsxs"} - else Exp.ident ~loc {loc; txt = moduleAccessName config "jsx"} + if count_of_children children_expr > 1 then + Exp.ident ~loc {loc; txt = module_access_name config "jsxs"} + else Exp.ident ~loc {loc; txt = module_access_name config "jsx"} | "classic" | _ -> - if countOfChildren childrenExpr > 1 then + if count_of_children children_expr > 1 then Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElementVariadic")} else @@ -1456,20 +1480,20 @@ let expr ~config mapper expression = (* Delegate to the default mapper, a deep identity traversal *) | e -> default_mapper.expr mapper e -let module_binding ~(config : Jsx_common.jsxConfig) mapper module_binding = - config.nestedModules <- module_binding.pmb_name.txt :: config.nestedModules; +let module_binding ~(config : Jsx_common.jsx_config) mapper module_binding = + config.nested_modules <- module_binding.pmb_name.txt :: config.nested_modules; let mapped = default_mapper.module_binding mapper module_binding in let () = - match config.nestedModules with - | _ :: rest -> config.nestedModules <- rest + match config.nested_modules with + | _ :: rest -> config.nested_modules <- rest | [] -> () in mapped (* TODO: some line number might still be wrong *) -let jsxMapper ~config = +let jsx_mapper ~config = let expr = expr ~config in let module_binding = module_binding ~config in - let transformStructureItem = transformStructureItem ~config in - let transformSignatureItem = transformSignatureItem ~config in - (expr, module_binding, transformSignatureItem, transformStructureItem) + let transform_structure_item = transform_structure_item ~config in + let transform_signature_item = transform_signature_item ~config in + (expr, module_binding, transform_signature_item, transform_structure_item) diff --git a/analysis/vendor/res_syntax/reactjs_jsx_v3.ml b/analysis/vendor/res_syntax/reactjs_jsx_v3.ml index 83316c9d5..46de98bf4 100644 --- a/analysis/vendor/res_syntax/reactjs_jsx_v3.ml +++ b/analysis/vendor/res_syntax/reactjs_jsx_v3.ml @@ -10,48 +10,48 @@ let labelled str = Labelled str let optional str = Optional str -let isOptional str = +let is_optional str = match str with | Optional _ -> true | _ -> false -let isLabelled str = +let is_labelled str = match str with | Labelled _ -> true | _ -> false -let getLabel str = +let get_label str = match str with | Optional str | Labelled str -> str | Nolabel -> "" -let optionIdent = Lident "option" +let option_ident = Lident "option" -let constantString ~loc str = +let constant_string ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) -let safeTypeFromValue valueStr = - let valueStr = getLabel valueStr in - if valueStr = "" || (valueStr.[0] [@doesNotRaise]) <> '_' then valueStr - else "T" ^ valueStr +let safe_type_from_value value_str = + let value_str = get_label value_str in + if value_str = "" || (value_str.[0] [@doesNotRaise]) <> '_' then value_str + else "T" ^ value_str -let keyType loc = - Typ.constr ~loc {loc; txt = optionIdent} +let key_type loc = + Typ.constr ~loc {loc; txt = option_ident} [Typ.constr ~loc {loc; txt = Lident "string"} []] type 'a children = ListLiteral of 'a | Exact of 'a -type componentConfig = {propsName: string} +type component_config = {props_name: string} (* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) -let transformChildrenIfListUpper ~loc ~mapper theList = - let rec transformChildren_ theList accum = +let transform_children_if_list_upper ~loc ~mapper the_list = + let rec transformChildren_ the_list accum = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) - match theList with + match the_list with | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> ( match accum with - | [singleElement] -> Exact singleElement + | [single_element] -> Exact single_element | accum -> ListLiteral (Exp.array ~loc (List.rev accum))) | { pexp_desc = @@ -59,15 +59,15 @@ let transformChildrenIfListUpper ~loc ~mapper theList = ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); } -> transformChildren_ acc (mapper.expr mapper v :: accum) - | notAList -> Exact (mapper.expr mapper notAList) + | not_a_list -> Exact (mapper.expr mapper not_a_list) in - transformChildren_ theList [] + transformChildren_ the_list [] -let transformChildrenIfList ~loc ~mapper theList = - let rec transformChildren_ theList accum = +let transform_children_if_list ~loc ~mapper the_list = + let rec transformChildren_ the_list accum = (* not in the sense of converting a list to an array; convert the AST reprensentation of a list to the AST reprensentation of an array *) - match theList with + match the_list with | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> Exp.array ~loc (List.rev accum) | { @@ -76,91 +76,93 @@ let transformChildrenIfList ~loc ~mapper theList = ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); } -> transformChildren_ acc (mapper.expr mapper v :: accum) - | notAList -> mapper.expr mapper notAList + | not_a_list -> mapper.expr mapper not_a_list in - transformChildren_ theList [] + transformChildren_ the_list [] -let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = +let extract_children ?(remove_last_position_unit = false) ~loc + props_and_children = let rec allButLast_ lst acc = match lst with | [] -> [] | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> acc | (Nolabel, {pexp_loc}) :: _rest -> - Jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raise_error ~loc:pexp_loc "JSX: found non-labelled argument before the last position" | arg :: rest -> allButLast_ rest (arg :: acc) in - let allButLast lst = allButLast_ lst [] |> List.rev in + let all_but_last lst = allButLast_ lst [] |> List.rev in match List.partition (fun (label, _) -> label = labelled "children") - propsAndChildren + props_and_children with | [], props -> (* no children provided? Place a placeholder list *) ( Exp.construct ~loc {loc; txt = Lident "[]"} None, - if removeLastPositionUnit then allButLast props else props ) - | [(_, childrenExpr)], props -> - (childrenExpr, if removeLastPositionUnit then allButLast props else props) + if remove_last_position_unit then all_but_last props else props ) + | [(_, children_expr)], props -> + ( children_expr, + if remove_last_position_unit then all_but_last props else props ) | _ -> - Jsx_common.raiseError ~loc + Jsx_common.raise_error ~loc "JSX: somehow there's more than one `children` label" -let unerasableIgnore loc = +let unerasable_ignore loc = ( {loc; txt = "warning"}, PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] ) -let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) +let merlin_focus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) (* Helper method to filter out any attribute that isn't [@react.component] *) -let otherAttrsPure (loc, _) = loc.txt <> "react.component" +let other_attrs_pure (loc, _) = loc.txt <> "react.component" (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) -let rec getFnName binding = +let rec get_fn_name binding = match binding with | {ppat_desc = Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat + | {ppat_desc = Ppat_constraint (pat, _)} -> get_fn_name pat | {ppat_loc} -> - Jsx_common.raiseError ~loc:ppat_loc + Jsx_common.raise_error ~loc:ppat_loc "react.component calls cannot be destructured." -let makeNewBinding binding expression newName = +let make_new_binding binding expression new_name = match binding with | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> { binding with pvb_pat = - {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = newName}}; + {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = new_name}}; pvb_expr = expression; - pvb_attributes = [merlinFocus]; + pvb_attributes = [merlin_focus]; } | {pvb_loc} -> - Jsx_common.raiseError ~loc:pvb_loc + Jsx_common.raise_error ~loc:pvb_loc "react.component calls cannot be destructured." (* Lookup the value of `props` otherwise raise Invalid_argument error *) -let getPropsNameValue _acc (loc, exp) = +let get_props_name_value _acc (loc, exp) = match (loc, exp) with | {txt = Lident "props"}, {pexp_desc = Pexp_ident {txt = Lident str}} -> - {propsName = str} + {props_name = str} | {txt; loc}, _ -> - Jsx_common.raiseError ~loc + Jsx_common.raise_error ~loc "react.component only accepts props as an option, given: { %s }" (Longident.last txt) (* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *) -let getPropsAttr payload = - let defaultProps = {propsName = "Props"} in +let get_props_attr payload = + let default_props = {props_name = "Props"} in match payload with | Some (PStr ({ pstr_desc = - Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _); + Pstr_eval ({pexp_desc = Pexp_record (record_fields, None)}, _); } :: _rest)) -> - List.fold_left getPropsNameValue defaultProps recordFields + List.fold_left get_props_name_value default_props record_fields | Some (PStr ({ @@ -168,43 +170,43 @@ let getPropsAttr payload = Pstr_eval ({pexp_desc = Pexp_ident {txt = Lident "props"}}, _); } :: _rest)) -> - {propsName = "props"} + {props_name = "props"} | Some (PStr ({pstr_desc = Pstr_eval (_, _); pstr_loc} :: _rest)) -> - Jsx_common.raiseError ~loc:pstr_loc + Jsx_common.raise_error ~loc:pstr_loc "react.component accepts a record config with props as an options." - | _ -> defaultProps + | _ -> default_props (* Plucks the label, loc, and type_ from an AST node *) -let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = +let pluck_label_default_loc_type (label, default, _, _, loc, type_) = (label, default, loc, type_) (* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) -let filenameFromLoc (pstr_loc : Location.t) = - let fileName = +let filename_from_loc (pstr_loc : Location.t) = + let file_name = match pstr_loc.loc_start.pos_fname with | "" -> !Location.input_name - | fileName -> fileName + | file_name -> file_name in - let fileName = - try Filename.chop_extension (Filename.basename fileName) - with Invalid_argument _ -> fileName + let file_name = + try Filename.chop_extension (Filename.basename file_name) + with Invalid_argument _ -> file_name in - let fileName = String.capitalize_ascii fileName in - fileName + let file_name = String.capitalize_ascii file_name in + file_name (* Build a string representation of a module name with segments separated by $ *) -let makeModuleName fileName nestedModules fnName = - let fullModuleName = - match (fileName, nestedModules, fnName) with +let make_module_name file_name nested_modules fn_name = + let full_module_name = + match (file_name, nested_modules, fn_name) with (* TODO: is this even reachable? It seems like the fileName always exists *) - | "", nestedModules, "make" -> nestedModules - | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) - | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules - | fileName, nestedModules, fnName -> - fileName :: List.rev (fnName :: nestedModules) + | "", nested_modules, "make" -> nested_modules + | "", nested_modules, fn_name -> List.rev (fn_name :: nested_modules) + | file_name, nested_modules, "make" -> file_name :: List.rev nested_modules + | file_name, nested_modules, fn_name -> + file_name :: List.rev (fn_name :: nested_modules) in - let fullModuleName = String.concat "$" fullModuleName in - fullModuleName + let full_module_name = String.concat "$" full_module_name in + full_module_name (* AST node builders @@ -213,16 +215,16 @@ let makeModuleName fileName nestedModules fnName = *) (* Build an AST node representing all named args for the `external` definition for a component's props *) -let rec recursivelyMakeNamedArgsForExternal list args = +let rec recursively_make_named_args_for_external list args = match list with - | (label, default, loc, interiorType) :: tl -> - recursivelyMakeNamedArgsForExternal tl + | (label, default, loc, interior_type) :: tl -> + recursively_make_named_args_for_external tl (Typ.arrow ~loc label - (match (label, interiorType, default) with + (match (label, interior_type, default) with (* ~foo=1 *) | label, None, Some _ -> { - ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_desc = Ptyp_var (safe_type_from_value label); ptyp_loc = loc; ptyp_attributes = []; } @@ -242,19 +244,19 @@ let rec recursivelyMakeNamedArgsForExternal list args = _ ) (* ~foo: int=? - note this isnt valid. but we want to get a type error *) | label, Some type_, _ - when isOptional label -> + when is_optional label -> type_ (* ~foo=? *) - | label, None, _ when isOptional label -> + | label, None, _ when is_optional label -> { - ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_desc = Ptyp_var (safe_type_from_value label); ptyp_loc = loc; ptyp_attributes = []; } (* ~foo *) | label, None, _ -> { - ptyp_desc = Ptyp_var (safeTypeFromValue label); + ptyp_desc = Ptyp_var (safe_type_from_value label); ptyp_loc = loc; ptyp_attributes = []; } @@ -262,61 +264,64 @@ let rec recursivelyMakeNamedArgsForExternal list args = args) | [] -> args -(* Build an AST node for the [@bs.obj] representing props for a component *) -let makePropsValue fnName loc namedArgListWithKeyAndRef propsType = - let propsName = fnName ^ "Props" in +(* Build an AST node for the [@obj] representing props for a component *) +let make_props_value fn_name loc named_arg_list_with_key_and_ref props_type = + let props_name = fn_name ^ "Props" in { - pval_name = {txt = propsName; loc}; + pval_name = {txt = props_name; loc}; pval_type = - recursivelyMakeNamedArgsForExternal namedArgListWithKeyAndRef + recursively_make_named_args_for_external named_arg_list_with_key_and_ref (Typ.arrow nolabel { ptyp_desc = Ptyp_constr ({txt = Lident "unit"; loc}, []); ptyp_loc = loc; ptyp_attributes = []; } - propsType); + props_type); pval_prim = [""]; - pval_attributes = [({txt = "bs.obj"; loc}, PStr [])]; + pval_attributes = [({txt = "obj"; loc}, PStr [])]; pval_loc = loc; } -(* Build an AST node representing an `external` with the definition of the [@bs.obj] *) -let makePropsExternal fnName loc namedArgListWithKeyAndRef propsType = +(* Build an AST node representing an `external` with the definition of the [@obj] *) +let make_props_external fn_name loc named_arg_list_with_key_and_ref props_type = { pstr_loc = loc; pstr_desc = Pstr_primitive - (makePropsValue fnName loc namedArgListWithKeyAndRef propsType); + (make_props_value fn_name loc named_arg_list_with_key_and_ref props_type); } (* Build an AST node for the signature of the `external` definition *) -let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType = +let make_props_external_sig fn_name loc named_arg_list_with_key_and_ref + props_type = { psig_loc = loc; psig_desc = - Psig_value (makePropsValue fnName loc namedArgListWithKeyAndRef propsType); + Psig_value + (make_props_value fn_name loc named_arg_list_with_key_and_ref props_type); } (* Build an AST node for the props name when converted to an object inside the function signature *) -let makePropsName ~loc name = +let make_props_name ~loc name = {ppat_desc = Ppat_var {txt = name; loc}; ppat_loc = loc; ppat_attributes = []} -let makeObjectField loc (str, attrs, type_) = +let make_object_field loc (str, attrs, type_) = Otag ({loc; txt = str}, attrs, type_) (* Build an AST node representing a "closed" object representing a component's props *) -let makePropsType ~loc namedTypeList = +let make_props_type ~loc named_type_list = Typ.mk ~loc - (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed)) + (Ptyp_object (List.map (make_object_field loc) named_type_list, Closed)) (* Builds an AST node for the entire `external` definition of props *) -let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList = - makePropsExternal fnName loc - (List.map pluckLabelDefaultLocType namedArgListWithKeyAndRef) - (makePropsType ~loc namedTypeList) +let make_external_decl fn_name loc named_arg_list_with_key_and_ref + named_type_list = + make_props_external fn_name loc + (List.map pluck_label_default_loc_type named_arg_list_with_key_and_ref) + (make_props_type ~loc named_type_list) -let newtypeToVar newtype type_ = +let newtype_to_var newtype type_ = let var_desc = Ptyp_var ("type-" ^ newtype) in let typ (mapper : Ast_mapper.mapper) typ = match typ.ptyp_desc with @@ -328,55 +333,57 @@ let newtypeToVar newtype type_ = mapper.typ mapper type_ (* TODO: some line number might still be wrong *) -let jsxMapper ~config = - let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments = - let children, argsWithLabels = - extractChildren ~loc ~removeLastPositionUnit:true callArguments +let jsx_mapper ~config = + let transform_uppercase_call3 module_path mapper loc attrs _ call_arguments = + let children, args_with_labels = + extract_children ~loc ~remove_last_position_unit:true call_arguments in - let argsForMake = argsWithLabels in - let childrenExpr = transformChildrenIfListUpper ~loc ~mapper children in - let recursivelyTransformedArgsForMake = - argsForMake + let args_for_make = args_with_labels in + let children_expr = + transform_children_if_list_upper ~loc ~mapper children + in + let recursively_transformed_args_for_make = + args_for_make |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) in - let childrenArg = ref None in + let children_arg = ref None in let args = - recursivelyTransformedArgsForMake - @ (match childrenExpr with + recursively_transformed_args_for_make + @ (match children_expr with | Exact children -> [(labelled "children", children)] | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] | ListLiteral expression -> (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; + children_arg := Some expression; [ ( labelled "children", Exp.ident ~loc {loc; txt = Ldot (Lident "React", "null")} ); ]) @ [(nolabel, Exp.construct ~loc {loc; txt = Lident "()"} None)] in - let isCap str = String.capitalize_ascii str = str in + let is_cap str = String.capitalize_ascii str = str in let ident = - match modulePath with - | Lident _ -> Ldot (modulePath, "make") - | Ldot (_modulePath, value) as fullPath when isCap value -> - Ldot (fullPath, "make") - | modulePath -> modulePath + match module_path with + | Lident _ -> Ldot (module_path, "make") + | Ldot (_modulePath, value) as full_path when is_cap value -> + Ldot (full_path, "make") + | module_path -> module_path in - let propsIdent = + let props_ident = match ident with | Lident path -> Lident (path ^ "Props") | Ldot (ident, path) -> Ldot (ident, path ^ "Props") | _ -> - Jsx_common.raiseError ~loc + Jsx_common.raise_error ~loc "JSX name can't be the result of function applications" in let props = - Exp.apply ~attrs ~loc (Exp.ident ~loc {loc; txt = propsIdent}) args + Exp.apply ~attrs ~loc (Exp.ident ~loc {loc; txt = props_ident}) args in (* handle key, ref, children *) (* React.createElement(Component.make, props, ...children) *) - match !childrenArg with + match !children_arg with | None -> Exp.apply ~loc ~attrs (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElement")}) @@ -392,11 +399,11 @@ let jsxMapper ~config = ] in - let transformLowercaseCall3 mapper loc attrs callArguments id = - let children, nonChildrenProps = extractChildren ~loc callArguments in - let componentNameExpr = constantString ~loc id in - let childrenExpr = transformChildrenIfList ~loc ~mapper children in - let createElementCall = + let transform_lowercase_call3 mapper loc attrs call_arguments id = + let children, non_children_props = extract_children ~loc call_arguments in + let component_name_expr = constant_string ~loc id in + let children_expr = transform_children_if_list ~loc ~mapper children in + let create_element_call = match children with (* [@JSX] div(~children=[a]), coming from
a
*) | { @@ -407,34 +414,34 @@ let jsxMapper ~config = "createDOMElementVariadic" (* [@JSX] div(~children= value), coming from
...(value)
*) | {pexp_loc} -> - Jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raise_error ~loc:pexp_loc "A spread as a DOM element's children don't make sense written \ together. You can simply remove the spread." in let args = - match nonChildrenProps with + match non_children_props with | [_justTheUnitArgumentAtEnd] -> [ (* "div" *) - (nolabel, componentNameExpr); + (nolabel, component_name_expr); (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); + (nolabel, children_expr); ] - | nonEmptyProps -> - let propsCall = + | non_empty_props -> + let props_call = Exp.apply ~loc (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")}) - (nonEmptyProps + (non_empty_props |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) in [ (* "div" *) - (nolabel, componentNameExpr); + (nolabel, component_name_expr); (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsCall); + (labelled "props", props_call); (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); + (nolabel, children_expr); ] in Exp.apply @@ -442,30 +449,30 @@ let jsxMapper ~config = ~attrs (* ReactDOMRe.createElement *) (Exp.ident ~loc - {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) + {loc; txt = Ldot (Lident "ReactDOMRe", create_element_call)}) args in - let rec recursivelyTransformNamedArgsForMake expr args newtypes = + let rec recursively_transform_named_args_for_make expr args newtypes = match expr.pexp_desc with (* TODO: make this show up with a loc. *) | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - Jsx_common.raiseError ~loc:expr.pexp_loc + Jsx_common.raise_error ~loc:expr.pexp_loc "Key cannot be accessed inside of a component. Don't worry - you can \ always key a component from its parent!" | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> - Jsx_common.raiseError ~loc:expr.pexp_loc + Jsx_common.raise_error ~loc:expr.pexp_loc "Ref cannot be passed as a normal prop. Either give the prop a \ different name or use the `forwardRef` API instead." | Pexp_fun (arg, default, pattern, expression) - when isOptional arg || isLabelled arg -> + when is_optional arg || is_labelled arg -> let () = - match (isOptional arg, pattern, default) with + match (is_optional arg, pattern, default) with | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( match ptyp_desc with | Ptyp_constr ({txt = Lident "option"}, [_]) -> () | _ -> - let currentType = + let current_type = match ptyp_desc with | Ptyp_constr ({txt}, []) -> String.concat "." (Longident.flatten txt) @@ -478,14 +485,14 @@ let jsxMapper ~config = (Printf.sprintf "React: optional argument annotations must have explicit \ `option`. Did you mean `option<%s>=?`?" - currentType))) + current_type))) | _ -> () in let alias = match pattern with | {ppat_desc = Ppat_alias (_, {txt}) | Ppat_var {txt}} -> txt | {ppat_desc = Ppat_any} -> "_" - | _ -> getLabel arg + | _ -> get_label arg in let type_ = match pattern with @@ -493,7 +500,7 @@ let jsxMapper ~config = | _ -> None in - recursivelyTransformNamedArgsForMake expression + recursively_transform_named_args_for_make expression ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) newtypes | Pexp_fun @@ -516,44 +523,45 @@ let jsxMapper ~config = "React: react.component refs only support plain arguments and type \ annotations." | Pexp_newtype (label, expression) -> - recursivelyTransformNamedArgsForMake expression args (label :: newtypes) + recursively_transform_named_args_for_make expression args + (label :: newtypes) | Pexp_constraint (expression, _typ) -> - recursivelyTransformNamedArgsForMake expression args newtypes + recursively_transform_named_args_for_make expression args newtypes | _ -> (args, newtypes, None) in - let argToType types (name, default, _noLabelName, _alias, loc, type_) = + let arg_to_type types (name, default, _noLabelName, _alias, loc, type_) = match (type_, name, default) with | Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, name, _ - when isOptional name -> - ( getLabel name, + when is_optional name -> + ( get_label name, [], { type_ with ptyp_desc = - Ptyp_constr ({loc = type_.ptyp_loc; txt = optionIdent}, [type_]); + Ptyp_constr ({loc = type_.ptyp_loc; txt = option_ident}, [type_]); } ) :: types | Some type_, name, Some _default -> - ( getLabel name, + ( get_label name, [], { - ptyp_desc = Ptyp_constr ({loc; txt = optionIdent}, [type_]); + ptyp_desc = Ptyp_constr ({loc; txt = option_ident}, [type_]); ptyp_loc = loc; ptyp_attributes = []; } ) :: types - | Some type_, name, _ -> (getLabel name, [], type_) :: types - | None, name, _ when isOptional name -> - ( getLabel name, + | Some type_, name, _ -> (get_label name, [], type_) :: types + | None, name, _ when is_optional name -> + ( get_label name, [], { ptyp_desc = Ptyp_constr - ( {loc; txt = optionIdent}, + ( {loc; txt = option_ident}, [ { - ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_desc = Ptyp_var (safe_type_from_value name); ptyp_loc = loc; ptyp_attributes = []; }; @@ -562,11 +570,11 @@ let jsxMapper ~config = ptyp_attributes = []; } ) :: types - | None, name, _ when isLabelled name -> - ( getLabel name, + | None, name, _ when is_labelled name -> + ( get_label name, [], { - ptyp_desc = Ptyp_var (safeTypeFromValue name); + ptyp_desc = Ptyp_var (safe_type_from_value name); ptyp_loc = loc; ptyp_attributes = []; } ) @@ -574,145 +582,151 @@ let jsxMapper ~config = | _ -> types in - let argToConcreteType types (name, loc, type_) = + let arg_to_concrete_type types (name, loc, type_) = match name with - | name when isLabelled name -> (getLabel name, [], type_) :: types - | name when isOptional name -> - (getLabel name, [], Typ.constr ~loc {loc; txt = optionIdent} [type_]) + | name when is_labelled name -> (get_label name, [], type_) :: types + | name when is_optional name -> + (get_label name, [], Typ.constr ~loc {loc; txt = option_ident} [type_]) :: types | _ -> types in - let nestedModules = ref [] in - let transformStructureItem item = + let nested_modules = ref [] in + let transform_structure_item item = match item with (* external *) | { pstr_loc; pstr_desc = Pstr_primitive - ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + ({pval_name = {txt = fn_name}; pval_attributes; pval_type} as value_description); } as pstr -> ( - match List.filter Jsx_common.hasAttr pval_attributes with + match List.filter Jsx_common.has_attr pval_attributes with | [] -> [item] | [_] -> - let pval_type = Jsx_common.extractUncurried pval_type in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + let pval_type = Jsx_common.extract_uncurried pval_type in + let rec get_prop_types types ({ptyp_loc; ptyp_desc} as full_type) = match ptyp_desc with | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) + when is_labelled name || is_optional name -> + get_prop_types ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> get_prop_types types rest + | Ptyp_arrow (name, type_, return_value) + when is_labelled name || is_optional name -> + (return_value, (name, return_value.ptyp_loc, type_) :: types) + | _ -> (full_type, types) + in + let inner_type, prop_types = get_prop_types [] pval_type in + let named_type_list = + List.fold_left arg_to_concrete_type [] prop_types in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = + let pluck_label_and_loc (label, loc, type_) = (label, None (* default *), loc, Some type_) in - let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in - let externalPropsDecl = - makePropsExternal fnName pstr_loc - ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) - :: List.map pluckLabelAndLoc propTypes) - retPropsType + let ret_props_type = make_props_type ~loc:pstr_loc named_type_list in + let external_props_decl = + make_props_external fn_name pstr_loc + ((optional "key", None, pstr_loc, Some (key_type pstr_loc)) + :: List.map pluck_label_and_loc prop_types) + ret_props_type in (* can't be an arrow because it will defensively uncurry *) - let newExternalType = + let new_external_type = Ptyp_constr ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) + [ret_props_type; inner_type] ) in - let newStructure = + let new_structure = { pstr with pstr_desc = Pstr_primitive { value_description with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; + pval_type = {pval_type with ptyp_desc = new_external_type}; + pval_attributes = List.filter other_attrs_pure pval_attributes; }; } in - [externalPropsDecl; newStructure] + [external_props_decl; new_structure] | _ -> - Jsx_common.raiseError ~loc:pstr_loc + Jsx_common.raise_error ~loc:pstr_loc "Only one react.component call can exist on a component at one time") (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let mapBinding binding = - if Jsx_common.hasAttrOnBinding binding then - let binding = Jsx_common.removeArity binding in - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in + | {pstr_loc; pstr_desc = Pstr_value (rec_flag, value_bindings)} -> ( + let file_name = filename_from_loc pstr_loc in + let empty_loc = Location.in_file file_name in + let map_binding binding = + if Jsx_common.has_attr_on_binding binding then + let binding = Jsx_common.remove_arity binding in + let binding_loc = binding.pvb_loc in + let binding_pat_loc = binding.pvb_pat.ppat_loc in let binding = { binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; + pvb_pat = {binding.pvb_pat with ppat_loc = empty_loc}; + pvb_loc = empty_loc; } in - let fnName = getFnName binding.pvb_pat in - let internalFnName = fnName ^ "$Internal" in - let fullModuleName = makeModuleName fileName !nestedModules fnName in - let modifiedBindingOld binding = + let fn_name = get_fn_name binding.pvb_pat in + let internal_fn_name = fn_name ^ "$Internal" in + let full_module_name = + make_module_name file_name !nested_modules fn_name + in + let modified_binding_old binding = let expression = binding.pvb_expr in (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = + let rec spelunk_for_fun_expression expression = match expression with (* let make = (~prop) => ... *) | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> expression (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (_recursive, _vbs, returnExpression)} -> + | {pexp_desc = Pexp_let (_recursive, _vbs, return_expression)} -> (* here's where we spelunk! *) - spelunkForFunExpression returnExpression + spelunk_for_fun_expression return_expression (* let make = React.forwardRef((~prop) => ...) *) | { pexp_desc = Pexp_apply - (_wrapperExpression, [(Nolabel, innerFunctionExpression)]); + (_wrapperExpression, [(Nolabel, inner_function_expression)]); } -> - spelunkForFunExpression innerFunctionExpression + spelunk_for_fun_expression inner_function_expression | { pexp_desc = - Pexp_sequence (_wrapperExpression, innerFunctionExpression); + Pexp_sequence (_wrapperExpression, inner_function_expression); } -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> - spelunkForFunExpression innerFunctionExpression + spelunk_for_fun_expression inner_function_expression + | {pexp_desc = Pexp_constraint (inner_function_expression, _typ)} + -> + spelunk_for_fun_expression inner_function_expression | {pexp_loc} -> - Jsx_common.raiseError ~loc:pexp_loc + Jsx_common.raise_error ~loc:pexp_loc "react.component calls can only be on function definitions \ or component wrappers (forwardRef, memo)." in - spelunkForFunExpression expression + spelunk_for_fun_expression expression in - let modifiedBinding binding = - let hasApplication = ref false in - let wrapExpressionWithBinding expressionFn expression = - Vb.mk ~loc:bindingLoc - ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) - (Pat.var ~loc:bindingPatLoc {loc = bindingPatLoc; txt = fnName}) - (expressionFn expression) + let modified_binding binding = + let has_application = ref false in + let wrap_expression_with_binding expression_fn expression = + Vb.mk ~loc:binding_loc + ~attrs:(List.filter other_attrs_pure binding.pvb_attributes) + (Pat.var ~loc:binding_pat_loc + {loc = binding_pat_loc; txt = fn_name}) + (expression_fn expression) in let expression = binding.pvb_expr in - let unerasableIgnoreExp exp = + let unerasable_ignore_exp exp = { exp with pexp_attributes = - unerasableIgnore emptyLoc :: exp.pexp_attributes; + unerasable_ignore empty_loc :: exp.pexp_attributes; } in (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = + let rec spelunk_for_fun_expression expression = match expression with (* let make = (~prop) => ... with no final unit *) | { @@ -721,14 +735,14 @@ let jsxMapper ~config = ( ((Labelled _ | Optional _) as label), default, pattern, - ({pexp_desc = Pexp_fun _} as internalExpression) ); + ({pexp_desc = Pexp_fun _} as internal_expression) ); } -> - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression + let wrap, has_unit, exp = + spelunk_for_fun_expression internal_expression in ( wrap, - hasUnit, - unerasableIgnoreExp + has_unit, + unerasable_ignore_exp { expression with pexp_desc = Pexp_fun (label, default, pattern, exp); @@ -756,14 +770,14 @@ let jsxMapper ~config = _pattern, _internalExpression ); } -> - ((fun a -> a), false, unerasableIgnoreExp expression) + ((fun a -> a), false, unerasable_ignore_exp expression) (* let make = (prop) => ... *) | { pexp_desc = Pexp_fun (_nolabel, _default, pattern, _internalExpression); } -> - if hasApplication.contents then - ((fun a -> a), false, unerasableIgnoreExp expression) + if has_application.contents then + ((fun a -> a), false, unerasable_ignore_exp expression) else Location.raise_errorf ~loc:pattern.ppat_loc "React: props need to be labelled arguments.\n\ @@ -772,357 +786,366 @@ let jsxMapper ~config = \ If your component doesn't have any props use () or _ \ instead of a name." (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> + | {pexp_desc = Pexp_let (recursive, vbs, internal_expression)} -> (* here's where we spelunk! *) - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression + let wrap, has_unit, exp = + spelunk_for_fun_expression internal_expression in ( wrap, - hasUnit, + has_unit, {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} ) (* let make = React.forwardRef((~prop) => ...) *) | { pexp_desc = - Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); + Pexp_apply + (wrapper_expression, [(Nolabel, internal_expression)]); } -> - let () = hasApplication := true in - let _, hasUnit, exp = - spelunkForFunExpression internalExpression + let () = has_application := true in + let _, has_unit, exp = + spelunk_for_fun_expression internal_expression in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasUnit, + ( (fun exp -> Exp.apply wrapper_expression [(nolabel, exp)]), + has_unit, exp ) | { - pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); + pexp_desc = + Pexp_sequence (wrapper_expression, internal_expression); } -> - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression + let wrap, has_unit, exp = + spelunk_for_fun_expression internal_expression in ( wrap, - hasUnit, + has_unit, { expression with - pexp_desc = Pexp_sequence (wrapperExpression, exp); + pexp_desc = Pexp_sequence (wrapper_expression, exp); } ) | e -> ((fun a -> a), false, e) in - let wrapExpression, hasUnit, expression = - spelunkForFunExpression expression + let wrap_expression, has_unit, expression = + spelunk_for_fun_expression expression in - (wrapExpressionWithBinding wrapExpression, hasUnit, expression) + (wrap_expression_with_binding wrap_expression, has_unit, expression) + in + let binding_wrapper, has_unit, expression = + modified_binding binding in - let bindingWrapper, hasUnit, expression = modifiedBinding binding in - let reactComponentAttribute = - try Some (List.find Jsx_common.hasAttr binding.pvb_attributes) + let react_component_attribute = + try Some (List.find Jsx_common.has_attr binding.pvb_attributes) with Not_found -> None in let _attr_loc, payload = - match reactComponentAttribute with + match react_component_attribute with | Some (loc, payload) -> (loc.loc, Some payload) - | None -> (emptyLoc, None) + | None -> (empty_loc, None) in - let props = getPropsAttr payload in + let props = get_props_attr payload in (* do stuff here! *) - let namedArgList, newtypes, forwardRef = - recursivelyTransformNamedArgsForMake - (modifiedBindingOld binding) + let named_arg_list, newtypes, forward_ref = + recursively_transform_named_args_for_make + (modified_binding_old binding) [] [] in - let namedArgListWithKeyAndRef = + let named_arg_list_with_key_and_ref = ( optional "key", None, - Pat.var {txt = "key"; loc = emptyLoc}, + Pat.var {txt = "key"; loc = empty_loc}, "key", - emptyLoc, - Some (keyType emptyLoc) ) - :: namedArgList + empty_loc, + Some (key_type empty_loc) ) + :: named_arg_list in - let namedArgListWithKeyAndRef = - match forwardRef with + let named_arg_list_with_key_and_ref = + match forward_ref with | Some _ -> ( optional "ref", None, - Pat.var {txt = "key"; loc = emptyLoc}, + Pat.var {txt = "key"; loc = empty_loc}, "ref", - emptyLoc, + empty_loc, None ) - :: namedArgListWithKeyAndRef - | None -> namedArgListWithKeyAndRef + :: named_arg_list_with_key_and_ref + | None -> named_arg_list_with_key_and_ref in - let namedArgListWithKeyAndRefForNew = - match forwardRef with + let named_arg_list_with_key_and_ref_for_new = + match forward_ref with | Some txt -> - namedArgList + named_arg_list @ [ ( nolabel, None, - Pat.var {txt; loc = emptyLoc}, + Pat.var {txt; loc = empty_loc}, txt, - emptyLoc, + empty_loc, None ); ] - | None -> namedArgList + | None -> named_arg_list in - let pluckArg (label, _, _, alias, loc, _) = - let labelString = + let pluck_arg (label, _, _, alias, loc, _) = + let label_string = match label with - | label when isOptional label || isLabelled label -> - getLabel label + | label when is_optional label || is_labelled label -> + get_label label | _ -> "" in ( label, - match labelString with + match label_string with | "" -> Exp.ident ~loc {txt = Lident alias; loc} - | labelString -> + | label_string -> Exp.apply ~loc (Exp.ident ~loc {txt = Lident "##"; loc}) [ - (nolabel, Exp.ident ~loc {txt = Lident props.propsName; loc}); - (nolabel, Exp.ident ~loc {txt = Lident labelString; loc}); + ( nolabel, + Exp.ident ~loc {txt = Lident props.props_name; loc} ); + (nolabel, Exp.ident ~loc {txt = Lident label_string; loc}); ] ) in - let namedTypeList = List.fold_left argToType [] namedArgList in - let loc = emptyLoc in - let externalArgs = + let named_type_list = List.fold_left arg_to_type [] named_arg_list in + let loc = empty_loc in + let external_args = (* translate newtypes to type variables *) List.fold_left (fun args newtype -> List.map - (fun (a, b, c, d, e, maybeTyp) -> - match maybeTyp with + (fun (a, b, c, d, e, maybe_typ) -> + match maybe_typ with | Some typ -> - (a, b, c, d, e, Some (newtypeToVar newtype.txt typ)) + (a, b, c, d, e, Some (newtype_to_var newtype.txt typ)) | None -> (a, b, c, d, e, None)) args) - namedArgListWithKeyAndRef newtypes + named_arg_list_with_key_and_ref newtypes in - let externalTypes = + let external_types = (* translate newtypes to type variables *) List.fold_left (fun args newtype -> List.map - (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) + (fun (a, b, typ) -> (a, b, newtype_to_var newtype.txt typ)) args) - namedTypeList newtypes + named_type_list newtypes in - let externalDecl = - makeExternalDecl fnName loc externalArgs externalTypes + let external_decl = + make_external_decl fn_name loc external_args external_types in - let innerExpressionArgs = - List.map pluckArg namedArgListWithKeyAndRefForNew + let inner_expression_args = + List.map pluck_arg named_arg_list_with_key_and_ref_for_new @ - if hasUnit then + if has_unit then [(Nolabel, Exp.construct {loc; txt = Lident "()"} None)] else [] in - let innerExpression = + let inner_expression = Exp.apply (Exp.ident { loc; txt = Lident - (match recFlag with - | Recursive -> internalFnName - | Nonrecursive -> fnName); + (match rec_flag with + | Recursive -> internal_fn_name + | Nonrecursive -> fn_name); }) - innerExpressionArgs + inner_expression_args in - let innerExpressionWithRef = - match forwardRef with + let inner_expression_with_ref = + match forward_ref with | Some txt -> { - innerExpression with + inner_expression with pexp_desc = Pexp_fun ( nolabel, None, { - ppat_desc = Ppat_var {txt; loc = emptyLoc}; - ppat_loc = emptyLoc; + ppat_desc = Ppat_var {txt; loc = empty_loc}; + ppat_loc = empty_loc; ppat_attributes = []; }, - innerExpression ); + inner_expression ); } - | None -> innerExpression + | None -> inner_expression in - let fullExpression = + let full_expression = Exp.fun_ nolabel None { ppat_desc = Ppat_constraint - ( makePropsName ~loc:emptyLoc props.propsName, - makePropsType ~loc:emptyLoc externalTypes ); - ppat_loc = emptyLoc; + ( make_props_name ~loc:empty_loc props.props_name, + make_props_type ~loc:empty_loc external_types ); + ppat_loc = empty_loc; ppat_attributes = []; } - innerExpressionWithRef + inner_expression_with_ref in - let fullExpression = + let full_expression = if !Config.uncurried = Uncurried then - fullExpression - |> Ast_uncurried.uncurriedFun ~loc:fullExpression.pexp_loc + full_expression + |> Ast_uncurried.uncurried_fun ~loc:full_expression.pexp_loc ~arity:1 - else fullExpression + else full_expression in - let fullExpression = - match fullModuleName with - | "" -> fullExpression + let full_expression = + match full_module_name with + | "" -> full_expression | txt -> Exp.let_ Nonrecursive [ - Vb.mk ~loc:emptyLoc - (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt}) - fullExpression; + Vb.mk ~loc:empty_loc + (Pat.var ~loc:empty_loc {loc = empty_loc; txt}) + full_expression; ] - (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt}) + (Exp.ident ~loc:empty_loc {loc = empty_loc; txt = Lident txt}) in - let bindings, newBinding = - match recFlag with + let bindings, new_binding = + match rec_flag with | Recursive -> ( [ - bindingWrapper - (Exp.let_ ~loc:emptyLoc Recursive + binding_wrapper + (Exp.let_ ~loc:empty_loc Recursive [ - makeNewBinding binding expression internalFnName; + make_new_binding binding expression internal_fn_name; Vb.mk - (Pat.var {loc = emptyLoc; txt = fnName}) - fullExpression; + (Pat.var {loc = empty_loc; txt = fn_name}) + full_expression; ] - (Exp.ident {loc = emptyLoc; txt = Lident fnName})); + (Exp.ident {loc = empty_loc; txt = Lident fn_name})); ], None ) | Nonrecursive -> ( [{binding with pvb_expr = expression}], - Some (bindingWrapper fullExpression) ) + Some (binding_wrapper full_expression) ) in - (Some externalDecl, bindings, newBinding) + (Some external_decl, bindings, new_binding) else (None, [binding], None) in - let structuresAndBinding = List.map mapBinding valueBindings in - let otherStructures (extern, binding, newBinding) - (externs, bindings, newBindings) = + let structures_and_binding = List.map map_binding value_bindings in + let other_structures (extern, binding, new_binding) + (externs, bindings, new_bindings) = let externs = match extern with | Some extern -> extern :: externs | None -> externs in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings + let new_bindings = + match new_binding with + | Some new_binding -> new_binding :: new_bindings + | None -> new_bindings in - (externs, binding @ bindings, newBindings) + (externs, binding @ bindings, new_bindings) in - let externs, bindings, newBindings = - List.fold_right otherStructures structuresAndBinding ([], [], []) + let externs, bindings, new_bindings = + List.fold_right other_structures structures_and_binding ([], [], []) in externs - @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] + @ [{pstr_loc; pstr_desc = Pstr_value (rec_flag, bindings)}] @ - match newBindings with + match new_bindings with | [] -> [] - | newBindings -> - [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) + | new_bindings -> + [ + {pstr_loc = empty_loc; pstr_desc = Pstr_value (rec_flag, new_bindings)}; + ]) | _ -> [item] in - let transformSignatureItem item = + let transform_signature_item item = match item with | { psig_loc; psig_desc = Psig_value - ({pval_name = {txt = fnName}; pval_attributes; pval_type} as + ({pval_name = {txt = fn_name}; pval_attributes; pval_type} as psig_desc); } as psig -> ( - match List.filter Jsx_common.hasAttr pval_attributes with + match List.filter Jsx_common.has_attr pval_attributes with | [] -> [item] | [_] -> - let pval_type = Jsx_common.extractUncurried pval_type in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = + let pval_type = Jsx_common.extract_uncurried pval_type in + let rec get_prop_types types ({ptyp_loc; ptyp_desc} as full_type) = match ptyp_desc with | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isOptional name || isLabelled name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) + when is_optional name || is_labelled name -> + get_prop_types ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> get_prop_types types rest + | Ptyp_arrow (name, type_, return_value) + when is_optional name || is_labelled name -> + (return_value, (name, return_value.ptyp_loc, type_) :: types) + | _ -> (full_type, types) + in + let inner_type, prop_types = get_prop_types [] pval_type in + let named_type_list = + List.fold_left arg_to_concrete_type [] prop_types in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = + let pluck_label_and_loc (label, loc, type_) = (label, None, loc, Some type_) in - let retPropsType = makePropsType ~loc:psig_loc namedTypeList in - let externalPropsDecl = - makePropsExternalSig fnName psig_loc - ((optional "key", None, psig_loc, Some (keyType psig_loc)) - :: List.map pluckLabelAndLoc propTypes) - retPropsType + let ret_props_type = make_props_type ~loc:psig_loc named_type_list in + let external_props_decl = + make_props_external_sig fn_name psig_loc + ((optional "key", None, psig_loc, Some (key_type psig_loc)) + :: List.map pluck_label_and_loc prop_types) + ret_props_type in (* can't be an arrow because it will defensively uncurry *) - let newExternalType = + let new_external_type = Ptyp_constr ( {loc = psig_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) + [ret_props_type; inner_type] ) in - let newStructure = + let new_structure = { psig with psig_desc = Psig_value { psig_desc with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; + pval_type = {pval_type with ptyp_desc = new_external_type}; + pval_attributes = List.filter other_attrs_pure pval_attributes; }; } in - [externalPropsDecl; newStructure] + [external_props_decl; new_structure] | _ -> - Jsx_common.raiseError ~loc:psig_loc + Jsx_common.raise_error ~loc:psig_loc "Only one react.component call can exist on a component at one time") | _ -> [item] in - let transformJsxCall mapper callExpression callArguments attrs = - match callExpression.pexp_desc with + let transform_jsx_call mapper call_expression call_arguments attrs = + match call_expression.pexp_desc with | Pexp_ident caller -> ( match caller with | {txt = Lident "createElement"; loc} -> - Jsx_common.raiseError ~loc + Jsx_common.raise_error ~loc "JSX: `createElement` should be preceeded by a module name." (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> ( + | {loc; txt = Ldot (module_path, ("createElement" | "make"))} -> ( match config.Jsx_common.version with | 3 -> - transformUppercaseCall3 modulePath mapper loc attrs callExpression - callArguments - | _ -> Jsx_common.raiseError ~loc "JSX: the JSX version must be 3") + transform_uppercase_call3 module_path mapper loc attrs call_expression + call_arguments + | _ -> Jsx_common.raise_error ~loc "JSX: the JSX version must be 3") (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) (* turn that into ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) | {loc; txt = Lident id} -> ( match config.version with - | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id - | _ -> Jsx_common.raiseError ~loc "JSX: the JSX version must be 3") - | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - Jsx_common.raiseError ~loc + | 3 -> transform_lowercase_call3 mapper loc attrs call_arguments id + | _ -> Jsx_common.raise_error ~loc "JSX: the JSX version must be 3") + | {txt = Ldot (_, anything_not_create_element_or_make); loc} -> + Jsx_common.raise_error ~loc "JSX: the JSX attribute should be attached to a \ `YourModuleName.createElement` or `YourModuleName.make` call. We \ saw `%s` instead" - anythingNotCreateElementOrMake + anything_not_create_element_or_make | {txt = Lapply _; loc} -> (* don't think there's ever a case where this is reached *) - Jsx_common.raiseError ~loc + Jsx_common.raise_error ~loc "JSX: encountered a weird case while processing the code. Please \ report this!") | _ -> - Jsx_common.raiseError ~loc:callExpression.pexp_loc + Jsx_common.raise_error ~loc:call_expression.pexp_loc "JSX: `createElement` should be preceeded by a simple, direct module \ name." in @@ -1130,18 +1153,21 @@ let jsxMapper ~config = let expr mapper expression = match expression with (* Does the function application have the @JSX attribute? *) - | {pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes} - -> ( - let jsxAttribute, nonJSXAttributes = + | { + pexp_desc = Pexp_apply (call_expression, call_arguments); + pexp_attributes; + } -> ( + let jsx_attribute, non_jsx_attributes = List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes in - match (jsxAttribute, nonJSXAttributes) with + match (jsx_attribute, non_jsx_attributes) with (* no JSX attribute *) | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - transformJsxCall mapper callExpression callArguments nonJSXAttributes) + | _, non_jsx_attributes -> + transform_jsx_call mapper call_expression call_arguments + non_jsx_attributes) (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) | { pexp_desc = @@ -1149,32 +1175,34 @@ let jsxMapper ~config = ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) | Pexp_construct ({txt = Lident "[]"; loc}, None) ); pexp_attributes; - } as listItems -> ( - let jsxAttribute, nonJSXAttributes = + } as list_items -> ( + let jsx_attribute, non_jsx_attributes = List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes in - match (jsxAttribute, nonJSXAttributes) with + match (jsx_attribute, non_jsx_attributes) with (* no JSX attribute *) | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> + | _, non_jsx_attributes -> let loc = {loc with loc_ghost = true} in let fragment = Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")} in - let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in + let children_expr = + transform_children_if_list ~loc ~mapper list_items + in let args = [ (* "div" *) (nolabel, fragment); (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); + (nolabel, children_expr); ] in Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs:nonJSXAttributes + ~attrs:non_jsx_attributes (* ReactDOMRe.createElement *) (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "createElement")}) @@ -1184,13 +1212,13 @@ let jsxMapper ~config = in let module_binding mapper module_binding = - let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in + let _ = nested_modules := module_binding.pmb_name.txt :: !nested_modules in let mapped = default_mapper.module_binding mapper module_binding in let () = - match !nestedModules with - | _ :: rest -> nestedModules := rest + match !nested_modules with + | _ :: rest -> nested_modules := rest | [] -> () in mapped in - (expr, module_binding, transformSignatureItem, transformStructureItem) + (expr, module_binding, transform_signature_item, transform_structure_item) diff --git a/analysis/vendor/res_syntax/res_ast_conversion.ml b/analysis/vendor/res_syntax/res_ast_conversion.ml index b8c419b80..910d7e731 100644 --- a/analysis/vendor/res_syntax/res_ast_conversion.ml +++ b/analysis/vendor/res_syntax/res_ast_conversion.ml @@ -1,4 +1,4 @@ -let concatLongidents l1 l2 = +let concat_longidents l1 l2 = let parts1 = Longident.flatten l1 in let parts2 = Longident.flatten l2 in match List.concat [parts1; parts2] |> Longident.unflatten with @@ -6,78 +6,85 @@ let concatLongidents l1 l2 = | None -> l2 (* TODO: support nested open's ? *) -let rec rewritePpatOpen longidentOpen pat = +let rec rewrite_ppat_open longident_open pat = match pat.Parsetree.ppat_desc with | Ppat_array (first :: rest) -> (* Color.[Red, Blue, Green] -> [Color.Red, Blue, Green] *) { pat with - ppat_desc = Ppat_array (rewritePpatOpen longidentOpen first :: rest); + ppat_desc = Ppat_array (rewrite_ppat_open longident_open first :: rest); } | Ppat_tuple (first :: rest) -> (* Color.(Red, Blue, Green) -> (Color.Red, Blue, Green) *) { pat with - ppat_desc = Ppat_tuple (rewritePpatOpen longidentOpen first :: rest); + ppat_desc = Ppat_tuple (rewrite_ppat_open longident_open first :: rest); } | Ppat_construct - ( ({txt = Longident.Lident "::"} as listConstructor), + ( ({txt = Longident.Lident "::"} as list_constructor), Some ({ppat_desc = Ppat_tuple (pat :: rest)} as element) ) -> (* Color.(list[Red, Blue, Green]) -> list[Color.Red, Blue, Green] *) { pat with ppat_desc = Ppat_construct - ( listConstructor, + ( list_constructor, Some { element with ppat_desc = - Ppat_tuple (rewritePpatOpen longidentOpen pat :: rest); + Ppat_tuple (rewrite_ppat_open longident_open pat :: rest); } ); } - | Ppat_construct (({txt = constructor} as longidentLoc), optPattern) -> + | Ppat_construct (({txt = constructor} as longident_loc), opt_pattern) -> (* Foo.(Bar(a)) -> Foo.Bar(a) *) { pat with ppat_desc = Ppat_construct - ( {longidentLoc with txt = concatLongidents longidentOpen constructor}, - optPattern ); + ( { + longident_loc with + txt = concat_longidents longident_open constructor; + }, + opt_pattern ); } - | Ppat_record ((({txt = lbl} as longidentLoc), firstPat) :: rest, flag) -> + | Ppat_record ((({txt = lbl} as longident_loc), first_pat) :: rest, flag) -> (* Foo.{x} -> {Foo.x: x} *) - let firstRow = - ({longidentLoc with txt = concatLongidents longidentOpen lbl}, firstPat) + let first_row = + ( {longident_loc with txt = concat_longidents longident_open lbl}, + first_pat ) in - {pat with ppat_desc = Ppat_record (firstRow :: rest, flag)} + {pat with ppat_desc = Ppat_record (first_row :: rest, flag)} | Ppat_or (pat1, pat2) -> { pat with ppat_desc = Ppat_or - ( rewritePpatOpen longidentOpen pat1, - rewritePpatOpen longidentOpen pat2 ); + ( rewrite_ppat_open longident_open pat1, + rewrite_ppat_open longident_open pat2 ); } | Ppat_constraint (pattern, typ) -> { pat with - ppat_desc = Ppat_constraint (rewritePpatOpen longidentOpen pattern, typ); + ppat_desc = Ppat_constraint (rewrite_ppat_open longident_open pattern, typ); } - | Ppat_type ({txt = constructor} as longidentLoc) -> + | Ppat_type ({txt = constructor} as longident_loc) -> { pat with ppat_desc = Ppat_type - {longidentLoc with txt = concatLongidents longidentOpen constructor}; + { + longident_loc with + txt = concat_longidents longident_open constructor; + }; } | Ppat_lazy p -> - {pat with ppat_desc = Ppat_lazy (rewritePpatOpen longidentOpen p)} + {pat with ppat_desc = Ppat_lazy (rewrite_ppat_open longident_open p)} | Ppat_exception p -> - {pat with ppat_desc = Ppat_exception (rewritePpatOpen longidentOpen p)} + {pat with ppat_desc = Ppat_exception (rewrite_ppat_open longident_open p)} | _ -> pat -let escapeTemplateLiteral s = +let escape_template_literal s = let len = String.length s in let b = Buffer.create len in let i = ref 0 in @@ -111,7 +118,7 @@ let escapeTemplateLiteral s = done; Buffer.contents b -let escapeStringContents s = +let escape_string_contents s = let len = String.length s in let b = Buffer.create len in @@ -137,64 +144,65 @@ let escapeStringContents s = done; Buffer.contents b -let looksLikeRecursiveTypeDeclaration typeDeclaration = +let looks_like_recursive_type_declaration type_declaration = let open Parsetree in - let name = typeDeclaration.ptype_name.txt in - let rec checkKind kind = + let name = type_declaration.ptype_name.txt in + let rec check_kind kind = match kind with | Ptype_abstract | Ptype_open -> false - | Ptype_variant constructorDeclarations -> - List.exists checkConstructorDeclaration constructorDeclarations - | Ptype_record labelDeclarations -> - List.exists checkLabelDeclaration labelDeclarations - and checkConstructorDeclaration constrDecl = - checkConstructorArguments constrDecl.pcd_args + | Ptype_variant constructor_declarations -> + List.exists check_constructor_declaration constructor_declarations + | Ptype_record label_declarations -> + List.exists check_label_declaration label_declarations + and check_constructor_declaration constr_decl = + check_constructor_arguments constr_decl.pcd_args || - match constrDecl.pcd_res with - | Some typexpr -> checkTypExpr typexpr + match constr_decl.pcd_res with + | Some typexpr -> check_typ_expr typexpr | None -> false - and checkLabelDeclaration labelDeclaration = - checkTypExpr labelDeclaration.pld_type - and checkConstructorArguments constrArg = - match constrArg with - | Pcstr_tuple types -> List.exists checkTypExpr types - | Pcstr_record labelDeclarations -> - List.exists checkLabelDeclaration labelDeclarations - and checkTypExpr typ = + and check_label_declaration label_declaration = + check_typ_expr label_declaration.pld_type + and check_constructor_arguments constr_arg = + match constr_arg with + | Pcstr_tuple types -> List.exists check_typ_expr types + | Pcstr_record label_declarations -> + List.exists check_label_declaration label_declarations + and check_typ_expr typ = match typ.ptyp_desc with | Ptyp_any -> false | Ptyp_var _ -> false - | Ptyp_object (fields, _) -> List.exists checkObjectField fields + | Ptyp_object (fields, _) -> List.exists check_object_field fields | Ptyp_class _ -> false | Ptyp_package _ -> false | Ptyp_extension _ -> false - | Ptyp_arrow (_lbl, typ1, typ2) -> checkTypExpr typ1 || checkTypExpr typ2 - | Ptyp_tuple types -> List.exists checkTypExpr types + | Ptyp_arrow (_lbl, typ1, typ2) -> + check_typ_expr typ1 || check_typ_expr typ2 + | Ptyp_tuple types -> List.exists check_typ_expr types | Ptyp_constr ({txt = longident}, types) -> (match longident with | Lident ident -> ident = name | _ -> false) - || List.exists checkTypExpr types - | Ptyp_alias (typ, _) -> checkTypExpr typ - | Ptyp_variant (rowFields, _, _) -> List.exists checkRowFields rowFields - | Ptyp_poly (_, typ) -> checkTypExpr typ - and checkObjectField field = + || List.exists check_typ_expr types + | Ptyp_alias (typ, _) -> check_typ_expr typ + | Ptyp_variant (row_fields, _, _) -> List.exists check_row_fields row_fields + | Ptyp_poly (_, typ) -> check_typ_expr typ + and check_object_field field = match field with - | Otag (_label, _attrs, typ) -> checkTypExpr typ - | Oinherit typ -> checkTypExpr typ - and checkRowFields rowField = - match rowField with - | Rtag (_, _, _, types) -> List.exists checkTypExpr types - | Rinherit typexpr -> checkTypExpr typexpr - and checkManifest manifest = + | Otag (_label, _attrs, typ) -> check_typ_expr typ + | Oinherit typ -> check_typ_expr typ + and check_row_fields row_field = + match row_field with + | Rtag (_, _, _, types) -> List.exists check_typ_expr types + | Rinherit typexpr -> check_typ_expr typexpr + and check_manifest manifest = match manifest with - | Some typ -> checkTypExpr typ + | Some typ -> check_typ_expr typ | None -> false in - checkKind typeDeclaration.ptype_kind - || checkManifest typeDeclaration.ptype_manifest + check_kind type_declaration.ptype_kind + || check_manifest type_declaration.ptype_manifest -let filterReasonRawLiteral attrs = +let filter_reason_raw_literal attrs = List.filter (fun attr -> match attr with @@ -202,12 +210,12 @@ let filterReasonRawLiteral attrs = | _ -> true) attrs -let stringLiteralMapper stringData = - let isSameLocation l1 l2 = +let string_literal_mapper string_data = + let is_same_location l1 l2 = let open Location in l1.loc_start.pos_cnum == l2.loc_start.pos_cnum in - let remainingStringData = stringData in + let remaining_string_data = string_data in let open Ast_mapper in { default_mapper with @@ -217,12 +225,12 @@ let stringLiteralMapper stringData = | Pexp_constant (Pconst_string (_txt, None)) -> ( match List.find_opt - (fun (_stringData, stringLoc) -> - isSameLocation stringLoc expr.pexp_loc) - remainingStringData + (fun (_stringData, string_loc) -> + is_same_location string_loc expr.pexp_loc) + remaining_string_data with - | Some (stringData, _) -> - let stringData = + | Some (string_data, _) -> + let string_data = let attr = List.find_opt (fun attr -> @@ -248,19 +256,19 @@ let stringLiteralMapper stringData = ] ) -> raw | _ -> - (String.sub [@doesNotRaise]) stringData 1 - (String.length stringData - 2) + (String.sub [@doesNotRaise]) string_data 1 + (String.length string_data - 2) in { expr with - pexp_attributes = filterReasonRawLiteral expr.pexp_attributes; - pexp_desc = Pexp_constant (Pconst_string (stringData, None)); + pexp_attributes = filter_reason_raw_literal expr.pexp_attributes; + pexp_desc = Pexp_constant (Pconst_string (string_data, None)); } | None -> default_mapper.expr mapper expr) | _ -> default_mapper.expr mapper expr); } -let hasUncurriedAttribute attrs = +let has_uncurried_attribute attrs = List.exists (fun attr -> match attr with @@ -268,24 +276,12 @@ let hasUncurriedAttribute attrs = | _ -> false) attrs -let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) +let template_literal_attr = (Location.mknoloc "res.template", Parsetree.PStr []) let normalize = let open Ast_mapper in { default_mapper with - extension = - (fun mapper ext -> - match ext with - | id, payload -> - ( {id with txt = Res_printer.convertBsExtension id.txt}, - default_mapper.payload mapper payload )); - attribute = - (fun mapper attr -> - match attr with - | id, payload -> - ( {id with txt = Res_printer.convertBsExternalAttribute id.txt}, - default_mapper.payload mapper payload )); attributes = (fun mapper attrs -> attrs @@ -303,21 +299,24 @@ let normalize = pat = (fun mapper p -> match p.ppat_desc with - | Ppat_open ({txt = longidentOpen}, pattern) -> - let p = rewritePpatOpen longidentOpen pattern in + | Ppat_open ({txt = longident_open}, pattern) -> + let p = rewrite_ppat_open longident_open pattern in default_mapper.pat mapper p | Ppat_constant (Pconst_string (txt, tag)) -> - let newTag = + let new_tag = match tag with (* transform {|abc|} into {js|abc|js}, because `template string` is interpreted as {js||js} *) | Some "" -> Some "js" | tag -> tag in - let s = Parsetree.Pconst_string (escapeTemplateLiteral txt, newTag) in + let s = + Parsetree.Pconst_string (escape_template_literal txt, new_tag) + in { p with ppat_attributes = - templateLiteralAttr :: mapper.attributes mapper p.ppat_attributes; + template_literal_attr + :: mapper.attributes mapper p.ppat_attributes; ppat_desc = Ppat_constant s; } | _ -> default_mapper.pat mapper p); @@ -334,46 +333,48 @@ let normalize = (fun mapper expr -> match expr.pexp_desc with | Pexp_constant (Pconst_string (txt, None)) -> - let raw = escapeStringContents txt in + let raw = escape_string_contents txt in let s = Parsetree.Pconst_string (raw, None) in {expr with pexp_desc = Pexp_constant s} | Pexp_constant (Pconst_string (txt, tag)) -> - let newTag = + let new_tag = match tag with (* transform {|abc|} into {js|abc|js}, we want to preserve unicode by default *) | Some "" -> Some "js" | tag -> tag in - let s = Parsetree.Pconst_string (escapeTemplateLiteral txt, newTag) in + let s = + Parsetree.Pconst_string (escape_template_literal txt, new_tag) + in { expr with pexp_attributes = - templateLiteralAttr + template_literal_attr :: mapper.attributes mapper expr.pexp_attributes; pexp_desc = Pexp_constant s; } | Pexp_apply - ( callExpr, + ( call_expr, [ ( Nolabel, ({ pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None); pexp_attributes = []; - } as unitExpr) ); + } as unit_expr) ); ] ) - when hasUncurriedAttribute expr.pexp_attributes -> + when has_uncurried_attribute expr.pexp_attributes -> { expr with pexp_attributes = mapper.attributes mapper expr.pexp_attributes; pexp_desc = Pexp_apply - ( callExpr, + ( call_expr, [ ( Nolabel, { - unitExpr with - pexp_loc = {unitExpr.pexp_loc with loc_ghost = true}; + unit_expr with + pexp_loc = {unit_expr.pexp_loc with loc_ghost = true}; } ); ] ); } @@ -438,10 +439,10 @@ let normalize = pexp_desc = ( Pexp_constant (Pconst_string (txt, None)) | Pexp_ident {txt = Longident.Lident txt} ); - pexp_loc = labelLoc; + pexp_loc = label_loc; } ); ] ) -> - let label = Location.mkloc txt labelLoc in + let label = Location.mkloc txt label_loc in { pexp_loc = expr.pexp_loc; pexp_attributes = expr.pexp_attributes; @@ -456,7 +457,7 @@ let normalize = ppat_desc = Ppat_construct ({txt = Longident.Lident "true"}, None); }; - pc_rhs = thenExpr; + pc_rhs = then_expr; }; { pc_lhs = @@ -464,10 +465,10 @@ let normalize = ppat_desc = Ppat_construct ({txt = Longident.Lident "false"}, None); }; - pc_rhs = elseExpr; + pc_rhs = else_expr; }; ] ) -> - let ternaryMarker = + let ternary_marker = (Location.mknoloc "res.ternary", Parsetree.PStr []) in { @@ -475,57 +476,59 @@ let normalize = pexp_desc = Pexp_ifthenelse ( mapper.expr mapper condition, - mapper.expr mapper thenExpr, - Some (mapper.expr mapper elseExpr) ); - pexp_attributes = ternaryMarker :: expr.pexp_attributes; + mapper.expr mapper then_expr, + Some (mapper.expr mapper else_expr) ); + pexp_attributes = ternary_marker :: expr.pexp_attributes; } | _ -> default_mapper.expr mapper expr); structure_item = - (fun mapper structureItem -> - match structureItem.pstr_desc with + (fun mapper structure_item -> + match structure_item.pstr_desc with (* heuristic: if we have multiple type declarations, mark them recursive *) - | Pstr_type ((Recursive as recFlag), typeDeclarations) -> + | Pstr_type ((Recursive as rec_flag), type_declarations) -> let flag = - match typeDeclarations with + match type_declarations with | [td] -> - if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive + if looks_like_recursive_type_declaration td then + Asttypes.Recursive else Asttypes.Nonrecursive - | _ -> recFlag + | _ -> rec_flag in { - structureItem with + structure_item with pstr_desc = Pstr_type ( flag, List.map - (fun typeDeclaration -> - default_mapper.type_declaration mapper typeDeclaration) - typeDeclarations ); + (fun type_declaration -> + default_mapper.type_declaration mapper type_declaration) + type_declarations ); } - | _ -> default_mapper.structure_item mapper structureItem); + | _ -> default_mapper.structure_item mapper structure_item); signature_item = - (fun mapper signatureItem -> - match signatureItem.psig_desc with + (fun mapper signature_item -> + match signature_item.psig_desc with (* heuristic: if we have multiple type declarations, mark them recursive *) - | Psig_type ((Recursive as recFlag), typeDeclarations) -> + | Psig_type ((Recursive as rec_flag), type_declarations) -> let flag = - match typeDeclarations with + match type_declarations with | [td] -> - if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive + if looks_like_recursive_type_declaration td then + Asttypes.Recursive else Asttypes.Nonrecursive - | _ -> recFlag + | _ -> rec_flag in { - signatureItem with + signature_item with psig_desc = Psig_type ( flag, List.map - (fun typeDeclaration -> - default_mapper.type_declaration mapper typeDeclaration) - typeDeclarations ); + (fun type_declaration -> + default_mapper.type_declaration mapper type_declaration) + type_declarations ); } - | _ -> default_mapper.signature_item mapper signatureItem); + | _ -> default_mapper.signature_item mapper signature_item); value_binding = (fun mapper vb -> match vb with @@ -539,7 +542,7 @@ let normalize = let typ = default_mapper.typ mapper typ in let pat = default_mapper.pat mapper pat in let expr = mapper.expr mapper expr in - let newPattern = + let new_pattern = { Parsetree.ppat_loc = {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; @@ -549,7 +552,7 @@ let normalize = in { vb with - pvb_pat = newPattern; + pvb_pat = new_pattern; pvb_expr = expr; pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes; } @@ -564,7 +567,7 @@ let normalize = let typ = default_mapper.typ mapper typ in let pat = default_mapper.pat mapper pat in let expr = mapper.expr mapper expr in - let newPattern = + let new_pattern = { Parsetree.ppat_loc = {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; @@ -574,7 +577,7 @@ let normalize = in { vb with - pvb_pat = newPattern; + pvb_pat = new_pattern; pvb_expr = expr; pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes; } @@ -584,10 +587,10 @@ let normalize = let structure s = normalize.Ast_mapper.structure normalize s let signature s = normalize.Ast_mapper.signature normalize s -let replaceStringLiteralStructure stringData structure = - let mapper = stringLiteralMapper stringData in +let replace_string_literal_structure string_data structure = + let mapper = string_literal_mapper string_data in mapper.Ast_mapper.structure mapper structure -let replaceStringLiteralSignature stringData signature = - let mapper = stringLiteralMapper stringData in +let replace_string_literal_signature string_data signature = + let mapper = string_literal_mapper string_data in mapper.Ast_mapper.signature mapper signature diff --git a/analysis/vendor/res_syntax/res_ast_conversion.mli b/analysis/vendor/res_syntax/res_ast_conversion.mli index 32163e8ce..745b7cc84 100644 --- a/analysis/vendor/res_syntax/res_ast_conversion.mli +++ b/analysis/vendor/res_syntax/res_ast_conversion.mli @@ -7,9 +7,9 @@ * The purpose of this routine is to place the original string back in * the parsetree for printing purposes. Unicode and escape sequences * shouldn't be mangled when *) -val replaceStringLiteralStructure : +val replace_string_literal_structure : (string * Location.t) list -> Parsetree.structure -> Parsetree.structure -val replaceStringLiteralSignature : +val replace_string_literal_signature : (string * Location.t) list -> Parsetree.signature -> Parsetree.signature (* transform parts of the parsetree into a suitable parsetree suitable diff --git a/analysis/vendor/res_syntax/res_ast_debugger.ml b/analysis/vendor/res_syntax/res_ast_debugger.ml index 150ff78e3..569026d62 100644 --- a/analysis/vendor/res_syntax/res_ast_debugger.ml +++ b/analysis/vendor/res_syntax/res_ast_debugger.ml @@ -1,13 +1,13 @@ module Doc = Res_doc module CommentTable = Res_comments_table -let printEngine = +let print_engine = Res_driver. { - printImplementation = + print_implementation = (fun ~width:_ ~filename:_ ~comments:_ structure -> Printast.implementation Format.std_formatter structure); - printInterface = + print_interface = (fun ~width:_ ~filename:_ ~comments:_ signature -> Printast.interface Format.std_formatter signature); } @@ -17,48 +17,49 @@ module Sexp : sig val atom : string -> t val list : t list -> t - val toString : t -> string + val to_string : t -> string end = struct type t = Atom of string | List of t list let atom s = Atom s let list l = List l - let rec toDoc t = + let rec to_doc t = match t with | Atom s -> Doc.text s | List [] -> Doc.text "()" - | List [sexpr] -> Doc.concat [Doc.lparen; toDoc sexpr; Doc.rparen] + | List [sexpr] -> Doc.concat [Doc.lparen; to_doc sexpr; Doc.rparen] | List (hd :: tail) -> Doc.group (Doc.concat [ Doc.lparen; - toDoc hd; + to_doc hd; Doc.indent (Doc.concat - [Doc.line; Doc.join ~sep:Doc.line (List.map toDoc tail)]); + [Doc.line; Doc.join ~sep:Doc.line (List.map to_doc tail)]); Doc.rparen; ]) - let toString sexpr = - let doc = toDoc sexpr in - Doc.toString ~width:80 doc + let to_string sexpr = + let doc = to_doc sexpr in + Doc.to_string ~width:80 doc end module SexpAst = struct open Parsetree - let mapEmpty ~f items = + let map_empty ~f items = match items with | [] -> [Sexp.list []] | items -> List.map f items - let string txt = Sexp.atom ("\"" ^ txt ^ "\"") + let string txt = + Sexp.atom ("\"" ^ Ext_ident.unwrap_uppercase_exotic txt ^ "\"") let char c = Sexp.atom ("'" ^ Char.escaped c ^ "'") - let optChar oc = + let opt_char oc = match oc with | None -> Sexp.atom "None" | Some c -> Sexp.list [Sexp.atom "Some"; char c] @@ -74,32 +75,32 @@ module SexpAst = struct in Sexp.list [Sexp.atom "longident"; loop l] - let closedFlag flag = + let closed_flag flag = match flag with | Asttypes.Closed -> Sexp.atom "Closed" | Open -> Sexp.atom "Open" - let directionFlag flag = + let direction_flag flag = match flag with | Asttypes.Upto -> Sexp.atom "Upto" | Downto -> Sexp.atom "Downto" - let recFlag flag = + let rec_flag flag = match flag with | Asttypes.Recursive -> Sexp.atom "Recursive" | Nonrecursive -> Sexp.atom "Nonrecursive" - let overrideFlag flag = + let override_flag flag = match flag with | Asttypes.Override -> Sexp.atom "Override" | Fresh -> Sexp.atom "Fresh" - let privateFlag flag = + let private_flag flag = match flag with | Asttypes.Public -> Sexp.atom "Public" | Private -> Sexp.atom "Private" - let mutableFlag flag = + let mutable_flag flag = match flag with | Asttypes.Immutable -> Sexp.atom "Immutable" | Mutable -> Sexp.atom "Mutable" @@ -110,7 +111,7 @@ module SexpAst = struct | Contravariant -> Sexp.atom "Contravariant" | Invariant -> Sexp.atom "Invariant" - let argLabel lbl = + let arg_label lbl = match lbl with | Asttypes.Nolabel -> Sexp.atom "Nolabel" | Labelled txt -> Sexp.list [Sexp.atom "Labelled"; string txt] @@ -120,7 +121,7 @@ module SexpAst = struct let sexpr = match c with | Pconst_integer (txt, tag) -> - Sexp.list [Sexp.atom "Pconst_integer"; string txt; optChar tag] + Sexp.list [Sexp.atom "Pconst_integer"; string txt; opt_char tag] | Pconst_char _ -> Sexp.list [Sexp.atom "Pconst_char"] | Pconst_string (_, Some "INTERNAL_RES_CHAR_CONTENTS") -> Sexp.list [Sexp.atom "Pconst_char"] @@ -134,14 +135,14 @@ module SexpAst = struct | None -> Sexp.atom "None"); ] | Pconst_float (txt, tag) -> - Sexp.list [Sexp.atom "Pconst_float"; string txt; optChar tag] + Sexp.list [Sexp.atom "Pconst_float"; string txt; opt_char tag] in Sexp.list [Sexp.atom "constant"; sexpr] let rec structure s = - Sexp.list (Sexp.atom "structure" :: List.map structureItem s) + Sexp.list (Sexp.atom "structure" :: List.map structure_item s) - and structureItem si = + and structure_item si = let desc = match si.pstr_desc with | Pstr_eval (expr, attrs) -> @@ -150,36 +151,38 @@ module SexpAst = struct Sexp.list [ Sexp.atom "Pstr_value"; - recFlag flag; - Sexp.list (mapEmpty ~f:valueBinding vbs); + rec_flag flag; + Sexp.list (map_empty ~f:value_binding vbs); ] | Pstr_primitive vd -> - Sexp.list [Sexp.atom "Pstr_primitive"; valueDescription vd] + Sexp.list [Sexp.atom "Pstr_primitive"; value_description vd] | Pstr_type (flag, tds) -> Sexp.list [ Sexp.atom "Pstr_type"; - recFlag flag; - Sexp.list (mapEmpty ~f:typeDeclaration tds); + rec_flag flag; + Sexp.list (map_empty ~f:type_declaration tds); ] | Pstr_typext typext -> - Sexp.list [Sexp.atom "Pstr_type"; typeExtension typext] + Sexp.list [Sexp.atom "Pstr_type"; type_extension typext] | Pstr_exception ec -> - Sexp.list [Sexp.atom "Pstr_exception"; extensionConstructor ec] - | Pstr_module mb -> Sexp.list [Sexp.atom "Pstr_module"; moduleBinding mb] + Sexp.list [Sexp.atom "Pstr_exception"; extension_constructor ec] + | Pstr_module mb -> Sexp.list [Sexp.atom "Pstr_module"; module_binding mb] | Pstr_recmodule mbs -> Sexp.list [ - Sexp.atom "Pstr_recmodule"; Sexp.list (mapEmpty ~f:moduleBinding mbs); + Sexp.atom "Pstr_recmodule"; + Sexp.list (map_empty ~f:module_binding mbs); ] - | Pstr_modtype modTypDecl -> - Sexp.list [Sexp.atom "Pstr_modtype"; moduleTypeDeclaration modTypDecl] - | Pstr_open openDesc -> - Sexp.list [Sexp.atom "Pstr_open"; openDescription openDesc] + | Pstr_modtype mod_typ_decl -> + Sexp.list + [Sexp.atom "Pstr_modtype"; module_type_declaration mod_typ_decl] + | Pstr_open open_desc -> + Sexp.list [Sexp.atom "Pstr_open"; open_description open_desc] | Pstr_class _ -> Sexp.atom "Pstr_class" | Pstr_class_type _ -> Sexp.atom "Pstr_class_type" | Pstr_include id -> - Sexp.list [Sexp.atom "Pstr_include"; includeDeclaration id] + Sexp.list [Sexp.atom "Pstr_include"; include_declaration id] | Pstr_attribute attr -> Sexp.list [Sexp.atom "Pstr_attribute"; attribute attr] | Pstr_extension (ext, attrs) -> @@ -187,15 +190,15 @@ module SexpAst = struct in Sexp.list [Sexp.atom "structure_item"; desc] - and includeDeclaration id = + and include_declaration id = Sexp.list [ Sexp.atom "include_declaration"; - moduleExpression id.pincl_mod; + module_expression id.pincl_mod; attributes id.pincl_attributes; ] - and openDescription od = + and open_description od = Sexp.list [ Sexp.atom "open_description"; @@ -203,55 +206,56 @@ module SexpAst = struct attributes od.popen_attributes; ] - and moduleTypeDeclaration mtd = + and module_type_declaration mtd = Sexp.list [ Sexp.atom "module_type_declaration"; string mtd.pmtd_name.Asttypes.txt; (match mtd.pmtd_type with | None -> Sexp.atom "None" - | Some modType -> Sexp.list [Sexp.atom "Some"; moduleType modType]); + | Some mod_type -> Sexp.list [Sexp.atom "Some"; module_type mod_type]); attributes mtd.pmtd_attributes; ] - and moduleBinding mb = + and module_binding mb = Sexp.list [ Sexp.atom "module_binding"; string mb.pmb_name.Asttypes.txt; - moduleExpression mb.pmb_expr; + module_expression mb.pmb_expr; attributes mb.pmb_attributes; ] - and moduleExpression me = + and module_expression me = let desc = match me.pmod_desc with - | Pmod_ident modName -> - Sexp.list [Sexp.atom "Pmod_ident"; longident modName.Asttypes.txt] + | Pmod_ident mod_name -> + Sexp.list [Sexp.atom "Pmod_ident"; longident mod_name.Asttypes.txt] | Pmod_structure s -> Sexp.list [Sexp.atom "Pmod_structure"; structure s] - | Pmod_functor (lbl, optModType, modExpr) -> + | Pmod_functor (lbl, opt_mod_type, mod_expr) -> Sexp.list [ Sexp.atom "Pmod_functor"; string lbl.Asttypes.txt; - (match optModType with + (match opt_mod_type with | None -> Sexp.atom "None" - | Some modType -> Sexp.list [Sexp.atom "Some"; moduleType modType]); - moduleExpression modExpr; + | Some mod_type -> + Sexp.list [Sexp.atom "Some"; module_type mod_type]); + module_expression mod_expr; ] - | Pmod_apply (callModExpr, modExprArg) -> + | Pmod_apply (call_mod_expr, mod_expr_arg) -> Sexp.list [ Sexp.atom "Pmod_apply"; - moduleExpression callModExpr; - moduleExpression modExprArg; + module_expression call_mod_expr; + module_expression mod_expr_arg; ] - | Pmod_constraint (modExpr, modType) -> + | Pmod_constraint (mod_expr, mod_type) -> Sexp.list [ Sexp.atom "Pmod_constraint"; - moduleExpression modExpr; - moduleType modType; + module_expression mod_expr; + module_type mod_type; ] | Pmod_unpack expr -> Sexp.list [Sexp.atom "Pmod_unpack"; expression expr] | Pmod_extension ext -> @@ -259,46 +263,47 @@ module SexpAst = struct in Sexp.list [Sexp.atom "module_expr"; desc; attributes me.pmod_attributes] - and moduleType mt = + and module_type mt = let desc = match mt.pmty_desc with - | Pmty_ident longidentLoc -> - Sexp.list [Sexp.atom "Pmty_ident"; longident longidentLoc.Asttypes.txt] + | Pmty_ident longident_loc -> + Sexp.list [Sexp.atom "Pmty_ident"; longident longident_loc.Asttypes.txt] | Pmty_signature s -> Sexp.list [Sexp.atom "Pmty_signature"; signature s] - | Pmty_functor (lbl, optModType, modType) -> + | Pmty_functor (lbl, opt_mod_type, mod_type) -> Sexp.list [ Sexp.atom "Pmty_functor"; string lbl.Asttypes.txt; - (match optModType with + (match opt_mod_type with | None -> Sexp.atom "None" - | Some modType -> Sexp.list [Sexp.atom "Some"; moduleType modType]); - moduleType modType; + | Some mod_type -> + Sexp.list [Sexp.atom "Some"; module_type mod_type]); + module_type mod_type; ] - | Pmty_alias longidentLoc -> - Sexp.list [Sexp.atom "Pmty_alias"; longident longidentLoc.Asttypes.txt] + | Pmty_alias longident_loc -> + Sexp.list [Sexp.atom "Pmty_alias"; longident longident_loc.Asttypes.txt] | Pmty_extension ext -> Sexp.list [Sexp.atom "Pmty_extension"; extension ext] - | Pmty_typeof modExpr -> - Sexp.list [Sexp.atom "Pmty_typeof"; moduleExpression modExpr] - | Pmty_with (modType, withConstraints) -> + | Pmty_typeof mod_expr -> + Sexp.list [Sexp.atom "Pmty_typeof"; module_expression mod_expr] + | Pmty_with (mod_type, with_constraints) -> Sexp.list [ Sexp.atom "Pmty_with"; - moduleType modType; - Sexp.list (mapEmpty ~f:withConstraint withConstraints); + module_type mod_type; + Sexp.list (map_empty ~f:with_constraint with_constraints); ] in Sexp.list [Sexp.atom "module_type"; desc; attributes mt.pmty_attributes] - and withConstraint wc = + and with_constraint wc = match wc with - | Pwith_type (longidentLoc, td) -> + | Pwith_type (longident_loc, td) -> Sexp.list [ Sexp.atom "Pmty_with"; - longident longidentLoc.Asttypes.txt; - typeDeclaration td; + longident longident_loc.Asttypes.txt; + type_declaration td; ] | Pwith_module (l1, l2) -> Sexp.list @@ -307,12 +312,12 @@ module SexpAst = struct longident l1.Asttypes.txt; longident l2.Asttypes.txt; ] - | Pwith_typesubst (longidentLoc, td) -> + | Pwith_typesubst (longident_loc, td) -> Sexp.list [ Sexp.atom "Pwith_typesubst"; - longident longidentLoc.Asttypes.txt; - typeDeclaration td; + longident longident_loc.Asttypes.txt; + type_declaration td; ] | Pwith_modsubst (l1, l2) -> Sexp.list @@ -322,37 +327,40 @@ module SexpAst = struct longident l2.Asttypes.txt; ] - and signature s = Sexp.list (Sexp.atom "signature" :: List.map signatureItem s) + and signature s = + Sexp.list (Sexp.atom "signature" :: List.map signature_item s) - and signatureItem si = + and signature_item si = let descr = match si.psig_desc with - | Psig_value vd -> Sexp.list [Sexp.atom "Psig_value"; valueDescription vd] - | Psig_type (flag, typeDeclarations) -> + | Psig_value vd -> + Sexp.list [Sexp.atom "Psig_value"; value_description vd] + | Psig_type (flag, type_declarations) -> Sexp.list [ Sexp.atom "Psig_type"; - recFlag flag; - Sexp.list (mapEmpty ~f:typeDeclaration typeDeclarations); + rec_flag flag; + Sexp.list (map_empty ~f:type_declaration type_declarations); ] - | Psig_typext typExt -> - Sexp.list [Sexp.atom "Psig_typext"; typeExtension typExt] - | Psig_exception extConstr -> - Sexp.list [Sexp.atom "Psig_exception"; extensionConstructor extConstr] - | Psig_module modDecl -> - Sexp.list [Sexp.atom "Psig_module"; moduleDeclaration modDecl] - | Psig_recmodule modDecls -> + | Psig_typext typ_ext -> + Sexp.list [Sexp.atom "Psig_typext"; type_extension typ_ext] + | Psig_exception ext_constr -> + Sexp.list [Sexp.atom "Psig_exception"; extension_constructor ext_constr] + | Psig_module mod_decl -> + Sexp.list [Sexp.atom "Psig_module"; module_declaration mod_decl] + | Psig_recmodule mod_decls -> Sexp.list [ Sexp.atom "Psig_recmodule"; - Sexp.list (mapEmpty ~f:moduleDeclaration modDecls); - ] - | Psig_modtype modTypDecl -> - Sexp.list [Sexp.atom "Psig_modtype"; moduleTypeDeclaration modTypDecl] - | Psig_open openDesc -> - Sexp.list [Sexp.atom "Psig_open"; openDescription openDesc] - | Psig_include inclDecl -> - Sexp.list [Sexp.atom "Psig_include"; includeDescription inclDecl] + Sexp.list (map_empty ~f:module_declaration mod_decls); + ] + | Psig_modtype mod_typ_decl -> + Sexp.list + [Sexp.atom "Psig_modtype"; module_type_declaration mod_typ_decl] + | Psig_open open_desc -> + Sexp.list [Sexp.atom "Psig_open"; open_description open_desc] + | Psig_include incl_decl -> + Sexp.list [Sexp.atom "Psig_include"; include_description incl_decl] | Psig_class _ -> Sexp.list [Sexp.atom "Psig_class"] | Psig_class_type _ -> Sexp.list [Sexp.atom "Psig_class_type"] | Psig_attribute attr -> @@ -362,24 +370,24 @@ module SexpAst = struct in Sexp.list [Sexp.atom "signature_item"; descr] - and includeDescription id = + and include_description id = Sexp.list [ Sexp.atom "include_description"; - moduleType id.pincl_mod; + module_type id.pincl_mod; attributes id.pincl_attributes; ] - and moduleDeclaration md = + and module_declaration md = Sexp.list [ Sexp.atom "module_declaration"; string md.pmd_name.Asttypes.txt; - moduleType md.pmd_type; + module_type md.pmd_type; attributes md.pmd_attributes; ] - and valueBinding vb = + and value_binding vb = Sexp.list [ Sexp.atom "value_binding"; @@ -388,17 +396,17 @@ module SexpAst = struct attributes vb.pvb_attributes; ] - and valueDescription vd = + and value_description vd = Sexp.list [ Sexp.atom "value_description"; string vd.pval_name.Asttypes.txt; - coreType vd.pval_type; - Sexp.list (mapEmpty ~f:string vd.pval_prim); + core_type vd.pval_type; + Sexp.list (map_empty ~f:string vd.pval_prim); attributes vd.pval_attributes; ] - and typeDeclaration td = + and type_declaration td = Sexp.list [ Sexp.atom "type_declaration"; @@ -407,56 +415,56 @@ module SexpAst = struct [ Sexp.atom "ptype_params"; Sexp.list - (mapEmpty + (map_empty ~f:(fun (typexpr, var) -> - Sexp.list [coreType typexpr; variance var]) + Sexp.list [core_type typexpr; variance var]) td.ptype_params); ]; Sexp.list [ Sexp.atom "ptype_cstrs"; Sexp.list - (mapEmpty + (map_empty ~f:(fun (typ1, typ2, _loc) -> - Sexp.list [coreType typ1; coreType typ2]) + Sexp.list [core_type typ1; core_type typ2]) td.ptype_cstrs); ]; - Sexp.list [Sexp.atom "ptype_kind"; typeKind td.ptype_kind]; + Sexp.list [Sexp.atom "ptype_kind"; type_kind td.ptype_kind]; Sexp.list [ Sexp.atom "ptype_manifest"; (match td.ptype_manifest with | None -> Sexp.atom "None" - | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); + | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]); ]; - Sexp.list [Sexp.atom "ptype_private"; privateFlag td.ptype_private]; + Sexp.list [Sexp.atom "ptype_private"; private_flag td.ptype_private]; attributes td.ptype_attributes; ] - and extensionConstructor ec = + and extension_constructor ec = Sexp.list [ Sexp.atom "extension_constructor"; string ec.pext_name.Asttypes.txt; - extensionConstructorKind ec.pext_kind; + extension_constructor_kind ec.pext_kind; attributes ec.pext_attributes; ] - and extensionConstructorKind kind = + and extension_constructor_kind kind = match kind with - | Pext_decl (args, optTypExpr) -> + | Pext_decl (args, opt_typ_expr) -> Sexp.list [ Sexp.atom "Pext_decl"; - constructorArguments args; - (match optTypExpr with + constructor_arguments args; + (match opt_typ_expr with | None -> Sexp.atom "None" - | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); + | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]); ] - | Pext_rebind longidentLoc -> - Sexp.list [Sexp.atom "Pext_rebind"; longident longidentLoc.Asttypes.txt] + | Pext_rebind longident_loc -> + Sexp.list [Sexp.atom "Pext_rebind"; longident longident_loc.Asttypes.txt] - and typeExtension te = + and type_extension te = Sexp.list [ Sexp.atom "type_extension"; @@ -466,95 +474,99 @@ module SexpAst = struct [ Sexp.atom "ptyext_parms"; Sexp.list - (mapEmpty + (map_empty ~f:(fun (typexpr, var) -> - Sexp.list [coreType typexpr; variance var]) + Sexp.list [core_type typexpr; variance var]) te.ptyext_params); ]; Sexp.list [ Sexp.atom "ptyext_constructors"; - Sexp.list (mapEmpty ~f:extensionConstructor te.ptyext_constructors); + Sexp.list + (map_empty ~f:extension_constructor te.ptyext_constructors); ]; - Sexp.list [Sexp.atom "ptyext_private"; privateFlag te.ptyext_private]; + Sexp.list [Sexp.atom "ptyext_private"; private_flag te.ptyext_private]; attributes te.ptyext_attributes; ] - and typeKind kind = + and type_kind kind = match kind with | Ptype_abstract -> Sexp.atom "Ptype_abstract" - | Ptype_variant constrDecls -> + | Ptype_variant constr_decls -> Sexp.list [ Sexp.atom "Ptype_variant"; - Sexp.list (mapEmpty ~f:constructorDeclaration constrDecls); + Sexp.list (map_empty ~f:constructor_declaration constr_decls); ] - | Ptype_record lblDecls -> + | Ptype_record lbl_decls -> Sexp.list [ Sexp.atom "Ptype_record"; - Sexp.list (mapEmpty ~f:labelDeclaration lblDecls); + Sexp.list (map_empty ~f:label_declaration lbl_decls); ] | Ptype_open -> Sexp.atom "Ptype_open" - and constructorDeclaration cd = + and constructor_declaration cd = Sexp.list [ Sexp.atom "constructor_declaration"; string cd.pcd_name.Asttypes.txt; - Sexp.list [Sexp.atom "pcd_args"; constructorArguments cd.pcd_args]; + Sexp.list [Sexp.atom "pcd_args"; constructor_arguments cd.pcd_args]; Sexp.list [ Sexp.atom "pcd_res"; (match cd.pcd_res with | None -> Sexp.atom "None" - | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); + | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]); ]; attributes cd.pcd_attributes; ] - and constructorArguments args = + and constructor_arguments args = match args with | Pcstr_tuple types -> Sexp.list - [Sexp.atom "Pcstr_tuple"; Sexp.list (mapEmpty ~f:coreType types)] + [Sexp.atom "Pcstr_tuple"; Sexp.list (map_empty ~f:core_type types)] | Pcstr_record lds -> Sexp.list - [Sexp.atom "Pcstr_record"; Sexp.list (mapEmpty ~f:labelDeclaration lds)] + [ + Sexp.atom "Pcstr_record"; + Sexp.list (map_empty ~f:label_declaration lds); + ] - and labelDeclaration ld = + and label_declaration ld = Sexp.list [ Sexp.atom "label_declaration"; string ld.pld_name.Asttypes.txt; - mutableFlag ld.pld_mutable; - coreType ld.pld_type; + mutable_flag ld.pld_mutable; + core_type ld.pld_type; attributes ld.pld_attributes; ] and expression expr = let desc = match expr.pexp_desc with - | Pexp_ident longidentLoc -> - Sexp.list [Sexp.atom "Pexp_ident"; longident longidentLoc.Asttypes.txt] + | Pexp_ident longident_loc -> + Sexp.list [Sexp.atom "Pexp_ident"; longident longident_loc.Asttypes.txt] | Pexp_constant c -> Sexp.list [Sexp.atom "Pexp_constant"; constant c] | Pexp_let (flag, vbs, expr) -> Sexp.list [ Sexp.atom "Pexp_let"; - recFlag flag; - Sexp.list (mapEmpty ~f:valueBinding vbs); + rec_flag flag; + Sexp.list (map_empty ~f:value_binding vbs); expression expr; ] | Pexp_function cases -> Sexp.list - [Sexp.atom "Pexp_function"; Sexp.list (mapEmpty ~f:case cases)] - | Pexp_fun (argLbl, exprOpt, pat, expr) -> + [Sexp.atom "Pexp_function"; Sexp.list (map_empty ~f:case cases)] + | Pexp_fun (arg_lbl, expr_opt, pat, expr) -> Sexp.list [ Sexp.atom "Pexp_fun"; - argLabel argLbl; - (match exprOpt with + arg_label arg_lbl; + (match expr_opt with | None -> Sexp.atom "None" | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); pattern pat; @@ -566,9 +578,9 @@ module SexpAst = struct Sexp.atom "Pexp_apply"; expression expr; Sexp.list - (mapEmpty - ~f:(fun (argLbl, expr) -> - Sexp.list [argLabel argLbl; expression expr]) + (map_empty + ~f:(fun (arg_lbl, expr) -> + Sexp.list [arg_label arg_lbl; expression expr]) args); ] | Pexp_match (expr, cases) -> @@ -576,75 +588,75 @@ module SexpAst = struct [ Sexp.atom "Pexp_match"; expression expr; - Sexp.list (mapEmpty ~f:case cases); + Sexp.list (map_empty ~f:case cases); ] | Pexp_try (expr, cases) -> Sexp.list [ Sexp.atom "Pexp_try"; expression expr; - Sexp.list (mapEmpty ~f:case cases); + Sexp.list (map_empty ~f:case cases); ] | Pexp_tuple exprs -> Sexp.list - [Sexp.atom "Pexp_tuple"; Sexp.list (mapEmpty ~f:expression exprs)] - | Pexp_construct (longidentLoc, exprOpt) -> + [Sexp.atom "Pexp_tuple"; Sexp.list (map_empty ~f:expression exprs)] + | Pexp_construct (longident_loc, expr_opt) -> Sexp.list [ Sexp.atom "Pexp_construct"; - longident longidentLoc.Asttypes.txt; - (match exprOpt with + longident longident_loc.Asttypes.txt; + (match expr_opt with | None -> Sexp.atom "None" | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); ] - | Pexp_variant (lbl, exprOpt) -> + | Pexp_variant (lbl, expr_opt) -> Sexp.list [ Sexp.atom "Pexp_variant"; string lbl; - (match exprOpt with + (match expr_opt with | None -> Sexp.atom "None" | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); ] - | Pexp_record (rows, optExpr) -> + | Pexp_record (rows, opt_expr) -> Sexp.list [ Sexp.atom "Pexp_record"; Sexp.list - (mapEmpty - ~f:(fun (longidentLoc, expr) -> + (map_empty + ~f:(fun (longident_loc, expr) -> Sexp.list - [longident longidentLoc.Asttypes.txt; expression expr]) + [longident longident_loc.Asttypes.txt; expression expr]) rows); - (match optExpr with + (match opt_expr with | None -> Sexp.atom "None" | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); ] - | Pexp_field (expr, longidentLoc) -> + | Pexp_field (expr, longident_loc) -> Sexp.list [ Sexp.atom "Pexp_field"; expression expr; - longident longidentLoc.Asttypes.txt; + longident longident_loc.Asttypes.txt; ] - | Pexp_setfield (expr1, longidentLoc, expr2) -> + | Pexp_setfield (expr1, longident_loc, expr2) -> Sexp.list [ Sexp.atom "Pexp_setfield"; expression expr1; - longident longidentLoc.Asttypes.txt; + longident longident_loc.Asttypes.txt; expression expr2; ] | Pexp_array exprs -> Sexp.list - [Sexp.atom "Pexp_array"; Sexp.list (mapEmpty ~f:expression exprs)] - | Pexp_ifthenelse (expr1, expr2, optExpr) -> + [Sexp.atom "Pexp_array"; Sexp.list (map_empty ~f:expression exprs)] + | Pexp_ifthenelse (expr1, expr2, opt_expr) -> Sexp.list [ Sexp.atom "Pexp_ifthenelse"; expression expr1; expression expr2; - (match optExpr with + (match opt_expr with | None -> Sexp.atom "None" | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); ] @@ -660,39 +672,39 @@ module SexpAst = struct pattern pat; expression e1; expression e2; - directionFlag flag; + direction_flag flag; expression e3; ] | Pexp_constraint (expr, typexpr) -> Sexp.list - [Sexp.atom "Pexp_constraint"; expression expr; coreType typexpr] - | Pexp_coerce (expr, optTyp, typexpr) -> + [Sexp.atom "Pexp_constraint"; expression expr; core_type typexpr] + | Pexp_coerce (expr, opt_typ, typexpr) -> Sexp.list [ Sexp.atom "Pexp_coerce"; expression expr; - (match optTyp with + (match opt_typ with | None -> Sexp.atom "None" - | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); - coreType typexpr; + | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]); + core_type typexpr; ] | Pexp_send _ -> Sexp.list [Sexp.atom "Pexp_send"] | Pexp_new _ -> Sexp.list [Sexp.atom "Pexp_new"] | Pexp_setinstvar _ -> Sexp.list [Sexp.atom "Pexp_setinstvar"] | Pexp_override _ -> Sexp.list [Sexp.atom "Pexp_override"] - | Pexp_letmodule (modName, modExpr, expr) -> + | Pexp_letmodule (mod_name, mod_expr, expr) -> Sexp.list [ Sexp.atom "Pexp_letmodule"; - string modName.Asttypes.txt; - moduleExpression modExpr; + string mod_name.Asttypes.txt; + module_expression mod_expr; expression expr; ] - | Pexp_letexception (extConstr, expr) -> + | Pexp_letexception (ext_constr, expr) -> Sexp.list [ Sexp.atom "Pexp_letexception"; - extensionConstructor extConstr; + extension_constructor ext_constr; expression expr; ] | Pexp_assert expr -> Sexp.list [Sexp.atom "Pexp_assert"; expression expr] @@ -702,14 +714,14 @@ module SexpAst = struct | Pexp_newtype (lbl, expr) -> Sexp.list [Sexp.atom "Pexp_newtype"; string lbl.Asttypes.txt; expression expr] - | Pexp_pack modExpr -> - Sexp.list [Sexp.atom "Pexp_pack"; moduleExpression modExpr] - | Pexp_open (flag, longidentLoc, expr) -> + | Pexp_pack mod_expr -> + Sexp.list [Sexp.atom "Pexp_pack"; module_expression mod_expr] + | Pexp_open (flag, longident_loc, expr) -> Sexp.list [ Sexp.atom "Pexp_open"; - overrideFlag flag; - longident longidentLoc.Asttypes.txt; + override_flag flag; + longident longident_loc.Asttypes.txt; expression expr; ] | Pexp_extension ext -> @@ -746,22 +758,22 @@ module SexpAst = struct Sexp.list [Sexp.atom "Ppat_interval"; constant lo; constant hi] | Ppat_tuple patterns -> Sexp.list - [Sexp.atom "Ppat_tuple"; Sexp.list (mapEmpty ~f:pattern patterns)] - | Ppat_construct (longidentLoc, optPattern) -> + [Sexp.atom "Ppat_tuple"; Sexp.list (map_empty ~f:pattern patterns)] + | Ppat_construct (longident_loc, opt_pattern) -> Sexp.list [ Sexp.atom "Ppat_construct"; - longident longidentLoc.Location.txt; - (match optPattern with + longident longident_loc.Location.txt; + (match opt_pattern with | None -> Sexp.atom "None" | Some p -> Sexp.list [Sexp.atom "some"; pattern p]); ] - | Ppat_variant (lbl, optPattern) -> + | Ppat_variant (lbl, opt_pattern) -> Sexp.list [ Sexp.atom "Ppat_variant"; string lbl; - (match optPattern with + (match opt_pattern with | None -> Sexp.atom "None" | Some p -> Sexp.list [Sexp.atom "Some"; pattern p]); ] @@ -769,125 +781,134 @@ module SexpAst = struct Sexp.list [ Sexp.atom "Ppat_record"; - closedFlag flag; + closed_flag flag; Sexp.list - (mapEmpty - ~f:(fun (longidentLoc, p) -> - Sexp.list [longident longidentLoc.Location.txt; pattern p]) + (map_empty + ~f:(fun (longident_loc, p) -> + Sexp.list [longident longident_loc.Location.txt; pattern p]) rows); ] | Ppat_array patterns -> Sexp.list - [Sexp.atom "Ppat_array"; Sexp.list (mapEmpty ~f:pattern patterns)] + [Sexp.atom "Ppat_array"; Sexp.list (map_empty ~f:pattern patterns)] | Ppat_or (p1, p2) -> Sexp.list [Sexp.atom "Ppat_or"; pattern p1; pattern p2] | Ppat_constraint (p, typexpr) -> - Sexp.list [Sexp.atom "Ppat_constraint"; pattern p; coreType typexpr] - | Ppat_type longidentLoc -> - Sexp.list [Sexp.atom "Ppat_type"; longident longidentLoc.Location.txt] + Sexp.list [Sexp.atom "Ppat_constraint"; pattern p; core_type typexpr] + | Ppat_type longident_loc -> + Sexp.list [Sexp.atom "Ppat_type"; longident longident_loc.Location.txt] | Ppat_lazy p -> Sexp.list [Sexp.atom "Ppat_lazy"; pattern p] - | Ppat_unpack stringLoc -> - Sexp.list [Sexp.atom "Ppat_unpack"; string stringLoc.Location.txt] + | Ppat_unpack string_loc -> + Sexp.list [Sexp.atom "Ppat_unpack"; string string_loc.Location.txt] | Ppat_exception p -> Sexp.list [Sexp.atom "Ppat_exception"; pattern p] | Ppat_extension ext -> Sexp.list [Sexp.atom "Ppat_extension"; extension ext] - | Ppat_open (longidentLoc, p) -> + | Ppat_open (longident_loc, p) -> Sexp.list [ - Sexp.atom "Ppat_open"; longident longidentLoc.Location.txt; pattern p; + Sexp.atom "Ppat_open"; + longident longident_loc.Location.txt; + pattern p; ] in Sexp.list [Sexp.atom "pattern"; descr] - and objectField field = + and object_field field = match field with - | Otag (lblLoc, attrs, typexpr) -> + | Otag (lbl_loc, attrs, typexpr) -> Sexp.list [ - Sexp.atom "Otag"; string lblLoc.txt; attributes attrs; coreType typexpr; + Sexp.atom "Otag"; + string lbl_loc.txt; + attributes attrs; + core_type typexpr; ] - | Oinherit typexpr -> Sexp.list [Sexp.atom "Oinherit"; coreType typexpr] + | Oinherit typexpr -> Sexp.list [Sexp.atom "Oinherit"; core_type typexpr] - and rowField field = + and row_field field = match field with - | Rtag (labelLoc, attrs, truth, types) -> + | Rtag (label_loc, attrs, truth, types) -> Sexp.list [ Sexp.atom "Rtag"; - string labelLoc.txt; + string label_loc.txt; attributes attrs; Sexp.atom (if truth then "true" else "false"); - Sexp.list (mapEmpty ~f:coreType types); + Sexp.list (map_empty ~f:core_type types); ] - | Rinherit typexpr -> Sexp.list [Sexp.atom "Rinherit"; coreType typexpr] + | Rinherit typexpr -> Sexp.list [Sexp.atom "Rinherit"; core_type typexpr] - and packageType (modNameLoc, packageConstraints) = + and package_type (mod_name_loc, package_constraints) = Sexp.list [ Sexp.atom "package_type"; - longident modNameLoc.Asttypes.txt; + longident mod_name_loc.Asttypes.txt; Sexp.list - (mapEmpty - ~f:(fun (modNameLoc, typexpr) -> - Sexp.list [longident modNameLoc.Asttypes.txt; coreType typexpr]) - packageConstraints); + (map_empty + ~f:(fun (mod_name_loc, typexpr) -> + Sexp.list + [longident mod_name_loc.Asttypes.txt; core_type typexpr]) + package_constraints); ] - and coreType typexpr = + and core_type typexpr = let desc = match typexpr.ptyp_desc with | Ptyp_any -> Sexp.atom "Ptyp_any" | Ptyp_var var -> Sexp.list [Sexp.atom "Ptyp_var"; string var] - | Ptyp_arrow (argLbl, typ1, typ2) -> + | Ptyp_arrow (arg_lbl, typ1, typ2) -> Sexp.list [ - Sexp.atom "Ptyp_arrow"; argLabel argLbl; coreType typ1; coreType typ2; + Sexp.atom "Ptyp_arrow"; + arg_label arg_lbl; + core_type typ1; + core_type typ2; ] | Ptyp_tuple types -> Sexp.list - [Sexp.atom "Ptyp_tuple"; Sexp.list (mapEmpty ~f:coreType types)] - | Ptyp_constr (longidentLoc, types) -> + [Sexp.atom "Ptyp_tuple"; Sexp.list (map_empty ~f:core_type types)] + | Ptyp_constr (longident_loc, types) -> Sexp.list [ Sexp.atom "Ptyp_constr"; - longident longidentLoc.txt; - Sexp.list (mapEmpty ~f:coreType types); + longident longident_loc.txt; + Sexp.list (map_empty ~f:core_type types); ] | Ptyp_alias (typexpr, alias) -> - Sexp.list [Sexp.atom "Ptyp_alias"; coreType typexpr; string alias] + Sexp.list [Sexp.atom "Ptyp_alias"; core_type typexpr; string alias] | Ptyp_object (fields, flag) -> Sexp.list [ Sexp.atom "Ptyp_object"; - closedFlag flag; - Sexp.list (mapEmpty ~f:objectField fields); + closed_flag flag; + Sexp.list (map_empty ~f:object_field fields); ] - | Ptyp_class (longidentLoc, types) -> + | Ptyp_class (longident_loc, types) -> Sexp.list [ Sexp.atom "Ptyp_class"; - longident longidentLoc.Location.txt; - Sexp.list (mapEmpty ~f:coreType types); + longident longident_loc.Location.txt; + Sexp.list (map_empty ~f:core_type types); ] - | Ptyp_variant (fields, flag, optLabels) -> + | Ptyp_variant (fields, flag, opt_labels) -> Sexp.list [ Sexp.atom "Ptyp_variant"; - Sexp.list (mapEmpty ~f:rowField fields); - closedFlag flag; - (match optLabels with + Sexp.list (map_empty ~f:row_field fields); + closed_flag flag; + (match opt_labels with | None -> Sexp.atom "None" - | Some lbls -> Sexp.list (mapEmpty ~f:string lbls)); + | Some lbls -> Sexp.list (map_empty ~f:string lbls)); ] | Ptyp_poly (lbls, typexpr) -> Sexp.list [ Sexp.atom "Ptyp_poly"; - Sexp.list (mapEmpty ~f:(fun lbl -> string lbl.Asttypes.txt) lbls); - coreType typexpr; + Sexp.list (map_empty ~f:(fun lbl -> string lbl.Asttypes.txt) lbls); + core_type typexpr; ] | Ptyp_package package -> - Sexp.list [Sexp.atom "Ptyp_package"; packageType package] + Sexp.list [Sexp.atom "Ptyp_package"; package_type package] | Ptyp_extension ext -> Sexp.list [Sexp.atom "Ptyp_extension"; extension ext] in @@ -895,55 +916,55 @@ module SexpAst = struct and payload p = match p with - | PStr s -> Sexp.list (Sexp.atom "PStr" :: mapEmpty ~f:structureItem s) + | PStr s -> Sexp.list (Sexp.atom "PStr" :: map_empty ~f:structure_item s) | PSig s -> Sexp.list [Sexp.atom "PSig"; signature s] - | PTyp ct -> Sexp.list [Sexp.atom "PTyp"; coreType ct] - | PPat (pat, optExpr) -> + | PTyp ct -> Sexp.list [Sexp.atom "PTyp"; core_type ct] + | PPat (pat, opt_expr) -> Sexp.list [ Sexp.atom "PPat"; pattern pat; - (match optExpr with + (match opt_expr with | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr] | None -> Sexp.atom "None"); ] - and attribute (stringLoc, p) = + and attribute (string_loc, p) = Sexp.list - [Sexp.atom "attribute"; Sexp.atom stringLoc.Asttypes.txt; payload p] + [Sexp.atom "attribute"; Sexp.atom string_loc.Asttypes.txt; payload p] - and extension (stringLoc, p) = + and extension (string_loc, p) = Sexp.list - [Sexp.atom "extension"; Sexp.atom stringLoc.Asttypes.txt; payload p] + [Sexp.atom "extension"; Sexp.atom string_loc.Asttypes.txt; payload p] and attributes attrs = - let sexprs = mapEmpty ~f:attribute attrs in + let sexprs = map_empty ~f:attribute attrs in Sexp.list (Sexp.atom "attributes" :: sexprs) - let printEngine = + let print_engine = Res_driver. { - printImplementation = + print_implementation = (fun ~width:_ ~filename:_ ~comments:_ parsetree -> - parsetree |> structure |> Sexp.toString |> print_string); - printInterface = + parsetree |> structure |> Sexp.to_string |> print_string); + print_interface = (fun ~width:_ ~filename:_ ~comments:_ parsetree -> - parsetree |> signature |> Sexp.toString |> print_string); + parsetree |> signature |> Sexp.to_string |> print_string); } end -let sexpPrintEngine = SexpAst.printEngine +let sexp_print_engine = SexpAst.print_engine -let commentsPrintEngine = +let comments_print_engine = { - Res_driver.printImplementation = + Res_driver.print_implementation = (fun ~width:_ ~filename:_ ~comments s -> - let cmtTbl = CommentTable.make () in - CommentTable.walkStructure s cmtTbl comments; - CommentTable.log cmtTbl); - printInterface = + let cmt_tbl = CommentTable.make () in + CommentTable.walk_structure s cmt_tbl comments; + CommentTable.log cmt_tbl); + print_interface = (fun ~width:_ ~filename:_ ~comments s -> - let cmtTbl = CommentTable.make () in - CommentTable.walkSignature s cmtTbl comments; - CommentTable.log cmtTbl); + let cmt_tbl = CommentTable.make () in + CommentTable.walk_signature s cmt_tbl comments; + CommentTable.log cmt_tbl); } diff --git a/analysis/vendor/res_syntax/res_ast_debugger.mli b/analysis/vendor/res_syntax/res_ast_debugger.mli index 1b325b742..66588af59 100644 --- a/analysis/vendor/res_syntax/res_ast_debugger.mli +++ b/analysis/vendor/res_syntax/res_ast_debugger.mli @@ -1,3 +1,3 @@ -val printEngine : Res_driver.printEngine -val sexpPrintEngine : Res_driver.printEngine -val commentsPrintEngine : Res_driver.printEngine +val print_engine : Res_driver.print_engine +val sexp_print_engine : Res_driver.print_engine +val comments_print_engine : Res_driver.print_engine diff --git a/analysis/vendor/res_syntax/res_cli.ml b/analysis/vendor/res_syntax/res_cli.ml index 8583f9639..d5fca5d13 100644 --- a/analysis/vendor/res_syntax/res_cli.ml +++ b/analysis/vendor/res_syntax/res_cli.ml @@ -162,9 +162,9 @@ module ResClflags : sig val origin : string ref val file : string ref val interface : bool ref - val jsxVersion : int ref - val jsxModule : string ref - val jsxMode : string ref + val jsx_version : int ref + val jsx_module : string ref + val jsx_mode : string ref val typechecker : bool ref val parse : unit -> unit @@ -175,9 +175,9 @@ end = struct let print = ref "res" let origin = ref "" let interface = ref false - let jsxVersion = ref (-1) - let jsxModule = ref "react" - let jsxMode = ref "automatic" + let jsx_version = ref (-1) + let jsx_module = ref "react" + let jsx_mode = ref "automatic" let file = ref "" let typechecker = ref false @@ -207,14 +207,14 @@ end = struct Arg.Unit (fun () -> interface := true), "Parse as interface" ); ( "-jsx-version", - Arg.Int (fun i -> jsxVersion := i), + Arg.Int (fun i -> jsx_version := i), "Apply a specific built-in ppx before parsing, none or 3, 4. Default: \ none" ); ( "-jsx-module", - Arg.String (fun txt -> jsxModule := txt), + Arg.String (fun txt -> jsx_module := txt), "Specify the jsx module. Default: react" ); ( "-jsx-mode", - Arg.String (fun txt -> jsxMode := txt), + Arg.String (fun txt -> jsx_mode := txt), "Specify the jsx mode, classic or automatic. Default: automatic" ); ( "-typechecker", Arg.Unit (fun () -> typechecker := true), @@ -226,37 +226,37 @@ end = struct end module CliArgProcessor = struct - type backend = Parser : 'diagnostics Res_driver.parsingEngine -> backend + type backend = Parser : 'diagnostics Res_driver.parsing_engine -> backend [@@unboxed] - let processFile ~isInterface ~width ~recover ~origin ~target ~jsxVersion - ~jsxModule ~jsxMode ~typechecker filename = + let process_file ~is_interface ~width ~recover ~origin ~target ~jsx_version + ~jsx_module ~jsx_mode ~typechecker filename = let len = String.length filename in - let processInterface = - isInterface + let process_interface = + is_interface || (len > 0 && (String.get [@doesNotRaise]) filename (len - 1) = 'i') in - let parsingEngine = + let parsing_engine = match origin with - | "ml" -> Parser Res_driver_ml_parser.parsingEngine - | "res" -> Parser Res_driver.parsingEngine + | "ml" -> Parser Res_driver_ml_parser.parsing_engine + | "res" -> Parser Res_driver.parsing_engine | "" -> ( match Filename.extension filename with - | ".ml" | ".mli" -> Parser Res_driver_ml_parser.parsingEngine - | _ -> Parser Res_driver.parsingEngine) + | ".ml" | ".mli" -> Parser Res_driver_ml_parser.parsing_engine + | _ -> Parser Res_driver.parsing_engine) | origin -> print_endline ("-parse needs to be either ml or res. You provided " ^ origin); exit 1 in - let printEngine = + let print_engine = match target with - | "binary" -> Res_driver_binary.printEngine - | "ml" -> Res_driver_ml_parser.printEngine - | "ast" -> Res_ast_debugger.printEngine - | "sexp" -> Res_ast_debugger.sexpPrintEngine - | "comments" -> Res_ast_debugger.commentsPrintEngine - | "res" -> Res_driver.printEngine + | "binary" -> Res_driver_binary.print_engine + | "ml" -> Res_driver_ml_parser.print_engine + | "ast" -> Res_ast_debugger.print_engine + | "sexp" -> Res_ast_debugger.sexp_print_engine + | "comments" -> Res_ast_debugger.comments_print_engine + | "res" -> Res_driver.print_engine | target -> print_endline ("-print needs to be either binary, ml, ast, sexp, comments or res. \ @@ -264,57 +264,57 @@ module CliArgProcessor = struct exit 1 in - let forPrinter = + let for_printer = match target with | ("res" | "sexp") when not typechecker -> true | _ -> false in - let (Parser backend) = parsingEngine in + let (Parser backend) = parsing_engine in (* This is the whole purpose of the Color module above *) Color.setup None; - if processInterface then - let parseResult = backend.parseInterface ~forPrinter ~filename in - if parseResult.invalid then ( - backend.stringOfDiagnostics ~source:parseResult.source - ~filename:parseResult.filename parseResult.diagnostics; + if process_interface then + let parse_result = backend.parse_interface ~for_printer ~filename in + if parse_result.invalid then ( + backend.string_of_diagnostics ~source:parse_result.source + ~filename:parse_result.filename parse_result.diagnostics; if recover then - printEngine.printInterface ~width ~filename - ~comments:parseResult.comments parseResult.parsetree + print_engine.print_interface ~width ~filename + ~comments:parse_result.comments parse_result.parsetree else exit 1) else let parsetree = - Jsx_ppx.rewrite_signature ~jsxVersion ~jsxModule ~jsxMode - parseResult.parsetree + Jsx_ppx.rewrite_signature ~jsx_version ~jsx_module ~jsx_mode + parse_result.parsetree in - printEngine.printInterface ~width ~filename - ~comments:parseResult.comments parsetree + print_engine.print_interface ~width ~filename + ~comments:parse_result.comments parsetree else - let parseResult = backend.parseImplementation ~forPrinter ~filename in - if parseResult.invalid then ( - backend.stringOfDiagnostics ~source:parseResult.source - ~filename:parseResult.filename parseResult.diagnostics; + let parse_result = backend.parse_implementation ~for_printer ~filename in + if parse_result.invalid then ( + backend.string_of_diagnostics ~source:parse_result.source + ~filename:parse_result.filename parse_result.diagnostics; if recover then - printEngine.printImplementation ~width ~filename - ~comments:parseResult.comments parseResult.parsetree + print_engine.print_implementation ~width ~filename + ~comments:parse_result.comments parse_result.parsetree else exit 1) else let parsetree = - Jsx_ppx.rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode - parseResult.parsetree + Jsx_ppx.rewrite_implementation ~jsx_version ~jsx_module ~jsx_mode + parse_result.parsetree in - printEngine.printImplementation ~width ~filename - ~comments:parseResult.comments parsetree + print_engine.print_implementation ~width ~filename + ~comments:parse_result.comments parsetree [@@raises exit] end -(* let () = +let () = if not !Sys.interactive then ( ResClflags.parse (); - CliArgProcessor.processFile ~isInterface:!ResClflags.interface + CliArgProcessor.process_file ~is_interface:!ResClflags.interface ~width:!ResClflags.width ~recover:!ResClflags.recover ~target:!ResClflags.print ~origin:!ResClflags.origin - ~jsxVersion:!ResClflags.jsxVersion ~jsxModule:!ResClflags.jsxModule - ~jsxMode:!ResClflags.jsxMode ~typechecker:!ResClflags.typechecker + ~jsx_version:!ResClflags.jsx_version ~jsx_module:!ResClflags.jsx_module + ~jsx_mode:!ResClflags.jsx_mode ~typechecker:!ResClflags.typechecker !ResClflags.file) - [@@raises exit] *) +[@@raises exit] diff --git a/analysis/vendor/res_syntax/res_comment.ml b/analysis/vendor/res_syntax/res_comment.ml index 579b5d327..d4e7bd0a4 100644 --- a/analysis/vendor/res_syntax/res_comment.ml +++ b/analysis/vendor/res_syntax/res_comment.ml @@ -1,6 +1,6 @@ type style = SingleLine | MultiLine | DocComment | ModuleComment -let styleToString s = +let style_to_string s = match s with | SingleLine -> "SingleLine" | MultiLine -> "MultiLine" @@ -11,46 +11,46 @@ type t = { txt: string; style: style; loc: Location.t; - mutable prevTokEndPos: Lexing.position; + mutable prev_tok_end_pos: Lexing.position; } let loc t = t.loc let txt t = t.txt -let prevTokEndPos t = t.prevTokEndPos +let prev_tok_end_pos t = t.prev_tok_end_pos -let setPrevTokEndPos t pos = t.prevTokEndPos <- pos +let set_prev_tok_end_pos t pos = t.prev_tok_end_pos <- pos -let isSingleLineComment t = t.style = SingleLine +let is_single_line_comment t = t.style = SingleLine -let isDocComment t = t.style = DocComment +let is_doc_comment t = t.style = DocComment -let isModuleComment t = t.style = ModuleComment +let is_module_comment t = t.style = ModuleComment -let toString t = +let to_string t = let {Location.loc_start; loc_end} = t.loc in Format.sprintf "(txt: %s\nstyle: %s\nlocation: %d,%d-%d,%d)" t.txt - (styleToString t.style) loc_start.pos_lnum + (style_to_string t.style) loc_start.pos_lnum (loc_start.pos_cnum - loc_start.pos_bol) loc_end.pos_lnum (loc_end.pos_cnum - loc_end.pos_bol) -let makeSingleLineComment ~loc txt = - {txt; loc; style = SingleLine; prevTokEndPos = Lexing.dummy_pos} +let make_single_line_comment ~loc txt = + {txt; loc; style = SingleLine; prev_tok_end_pos = Lexing.dummy_pos} -let makeMultiLineComment ~loc ~docComment ~standalone txt = +let make_multi_line_comment ~loc ~doc_comment ~standalone txt = { txt; loc; style = - (if docComment then if standalone then ModuleComment else DocComment + (if doc_comment then if standalone then ModuleComment else DocComment else MultiLine); - prevTokEndPos = Lexing.dummy_pos; + prev_tok_end_pos = Lexing.dummy_pos; } -let fromOcamlComment ~loc ~txt ~prevTokEndPos = - {txt; loc; style = MultiLine; prevTokEndPos} +let from_ocaml_comment ~loc ~txt ~prev_tok_end_pos = + {txt; loc; style = MultiLine; prev_tok_end_pos} -let trimSpaces s = +let trim_spaces s = let len = String.length s in if len = 0 then s else if String.unsafe_get s 0 = ' ' || String.unsafe_get s (len - 1) = ' ' diff --git a/analysis/vendor/res_syntax/res_comment.mli b/analysis/vendor/res_syntax/res_comment.mli index f1d5424d9..7cf10edd4 100644 --- a/analysis/vendor/res_syntax/res_comment.mli +++ b/analysis/vendor/res_syntax/res_comment.mli @@ -1,22 +1,22 @@ type t -val toString : t -> string +val to_string : t -> string val loc : t -> Location.t val txt : t -> string -val prevTokEndPos : t -> Lexing.position +val prev_tok_end_pos : t -> Lexing.position -val setPrevTokEndPos : t -> Lexing.position -> unit +val set_prev_tok_end_pos : t -> Lexing.position -> unit -val isDocComment : t -> bool +val is_doc_comment : t -> bool -val isModuleComment : t -> bool +val is_module_comment : t -> bool -val isSingleLineComment : t -> bool +val is_single_line_comment : t -> bool -val makeSingleLineComment : loc:Location.t -> string -> t -val makeMultiLineComment : - loc:Location.t -> docComment:bool -> standalone:bool -> string -> t -val fromOcamlComment : - loc:Location.t -> txt:string -> prevTokEndPos:Lexing.position -> t -val trimSpaces : string -> string +val make_single_line_comment : loc:Location.t -> string -> t +val make_multi_line_comment : + loc:Location.t -> doc_comment:bool -> standalone:bool -> string -> t +val from_ocaml_comment : + loc:Location.t -> txt:string -> prev_tok_end_pos:Lexing.position -> t +val trim_spaces : string -> string diff --git a/analysis/vendor/res_syntax/res_comments_table.ml b/analysis/vendor/res_syntax/res_comments_table.ml index d12ace528..b531fde32 100644 --- a/analysis/vendor/res_syntax/res_comments_table.ml +++ b/analysis/vendor/res_syntax/res_comments_table.ml @@ -24,7 +24,7 @@ let copy tbl = let empty = make () -let printEntries tbl = +let print_entries tbl = let open Location in Hashtbl.fold (fun (k : Location.t) (v : Comment.t list) acc -> @@ -44,7 +44,7 @@ let printEntries tbl = ] in let doc = - Doc.breakableGroup ~forceBreak:true + Doc.breakable_group ~force_break:true (Doc.concat [ loc; @@ -63,133 +63,133 @@ let printEntries tbl = tbl [] let log t = - let leadingStuff = printEntries t.leading in - let trailingStuff = printEntries t.trailing in - let stuffInside = printEntries t.inside in - Doc.breakableGroup ~forceBreak:true + let leading_stuff = print_entries t.leading in + let trailing_stuff = print_entries t.trailing in + let stuff_inside = print_entries t.inside in + Doc.breakable_group ~force_break:true (Doc.concat [ Doc.text "leading comments:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat leadingStuff]); + Doc.indent (Doc.concat [Doc.line; Doc.concat leading_stuff]); Doc.line; Doc.text "comments inside:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat stuffInside]); + Doc.indent (Doc.concat [Doc.line; Doc.concat stuff_inside]); Doc.line; Doc.text "trailing comments:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat trailingStuff]); + Doc.indent (Doc.concat [Doc.line; Doc.concat trailing_stuff]); Doc.line; ]) - |> Doc.toString ~width:80 |> print_endline + |> Doc.to_string ~width:80 |> print_endline let attach tbl loc comments = match comments with | [] -> () | comments -> Hashtbl.replace tbl loc comments -let partitionByLoc comments loc = +let partition_by_loc comments loc = let rec loop (leading, inside, trailing) comments = let open Location in match comments with | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + let cmt_loc = Comment.loc comment in + if cmt_loc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then loop (comment :: leading, inside, trailing) rest - else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then + else if cmt_loc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then loop (leading, inside, comment :: trailing) rest else loop (leading, comment :: inside, trailing) rest | [] -> (List.rev leading, List.rev inside, List.rev trailing) in loop ([], [], []) comments -let partitionLeadingTrailing comments loc = +let partition_leading_trailing comments loc = let rec loop (leading, trailing) comments = let open Location in match comments with | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + let cmt_loc = Comment.loc comment in + if cmt_loc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then loop (comment :: leading, trailing) rest else loop (leading, comment :: trailing) rest | [] -> (List.rev leading, List.rev trailing) in loop ([], []) comments -let partitionByOnSameLine loc comments = - let rec loop (onSameLine, onOtherLine) comments = +let partition_by_on_same_line loc comments = + let rec loop (on_same_line, on_other_line) comments = let open Location in match comments with - | [] -> (List.rev onSameLine, List.rev onOtherLine) + | [] -> (List.rev on_same_line, List.rev on_other_line) | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_start.pos_lnum == loc.loc_end.pos_lnum then - loop (comment :: onSameLine, onOtherLine) rest - else loop (onSameLine, comment :: onOtherLine) rest + let cmt_loc = Comment.loc comment in + if cmt_loc.loc_start.pos_lnum == loc.loc_end.pos_lnum then + loop (comment :: on_same_line, on_other_line) rest + else loop (on_same_line, comment :: on_other_line) rest in loop ([], []) comments -let partitionAdjacentTrailing loc1 comments = +let partition_adjacent_trailing loc1 comments = let open Location in let open Lexing in - let rec loop ~prevEndPos afterLoc1 comments = + let rec loop ~prev_end_pos after_loc1 comments = match comments with - | [] -> (List.rev afterLoc1, []) + | [] -> (List.rev after_loc1, []) | comment :: rest as comments -> - let cmtPrevEndPos = Comment.prevTokEndPos comment in - if prevEndPos.Lexing.pos_cnum == cmtPrevEndPos.pos_cnum then - let commentEnd = (Comment.loc comment).loc_end in - loop ~prevEndPos:commentEnd (comment :: afterLoc1) rest - else (List.rev afterLoc1, comments) + let cmt_prev_end_pos = Comment.prev_tok_end_pos comment in + if prev_end_pos.Lexing.pos_cnum == cmt_prev_end_pos.pos_cnum then + let comment_end = (Comment.loc comment).loc_end in + loop ~prev_end_pos:comment_end (comment :: after_loc1) rest + else (List.rev after_loc1, comments) in - loop ~prevEndPos:loc1.loc_end [] comments + loop ~prev_end_pos:loc1.loc_end [] comments -let rec collectListPatterns acc pattern = +let rec collect_list_patterns acc pattern = let open Parsetree in match pattern.ppat_desc with | Ppat_construct ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) -> - collectListPatterns (pat :: acc) rest + collect_list_patterns (pat :: acc) rest | Ppat_construct ({txt = Longident.Lident "[]"}, None) -> List.rev acc | _ -> List.rev (pattern :: acc) -let rec collectListExprs acc expr = +let rec collect_list_exprs acc expr = let open Parsetree in match expr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [expr; rest]}) -> - collectListExprs (expr :: acc) rest + collect_list_exprs (expr :: acc) rest | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> List.rev acc | _ -> List.rev (expr :: acc) (* TODO: use ParsetreeViewer *) -let arrowType ct = +let arrow_type ct = let open Parsetree in - let rec process attrsBefore acc typ = + let rec process attrs_before acc typ = match typ with | { ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); ptyp_attributes = []; } -> let arg = ([], lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + process attrs_before (arg :: acc) typ2 | { ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); ptyp_attributes = [({txt = "bs"}, _)] as attrs; } -> let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 + process attrs_before (arg :: acc) typ2 | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} - as returnType -> + as return_type -> let args = List.rev acc in - (attrsBefore, args, returnType) + (attrs_before, args, return_type) | { ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2); ptyp_attributes = attrs; } -> let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 - | typ -> (attrsBefore, List.rev acc, typ) + process attrs_before (arg :: acc) typ2 + | typ -> (attrs_before, List.rev acc, typ) in match ct with | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as @@ -198,54 +198,54 @@ let arrowType ct = | typ -> process [] [] typ (* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) -let modExprApply modExpr = - let rec loop acc modExpr = - match modExpr with +let mod_expr_apply mod_expr = + let rec loop acc mod_expr = + match mod_expr with | {Parsetree.pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next - | _ -> modExpr :: acc + | _ -> mod_expr :: acc in - loop [] modExpr + loop [] mod_expr (* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) -let modExprFunctor modExpr = - let rec loop acc modExpr = - match modExpr with +let mod_expr_functor mod_expr = + let rec loop acc mod_expr = + match mod_expr with | { - Parsetree.pmod_desc = Pmod_functor (lbl, modType, returnModExpr); + Parsetree.pmod_desc = Pmod_functor (lbl, mod_type, return_mod_expr); pmod_attributes = attrs; } -> - let param = (attrs, lbl, modType) in - loop (param :: acc) returnModExpr - | returnModExpr -> (List.rev acc, returnModExpr) + let param = (attrs, lbl, mod_type) in + loop (param :: acc) return_mod_expr + | return_mod_expr -> (List.rev acc, return_mod_expr) in - loop [] modExpr + loop [] mod_expr -let functorType modtype = +let functor_type modtype = let rec process acc modtype = match modtype with | { - Parsetree.pmty_desc = Pmty_functor (lbl, argType, returnType); + Parsetree.pmty_desc = Pmty_functor (lbl, arg_type, return_type); pmty_attributes = attrs; } -> - let arg = (attrs, lbl, argType) in - process (arg :: acc) returnType - | modType -> (List.rev acc, modType) + let arg = (attrs, lbl, arg_type) in + process (arg :: acc) return_type + | mod_type -> (List.rev acc, mod_type) in process [] modtype -let funExpr expr = +let fun_expr expr = let open Parsetree in (* Turns (type t, type u, type z) into "type t u z" *) - let rec collectNewTypes acc returnExpr = - match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} + let rec collect_new_types acc return_expr = + match return_expr with + | {pexp_desc = Pexp_newtype (string_loc, return_expr); pexp_attributes = []} -> - collectNewTypes (stringLoc :: acc) returnExpr - | returnExpr -> + collect_new_types (string_loc :: acc) return_expr + | return_expr -> let loc = match (acc, List.rev acc) with - | _startLoc :: _, endLoc :: _ -> - {endLoc.loc with loc_end = endLoc.loc.loc_end} + | _startLoc :: _, end_loc :: _ -> + {end_loc.loc with loc_end = end_loc.loc.loc_end} | _ -> Location.none in let txt = @@ -253,7 +253,7 @@ let funExpr expr = (fun curr acc -> acc ^ " " ^ curr.Location.txt) acc "type" in - (Location.mkloc txt loc, returnExpr) + (Location.mkloc txt loc, return_expr) in (* For simplicity reason Pexp_newtype gets converted to a Nolabel parameter, * otherwise this function would need to return a variant: @@ -261,38 +261,38 @@ let funExpr expr = * | NewType(...) * This complicates printing with an extra variant/boxing/allocation for a code-path * that is not often used. Lets just keep it simple for now *) - let rec collect attrsBefore acc expr = + let rec collect attrs_before acc expr = match expr with | { - pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); + pexp_desc = Pexp_fun (lbl, default_expr, pattern, return_expr); pexp_attributes = []; } -> - let parameter = ([], lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let var, returnExpr = collectNewTypes [stringLoc] rest in + let parameter = ([], lbl, default_expr, pattern) in + collect attrs_before (parameter :: acc) return_expr + | {pexp_desc = Pexp_newtype (string_loc, rest); pexp_attributes = attrs} -> + let var, return_expr = collect_new_types [string_loc] rest in let parameter = ( attrs, Asttypes.Nolabel, None, - Ast_helper.Pat.var ~loc:stringLoc.loc var ) + Ast_helper.Pat.var ~loc:string_loc.loc var ) in - collect attrsBefore (parameter :: acc) returnExpr + collect attrs_before (parameter :: acc) return_expr | { - pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); + pexp_desc = Pexp_fun (lbl, default_expr, pattern, return_expr); pexp_attributes = [({txt = "bs"}, _)] as attrs; } -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr + let parameter = (attrs, lbl, default_expr, pattern) in + collect attrs_before (parameter :: acc) return_expr | { pexp_desc = Pexp_fun - (((Labelled _ | Optional _) as lbl), defaultExpr, pattern, returnExpr); + (((Labelled _ | Optional _) as lbl), default_expr, pattern, return_expr); pexp_attributes = attrs; } -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr - | expr -> (attrsBefore, List.rev acc, expr) + let parameter = (attrs, lbl, default_expr, pattern) in + collect attrs_before (parameter :: acc) return_expr + | expr -> (attrs_before, List.rev acc, expr) in match expr with | { @@ -302,19 +302,19 @@ let funExpr expr = collect attrs [] {expr with pexp_attributes = []} | expr -> collect [] [] expr -let rec isBlockExpr expr = +let rec is_block_expr expr = let open Parsetree in match expr.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> true - | Pexp_apply (callExpr, _) when isBlockExpr callExpr -> true - | Pexp_constraint (expr, _) when isBlockExpr expr -> true - | Pexp_field (expr, _) when isBlockExpr expr -> true - | Pexp_setfield (expr, _, _) when isBlockExpr expr -> true + | Pexp_apply (call_expr, _) when is_block_expr call_expr -> true + | Pexp_constraint (expr, _) when is_block_expr expr -> true + | Pexp_field (expr, _) when is_block_expr expr -> true + | Pexp_setfield (expr, _, _) when is_block_expr expr -> true | _ -> false -let isIfThenElseExpr expr = +let is_if_then_else_expr expr = let open Parsetree in match expr.pexp_desc with | Pexp_ifthenelse _ -> true @@ -341,14 +341,14 @@ type node = | TypeDeclaration of Parsetree.type_declaration | ValueBinding of Parsetree.value_binding -let getLoc node = +let get_loc node = let open Parsetree in match node with | Case case -> { case.pc_lhs.ppat_loc with loc_end = - (match ParsetreeViewer.processBracesAttr case.pc_rhs with + (match ParsetreeViewer.process_braces_attr case.pc_rhs with | None, _ -> case.pc_rhs.pexp_loc.loc_end | Some ({loc}, _), _ -> loc.Location.loc_end); } @@ -385,311 +385,332 @@ let getLoc node = | TypeDeclaration td -> td.ptype_loc | ValueBinding vb -> vb.pvb_loc -let rec walkStructure s t comments = +let rec walk_structure s t comments = match s with | _ when comments = [] -> () | [] -> attach t.inside Location.none comments - | s -> walkList (s |> List.map (fun si -> StructureItem si)) t comments + | s -> walk_list (s |> List.map (fun si -> StructureItem si)) t comments -and walkStructureItem si t comments = +and walk_structure_item si t comments = match si.Parsetree.pstr_desc with | _ when comments = [] -> () - | Pstr_primitive valueDescription -> - walkValueDescription valueDescription t comments - | Pstr_open openDescription -> walkOpenDescription openDescription t comments - | Pstr_value (_, valueBindings) -> walkValueBindings valueBindings t comments - | Pstr_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments - | Pstr_eval (expr, _) -> walkExpression expr t comments - | Pstr_module moduleBinding -> walkModuleBinding moduleBinding t comments - | Pstr_recmodule moduleBindings -> - walkList - (moduleBindings |> List.map (fun mb -> ModuleBinding mb)) + | Pstr_primitive value_description -> + walk_value_description value_description t comments + | Pstr_open open_description -> + walk_open_description open_description t comments + | Pstr_value (_, value_bindings) -> + walk_value_bindings value_bindings t comments + | Pstr_type (_, type_declarations) -> + walk_type_declarations type_declarations t comments + | Pstr_eval (expr, _) -> walk_expression expr t comments + | Pstr_module module_binding -> walk_module_binding module_binding t comments + | Pstr_recmodule module_bindings -> + walk_list + (module_bindings |> List.map (fun mb -> ModuleBinding mb)) t comments - | Pstr_modtype modTypDecl -> walkModuleTypeDeclaration modTypDecl t comments - | Pstr_attribute attribute -> walkAttribute attribute t comments - | Pstr_extension (extension, _) -> walkExtension extension t comments - | Pstr_include includeDeclaration -> - walkIncludeDeclaration includeDeclaration t comments - | Pstr_exception extensionConstructor -> - walkExtensionConstructor extensionConstructor t comments - | Pstr_typext typeExtension -> walkTypeExtension typeExtension t comments + | Pstr_modtype mod_typ_decl -> + walk_module_type_declaration mod_typ_decl t comments + | Pstr_attribute attribute -> walk_attribute attribute t comments + | Pstr_extension (extension, _) -> walk_extension extension t comments + | Pstr_include include_declaration -> + walk_include_declaration include_declaration t comments + | Pstr_exception extension_constructor -> + walk_extension_constructor extension_constructor t comments + | Pstr_typext type_extension -> walk_type_extension type_extension t comments | Pstr_class_type _ | Pstr_class _ -> () -and walkValueDescription vd t comments = - let leading, trailing = partitionLeadingTrailing comments vd.pval_name.loc in +and walk_value_description vd t comments = + let leading, trailing = + partition_leading_trailing comments vd.pval_name.loc + in attach t.leading vd.pval_name.loc leading; - let afterName, rest = partitionAdjacentTrailing vd.pval_name.loc trailing in - attach t.trailing vd.pval_name.loc afterName; - let before, inside, after = partitionByLoc rest vd.pval_type.ptyp_loc in + let after_name, rest = + partition_adjacent_trailing vd.pval_name.loc trailing + in + attach t.trailing vd.pval_name.loc after_name; + let before, inside, after = partition_by_loc rest vd.pval_type.ptyp_loc in attach t.leading vd.pval_type.ptyp_loc before; - walkCoreType vd.pval_type t inside; + walk_core_type vd.pval_type t inside; attach t.trailing vd.pval_type.ptyp_loc after -and walkTypeExtension te t comments = +and walk_type_extension te t comments = let leading, trailing = - partitionLeadingTrailing comments te.ptyext_path.loc + partition_leading_trailing comments te.ptyext_path.loc in attach t.leading te.ptyext_path.loc leading; - let afterPath, rest = partitionAdjacentTrailing te.ptyext_path.loc trailing in - attach t.trailing te.ptyext_path.loc afterPath; + let after_path, rest = + partition_adjacent_trailing te.ptyext_path.loc trailing + in + attach t.trailing te.ptyext_path.loc after_path; (* type params *) let rest = match te.ptyext_params with | [] -> rest - | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest + | type_params -> + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walk_node:walk_type_param ~newline_delimited:false type_params t rest in - walkList + walk_list (te.ptyext_constructors |> List.map (fun ec -> ExtensionConstructor ec)) t rest -and walkIncludeDeclaration inclDecl t comments = +and walk_include_declaration incl_decl t comments = let before, inside, after = - partitionByLoc comments inclDecl.pincl_mod.pmod_loc + partition_by_loc comments incl_decl.pincl_mod.pmod_loc in - attach t.leading inclDecl.pincl_mod.pmod_loc before; - walkModuleExpr inclDecl.pincl_mod t inside; - attach t.trailing inclDecl.pincl_mod.pmod_loc after + attach t.leading incl_decl.pincl_mod.pmod_loc before; + walk_module_expr incl_decl.pincl_mod t inside; + attach t.trailing incl_decl.pincl_mod.pmod_loc after -and walkModuleTypeDeclaration mtd t comments = - let leading, trailing = partitionLeadingTrailing comments mtd.pmtd_name.loc in +and walk_module_type_declaration mtd t comments = + let leading, trailing = + partition_leading_trailing comments mtd.pmtd_name.loc + in attach t.leading mtd.pmtd_name.loc leading; match mtd.pmtd_type with | None -> attach t.trailing mtd.pmtd_name.loc trailing - | Some modType -> - let afterName, rest = - partitionAdjacentTrailing mtd.pmtd_name.loc trailing + | Some mod_type -> + let after_name, rest = + partition_adjacent_trailing mtd.pmtd_name.loc trailing in - attach t.trailing mtd.pmtd_name.loc afterName; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - -and walkModuleBinding mb t comments = - let leading, trailing = partitionLeadingTrailing comments mb.pmb_name.loc in + attach t.trailing mtd.pmtd_name.loc after_name; + let before, inside, after = partition_by_loc rest mod_type.pmty_loc in + attach t.leading mod_type.pmty_loc before; + walk_mod_type mod_type t inside; + attach t.trailing mod_type.pmty_loc after + +and walk_module_binding mb t comments = + let leading, trailing = partition_leading_trailing comments mb.pmb_name.loc in attach t.leading mb.pmb_name.loc leading; - let afterName, rest = partitionAdjacentTrailing mb.pmb_name.loc trailing in - attach t.trailing mb.pmb_name.loc afterName; - let leading, inside, trailing = partitionByLoc rest mb.pmb_expr.pmod_loc in + let after_name, rest = partition_adjacent_trailing mb.pmb_name.loc trailing in + attach t.trailing mb.pmb_name.loc after_name; + let leading, inside, trailing = partition_by_loc rest mb.pmb_expr.pmod_loc in (match mb.pmb_expr.pmod_desc with | Pmod_constraint _ -> - walkModuleExpr mb.pmb_expr t (List.concat [leading; inside]) + walk_module_expr mb.pmb_expr t (List.concat [leading; inside]) | _ -> attach t.leading mb.pmb_expr.pmod_loc leading; - walkModuleExpr mb.pmb_expr t inside); + walk_module_expr mb.pmb_expr t inside); attach t.trailing mb.pmb_expr.pmod_loc trailing -and walkSignature signature t comments = +and walk_signature signature t comments = match signature with | _ when comments = [] -> () | [] -> attach t.inside Location.none comments | _s -> - walkList (signature |> List.map (fun si -> SignatureItem si)) t comments + walk_list (signature |> List.map (fun si -> SignatureItem si)) t comments -and walkSignatureItem (si : Parsetree.signature_item) t comments = +and walk_signature_item (si : Parsetree.signature_item) t comments = match si.psig_desc with | _ when comments = [] -> () - | Psig_value valueDescription -> - walkValueDescription valueDescription t comments - | Psig_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments - | Psig_typext typeExtension -> walkTypeExtension typeExtension t comments - | Psig_exception extensionConstructor -> - walkExtensionConstructor extensionConstructor t comments - | Psig_module moduleDeclaration -> - walkModuleDeclaration moduleDeclaration t comments - | Psig_recmodule moduleDeclarations -> - walkList - (moduleDeclarations |> List.map (fun md -> ModuleDeclaration md)) + | Psig_value value_description -> + walk_value_description value_description t comments + | Psig_type (_, type_declarations) -> + walk_type_declarations type_declarations t comments + | Psig_typext type_extension -> walk_type_extension type_extension t comments + | Psig_exception extension_constructor -> + walk_extension_constructor extension_constructor t comments + | Psig_module module_declaration -> + walk_module_declaration module_declaration t comments + | Psig_recmodule module_declarations -> + walk_list + (module_declarations |> List.map (fun md -> ModuleDeclaration md)) t comments - | Psig_modtype moduleTypeDeclaration -> - walkModuleTypeDeclaration moduleTypeDeclaration t comments - | Psig_open openDescription -> walkOpenDescription openDescription t comments - | Psig_include includeDescription -> - walkIncludeDescription includeDescription t comments - | Psig_attribute attribute -> walkAttribute attribute t comments - | Psig_extension (extension, _) -> walkExtension extension t comments + | Psig_modtype module_type_declaration -> + walk_module_type_declaration module_type_declaration t comments + | Psig_open open_description -> + walk_open_description open_description t comments + | Psig_include include_description -> + walk_include_description include_description t comments + | Psig_attribute attribute -> walk_attribute attribute t comments + | Psig_extension (extension, _) -> walk_extension extension t comments | Psig_class _ | Psig_class_type _ -> () -and walkIncludeDescription id t comments = - let before, inside, after = partitionByLoc comments id.pincl_mod.pmty_loc in +and walk_include_description id t comments = + let before, inside, after = partition_by_loc comments id.pincl_mod.pmty_loc in attach t.leading id.pincl_mod.pmty_loc before; - walkModType id.pincl_mod t inside; + walk_mod_type id.pincl_mod t inside; attach t.trailing id.pincl_mod.pmty_loc after -and walkModuleDeclaration md t comments = - let leading, trailing = partitionLeadingTrailing comments md.pmd_name.loc in +and walk_module_declaration md t comments = + let leading, trailing = partition_leading_trailing comments md.pmd_name.loc in attach t.leading md.pmd_name.loc leading; - let afterName, rest = partitionAdjacentTrailing md.pmd_name.loc trailing in - attach t.trailing md.pmd_name.loc afterName; - let leading, inside, trailing = partitionByLoc rest md.pmd_type.pmty_loc in + let after_name, rest = partition_adjacent_trailing md.pmd_name.loc trailing in + attach t.trailing md.pmd_name.loc after_name; + let leading, inside, trailing = partition_by_loc rest md.pmd_type.pmty_loc in attach t.leading md.pmd_type.pmty_loc leading; - walkModType md.pmd_type t inside; + walk_mod_type md.pmd_type t inside; attach t.trailing md.pmd_type.pmty_loc trailing -and walkNode node tbl comments = +and walk_node node tbl comments = match node with - | Case c -> walkCase c tbl comments - | CoreType ct -> walkCoreType ct tbl comments - | ExprArgument ea -> walkExprArgument ea tbl comments - | Expression e -> walkExpression e tbl comments - | ExprRecordRow (ri, e) -> walkExprRecordRow (ri, e) tbl comments - | ExtensionConstructor ec -> walkExtensionConstructor ec tbl comments - | LabelDeclaration ld -> walkLabelDeclaration ld tbl comments - | ModuleBinding mb -> walkModuleBinding mb tbl comments - | ModuleDeclaration md -> walkModuleDeclaration md tbl comments - | ModuleExpr me -> walkModuleExpr me tbl comments - | ObjectField f -> walkObjectField f tbl comments - | PackageConstraint (li, te) -> walkPackageConstraint (li, te) tbl comments - | Pattern p -> walkPattern p tbl comments - | PatternRecordRow (li, p) -> walkPatternRecordRow (li, p) tbl comments - | RowField rf -> walkRowField rf tbl comments - | SignatureItem si -> walkSignatureItem si tbl comments - | StructureItem si -> walkStructureItem si tbl comments - | TypeDeclaration td -> walkTypeDeclaration td tbl comments - | ValueBinding vb -> walkValueBinding vb tbl comments - -and walkList : ?prevLoc:Location.t -> node list -> t -> Comment.t list -> unit = - fun ?prevLoc l t comments -> + | Case c -> walk_case c tbl comments + | CoreType ct -> walk_core_type ct tbl comments + | ExprArgument ea -> walk_expr_argument ea tbl comments + | Expression e -> walk_expression e tbl comments + | ExprRecordRow (ri, e) -> walk_expr_record_row (ri, e) tbl comments + | ExtensionConstructor ec -> walk_extension_constructor ec tbl comments + | LabelDeclaration ld -> walk_label_declaration ld tbl comments + | ModuleBinding mb -> walk_module_binding mb tbl comments + | ModuleDeclaration md -> walk_module_declaration md tbl comments + | ModuleExpr me -> walk_module_expr me tbl comments + | ObjectField f -> walk_object_field f tbl comments + | PackageConstraint (li, te) -> walk_package_constraint (li, te) tbl comments + | Pattern p -> walk_pattern p tbl comments + | PatternRecordRow (li, p) -> walk_pattern_record_row (li, p) tbl comments + | RowField rf -> walk_row_field rf tbl comments + | SignatureItem si -> walk_signature_item si tbl comments + | StructureItem si -> walk_structure_item si tbl comments + | TypeDeclaration td -> walk_type_declaration td tbl comments + | ValueBinding vb -> walk_value_binding vb tbl comments + +and walk_list : ?prev_loc:Location.t -> node list -> t -> Comment.t list -> unit + = + fun ?prev_loc l t comments -> match l with | _ when comments = [] -> () | [] -> ( - match prevLoc with + match prev_loc with | Some loc -> attach t.trailing loc comments | None -> ()) | node :: rest -> - let currLoc = getLoc node in - let leading, inside, trailing = partitionByLoc comments currLoc in - (match prevLoc with + let curr_loc = get_loc node in + let leading, inside, trailing = partition_by_loc comments curr_loc in + (match prev_loc with | None -> (* first node, all leading comments attach here *) - attach t.leading currLoc leading - | Some prevLoc -> + attach t.leading curr_loc leading + | Some prev_loc -> (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then ( - let afterPrev, beforeCurr = partitionAdjacentTrailing prevLoc leading in - attach t.trailing prevLoc afterPrev; - attach t.leading currLoc beforeCurr) + if prev_loc.loc_end.pos_lnum == curr_loc.loc_start.pos_lnum then ( + let after_prev, before_curr = + partition_adjacent_trailing prev_loc leading + in + attach t.trailing prev_loc after_prev; + attach t.leading curr_loc before_curr) else - let onSameLineAsPrev, afterPrev = - partitionByOnSameLine prevLoc leading + let on_same_line_as_prev, after_prev = + partition_by_on_same_line prev_loc leading + in + attach t.trailing prev_loc on_same_line_as_prev; + let leading, _inside, _trailing = + partition_by_loc after_prev curr_loc in - attach t.trailing prevLoc onSameLineAsPrev; - let leading, _inside, _trailing = partitionByLoc afterPrev currLoc in - attach t.leading currLoc leading); - walkNode node t inside; - walkList ~prevLoc:currLoc rest t trailing + attach t.leading curr_loc leading); + walk_node node t inside; + walk_list ~prev_loc:curr_loc rest t trailing (* The parsetree doesn't always contain location info about the opening or * closing token of a "list-of-things". This routine visits the whole list, * but returns any remaining comments that likely fall after the whole list. *) -and visitListButContinueWithRemainingComments : +and visit_list_but_continue_with_remaining_comments : 'node. - ?prevLoc:Location.t -> - newlineDelimited:bool -> - getLoc:('node -> Location.t) -> - walkNode:('node -> t -> Comment.t list -> unit) -> + ?prev_loc:Location.t -> + newline_delimited:bool -> + get_loc:('node -> Location.t) -> + walk_node:('node -> t -> Comment.t list -> unit) -> 'node list -> t -> Comment.t list -> Comment.t list = - fun ?prevLoc ~newlineDelimited ~getLoc ~walkNode l t comments -> + fun ?prev_loc ~newline_delimited ~get_loc ~walk_node l t comments -> let open Location in match l with | _ when comments = [] -> [] | [] -> ( - match prevLoc with + match prev_loc with | Some loc -> - let afterPrev, rest = - if newlineDelimited then partitionByOnSameLine loc comments - else partitionAdjacentTrailing loc comments + let after_prev, rest = + if newline_delimited then partition_by_on_same_line loc comments + else partition_adjacent_trailing loc comments in - attach t.trailing loc afterPrev; + attach t.trailing loc after_prev; rest | None -> comments) | node :: rest -> - let currLoc = getLoc node in - let leading, inside, trailing = partitionByLoc comments currLoc in + let curr_loc = get_loc node in + let leading, inside, trailing = partition_by_loc comments curr_loc in let () = - match prevLoc with + match prev_loc with | None -> (* first node, all leading comments attach here *) - attach t.leading currLoc leading; + attach t.leading curr_loc leading; () - | Some prevLoc -> + | Some prev_loc -> (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then - let afterPrev, beforeCurr = - partitionAdjacentTrailing prevLoc leading + if prev_loc.loc_end.pos_lnum == curr_loc.loc_start.pos_lnum then + let after_prev, before_curr = + partition_adjacent_trailing prev_loc leading in - let () = attach t.trailing prevLoc afterPrev in - let () = attach t.leading currLoc beforeCurr in + let () = attach t.trailing prev_loc after_prev in + let () = attach t.leading curr_loc before_curr in () else - let onSameLineAsPrev, afterPrev = - partitionByOnSameLine prevLoc leading + let on_same_line_as_prev, after_prev = + partition_by_on_same_line prev_loc leading + in + let () = attach t.trailing prev_loc on_same_line_as_prev in + let leading, _inside, _trailing = + partition_by_loc after_prev curr_loc in - let () = attach t.trailing prevLoc onSameLineAsPrev in - let leading, _inside, _trailing = partitionByLoc afterPrev currLoc in - let () = attach t.leading currLoc leading in + let () = attach t.leading curr_loc leading in () in - walkNode node t inside; - visitListButContinueWithRemainingComments ~prevLoc:currLoc ~getLoc ~walkNode - ~newlineDelimited rest t trailing + walk_node node t inside; + visit_list_but_continue_with_remaining_comments ~prev_loc:curr_loc ~get_loc + ~walk_node ~newline_delimited rest t trailing -and walkValueBindings vbs t comments = - walkList (vbs |> List.map (fun vb -> ValueBinding vb)) t comments +and walk_value_bindings vbs t comments = + walk_list (vbs |> List.map (fun vb -> ValueBinding vb)) t comments -and walkOpenDescription openDescription t comments = - let loc = openDescription.popen_lid.loc in - let leading, trailing = partitionLeadingTrailing comments loc in +and walk_open_description open_description t comments = + let loc = open_description.popen_lid.loc in + let leading, trailing = partition_leading_trailing comments loc in attach t.leading loc leading; attach t.trailing loc trailing -and walkTypeDeclarations typeDeclarations t comments = - walkList - (typeDeclarations |> List.map (fun td -> TypeDeclaration td)) +and walk_type_declarations type_declarations t comments = + walk_list + (type_declarations |> List.map (fun td -> TypeDeclaration td)) t comments -and walkTypeParam (typexpr, _variance) t comments = - walkCoreType typexpr t comments +and walk_type_param (typexpr, _variance) t comments = + walk_core_type typexpr t comments -and walkTypeDeclaration (td : Parsetree.type_declaration) t comments = - let beforeName, rest = partitionLeadingTrailing comments td.ptype_name.loc in - attach t.leading td.ptype_name.loc beforeName; +and walk_type_declaration (td : Parsetree.type_declaration) t comments = + let before_name, rest = + partition_leading_trailing comments td.ptype_name.loc + in + attach t.leading td.ptype_name.loc before_name; - let afterName, rest = partitionAdjacentTrailing td.ptype_name.loc rest in - attach t.trailing td.ptype_name.loc afterName; + let after_name, rest = partition_adjacent_trailing td.ptype_name.loc rest in + attach t.trailing td.ptype_name.loc after_name; (* type params *) let rest = match td.ptype_params with | [] -> rest - | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest + | type_params -> + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walk_node:walk_type_param ~newline_delimited:false type_params t rest in (* manifest: = typexpr *) let rest = match td.ptype_manifest with | Some typexpr -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest typexpr.ptyp_loc + let before_typ, inside_typ, after_typ = + partition_by_loc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + let after_typ, rest = + partition_adjacent_trailing typexpr.Parsetree.ptyp_loc after_typ in - attach t.trailing typexpr.ptyp_loc afterTyp; + attach t.trailing typexpr.ptyp_loc after_typ; rest | None -> rest in @@ -697,76 +718,77 @@ and walkTypeDeclaration (td : Parsetree.type_declaration) t comments = let rest = match td.ptype_kind with | Ptype_abstract | Ptype_open -> rest - | Ptype_record labelDeclarations -> + | Ptype_record label_declarations -> let () = - if labelDeclarations = [] then attach t.inside td.ptype_loc rest + if label_declarations = [] then attach t.inside td.ptype_loc rest else - walkList - (labelDeclarations |> List.map (fun ld -> LabelDeclaration ld)) + walk_list + (label_declarations |> List.map (fun ld -> LabelDeclaration ld)) t rest in [] - | Ptype_variant constructorDeclarations -> - walkConstructorDeclarations constructorDeclarations t rest + | Ptype_variant constructor_declarations -> + walk_constructor_declarations constructor_declarations t rest in attach t.trailing td.ptype_loc rest -and walkLabelDeclarations lds t comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun ld -> ld.Parsetree.pld_loc) - ~walkNode:walkLabelDeclaration ~newlineDelimited:false lds t comments - -and walkLabelDeclaration ld t comments = - let beforeName, rest = partitionLeadingTrailing comments ld.pld_name.loc in - attach t.leading ld.pld_name.loc beforeName; - let afterName, rest = partitionAdjacentTrailing ld.pld_name.loc rest in - attach t.trailing ld.pld_name.loc afterName; - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest ld.pld_type.ptyp_loc +and walk_label_declarations lds t comments = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun ld -> ld.Parsetree.pld_loc) + ~walk_node:walk_label_declaration ~newline_delimited:false lds t comments + +and walk_label_declaration ld t comments = + let before_name, rest = partition_leading_trailing comments ld.pld_name.loc in + attach t.leading ld.pld_name.loc before_name; + let after_name, rest = partition_adjacent_trailing ld.pld_name.loc rest in + attach t.trailing ld.pld_name.loc after_name; + let before_typ, inside_typ, after_typ = + partition_by_loc rest ld.pld_type.ptyp_loc in - attach t.leading ld.pld_type.ptyp_loc beforeTyp; - walkCoreType ld.pld_type t insideTyp; - attach t.trailing ld.pld_type.ptyp_loc afterTyp - -and walkConstructorDeclarations cds t comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) - ~walkNode:walkConstructorDeclaration ~newlineDelimited:false cds t comments - -and walkConstructorDeclaration cd t comments = - let beforeName, rest = partitionLeadingTrailing comments cd.pcd_name.loc in - attach t.leading cd.pcd_name.loc beforeName; - let afterName, rest = partitionAdjacentTrailing cd.pcd_name.loc rest in - attach t.trailing cd.pcd_name.loc afterName; - let rest = walkConstructorArguments cd.pcd_args t rest in + attach t.leading ld.pld_type.ptyp_loc before_typ; + walk_core_type ld.pld_type t inside_typ; + attach t.trailing ld.pld_type.ptyp_loc after_typ + +and walk_constructor_declarations cds t comments = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun cd -> cd.Parsetree.pcd_loc) + ~walk_node:walk_constructor_declaration ~newline_delimited:false cds t + comments + +and walk_constructor_declaration cd t comments = + let before_name, rest = partition_leading_trailing comments cd.pcd_name.loc in + attach t.leading cd.pcd_name.loc before_name; + let after_name, rest = partition_adjacent_trailing cd.pcd_name.loc rest in + attach t.trailing cd.pcd_name.loc after_name; + let rest = walk_constructor_arguments cd.pcd_args t rest in let rest = match cd.pcd_res with | Some typexpr -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest typexpr.ptyp_loc + let before_typ, inside_typ, after_typ = + partition_by_loc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + let after_typ, rest = + partition_adjacent_trailing typexpr.Parsetree.ptyp_loc after_typ in - attach t.trailing typexpr.ptyp_loc afterTyp; + attach t.trailing typexpr.ptyp_loc after_typ; rest | None -> rest in attach t.trailing cd.pcd_loc rest -and walkConstructorArguments args t comments = +and walk_constructor_arguments args t comments = match args with | Pcstr_tuple typexprs -> - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Parsetree.ptyp_loc) - ~walkNode:walkCoreType ~newlineDelimited:false typexprs t comments - | Pcstr_record labelDeclarations -> - walkLabelDeclarations labelDeclarations t comments + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun n -> n.Parsetree.ptyp_loc) + ~walk_node:walk_core_type ~newline_delimited:false typexprs t comments + | Pcstr_record label_declarations -> + walk_label_declarations label_declarations t comments -and walkValueBinding vb t comments = +and walk_value_binding vb t comments = let open Location in let vb = let open Parsetree in @@ -794,7 +816,7 @@ and walkValueBinding vb t comments = | ( ({ ppat_desc = Ppat_constraint (pat, ({ptyp_desc = Ptyp_poly (_ :: _, t)} as typ)); - } as constrainedPattern), + } as constrained_pattern), {pexp_desc = Pexp_newtype (_, {pexp_desc = Pexp_constraint (expr, _)})} ) -> (* @@ -810,458 +832,482 @@ and walkValueBinding vb t comments = vb with pvb_pat = { - constrainedPattern with + constrained_pattern with ppat_desc = Ppat_constraint (pat, typ); ppat_loc = - {constrainedPattern.ppat_loc with loc_end = t.ptyp_loc.loc_end}; + {constrained_pattern.ppat_loc with loc_end = t.ptyp_loc.loc_end}; }; pvb_expr = expr; } | _ -> vb in - let patternLoc = vb.Parsetree.pvb_pat.ppat_loc in - let exprLoc = vb.Parsetree.pvb_expr.pexp_loc in + let pattern_loc = vb.Parsetree.pvb_pat.ppat_loc in + let expr_loc = vb.Parsetree.pvb_expr.pexp_loc in let expr = vb.pvb_expr in - let leading, inside, trailing = partitionByLoc comments patternLoc in + let leading, inside, trailing = partition_by_loc comments pattern_loc in (* everything before start of pattern can only be leading on the pattern: * let |* before *| a = 1 *) - attach t.leading patternLoc leading; - walkPattern vb.Parsetree.pvb_pat t inside; - let afterPat, surroundingExpr = - partitionAdjacentTrailing patternLoc trailing + attach t.leading pattern_loc leading; + walk_pattern vb.Parsetree.pvb_pat t inside; + let after_pat, surrounding_expr = + partition_adjacent_trailing pattern_loc trailing in - attach t.trailing patternLoc afterPat; - let beforeExpr, insideExpr, afterExpr = - partitionByLoc surroundingExpr exprLoc + attach t.trailing pattern_loc after_pat; + let before_expr, inside_expr, after_expr = + partition_by_loc surrounding_expr expr_loc in - if isBlockExpr expr then - walkExpression expr t (List.concat [beforeExpr; insideExpr; afterExpr]) + if is_block_expr expr then + walk_expression expr t (List.concat [before_expr; inside_expr; after_expr]) else ( - attach t.leading exprLoc beforeExpr; - walkExpression expr t insideExpr; - attach t.trailing exprLoc afterExpr) + attach t.leading expr_loc before_expr; + walk_expression expr t inside_expr; + attach t.trailing expr_loc after_expr) -and walkExpression expr t comments = +and walk_expression expr t comments = let open Location in match expr.Parsetree.pexp_desc with | _ when comments = [] -> () | Pexp_constant _ -> - let leading, trailing = partitionLeadingTrailing comments expr.pexp_loc in + let leading, trailing = partition_leading_trailing comments expr.pexp_loc in attach t.leading expr.pexp_loc leading; attach t.trailing expr.pexp_loc trailing | Pexp_ident longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in + let leading, trailing = partition_leading_trailing comments longident.loc in attach t.leading longident.loc leading; attach t.trailing longident.loc trailing | Pexp_let ( _recFlag, - valueBindings, + value_bindings, {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} ) -> - walkValueBindings valueBindings t comments - | Pexp_let (_recFlag, valueBindings, expr2) -> + walk_value_bindings value_bindings t comments + | Pexp_let (_recFlag, value_bindings, expr2) -> let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun n -> if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then n.pvb_expr.pexp_loc else n.Parsetree.pvb_loc) - ~walkNode:walkValueBinding ~newlineDelimited:true valueBindings t + ~walk_node:walk_value_binding ~newline_delimited:true value_bindings t comments in - if isBlockExpr expr2 then walkExpression expr2 t comments + if is_block_expr expr2 then walk_expression expr2 t comments else - let leading, inside, trailing = partitionByLoc comments expr2.pexp_loc in + let leading, inside, trailing = + partition_by_loc comments expr2.pexp_loc + in attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; + walk_expression expr2 t inside; attach t.trailing expr2.pexp_loc trailing | Pexp_sequence (expr1, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let leading, inside, trailing = partition_by_loc comments expr1.pexp_loc in let comments = - if isBlockExpr expr1 then ( - let afterExpr, comments = - partitionByOnSameLine expr1.pexp_loc trailing + if is_block_expr expr1 then ( + let after_expr, comments = + partition_by_on_same_line expr1.pexp_loc trailing in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); + walk_expression expr1 t (List.concat [leading; inside; after_expr]); comments) else ( attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, comments = - partitionByOnSameLine expr1.pexp_loc trailing + walk_expression expr1 t inside; + let after_expr, comments = + partition_by_on_same_line expr1.pexp_loc trailing in - attach t.trailing expr1.pexp_loc afterExpr; + attach t.trailing expr1.pexp_loc after_expr; comments) in - if isBlockExpr expr2 then walkExpression expr2 t comments + if is_block_expr expr2 then walk_expression expr2 t comments else - let leading, inside, trailing = partitionByLoc comments expr2.pexp_loc in + let leading, inside, trailing = + partition_by_loc comments expr2.pexp_loc + in attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; + walk_expression expr2 t inside; attach t.trailing expr2.pexp_loc trailing | Pexp_open (_override, longident, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + let leading, comments = partition_leading_trailing comments expr.pexp_loc in attach t.leading {expr.pexp_loc with loc_end = longident.loc.loc_end} leading; - let leading, trailing = partitionLeadingTrailing comments longident.loc in + let leading, trailing = partition_leading_trailing comments longident.loc in attach t.leading longident.loc leading; - let afterLongident, rest = partitionByOnSameLine longident.loc trailing in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then walkExpression expr2 t rest + let after_longident, rest = + partition_by_on_same_line longident.loc trailing + in + attach t.trailing longident.loc after_longident; + if is_block_expr expr2 then walk_expression expr2 t rest else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; + walk_expression expr2 t inside; attach t.trailing expr2.pexp_loc trailing | Pexp_extension - ( {txt = "bs.obj" | "obj"}, + ( {txt = "obj"}, PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, [])}] ) -> - walkList + walk_list (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) t comments - | Pexp_extension extension -> walkExtension extension t comments - | Pexp_letexception (extensionConstructor, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + | Pexp_extension extension -> walk_extension extension t comments + | Pexp_letexception (extension_constructor, expr2) -> + let leading, comments = partition_leading_trailing comments expr.pexp_loc in attach t.leading - {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} + {expr.pexp_loc with loc_end = extension_constructor.pext_loc.loc_end} leading; let leading, inside, trailing = - partitionByLoc comments extensionConstructor.pext_loc + partition_by_loc comments extension_constructor.pext_loc in - attach t.leading extensionConstructor.pext_loc leading; - walkExtensionConstructor extensionConstructor t inside; - let afterExtConstr, rest = - partitionByOnSameLine extensionConstructor.pext_loc trailing + attach t.leading extension_constructor.pext_loc leading; + walk_extension_constructor extension_constructor t inside; + let after_ext_constr, rest = + partition_by_on_same_line extension_constructor.pext_loc trailing in - attach t.trailing extensionConstructor.pext_loc afterExtConstr; - if isBlockExpr expr2 then walkExpression expr2 t rest + attach t.trailing extension_constructor.pext_loc after_ext_constr; + if is_block_expr expr2 then walk_expression expr2 t rest else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; + walk_expression expr2 t inside; attach t.trailing expr2.pexp_loc trailing - | Pexp_letmodule (stringLoc, modExpr, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in + | Pexp_letmodule (string_loc, mod_expr, expr2) -> + let leading, comments = partition_leading_trailing comments expr.pexp_loc in attach t.leading - {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} + {expr.pexp_loc with loc_end = mod_expr.pmod_loc.loc_end} leading; - let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - let afterString, rest = partitionAdjacentTrailing stringLoc.loc trailing in - attach t.trailing stringLoc.loc afterString; - let beforeModExpr, insideModExpr, afterModExpr = - partitionByLoc rest modExpr.pmod_loc + let leading, trailing = + partition_leading_trailing comments string_loc.loc + in + attach t.leading string_loc.loc leading; + let after_string, rest = + partition_adjacent_trailing string_loc.loc trailing + in + attach t.trailing string_loc.loc after_string; + let before_mod_expr, inside_mod_expr, after_mod_expr = + partition_by_loc rest mod_expr.pmod_loc in - attach t.leading modExpr.pmod_loc beforeModExpr; - walkModuleExpr modExpr t insideModExpr; - let afterModExpr, rest = - partitionByOnSameLine modExpr.pmod_loc afterModExpr + attach t.leading mod_expr.pmod_loc before_mod_expr; + walk_module_expr mod_expr t inside_mod_expr; + let after_mod_expr, rest = + partition_by_on_same_line mod_expr.pmod_loc after_mod_expr in - attach t.trailing modExpr.pmod_loc afterModExpr; - if isBlockExpr expr2 then walkExpression expr2 t rest + attach t.trailing mod_expr.pmod_loc after_mod_expr; + if is_block_expr expr2 then walk_expression expr2 t rest else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; + walk_expression expr2 t inside; attach t.trailing expr2.pexp_loc trailing | Pexp_assert expr | Pexp_lazy expr -> - if isBlockExpr expr then walkExpression expr t comments + if is_block_expr expr then walk_expression expr t comments else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + let leading, inside, trailing = partition_by_loc comments expr.pexp_loc in attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; + walk_expression expr t inside; attach t.trailing expr.pexp_loc trailing - | Pexp_coerce (expr, optTypexpr, typexpr) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + | Pexp_coerce (expr, opt_typexpr, typexpr) -> + let leading, inside, trailing = partition_by_loc comments expr.pexp_loc in attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; + walk_expression expr t inside; + let after_expr, rest = partition_adjacent_trailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc after_expr; let rest = - match optTypexpr with + match opt_typexpr with | Some typexpr -> let leading, inside, trailing = - partitionByLoc comments typexpr.ptyp_loc + partition_by_loc comments typexpr.ptyp_loc in attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.ptyp_loc trailing + walk_core_type typexpr t inside; + let after_typ, rest = + partition_adjacent_trailing typexpr.ptyp_loc trailing in - attach t.trailing typexpr.ptyp_loc afterTyp; + attach t.trailing typexpr.ptyp_loc after_typ; rest | None -> rest in - let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in + let leading, inside, trailing = partition_by_loc rest typexpr.ptyp_loc in attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; + walk_core_type typexpr t inside; attach t.trailing typexpr.ptyp_loc trailing | Pexp_constraint (expr, typexpr) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + let leading, inside, trailing = partition_by_loc comments expr.pexp_loc in attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in + walk_expression expr t inside; + let after_expr, rest = partition_adjacent_trailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc after_expr; + let leading, inside, trailing = partition_by_loc rest typexpr.ptyp_loc in attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; + walk_core_type typexpr t inside; attach t.trailing typexpr.ptyp_loc trailing | Pexp_tuple [] | Pexp_array [] | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> attach t.inside expr.pexp_loc comments | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - walkList - (collectListExprs [] expr |> List.map (fun e -> Expression e)) + walk_list + (collect_list_exprs [] expr |> List.map (fun e -> Expression e)) t comments | Pexp_construct (longident, args) -> ( - let leading, trailing = partitionLeadingTrailing comments longident.loc in + let leading, trailing = partition_leading_trailing comments longident.loc in attach t.leading longident.loc leading; match args with | Some expr -> - let afterLongident, rest = - partitionAdjacentTrailing longident.loc trailing + let after_longident, rest = + partition_adjacent_trailing longident.loc trailing in - attach t.trailing longident.loc afterLongident; - walkExpression expr t rest + attach t.trailing longident.loc after_longident; + walk_expression expr t rest | None -> attach t.trailing longident.loc trailing) | Pexp_variant (_label, None) -> () - | Pexp_variant (_label, Some expr) -> walkExpression expr t comments + | Pexp_variant (_label, Some expr) -> walk_expression expr t comments | Pexp_array exprs | Pexp_tuple exprs -> - walkList (exprs |> List.map (fun e -> Expression e)) t comments - | Pexp_record (rows, spreadExpr) -> + walk_list (exprs |> List.map (fun e -> Expression e)) t comments + | Pexp_record (rows, spread_expr) -> if rows = [] then attach t.inside expr.pexp_loc comments else let comments = - match spreadExpr with + match spread_expr with | None -> comments | Some expr -> let leading, inside, trailing = - partitionByLoc comments expr.pexp_loc + partition_by_loc comments expr.pexp_loc in attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = - partitionAdjacentTrailing expr.pexp_loc trailing + walk_expression expr t inside; + let after_expr, rest = + partition_adjacent_trailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; + attach t.trailing expr.pexp_loc after_expr; rest in - walkList + walk_list (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) t comments | Pexp_field (expr, longident) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + let leading, inside, trailing = partition_by_loc comments expr.pexp_loc in let trailing = - if isBlockExpr expr then ( - let afterExpr, rest = - partitionAdjacentTrailing expr.pexp_loc trailing + if is_block_expr expr then ( + let after_expr, rest = + partition_adjacent_trailing expr.pexp_loc trailing in - walkExpression expr t (List.concat [leading; inside; afterExpr]); + walk_expression expr t (List.concat [leading; inside; after_expr]); rest) else ( attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; + walk_expression expr t inside; trailing) in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let leading, trailing = partitionLeadingTrailing rest longident.loc in + let after_expr, rest = partition_adjacent_trailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc after_expr; + let leading, trailing = partition_leading_trailing rest longident.loc in attach t.leading longident.loc leading; attach t.trailing longident.loc trailing | Pexp_setfield (expr1, longident, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let leading, inside, trailing = partition_by_loc comments expr1.pexp_loc in let rest = - if isBlockExpr expr1 then ( - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing + if is_block_expr expr1 then ( + let after_expr, rest = + partition_adjacent_trailing expr1.pexp_loc trailing in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); + walk_expression expr1 t (List.concat [leading; inside; after_expr]); rest) else - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing + let after_expr, rest = + partition_adjacent_trailing expr1.pexp_loc trailing in attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - attach t.trailing expr1.pexp_loc afterExpr; + walk_expression expr1 t inside; + attach t.trailing expr1.pexp_loc after_expr; rest in - let beforeLongident, afterLongident = - partitionLeadingTrailing rest longident.loc + let before_longident, after_longident = + partition_leading_trailing rest longident.loc in - attach t.leading longident.loc beforeLongident; - let afterLongident, rest = - partitionAdjacentTrailing longident.loc afterLongident + attach t.leading longident.loc before_longident; + let after_longident, rest = + partition_adjacent_trailing longident.loc after_longident in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then walkExpression expr2 t rest + attach t.trailing longident.loc after_longident; + if is_block_expr expr2 then walk_expression expr2 t rest else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; + walk_expression expr2 t inside; attach t.trailing expr2.pexp_loc trailing - | Pexp_ifthenelse (ifExpr, thenExpr, elseExpr) -> ( - let leading, rest = partitionLeadingTrailing comments expr.pexp_loc in + | Pexp_ifthenelse (if_expr, then_expr, else_expr) -> ( + let leading, rest = partition_leading_trailing comments expr.pexp_loc in attach t.leading expr.pexp_loc leading; - let leading, inside, trailing = partitionByLoc rest ifExpr.pexp_loc in + let leading, inside, trailing = partition_by_loc rest if_expr.pexp_loc in let comments = - if isBlockExpr ifExpr then ( - let afterExpr, comments = - partitionAdjacentTrailing ifExpr.pexp_loc trailing + if is_block_expr if_expr then ( + let after_expr, comments = + partition_adjacent_trailing if_expr.pexp_loc trailing in - walkExpression ifExpr t (List.concat [leading; inside; afterExpr]); + walk_expression if_expr t (List.concat [leading; inside; after_expr]); comments) else ( - attach t.leading ifExpr.pexp_loc leading; - walkExpression ifExpr t inside; - let afterExpr, comments = - partitionAdjacentTrailing ifExpr.pexp_loc trailing + attach t.leading if_expr.pexp_loc leading; + walk_expression if_expr t inside; + let after_expr, comments = + partition_adjacent_trailing if_expr.pexp_loc trailing in - attach t.trailing ifExpr.pexp_loc afterExpr; + attach t.trailing if_expr.pexp_loc after_expr; comments) in - let leading, inside, trailing = partitionByLoc comments thenExpr.pexp_loc in + let leading, inside, trailing = + partition_by_loc comments then_expr.pexp_loc + in let comments = - if isBlockExpr thenExpr then ( - let afterExpr, trailing = - partitionAdjacentTrailing thenExpr.pexp_loc trailing + if is_block_expr then_expr then ( + let after_expr, trailing = + partition_adjacent_trailing then_expr.pexp_loc trailing in - walkExpression thenExpr t (List.concat [leading; inside; afterExpr]); + walk_expression then_expr t (List.concat [leading; inside; after_expr]); trailing) else ( - attach t.leading thenExpr.pexp_loc leading; - walkExpression thenExpr t inside; - let afterExpr, comments = - partitionAdjacentTrailing thenExpr.pexp_loc trailing + attach t.leading then_expr.pexp_loc leading; + walk_expression then_expr t inside; + let after_expr, comments = + partition_adjacent_trailing then_expr.pexp_loc trailing in - attach t.trailing thenExpr.pexp_loc afterExpr; + attach t.trailing then_expr.pexp_loc after_expr; comments) in - match elseExpr with + match else_expr with | None -> () | Some expr -> - if isBlockExpr expr || isIfThenElseExpr expr then - walkExpression expr t comments + if is_block_expr expr || is_if_then_else_expr expr then + walk_expression expr t comments else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + let leading, inside, trailing = + partition_by_loc comments expr.pexp_loc + in attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; + walk_expression expr t inside; attach t.trailing expr.pexp_loc trailing) | Pexp_while (expr1, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in + let leading, inside, trailing = partition_by_loc comments expr1.pexp_loc in let rest = - if isBlockExpr expr1 then ( - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing + if is_block_expr expr1 then ( + let after_expr, rest = + partition_adjacent_trailing expr1.pexp_loc trailing in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); + walk_expression expr1 t (List.concat [leading; inside; after_expr]); rest) else ( attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing + walk_expression expr1 t inside; + let after_expr, rest = + partition_adjacent_trailing expr1.pexp_loc trailing in - attach t.trailing expr1.pexp_loc afterExpr; + attach t.trailing expr1.pexp_loc after_expr; rest) in - if isBlockExpr expr2 then walkExpression expr2 t rest + if is_block_expr expr2 then walk_expression expr2 t rest else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; + walk_expression expr2 t inside; attach t.trailing expr2.pexp_loc trailing | Pexp_for (pat, expr1, expr2, _, expr3) -> - let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in + let leading, inside, trailing = partition_by_loc comments pat.ppat_loc in attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in - attach t.trailing pat.ppat_loc afterPat; - let leading, inside, trailing = partitionByLoc rest expr1.pexp_loc in + walk_pattern pat t inside; + let after_pat, rest = partition_adjacent_trailing pat.ppat_loc trailing in + attach t.trailing pat.ppat_loc after_pat; + let leading, inside, trailing = partition_by_loc rest expr1.pexp_loc in attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc trailing in - attach t.trailing expr1.pexp_loc afterExpr; - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in + walk_expression expr1 t inside; + let after_expr, rest = + partition_adjacent_trailing expr1.pexp_loc trailing + in + attach t.trailing expr1.pexp_loc after_expr; + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr2.pexp_loc trailing in - attach t.trailing expr2.pexp_loc afterExpr; - if isBlockExpr expr3 then walkExpression expr3 t rest + walk_expression expr2 t inside; + let after_expr, rest = + partition_adjacent_trailing expr2.pexp_loc trailing + in + attach t.trailing expr2.pexp_loc after_expr; + if is_block_expr expr3 then walk_expression expr3 t rest else - let leading, inside, trailing = partitionByLoc rest expr3.pexp_loc in + let leading, inside, trailing = partition_by_loc rest expr3.pexp_loc in attach t.leading expr3.pexp_loc leading; - walkExpression expr3 t inside; + walk_expression expr3 t inside; attach t.trailing expr3.pexp_loc trailing - | Pexp_pack modExpr -> - let before, inside, after = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | Pexp_match (expr1, [case; elseBranch]) - when Res_parsetree_viewer.hasIfLetAttribute expr.pexp_attributes -> - let before, inside, after = partitionByLoc comments case.pc_lhs.ppat_loc in + | Pexp_pack mod_expr -> + let before, inside, after = partition_by_loc comments mod_expr.pmod_loc in + attach t.leading mod_expr.pmod_loc before; + walk_module_expr mod_expr t inside; + attach t.trailing mod_expr.pmod_loc after + | Pexp_match (expr1, [case; else_branch]) + when Res_parsetree_viewer.has_if_let_attribute expr.pexp_attributes -> + let before, inside, after = + partition_by_loc comments case.pc_lhs.ppat_loc + in attach t.leading case.pc_lhs.ppat_loc before; - walkPattern case.pc_lhs t inside; - let afterPat, rest = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in - attach t.trailing case.pc_lhs.ppat_loc afterPat; - let before, inside, after = partitionByLoc rest expr1.pexp_loc in + walk_pattern case.pc_lhs t inside; + let after_pat, rest = + partition_adjacent_trailing case.pc_lhs.ppat_loc after + in + attach t.trailing case.pc_lhs.ppat_loc after_pat; + let before, inside, after = partition_by_loc rest expr1.pexp_loc in attach t.leading expr1.pexp_loc before; - walkExpression expr1 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc after in - attach t.trailing expr1.pexp_loc afterExpr; - let before, inside, after = partitionByLoc rest case.pc_rhs.pexp_loc in + walk_expression expr1 t inside; + let after_expr, rest = partition_adjacent_trailing expr1.pexp_loc after in + attach t.trailing expr1.pexp_loc after_expr; + let before, inside, after = partition_by_loc rest case.pc_rhs.pexp_loc in let after = - if isBlockExpr case.pc_rhs then ( - let afterExpr, rest = - partitionAdjacentTrailing case.pc_rhs.pexp_loc after + if is_block_expr case.pc_rhs then ( + let after_expr, rest = + partition_adjacent_trailing case.pc_rhs.pexp_loc after in - walkExpression case.pc_rhs t (List.concat [before; inside; afterExpr]); + walk_expression case.pc_rhs t (List.concat [before; inside; after_expr]); rest) else ( attach t.leading case.pc_rhs.pexp_loc before; - walkExpression case.pc_rhs t inside; + walk_expression case.pc_rhs t inside; after) in - let afterExpr, rest = - partitionAdjacentTrailing case.pc_rhs.pexp_loc after + let after_expr, rest = + partition_adjacent_trailing case.pc_rhs.pexp_loc after in - attach t.trailing case.pc_rhs.pexp_loc afterExpr; + attach t.trailing case.pc_rhs.pexp_loc after_expr; let before, inside, after = - partitionByLoc rest elseBranch.pc_rhs.pexp_loc + partition_by_loc rest else_branch.pc_rhs.pexp_loc in let after = - if isBlockExpr elseBranch.pc_rhs then ( - let afterExpr, rest = - partitionAdjacentTrailing elseBranch.pc_rhs.pexp_loc after + if is_block_expr else_branch.pc_rhs then ( + let after_expr, rest = + partition_adjacent_trailing else_branch.pc_rhs.pexp_loc after in - walkExpression elseBranch.pc_rhs t - (List.concat [before; inside; afterExpr]); + walk_expression else_branch.pc_rhs t + (List.concat [before; inside; after_expr]); rest) else ( - attach t.leading elseBranch.pc_rhs.pexp_loc before; - walkExpression elseBranch.pc_rhs t inside; + attach t.leading else_branch.pc_rhs.pexp_loc before; + walk_expression else_branch.pc_rhs t inside; after) in - attach t.trailing elseBranch.pc_rhs.pexp_loc after + attach t.trailing else_branch.pc_rhs.pexp_loc after | Pexp_match (expr, cases) | Pexp_try (expr, cases) -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in + let before, inside, after = partition_by_loc comments expr.pexp_loc in let after = - if isBlockExpr expr then ( - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - walkExpression expr t (List.concat [before; inside; afterExpr]); + if is_block_expr expr then ( + let after_expr, rest = + partition_adjacent_trailing expr.pexp_loc after + in + walk_expression expr t (List.concat [before; inside; after_expr]); rest) else ( attach t.leading expr.pexp_loc before; - walkExpression expr t inside; + walk_expression expr t inside; after) in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - attach t.trailing expr.pexp_loc afterExpr; - walkList (cases |> List.map (fun case -> Case case)) t rest + let after_expr, rest = partition_adjacent_trailing expr.pexp_loc after in + attach t.trailing expr.pexp_loc after_expr; + walk_list (cases |> List.map (fun case -> Case case)) t rest (* unary expression: todo use parsetreeviewer *) | Pexp_apply ( { @@ -1272,11 +1318,11 @@ and walkExpression expr t comments = Longident.Lident ("~+" | "~+." | "~-" | "~-." | "not" | "!"); }; }, - [(Nolabel, argExpr)] ) -> - let before, inside, after = partitionByLoc comments argExpr.pexp_loc in - attach t.leading argExpr.pexp_loc before; - walkExpression argExpr t inside; - attach t.trailing argExpr.pexp_loc after + [(Nolabel, arg_expr)] ) -> + let before, inside, after = partition_by_loc comments arg_expr.pexp_loc in + attach t.leading arg_expr.pexp_loc before; + walk_expression arg_expr t inside; + attach t.trailing arg_expr.pexp_loc after (* binary expression *) | Pexp_apply ( { @@ -1291,44 +1337,44 @@ and walkExpression expr t comments = }; }, [(Nolabel, operand1); (Nolabel, operand2)] ) -> - let before, inside, after = partitionByLoc comments operand1.pexp_loc in + let before, inside, after = partition_by_loc comments operand1.pexp_loc in attach t.leading operand1.pexp_loc before; - walkExpression operand1 t inside; - let afterOperand1, rest = - partitionAdjacentTrailing operand1.pexp_loc after + walk_expression operand1 t inside; + let after_operand1, rest = + partition_adjacent_trailing operand1.pexp_loc after in - attach t.trailing operand1.pexp_loc afterOperand1; - let before, inside, after = partitionByLoc rest operand2.pexp_loc in + attach t.trailing operand1.pexp_loc after_operand1; + let before, inside, after = partition_by_loc rest operand2.pexp_loc in attach t.leading operand2.pexp_loc before; - walkExpression operand2 t inside; + walk_expression operand2 t inside; (* (List.concat [inside; after]); *) attach t.trailing operand2.pexp_loc after | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> - walkList [Expression parentExpr; Expression memberExpr] t comments + [(Nolabel, parent_expr); (Nolabel, member_expr)] ) -> + walk_list [Expression parent_expr; Expression member_expr] t comments | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr)] ) - -> - walkList - [Expression parentExpr; Expression memberExpr; Expression targetExpr] + [(Nolabel, parent_expr); (Nolabel, member_expr); (Nolabel, target_expr)] + ) -> + walk_list + [Expression parent_expr; Expression member_expr; Expression target_expr] t comments - | Pexp_apply (callExpr, arguments) -> - let before, inside, after = partitionByLoc comments callExpr.pexp_loc in + | Pexp_apply (call_expr, arguments) -> + let before, inside, after = partition_by_loc comments call_expr.pexp_loc in let after = - if isBlockExpr callExpr then ( - let afterExpr, rest = - partitionAdjacentTrailing callExpr.pexp_loc after + if is_block_expr call_expr then ( + let after_expr, rest = + partition_adjacent_trailing call_expr.pexp_loc after in - walkExpression callExpr t (List.concat [before; inside; afterExpr]); + walk_expression call_expr t (List.concat [before; inside; after_expr]); rest) else ( - attach t.leading callExpr.pexp_loc before; - walkExpression callExpr t inside; + attach t.leading call_expr.pexp_loc before; + walk_expression call_expr t inside; after) in - if ParsetreeViewer.isJsxExpression expr then ( + if ParsetreeViewer.is_jsx_expression expr then ( let props = arguments |> List.filter (fun (label, _) -> @@ -1337,16 +1383,16 @@ and walkExpression expr t comments = | Asttypes.Nolabel -> false | _ -> true) in - let maybeChildren = + let maybe_children = arguments |> List.find_opt (fun (label, _) -> label = Asttypes.Labelled "children") in - match maybeChildren with + match maybe_children with (* There is no need to deal with this situation as the children cannot be NONE *) | None -> () | Some (_, children) -> - let leading, inside, _ = partitionByLoc after children.pexp_loc in + let leading, inside, _ = partition_by_loc after children.pexp_loc in if props = [] then (* All comments inside a tag are trailing comments of the tag if there are no props *) - let afterExpr, _ = - partitionAdjacentTrailing callExpr.pexp_loc after + let after_expr, _ = + partition_adjacent_trailing call_expr.pexp_loc after in - attach t.trailing callExpr.pexp_loc afterExpr + attach t.trailing call_expr.pexp_loc after_expr else - walkList (props |> List.map (fun (_, e) -> ExprArgument e)) t leading; - walkExpression children t inside) + walk_list (props |> List.map (fun (_, e) -> ExprArgument e)) t leading; + walk_expression children t inside) else - let afterExpr, rest = partitionAdjacentTrailing callExpr.pexp_loc after in - attach t.trailing callExpr.pexp_loc afterExpr; - walkList (arguments |> List.map (fun (_, e) -> ExprArgument e)) t rest + let after_expr, rest = + partition_adjacent_trailing call_expr.pexp_loc after + in + attach t.trailing call_expr.pexp_loc after_expr; + walk_list (arguments |> List.map (fun (_, e) -> ExprArgument e)) t rest | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> ( - let _, parameters, returnExpr = funExpr expr in + let _, parameters, return_expr = fun_expr expr in let comments = - visitListButContinueWithRemainingComments ~newlineDelimited:false - ~walkNode:walkExprPararameter - ~getLoc:(fun (_attrs, _argLbl, exprOpt, pattern) -> + visit_list_but_continue_with_remaining_comments ~newline_delimited:false + ~walk_node:walk_expr_pararameter + ~get_loc:(fun (_attrs, _argLbl, expr_opt, pattern) -> let open Parsetree in - let startPos = + let start_pos = match pattern.ppat_attributes with | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> loc.loc_start | _ -> pattern.ppat_loc.loc_start in - match exprOpt with - | None -> {pattern.ppat_loc with loc_start = startPos} + match expr_opt with + | None -> {pattern.ppat_loc with loc_start = start_pos} | Some expr -> { pattern.ppat_loc with - loc_start = startPos; + loc_start = start_pos; loc_end = expr.pexp_loc.loc_end; }) parameters t comments in - match returnExpr.pexp_desc with + match return_expr.pexp_desc with | Pexp_constraint (expr, typ) when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum -> - let leading, inside, trailing = partitionByLoc comments typ.ptyp_loc in + let leading, inside, trailing = partition_by_loc comments typ.ptyp_loc in attach t.leading typ.ptyp_loc leading; - walkCoreType typ t inside; - let afterTyp, comments = - partitionAdjacentTrailing typ.ptyp_loc trailing + walk_core_type typ t inside; + let after_typ, comments = + partition_adjacent_trailing typ.ptyp_loc trailing in - attach t.trailing typ.ptyp_loc afterTyp; - if isBlockExpr expr then walkExpression expr t comments + attach t.trailing typ.ptyp_loc after_typ; + if is_block_expr expr then walk_expression expr t comments else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in + let leading, inside, trailing = + partition_by_loc comments expr.pexp_loc + in attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; + walk_expression expr t inside; attach t.trailing expr.pexp_loc trailing | _ -> - if isBlockExpr returnExpr then walkExpression returnExpr t comments + if is_block_expr return_expr then walk_expression return_expr t comments else let leading, inside, trailing = - partitionByLoc comments returnExpr.pexp_loc + partition_by_loc comments return_expr.pexp_loc in - attach t.leading returnExpr.pexp_loc leading; - walkExpression returnExpr t inside; - attach t.trailing returnExpr.pexp_loc trailing) + attach t.leading return_expr.pexp_loc leading; + walk_expression return_expr t inside; + attach t.trailing return_expr.pexp_loc trailing) | _ -> () -and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = - let leading, inside, trailing = partitionByLoc comments pattern.ppat_loc in +and walk_expr_pararameter (_attrs, _argLbl, expr_opt, pattern) t comments = + let leading, inside, trailing = partition_by_loc comments pattern.ppat_loc in attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - match exprOpt with + walk_pattern pattern t inside; + match expr_opt with | Some expr -> - let _afterPat, rest = partitionAdjacentTrailing pattern.ppat_loc trailing in + let _afterPat, rest = + partition_adjacent_trailing pattern.ppat_loc trailing + in attach t.trailing pattern.ppat_loc trailing; - if isBlockExpr expr then walkExpression expr t rest + if is_block_expr expr then walk_expression expr t rest else - let leading, inside, trailing = partitionByLoc rest expr.pexp_loc in + let leading, inside, trailing = partition_by_loc rest expr.pexp_loc in attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; + walk_expression expr t inside; attach t.trailing expr.pexp_loc trailing | None -> attach t.trailing pattern.ppat_loc trailing -and walkExprArgument expr t comments = +and walk_expr_argument expr t comments = match expr.Parsetree.pexp_attributes with | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> - let leading, trailing = partitionLeadingTrailing comments loc in + let leading, trailing = partition_leading_trailing comments loc in attach t.leading loc leading; - let afterLabel, rest = partitionAdjacentTrailing loc trailing in - attach t.trailing loc afterLabel; - let before, inside, after = partitionByLoc rest expr.pexp_loc in + let after_label, rest = partition_adjacent_trailing loc trailing in + attach t.trailing loc after_label; + let before, inside, after = partition_by_loc rest expr.pexp_loc in attach t.leading expr.pexp_loc before; - walkExpression expr t inside; + walk_expression expr t inside; attach t.trailing expr.pexp_loc after | _ -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in + let before, inside, after = partition_by_loc comments expr.pexp_loc in attach t.leading expr.pexp_loc before; - walkExpression expr t inside; + walk_expression expr t inside; attach t.trailing expr.pexp_loc after -and walkCase (case : Parsetree.case) t comments = - let before, inside, after = partitionByLoc comments case.pc_lhs.ppat_loc in +and walk_case (case : Parsetree.case) t comments = + let before, inside, after = partition_by_loc comments case.pc_lhs.ppat_loc in (* cases don't have a location on their own, leading comments should go * after the bar on the pattern *) - walkPattern case.pc_lhs t (List.concat [before; inside]); - let afterPat, rest = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in - attach t.trailing case.pc_lhs.ppat_loc afterPat; + walk_pattern case.pc_lhs t (List.concat [before; inside]); + let after_pat, rest = + partition_adjacent_trailing case.pc_lhs.ppat_loc after + in + attach t.trailing case.pc_lhs.ppat_loc after_pat; let comments = match case.pc_guard with | Some expr -> - let before, inside, after = partitionByLoc rest expr.pexp_loc in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - if isBlockExpr expr then - walkExpression expr t (List.concat [before; inside; afterExpr]) + let before, inside, after = partition_by_loc rest expr.pexp_loc in + let after_expr, rest = partition_adjacent_trailing expr.pexp_loc after in + if is_block_expr expr then + walk_expression expr t (List.concat [before; inside; after_expr]) else ( attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc afterExpr); + walk_expression expr t inside; + attach t.trailing expr.pexp_loc after_expr); rest | None -> rest in - if isBlockExpr case.pc_rhs then walkExpression case.pc_rhs t comments + if is_block_expr case.pc_rhs then walk_expression case.pc_rhs t comments else - let before, inside, after = partitionByLoc comments case.pc_rhs.pexp_loc in + let before, inside, after = + partition_by_loc comments case.pc_rhs.pexp_loc + in attach t.leading case.pc_rhs.pexp_loc before; - walkExpression case.pc_rhs t inside; + walk_expression case.pc_rhs t inside; attach t.trailing case.pc_rhs.pexp_loc after -and walkExprRecordRow (longident, expr) t comments = - let beforeLongident, afterLongident = - partitionLeadingTrailing comments longident.loc +and walk_expr_record_row (longident, expr) t comments = + let before_longident, after_longident = + partition_leading_trailing comments longident.loc in - attach t.leading longident.loc beforeLongident; - let afterLongident, rest = - partitionAdjacentTrailing longident.loc afterLongident + attach t.leading longident.loc before_longident; + let after_longident, rest = + partition_adjacent_trailing longident.loc after_longident in - attach t.trailing longident.loc afterLongident; - let leading, inside, trailing = partitionByLoc rest expr.pexp_loc in + attach t.trailing longident.loc after_longident; + let leading, inside, trailing = partition_by_loc rest expr.pexp_loc in attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; + walk_expression expr t inside; attach t.trailing expr.pexp_loc trailing -and walkExtensionConstructor extConstr t comments = +and walk_extension_constructor ext_constr t comments = let leading, trailing = - partitionLeadingTrailing comments extConstr.pext_name.loc + partition_leading_trailing comments ext_constr.pext_name.loc in - attach t.leading extConstr.pext_name.loc leading; - let afterName, rest = - partitionAdjacentTrailing extConstr.pext_name.loc trailing + attach t.leading ext_constr.pext_name.loc leading; + let after_name, rest = + partition_adjacent_trailing ext_constr.pext_name.loc trailing in - attach t.trailing extConstr.pext_name.loc afterName; - walkExtensionConstructorKind extConstr.pext_kind t rest + attach t.trailing ext_constr.pext_name.loc after_name; + walk_extension_constructor_kind ext_constr.pext_kind t rest -and walkExtensionConstructorKind kind t comments = +and walk_extension_constructor_kind kind t comments = match kind with | Pext_rebind longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in + let leading, trailing = partition_leading_trailing comments longident.loc in attach t.leading longident.loc leading; attach t.trailing longident.loc trailing - | Pext_decl (constructorArguments, maybeTypExpr) -> ( - let rest = walkConstructorArguments constructorArguments t comments in - match maybeTypExpr with + | Pext_decl (constructor_arguments, maybe_typ_expr) -> ( + let rest = walk_constructor_arguments constructor_arguments t comments in + match maybe_typ_expr with | None -> () | Some typexpr -> - let before, inside, after = partitionByLoc rest typexpr.ptyp_loc in + let before, inside, after = partition_by_loc rest typexpr.ptyp_loc in attach t.leading typexpr.ptyp_loc before; - walkCoreType typexpr t inside; + walk_core_type typexpr t inside; attach t.trailing typexpr.ptyp_loc after) -and walkModuleExpr modExpr t comments = - match modExpr.pmod_desc with +and walk_module_expr mod_expr t comments = + match mod_expr.pmod_desc with | Pmod_ident longident -> - let before, after = partitionLeadingTrailing comments longident.loc in + let before, after = partition_leading_trailing comments longident.loc in attach t.leading longident.loc before; attach t.trailing longident.loc after - | Pmod_structure [] -> attach t.inside modExpr.pmod_loc comments - | Pmod_structure structure -> walkStructure structure t comments - | Pmod_extension extension -> walkExtension extension t comments + | Pmod_structure [] -> attach t.inside mod_expr.pmod_loc comments + | Pmod_structure structure -> walk_structure structure t comments + | Pmod_extension extension -> walk_extension extension t comments | Pmod_unpack expr -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in + let before, inside, after = partition_by_loc comments expr.pexp_loc in attach t.leading expr.pexp_loc before; - walkExpression expr t inside; + walk_expression expr t inside; attach t.trailing expr.pexp_loc after | Pmod_constraint (modexpr, modtype) -> if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( - let before, inside, after = partitionByLoc comments modexpr.pmod_loc in + let before, inside, after = partition_by_loc comments modexpr.pmod_loc in attach t.leading modexpr.pmod_loc before; - walkModuleExpr modexpr t inside; - let after, rest = partitionAdjacentTrailing modexpr.pmod_loc after in + walk_module_expr modexpr t inside; + let after, rest = partition_adjacent_trailing modexpr.pmod_loc after in attach t.trailing modexpr.pmod_loc after; - let before, inside, after = partitionByLoc rest modtype.pmty_loc in + let before, inside, after = partition_by_loc rest modtype.pmty_loc in attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; + walk_mod_type modtype t inside; attach t.trailing modtype.pmty_loc after) else - let before, inside, after = partitionByLoc comments modtype.pmty_loc in + let before, inside, after = partition_by_loc comments modtype.pmty_loc in attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; - let after, rest = partitionAdjacentTrailing modtype.pmty_loc after in + walk_mod_type modtype t inside; + let after, rest = partition_adjacent_trailing modtype.pmty_loc after in attach t.trailing modtype.pmty_loc after; - let before, inside, after = partitionByLoc rest modexpr.pmod_loc in + let before, inside, after = partition_by_loc rest modexpr.pmod_loc in attach t.leading modexpr.pmod_loc before; - walkModuleExpr modexpr t inside; + walk_module_expr modexpr t inside; attach t.trailing modexpr.pmod_loc after | Pmod_apply (_callModExpr, _argModExpr) -> - let modExprs = modExprApply modExpr in - walkList (modExprs |> List.map (fun me -> ModuleExpr me)) t comments + let mod_exprs = mod_expr_apply mod_expr in + walk_list (mod_exprs |> List.map (fun me -> ModuleExpr me)) t comments | Pmod_functor _ -> ( - let parameters, returnModExpr = modExprFunctor modExpr in + let parameters, return_mod_expr = mod_expr_functor mod_expr in let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, lbl, modTypeOption) -> - match modTypeOption with + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (_, lbl, mod_type_option) -> + match mod_type_option with | None -> lbl.Asttypes.loc - | Some modType -> - {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end}) - ~walkNode:walkModExprParameter ~newlineDelimited:false parameters t + | Some mod_type -> + {lbl.loc with loc_end = mod_type.Parsetree.pmty_loc.loc_end}) + ~walk_node:walk_mod_expr_parameter ~newline_delimited:false parameters t comments in - match returnModExpr.pmod_desc with - | Pmod_constraint (modExpr, modType) - when modType.pmty_loc.loc_end.pos_cnum - <= modExpr.pmod_loc.loc_start.pos_cnum -> - let before, inside, after = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - let after, rest = partitionAdjacentTrailing modType.pmty_loc after in - attach t.trailing modType.pmty_loc after; - let before, inside, after = partitionByLoc rest modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after + match return_mod_expr.pmod_desc with + | Pmod_constraint (mod_expr, mod_type) + when mod_type.pmty_loc.loc_end.pos_cnum + <= mod_expr.pmod_loc.loc_start.pos_cnum -> + let before, inside, after = partition_by_loc comments mod_type.pmty_loc in + attach t.leading mod_type.pmty_loc before; + walk_mod_type mod_type t inside; + let after, rest = partition_adjacent_trailing mod_type.pmty_loc after in + attach t.trailing mod_type.pmty_loc after; + let before, inside, after = partition_by_loc rest mod_expr.pmod_loc in + attach t.leading mod_expr.pmod_loc before; + walk_module_expr mod_expr t inside; + attach t.trailing mod_expr.pmod_loc after | _ -> let before, inside, after = - partitionByLoc comments returnModExpr.pmod_loc + partition_by_loc comments return_mod_expr.pmod_loc in - attach t.leading returnModExpr.pmod_loc before; - walkModuleExpr returnModExpr t inside; - attach t.trailing returnModExpr.pmod_loc after) + attach t.leading return_mod_expr.pmod_loc before; + walk_module_expr return_mod_expr t inside; + attach t.trailing return_mod_expr.pmod_loc after) -and walkModExprParameter parameter t comments = - let _attrs, lbl, modTypeOption = parameter in - let leading, trailing = partitionLeadingTrailing comments lbl.loc in +and walk_mod_expr_parameter parameter t comments = + let _attrs, lbl, mod_type_option = parameter in + let leading, trailing = partition_leading_trailing comments lbl.loc in attach t.leading lbl.loc leading; - match modTypeOption with + match mod_type_option with | None -> attach t.trailing lbl.loc trailing - | Some modType -> - let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - -and walkModType modType t comments = - match modType.pmty_desc with + | Some mod_type -> + let after_lbl, rest = partition_adjacent_trailing lbl.loc trailing in + attach t.trailing lbl.loc after_lbl; + let before, inside, after = partition_by_loc rest mod_type.pmty_loc in + attach t.leading mod_type.pmty_loc before; + walk_mod_type mod_type t inside; + attach t.trailing mod_type.pmty_loc after + +and walk_mod_type mod_type t comments = + match mod_type.pmty_desc with | Pmty_ident longident | Pmty_alias longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in + let leading, trailing = partition_leading_trailing comments longident.loc in attach t.leading longident.loc leading; attach t.trailing longident.loc trailing - | Pmty_signature [] -> attach t.inside modType.pmty_loc comments - | Pmty_signature signature -> walkSignature signature t comments - | Pmty_extension extension -> walkExtension extension t comments - | Pmty_typeof modExpr -> - let before, inside, after = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | Pmty_with (modType, _withConstraints) -> - let before, inside, after = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after + | Pmty_signature [] -> attach t.inside mod_type.pmty_loc comments + | Pmty_signature signature -> walk_signature signature t comments + | Pmty_extension extension -> walk_extension extension t comments + | Pmty_typeof mod_expr -> + let before, inside, after = partition_by_loc comments mod_expr.pmod_loc in + attach t.leading mod_expr.pmod_loc before; + walk_module_expr mod_expr t inside; + attach t.trailing mod_expr.pmod_loc after + | Pmty_with (mod_type, _withConstraints) -> + let before, inside, after = partition_by_loc comments mod_type.pmty_loc in + attach t.leading mod_type.pmty_loc before; + walk_mod_type mod_type t inside; + attach t.trailing mod_type.pmty_loc after (* TODO: withConstraints*) | Pmty_functor _ -> - let parameters, returnModType = functorType modType in + let parameters, return_mod_type = functor_type mod_type in let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, lbl, modTypeOption) -> - match modTypeOption with + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (_, lbl, mod_type_option) -> + match mod_type_option with | None -> lbl.Asttypes.loc - | Some modType -> - if lbl.txt = "_" then modType.Parsetree.pmty_loc - else {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end}) - ~walkNode:walkModTypeParameter ~newlineDelimited:false parameters t + | Some mod_type -> + if lbl.txt = "_" then mod_type.Parsetree.pmty_loc + else {lbl.loc with loc_end = mod_type.Parsetree.pmty_loc.loc_end}) + ~walk_node:walk_mod_type_parameter ~newline_delimited:false parameters t comments in let before, inside, after = - partitionByLoc comments returnModType.pmty_loc + partition_by_loc comments return_mod_type.pmty_loc in - attach t.leading returnModType.pmty_loc before; - walkModType returnModType t inside; - attach t.trailing returnModType.pmty_loc after + attach t.leading return_mod_type.pmty_loc before; + walk_mod_type return_mod_type t inside; + attach t.trailing return_mod_type.pmty_loc after -and walkModTypeParameter (_, lbl, modTypeOption) t comments = - let leading, trailing = partitionLeadingTrailing comments lbl.loc in +and walk_mod_type_parameter (_, lbl, mod_type_option) t comments = + let leading, trailing = partition_leading_trailing comments lbl.loc in attach t.leading lbl.loc leading; - match modTypeOption with + match mod_type_option with | None -> attach t.trailing lbl.loc trailing - | Some modType -> - let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - -and walkPattern pat t comments = + | Some mod_type -> + let after_lbl, rest = partition_adjacent_trailing lbl.loc trailing in + attach t.trailing lbl.loc after_lbl; + let before, inside, after = partition_by_loc rest mod_type.pmty_loc in + attach t.leading mod_type.pmty_loc before; + walk_mod_type mod_type t inside; + attach t.trailing mod_type.pmty_loc after + +and walk_pattern pat t comments = let open Location in match pat.Parsetree.ppat_desc with | _ when comments = [] -> () | Ppat_alias (pat, alias) -> - let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in + let leading, inside, trailing = partition_by_loc comments pat.ppat_loc in attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in + walk_pattern pat t inside; + let after_pat, rest = partition_adjacent_trailing pat.ppat_loc trailing in attach t.leading pat.ppat_loc leading; - attach t.trailing pat.ppat_loc afterPat; - let beforeAlias, afterAlias = partitionLeadingTrailing rest alias.loc in - attach t.leading alias.loc beforeAlias; - attach t.trailing alias.loc afterAlias + attach t.trailing pat.ppat_loc after_pat; + let before_alias, after_alias = partition_leading_trailing rest alias.loc in + attach t.leading alias.loc before_alias; + attach t.trailing alias.loc after_alias | Ppat_tuple [] | Ppat_array [] | Ppat_construct ({txt = Longident.Lident "()"}, _) | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> attach t.inside pat.ppat_loc comments | Ppat_array patterns -> - walkList (patterns |> List.map (fun p -> Pattern p)) t comments + walk_list (patterns |> List.map (fun p -> Pattern p)) t comments | Ppat_tuple patterns -> - walkList (patterns |> List.map (fun p -> Pattern p)) t comments + walk_list (patterns |> List.map (fun p -> Pattern p)) t comments | Ppat_construct ({txt = Longident.Lident "::"}, _) -> - walkList - (collectListPatterns [] pat |> List.map (fun p -> Pattern p)) + walk_list + (collect_list_patterns [] pat |> List.map (fun p -> Pattern p)) t comments | Ppat_construct (constr, None) -> - let beforeConstr, afterConstr = - partitionLeadingTrailing comments constr.loc + let before_constr, after_constr = + partition_leading_trailing comments constr.loc in - attach t.leading constr.loc beforeConstr; - attach t.trailing constr.loc afterConstr + attach t.leading constr.loc before_constr; + attach t.trailing constr.loc after_constr | Ppat_construct (constr, Some pat) -> - let leading, trailing = partitionLeadingTrailing comments constr.loc in + let leading, trailing = partition_leading_trailing comments constr.loc in attach t.leading constr.loc leading; - let afterConstructor, rest = - partitionAdjacentTrailing constr.loc trailing + let after_constructor, rest = + partition_adjacent_trailing constr.loc trailing in - attach t.trailing constr.loc afterConstructor; - let leading, inside, trailing = partitionByLoc rest pat.ppat_loc in + attach t.trailing constr.loc after_constructor; + let leading, inside, trailing = partition_by_loc rest pat.ppat_loc in attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; + walk_pattern pat t inside; attach t.trailing pat.ppat_loc trailing | Ppat_variant (_label, None) -> () - | Ppat_variant (_label, Some pat) -> walkPattern pat t comments + | Ppat_variant (_label, Some pat) -> walk_pattern pat t comments | Ppat_type _ -> () - | Ppat_record (recordRows, _) -> - walkList - (recordRows |> List.map (fun (li, p) -> PatternRecordRow (li, p))) + | Ppat_record (record_rows, _) -> + walk_list + (record_rows |> List.map (fun (li, p) -> PatternRecordRow (li, p))) t comments | Ppat_or _ -> - walkList - (Res_parsetree_viewer.collectOrPatternChain pat + walk_list + (Res_parsetree_viewer.collect_or_pattern_chain pat |> List.map (fun pat -> Pattern pat)) t comments | Ppat_constraint (pattern, typ) -> - let beforePattern, insidePattern, afterPattern = - partitionByLoc comments pattern.ppat_loc + let before_pattern, inside_pattern, after_pattern = + partition_by_loc comments pattern.ppat_loc in - attach t.leading pattern.ppat_loc beforePattern; - walkPattern pattern t insidePattern; - let afterPattern, rest = - partitionAdjacentTrailing pattern.ppat_loc afterPattern + attach t.leading pattern.ppat_loc before_pattern; + walk_pattern pattern t inside_pattern; + let after_pattern, rest = + partition_adjacent_trailing pattern.ppat_loc after_pattern in - attach t.trailing pattern.ppat_loc afterPattern; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typ.ptyp_loc in - attach t.leading typ.ptyp_loc beforeTyp; - walkCoreType typ t insideTyp; - attach t.trailing typ.ptyp_loc afterTyp + attach t.trailing pattern.ppat_loc after_pattern; + let before_typ, inside_typ, after_typ = + partition_by_loc rest typ.ptyp_loc + in + attach t.leading typ.ptyp_loc before_typ; + walk_core_type typ t inside_typ; + attach t.trailing typ.ptyp_loc after_typ | Ppat_lazy pattern | Ppat_exception pattern -> - let leading, inside, trailing = partitionByLoc comments pattern.ppat_loc in + let leading, inside, trailing = + partition_by_loc comments pattern.ppat_loc + in attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; + walk_pattern pattern t inside; attach t.trailing pattern.ppat_loc trailing - | Ppat_unpack stringLoc -> - let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - attach t.trailing stringLoc.loc trailing - | Ppat_extension extension -> walkExtension extension t comments + | Ppat_unpack string_loc -> + let leading, trailing = + partition_leading_trailing comments string_loc.loc + in + attach t.leading string_loc.loc leading; + attach t.trailing string_loc.loc trailing + | Ppat_extension extension -> walk_extension extension t comments | _ -> () (* name: firstName *) -and walkPatternRecordRow row t comments = +and walk_pattern_record_row row t comments = match row with (* punned {x}*) - | ( {Location.txt = Longident.Lident ident; loc = longidentLoc}, + | ( {Location.txt = Longident.Lident ident; loc = longident_loc}, {Parsetree.ppat_desc = Ppat_var {txt; _}} ) when ident = txt -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments longidentLoc in - attach t.leading longidentLoc beforeLbl; - attach t.trailing longidentLoc afterLbl + let before_lbl, after_lbl = + partition_leading_trailing comments longident_loc + in + attach t.leading longident_loc before_lbl; + attach t.trailing longident_loc after_lbl | longident, pattern -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc beforeLbl; - let afterLbl, rest = partitionAdjacentTrailing longident.loc afterLbl in - attach t.trailing longident.loc afterLbl; - let leading, inside, trailing = partitionByLoc rest pattern.ppat_loc in + let before_lbl, after_lbl = + partition_leading_trailing comments longident.loc + in + attach t.leading longident.loc before_lbl; + let after_lbl, rest = partition_adjacent_trailing longident.loc after_lbl in + attach t.trailing longident.loc after_lbl; + let leading, inside, trailing = partition_by_loc rest pattern.ppat_loc in attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; + walk_pattern pattern t inside; attach t.trailing pattern.ppat_loc trailing -and walkRowField (rowField : Parsetree.row_field) t comments = - match rowField with +and walk_row_field (row_field : Parsetree.row_field) t comments = + match row_field with | Parsetree.Rtag ({loc}, _, _, _) -> - let before, after = partitionLeadingTrailing comments loc in + let before, after = partition_leading_trailing comments loc in attach t.leading loc before; attach t.trailing loc after | Rinherit _ -> () -and walkCoreType typ t comments = +and walk_core_type typ t comments = match typ.Parsetree.ptyp_desc with | _ when comments = [] -> () | Ptyp_tuple typexprs -> - walkList (typexprs |> List.map (fun ct -> CoreType ct)) t comments - | Ptyp_extension extension -> walkExtension extension t comments - | Ptyp_package packageType -> walkPackageType packageType t comments + walk_list (typexprs |> List.map (fun ct -> CoreType ct)) t comments + | Ptyp_extension extension -> walk_extension extension t comments + | Ptyp_package package_type -> walk_package_type package_type t comments | Ptyp_alias (typexpr, _alias) -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc + let before_typ, inside_typ, after_typ = + partition_by_loc comments typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ | Ptyp_poly (strings, typexpr) -> let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Asttypes.loc) - ~walkNode:(fun longident t comments -> - let beforeLongident, afterLongident = - partitionLeadingTrailing comments longident.loc + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun n -> n.Asttypes.loc) + ~walk_node:(fun longident t comments -> + let before_longident, after_longident = + partition_leading_trailing comments longident.loc in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident) - ~newlineDelimited:false strings t comments + attach t.leading longident.loc before_longident; + attach t.trailing longident.loc after_longident) + ~newline_delimited:false strings t comments in - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc + let before_typ, inside_typ, after_typ = + partition_by_loc comments typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - | Ptyp_variant (rowFields, _, _) -> - walkList (rowFields |> List.map (fun rf -> RowField rf)) t comments + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ + | Ptyp_variant (row_fields, _, _) -> + walk_list (row_fields |> List.map (fun rf -> RowField rf)) t comments + | Ptyp_constr + ({txt = Lident "function$"}, [({ptyp_desc = Ptyp_arrow _} as desc); _]) -> + walk_core_type desc t comments | Ptyp_constr (longident, typexprs) -> - let beforeLongident, _afterLongident = - partitionLeadingTrailing comments longident.loc + let before_longident, _afterLongident = + partition_leading_trailing comments longident.loc in - let afterLongident, rest = - partitionAdjacentTrailing longident.loc comments + let after_longident, rest = + partition_adjacent_trailing longident.loc comments in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident; - walkList (typexprs |> List.map (fun ct -> CoreType ct)) t rest + attach t.leading longident.loc before_longident; + attach t.trailing longident.loc after_longident; + walk_list (typexprs |> List.map (fun ct -> CoreType ct)) t rest | Ptyp_arrow _ -> - let _, parameters, typexpr = arrowType typ in - let comments = walkTypeParameters parameters t comments in - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc + let _, parameters, typexpr = arrow_type typ in + let comments = walk_type_parameters parameters t comments in + let before_typ, inside_typ, after_typ = + partition_by_loc comments typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - | Ptyp_object (fields, _) -> walkTypObjectFields fields t comments + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ + | Ptyp_object (fields, _) -> walk_typ_object_fields fields t comments | _ -> () -and walkTypObjectFields fields t comments = - walkList (fields |> List.map (fun f -> ObjectField f)) t comments +and walk_typ_object_fields fields t comments = + walk_list (fields |> List.map (fun f -> ObjectField f)) t comments -and walkObjectField field t comments = +and walk_object_field field t comments = match field with | Otag (lbl, _, typexpr) -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments lbl.loc in - attach t.leading lbl.loc beforeLbl; - let afterLbl, rest = partitionAdjacentTrailing lbl.loc afterLbl in - attach t.trailing lbl.loc afterLbl; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + let before_lbl, after_lbl = partition_leading_trailing comments lbl.loc in + attach t.leading lbl.loc before_lbl; + let after_lbl, rest = partition_adjacent_trailing lbl.loc after_lbl in + attach t.trailing lbl.loc after_lbl; + let before_typ, inside_typ, after_typ = + partition_by_loc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ | _ -> () -and walkTypeParameters typeParameters t comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, _, typexpr) -> +and walk_type_parameters type_parameters t comments = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (_, _, typexpr) -> match typexpr.Parsetree.ptyp_attributes with | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> {loc with loc_end = typexpr.ptyp_loc.loc_end} | _ -> typexpr.ptyp_loc) - ~walkNode:walkTypeParameter ~newlineDelimited:false typeParameters t + ~walk_node:walk_type_parameter ~newline_delimited:false type_parameters t comments -and walkTypeParameter (_attrs, _lbl, typexpr) t comments = - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc +and walk_type_parameter (_attrs, _lbl, typexpr) t comments = + let before_typ, inside_typ, after_typ = + partition_by_loc comments typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - -and walkPackageType packageType t comments = - let longident, packageConstraints = packageType in - let beforeLongident, afterLongident = - partitionLeadingTrailing comments longident.loc + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ + +and walk_package_type package_type t comments = + let longident, package_constraints = package_type in + let before_longident, after_longident = + partition_leading_trailing comments longident.loc in - attach t.leading longident.loc beforeLongident; - let afterLongident, rest = - partitionAdjacentTrailing longident.loc afterLongident + attach t.leading longident.loc before_longident; + let after_longident, rest = + partition_adjacent_trailing longident.loc after_longident in - attach t.trailing longident.loc afterLongident; - walkPackageConstraints packageConstraints t rest + attach t.trailing longident.loc after_longident; + walk_package_constraints package_constraints t rest -and walkPackageConstraints packageConstraints t comments = - walkList - (packageConstraints |> List.map (fun (li, te) -> PackageConstraint (li, te))) +and walk_package_constraints package_constraints t comments = + walk_list + (package_constraints + |> List.map (fun (li, te) -> PackageConstraint (li, te))) t comments -and walkPackageConstraint packageConstraint t comments = - let longident, typexpr = packageConstraint in - let beforeLongident, afterLongident = - partitionLeadingTrailing comments longident.loc +and walk_package_constraint package_constraint t comments = + let longident, typexpr = package_constraint in + let before_longident, after_longident = + partition_leading_trailing comments longident.loc + in + attach t.leading longident.loc before_longident; + let after_longident, rest = + partition_adjacent_trailing longident.loc after_longident in - attach t.leading longident.loc beforeLongident; - let afterLongident, rest = - partitionAdjacentTrailing longident.loc afterLongident + attach t.trailing longident.loc after_longident; + let before_typ, inside_typ, after_typ = + partition_by_loc rest typexpr.ptyp_loc in - attach t.trailing longident.loc afterLongident; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ -and walkExtension extension t comments = +and walk_extension extension t comments = let id, payload = extension in - let beforeId, afterId = partitionLeadingTrailing comments id.loc in - attach t.leading id.loc beforeId; - let afterId, rest = partitionAdjacentTrailing id.loc afterId in - attach t.trailing id.loc afterId; - walkPayload payload t rest - -and walkAttribute (id, payload) t comments = - let beforeId, afterId = partitionLeadingTrailing comments id.loc in - attach t.leading id.loc beforeId; - let afterId, rest = partitionAdjacentTrailing id.loc afterId in - attach t.trailing id.loc afterId; - walkPayload payload t rest - -and walkPayload payload t comments = + let before_id, after_id = partition_leading_trailing comments id.loc in + attach t.leading id.loc before_id; + let after_id, rest = partition_adjacent_trailing id.loc after_id in + attach t.trailing id.loc after_id; + walk_payload payload t rest + +and walk_attribute (id, payload) t comments = + let before_id, after_id = partition_leading_trailing comments id.loc in + attach t.leading id.loc before_id; + let after_id, rest = partition_adjacent_trailing id.loc after_id in + attach t.trailing id.loc after_id; + walk_payload payload t rest + +and walk_payload payload t comments = match payload with - | PStr s -> walkStructure s t comments + | PStr s -> walk_structure s t comments | _ -> () diff --git a/analysis/vendor/res_syntax/res_core.ml b/analysis/vendor/res_syntax/res_core.ml index eb4463840..48023f378 100644 --- a/analysis/vendor/res_syntax/res_core.ml +++ b/analysis/vendor/res_syntax/res_core.ml @@ -8,59 +8,60 @@ module Scanner = Res_scanner module Parser = Res_parser module LoopProgress = struct - let listRest list = + let list_rest list = match list with | [] -> assert false | _ :: rest -> rest end -let mkLoc startLoc endLoc = - Location.{loc_start = startLoc; loc_end = endLoc; loc_ghost = false} +let mk_loc start_loc end_loc = + Location.{loc_start = start_loc; loc_end = end_loc; loc_ghost = false} module Recover = struct - let defaultExpr () = + let default_expr () = let id = Location.mknoloc "rescript.exprhole" in Ast_helper.Exp.mk (Pexp_extension (id, PStr [])) - let defaultType () = + let default_type () = let id = Location.mknoloc "rescript.typehole" in Ast_helper.Typ.extension (id, PStr []) - let defaultPattern () = + let default_pattern () = let id = Location.mknoloc "rescript.patternhole" in Ast_helper.Pat.extension (id, PStr []) - let defaultModuleExpr () = Ast_helper.Mod.structure [] - let defaultModuleType () = Ast_helper.Mty.signature [] + let default_module_expr () = Ast_helper.Mod.structure [] + let default_module_type () = Ast_helper.Mty.signature [] - let defaultSignatureItem = + let default_signature_item = let id = Location.mknoloc "rescript.sigitemhole" in Ast_helper.Sig.extension (id, PStr []) - let recoverEqualGreater p = + let recover_equal_greater p = Parser.expect EqualGreater p; match p.Parser.token with | MinusGreater -> Parser.next p | _ -> () - let shouldAbortListParse p = + let should_abort_list_parse p = let rec check breadcrumbs = match breadcrumbs with | [] -> false | (grammar, _) :: rest -> - if Grammar.isPartOfList grammar p.Parser.token then true else check rest + if Grammar.is_part_of_list grammar p.Parser.token then true + else check rest in check p.breadcrumbs end module ErrorMessages = struct - let listPatternSpread = + let list_pattern_spread = "List pattern matches only supports one `...` spread, at the end.\n\ Explanation: a list spread at the tail is efficient, but a spread in the \ middle would create new lists; out of performance concern, our pattern \ matching currently guarantees to never create new intermediate data." - let recordPatternSpread = + let record_pattern_spread = "Record's `...` spread is not supported in pattern matches.\n\ Explanation: you can't collect a subset of a record's field into its own \ record, since a record needs an explicit declaration and that subset \ @@ -69,7 +70,7 @@ module ErrorMessages = struct (* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *) [@@live] - let arrayPatternSpread = + let array_pattern_spread = "Array's `...` spread is not supported in pattern matches.\n\ Explanation: such spread would create a subarray; out of performance \ concern, our pattern matching currently guarantees to never create new \ @@ -78,18 +79,18 @@ module ErrorMessages = struct + Array size check + `get` checks on the current pattern. If it's to \ obtain a subarray, use `Array.sub` or `Belt.Array.slice`." - let recordExprSpread = + let record_expr_spread = "Records can only have one `...` spread, at the beginning.\n\ Explanation: since records have a known, fixed shape, a spread like `{a, \ ...b}` wouldn't make sense, as `b` would override every field of `a` \ anyway." - let variantIdent = + let variant_ident = "A polymorphic variant (e.g. #id) must start with an alphabetical letter \ or be a number (e.g. #742)" - let experimentalIfLet expr = - let switchExpr = {expr with Parsetree.pexp_attributes = []} in + let experimental_if_let expr = + let switch_expr = {expr with Parsetree.pexp_attributes = []} in Doc.concat [ Doc.text "If-let is currently highly experimental."; @@ -97,52 +98,52 @@ module ErrorMessages = struct Doc.text "Use a regular `switch` with pattern matching instead:"; Doc.concat [ - Doc.hardLine; - Doc.hardLine; - ResPrinter.printExpression switchExpr CommentTable.empty; + Doc.hard_line; + Doc.hard_line; + ResPrinter.print_expression switch_expr CommentTable.empty; ]; ] - |> Doc.toString ~width:80 + |> Doc.to_string ~width:80 - let typeParam = + let type_param = "A type param consists of a singlequote followed by a name like `'a` or \ `'A`" - let typeVar = + let type_var = "A type variable consists of a singlequote followed by a name like `'a` or \ `'A`" - let attributeWithoutNode (attr : Parsetree.attribute) = - let {Asttypes.txt = attrName}, _ = attr in - "Did you forget to attach `" ^ attrName + let attribute_without_node (attr : Parsetree.attribute) = + let {Asttypes.txt = attr_name}, _ = attr in + "Did you forget to attach `" ^ attr_name ^ "` to an item?\n Standalone attributes start with `@@` like: `@@" - ^ attrName ^ "`" + ^ attr_name ^ "`" - let typeDeclarationNameLongident longident = + let type_declaration_name_longident longident = "A type declaration's name cannot contain a module access. Did you mean `" ^ Longident.last longident ^ "`?" - let tupleSingleElement = "A tuple needs at least two elements" + let tuple_single_element = "A tuple needs at least two elements" - let missingTildeLabeledParameter name = + let missing_tilde_labeled_parameter name = if name = "" then "A labeled parameter starts with a `~`." else "A labeled parameter starts with a `~`. Did you mean: `~" ^ name ^ "`?" - let stringInterpolationInPattern = + let string_interpolation_in_pattern = "String interpolation is not supported in pattern matching." - let spreadInRecordDeclaration = + let spread_in_record_declaration = "A record type declaration doesn't support the ... spread. Only an object \ (with quoted field names) does." - let objectQuotedFieldName name = + let object_quoted_field_name name = "An object type declaration needs quoted field names. Did you mean \"" ^ name ^ "\"?" - let forbiddenInlineRecordDeclaration = + let forbidden_inline_record_declaration = "An inline record type declaration is only allowed in a variant \ constructor's declaration" - let polyVarIntWithSuffix number = + let poly_var_int_with_suffix number = "A numeric polymorphic variant cannot be followed by a letter. Did you \ mean `#" ^ number ^ "`?" end @@ -151,35 +152,35 @@ module InExternal = struct let status = ref false end -let jsxAttr = (Location.mknoloc "JSX", Parsetree.PStr []) -let uncurriedAppAttr = (Location.mknoloc "res.uapp", Parsetree.PStr []) -let ternaryAttr = (Location.mknoloc "res.ternary", Parsetree.PStr []) -let ifLetAttr = (Location.mknoloc "res.iflet", Parsetree.PStr []) -let optionalAttr = (Location.mknoloc "res.optional", Parsetree.PStr []) -let makeAwaitAttr loc = (Location.mkloc "res.await" loc, Parsetree.PStr []) -let makeAsyncAttr loc = (Location.mkloc "res.async" loc, Parsetree.PStr []) +let jsx_attr = (Location.mknoloc "JSX", Parsetree.PStr []) +let uncurried_app_attr = (Location.mknoloc "res.uapp", Parsetree.PStr []) +let ternary_attr = (Location.mknoloc "res.ternary", Parsetree.PStr []) +let if_let_attr = (Location.mknoloc "res.iflet", Parsetree.PStr []) +let optional_attr = (Location.mknoloc "res.optional", Parsetree.PStr []) +let make_await_attr loc = (Location.mkloc "res.await" loc, Parsetree.PStr []) +let make_async_attr loc = (Location.mkloc "res.async" loc, Parsetree.PStr []) -let makeExpressionOptional ~optional (e : Parsetree.expression) = - if optional then {e with pexp_attributes = optionalAttr :: e.pexp_attributes} +let make_expression_optional ~optional (e : Parsetree.expression) = + if optional then {e with pexp_attributes = optional_attr :: e.pexp_attributes} else e -let makePatternOptional ~optional (p : Parsetree.pattern) = - if optional then {p with ppat_attributes = optionalAttr :: p.ppat_attributes} +let make_pattern_optional ~optional (p : Parsetree.pattern) = + if optional then {p with ppat_attributes = optional_attr :: p.ppat_attributes} else p -let suppressFragileMatchWarningAttr = +let suppress_fragile_match_warning_attr = ( Location.mknoloc "warning", Parsetree.PStr [ Ast_helper.Str.eval (Ast_helper.Exp.constant (Pconst_string ("-4", None))); ] ) -let makeBracesAttr loc = (Location.mkloc "res.braces" loc, Parsetree.PStr []) -let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) +let make_braces_attr loc = (Location.mkloc "res.braces" loc, Parsetree.PStr []) +let template_literal_attr = (Location.mknoloc "res.template", Parsetree.PStr []) -let taggedTemplateLiteralAttr = +let tagged_template_literal_attr = (Location.mknoloc "res.taggedTemplate", Parsetree.PStr []) -let spreadAttr = (Location.mknoloc "res.spread", Parsetree.PStr []) +let spread_attr = (Location.mknoloc "res.spread", Parsetree.PStr []) type argument = { dotted: bool; @@ -187,22 +188,22 @@ type argument = { expr: Parsetree.expression; } -type typeParameter = { +type type_parameter = { dotted: bool; attrs: Ast_helper.attrs; label: Asttypes.arg_label; typ: Parsetree.core_type; - startPos: Lexing.position; + start_pos: Lexing.position; } -type typDefOrExt = +type typ_def_or_ext = | TypeDef of { - recFlag: Asttypes.rec_flag; + rec_flag: Asttypes.rec_flag; types: Parsetree.type_declaration list; } | TypeExt of Parsetree.type_extension -type labelledParameter = +type labelled_parameter = | TermParameter of { dotted: bool; attrs: Parsetree.attributes; @@ -218,13 +219,13 @@ type labelledParameter = pos: Lexing.position; } -type recordPatternItem = +type record_pattern_item = | PatUnderscore | PatField of (Ast_helper.lid * Parsetree.pattern) type context = OrdinaryExpr | TernaryTrueBranchExpr | WhenExpr -let getClosingToken = function +let get_closing_token = function | Token.Lparen -> Token.Rparen | Lbrace -> Rbrace | Lbracket -> Rbracket @@ -232,8 +233,8 @@ let getClosingToken = function | LessThan -> GreaterThan | _ -> assert false -let rec goToClosing closingToken state = - match (state.Parser.token, closingToken) with +let rec go_to_closing closing_token state = + match (state.Parser.token, closing_token) with | Rparen, Token.Rparen | Rbrace, Rbrace | Rbracket, Rbracket @@ -242,16 +243,16 @@ let rec goToClosing closingToken state = () | ((Token.Lbracket | Lparen | Lbrace | List | LessThan) as t), _ -> Parser.next state; - goToClosing (getClosingToken t) state; - goToClosing closingToken state + go_to_closing (get_closing_token t) state; + go_to_closing closing_token state | (Rparen | Token.Rbrace | Rbracket | Eof), _ -> () (* TODO: how do report errors here? *) | _ -> Parser.next state; - goToClosing closingToken state + go_to_closing closing_token state (* Madness *) -let isEs6ArrowExpression ~inTernary p = +let is_es6_arrow_expression ~in_ternary p = Parser.lookahead p (fun state -> let async = match state.Parser.token with @@ -272,7 +273,7 @@ let isEs6ArrowExpression ~inTernary p = | EqualGreater -> true | _ -> false) | Lparen -> ( - let prevEndPos = state.prevEndPos in + let prev_end_pos = state.prev_end_pos in Parser.next state; match state.token with (* arrived at `()` here *) @@ -280,7 +281,7 @@ let isEs6ArrowExpression ~inTernary p = Parser.next state; match state.Parser.token with (* arrived at `() :` here *) - | Colon when not inTernary -> ( + | Colon when not in_ternary -> ( Parser.next state; match state.Parser.token with (* arrived at `() :typ` here *) @@ -290,7 +291,7 @@ let isEs6ArrowExpression ~inTernary p = (* arrived at `() :typ<` here *) | LessThan -> Parser.next state; - goToClosing GreaterThan state + go_to_closing GreaterThan state | _ -> ()); match state.Parser.token with (* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *) @@ -305,11 +306,11 @@ let isEs6ArrowExpression ~inTernary p = false (* (` always indicates the start of an expr, can't be es6 parameter *) | _ -> ( - goToClosing Rparen state; + go_to_closing Rparen state; match state.Parser.token with | EqualGreater -> true (* | Lbrace TODO: detect missing =>, is this possible? *) - | Colon when not inTernary -> true + | Colon when not in_ternary -> true | Rparen -> (* imagine having something as : * switch colour { @@ -321,19 +322,19 @@ let isEs6ArrowExpression ~inTernary p = * *) false | _ -> ( - Parser.nextUnsafe state; + Parser.next_unsafe state; (* error recovery, peek at the next token, * (elements, providerId] => { * in the example above, we have an unbalanced ] here *) match state.Parser.token with - | EqualGreater when state.startPos.pos_lnum == prevEndPos.pos_lnum - -> + | EqualGreater + when state.start_pos.pos_lnum == prev_end_pos.pos_lnum -> true | _ -> false))) | _ -> false) -let isEs6ArrowFunctor p = +let is_es6_arrow_functor p = Parser.lookahead p (fun state -> match state.Parser.token with (* | Uident _ | Underscore -> *) @@ -351,14 +352,14 @@ let isEs6ArrowFunctor p = | Colon | EqualGreater -> true | _ -> false) | _ -> ( - goToClosing Rparen state; + go_to_closing Rparen state; match state.Parser.token with | EqualGreater | Lbrace -> true | Colon -> true | _ -> false)) | _ -> false) -let isEs6ArrowType p = +let is_es6_arrow_type p = Parser.lookahead p (fun state -> match state.Parser.token with | Lparen -> ( @@ -371,20 +372,20 @@ let isEs6ArrowType p = | _ -> false) | Tilde | Dot -> true | _ -> ( - goToClosing Rparen state; + go_to_closing Rparen state; match state.Parser.token with | EqualGreater -> true | _ -> false)) | Tilde -> true | _ -> false) -let buildLongident words = +let build_longident words = match List.rev words with | [] -> assert false | hd :: tl -> List.fold_left (fun p s -> Longident.Ldot (p, s)) (Lident hd) tl -let makeInfixOperator (p : Parser.t) token startPos endPos = - let stringifiedToken = +let make_infix_operator (p : Parser.t) token start_pos end_pos = + let stringified_token = if token = Token.MinusGreater then if p.uncurried_config = Legacy then "|." else "|.u" else if token = Token.PlusPlus then "^" @@ -392,73 +393,73 @@ let makeInfixOperator (p : Parser.t) token startPos endPos = else if token = Token.BangEqualEqual then "!=" else if token = Token.Equal then ( (* TODO: could have a totally different meaning like x->fooSet(y)*) - Parser.err ~startPos ~endPos p + Parser.err ~start_pos ~end_pos p (Diagnostics.message "Did you mean `==` here?"); "=") else if token = Token.EqualEqual then "=" else if token = Token.EqualEqualEqual then "==" - else Token.toString token + else Token.to_string token in - let loc = mkLoc startPos endPos in - let operator = Location.mkloc (Longident.Lident stringifiedToken) loc in + let loc = mk_loc start_pos end_pos in + let operator = Location.mkloc (Longident.Lident stringified_token) loc in Ast_helper.Exp.ident ~loc operator -let negateString s = +let negate_string s = if String.length s > 0 && (s.[0] [@doesNotRaise]) = '-' then (String.sub [@doesNotRaise]) s 1 (String.length s - 1) else "-" ^ s -let makeUnaryExpr startPos tokenEnd token operand = +let make_unary_expr start_pos token_end token operand = match (token, operand.Parsetree.pexp_desc) with | (Token.Plus | PlusDot), Pexp_constant (Pconst_integer _ | Pconst_float _) -> operand | Minus, Pexp_constant (Pconst_integer (n, m)) -> { operand with - pexp_desc = Pexp_constant (Pconst_integer (negateString n, m)); + pexp_desc = Pexp_constant (Pconst_integer (negate_string n, m)); } | (Minus | MinusDot), Pexp_constant (Pconst_float (n, m)) -> - {operand with pexp_desc = Pexp_constant (Pconst_float (negateString n, m))} + {operand with pexp_desc = Pexp_constant (Pconst_float (negate_string n, m))} | (Token.Plus | PlusDot | Minus | MinusDot), _ -> - let tokenLoc = mkLoc startPos tokenEnd in - let operator = "~" ^ Token.toString token in + let token_loc = mk_loc start_pos token_end in + let operator = "~" ^ Token.to_string token in Ast_helper.Exp.apply - ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) - (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident operator) tokenLoc)) + ~loc:(mk_loc start_pos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:token_loc + (Location.mkloc (Longident.Lident operator) token_loc)) [(Nolabel, operand)] | Token.Bang, _ -> - let tokenLoc = mkLoc startPos tokenEnd in + let token_loc = mk_loc start_pos token_end in Ast_helper.Exp.apply - ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) - (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident "not") tokenLoc)) + ~loc:(mk_loc start_pos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:token_loc + (Location.mkloc (Longident.Lident "not") token_loc)) [(Nolabel, operand)] | _ -> operand -let makeListExpression loc seq extOpt = - let rec handleSeq = function +let make_list_expression loc seq ext_opt = + let rec handle_seq = function | [] -> ( - match extOpt with + match ext_opt with | Some ext -> ext | None -> let loc = {loc with Location.loc_ghost = true} in let nil = Location.mkloc (Longident.Lident "[]") loc in Ast_helper.Exp.construct ~loc nil None) | e1 :: el -> - let exp_el = handleSeq el in + let exp_el = handle_seq el in let loc = - mkLoc e1.Parsetree.pexp_loc.Location.loc_start exp_el.pexp_loc.loc_end + mk_loc e1.Parsetree.pexp_loc.Location.loc_start exp_el.pexp_loc.loc_end in let arg = Ast_helper.Exp.tuple ~loc [e1; exp_el] in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "::") loc) (Some arg) in - let expr = handleSeq seq in + let expr = handle_seq seq in {expr with pexp_loc = loc} -let makeListPattern loc seq ext_opt = +let make_list_pattern loc seq ext_opt = let rec handle_seq = function | [] -> let base_case = @@ -472,7 +473,9 @@ let makeListPattern loc seq ext_opt = base_case | p1 :: pl -> let pat_pl = handle_seq pl in - let loc = mkLoc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end in + let loc = + mk_loc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end + in let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in Ast_helper.Pat.mk ~loc (Ppat_construct (Location.mkloc (Longident.Lident "::") loc, Some arg)) @@ -480,12 +483,12 @@ let makeListPattern loc seq ext_opt = handle_seq seq (* TODO: diagnostic reporting *) -let lidentOfPath longident = +let lident_of_path longident = match Longident.flatten longident |> List.rev with | [] -> "" | ident :: _ -> ident -let makeNewtypes ~attrs ~loc newtypes exp = +let make_newtypes ~attrs ~loc newtypes exp = let expr = List.fold_right (fun newtype exp -> Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp))) @@ -499,9 +502,9 @@ let makeNewtypes ~attrs ~loc newtypes exp = * into * let f = (type t u v. foo : list) => ... *) -let wrapTypeAnnotation ~loc newtypes core_type body = +let wrap_type_annotation ~loc newtypes core_type body = let exp = - makeNewtypes ~attrs:[] ~loc newtypes + make_newtypes ~attrs:[] ~loc newtypes (Ast_helper.Exp.constraint_ ~loc body core_type) in let typ = @@ -516,7 +519,7 @@ let wrapTypeAnnotation ~loc newtypes core_type body = * return a wrapping function that wraps ((__x) => ...) around an expression * e.g. foo(_, 3) becomes (__x) => foo(__x, 3) *) -let processUnderscoreApplication (p : Parser.t) args = +let process_underscore_application (p : Parser.t) args = let exp_question = ref None in let hidden_var = "__x" in let check_arg ((lab, exp) as arg) = @@ -537,36 +540,37 @@ let processUnderscoreApplication (p : Parser.t) args = (Ppat_var (Location.mkloc hidden_var loc)) ~loc:Location.none in - let funExpr = Ast_helper.Exp.fun_ ~loc Nolabel None pattern exp_apply in - if p.uncurried_config = Legacy then funExpr - else Ast_uncurried.uncurriedFun ~loc ~arity:1 funExpr + let fun_expr = Ast_helper.Exp.fun_ ~loc Nolabel None pattern exp_apply in + if p.uncurried_config = Legacy then fun_expr + else Ast_uncurried.uncurried_fun ~loc ~arity:1 fun_expr | None -> exp_apply in (args, wrap) (* Transform A.a into a. For use with punned record fields as in {A.a, b}. *) -let removeModuleNameFromPunnedFieldValue exp = +let remove_module_name_from_punned_field_value exp = match exp.Parsetree.pexp_desc with - | Pexp_ident pathIdent -> + | Pexp_ident path_ident -> { exp with pexp_desc = - Pexp_ident {pathIdent with txt = Lident (Longident.last pathIdent.txt)}; + Pexp_ident + {path_ident with txt = Lident (Longident.last path_ident.txt)}; } | _ -> exp -let rec parseLident p = - let recoverLident p = +let rec parse_lident p = + let recover_lident p = if - Token.isKeyword p.Parser.token - && p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum + Token.is_keyword p.Parser.token + && p.Parser.prev_end_pos.pos_lnum == p.start_pos.pos_lnum then ( Parser.err p (Diagnostics.lident p.Parser.token); Parser.next p; None) else let rec loop p = - if (not (Recover.shouldAbortListParse p)) && p.token <> Eof then ( + if (not (Recover.should_abort_list_parse p)) && p.token <> Eof then ( Parser.next p; loop p) in @@ -577,69 +581,70 @@ let rec parseLident p = | Lident _ -> Some () | _ -> None in - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in match p.Parser.token with | Lident ident -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in (ident, loc) | Eof -> - Parser.err ~startPos p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("_", mkLoc startPos p.prevEndPos) + Parser.err ~start_pos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("_", mk_loc start_pos p.prev_end_pos) | _ -> ( - match recoverLident p with - | Some () -> parseLident p - | None -> ("_", mkLoc startPos p.prevEndPos)) + match recover_lident p with + | Some () -> parse_lident p + | None -> ("_", mk_loc start_pos p.prev_end_pos)) -let parseIdent ~msg ~startPos p = +let parse_ident ~msg ~start_pos p = match p.Parser.token with | Lident ident | Uident ident -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in (ident, loc) | token - when Token.isKeyword token && p.prevEndPos.pos_lnum == p.startPos.pos_lnum - -> - let tokenTxt = Token.toString token in + when Token.is_keyword token + && p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + let token_txt = Token.to_string token in let msg = - "`" ^ tokenTxt - ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt + "`" ^ token_txt + ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ token_txt ^ "\"" in - Parser.err ~startPos p (Diagnostics.message msg); + Parser.err ~start_pos p (Diagnostics.message msg); Parser.next p; - (tokenTxt, mkLoc startPos p.prevEndPos) + (token_txt, mk_loc start_pos p.prev_end_pos) | _token -> - Parser.err ~startPos p (Diagnostics.message msg); + Parser.err ~start_pos p (Diagnostics.message msg); Parser.next p; - ("", mkLoc startPos p.prevEndPos) + ("", mk_loc start_pos p.prev_end_pos) -let parseHashIdent ~startPos p = +let parse_hash_ident ~start_pos p = Parser.expect Hash p; match p.token with | String text -> Parser.next p; - (text, mkLoc startPos p.prevEndPos) + (text, mk_loc start_pos p.prev_end_pos) | Int {i; suffix} -> let () = match suffix with | Some _ -> Parser.err p - (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) + (Diagnostics.message (ErrorMessages.poly_var_int_with_suffix i)) | None -> () in Parser.next p; - (i, mkLoc startPos p.prevEndPos) + (i, mk_loc start_pos p.prev_end_pos) | Eof -> - Parser.err ~startPos p (Diagnostics.unexpected p.token p.breadcrumbs); - ("", mkLoc startPos p.prevEndPos) - | _ -> parseIdent ~startPos ~msg:ErrorMessages.variantIdent p + Parser.err ~start_pos p (Diagnostics.unexpected p.token p.breadcrumbs); + ("", mk_loc start_pos p.prev_end_pos) + | _ -> parse_ident ~start_pos ~msg:ErrorMessages.variant_ident p (* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *) -let parseValuePath p = - let startPos = p.Parser.startPos in +let parse_value_path p = + let start_pos = p.Parser.start_pos in let rec aux p path = - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in let token = p.token in Parser.next p; @@ -653,7 +658,7 @@ let parseValuePath p = Parser.err p (Diagnostics.unexpected token p.breadcrumbs); Longident.Ldot (path, "_")) else ( - Parser.err p ~startPos ~endPos:p.prevEndPos (Diagnostics.lident token); + Parser.err p ~start_pos ~end_pos:p.prev_end_pos (Diagnostics.lident token); path) in let ident = @@ -663,119 +668,123 @@ let parseValuePath p = Longident.Lident ident | Uident ident -> let res = aux p (Lident ident) in - Parser.nextUnsafe p; + Parser.next_unsafe p; res | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Parser.nextUnsafe p; + Parser.next_unsafe p; Longident.Lident "_" in - Location.mkloc ident (mkLoc startPos p.prevEndPos) + Location.mkloc ident (mk_loc start_pos p.prev_end_pos) -let parseValuePathAfterDot p = - let startPos = p.Parser.startPos in +let parse_value_path_after_dot p = + let start_pos = p.Parser.start_pos in match p.Parser.token with - | Lident _ | Uident _ -> parseValuePath p + | Lident _ | Uident _ -> parse_value_path p | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) + Location.mkloc (Longident.Lident "_") (mk_loc start_pos p.prev_end_pos) -let parseValuePathTail p startPos ident = +let parse_value_path_tail p start_pos ident = let rec loop p path = match p.Parser.token with | Lident ident -> Parser.next p; Location.mkloc (Longident.Ldot (path, ident)) - (mkLoc startPos p.prevEndPos) + (mk_loc start_pos p.prev_end_pos) | Uident ident -> Parser.next p; Parser.expect Dot p; loop p (Longident.Ldot (path, ident)) | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Location.mkloc (Longident.Ldot (path, "_")) (mkLoc startPos p.prevEndPos) + Location.mkloc + (Longident.Ldot (path, "_")) + (mk_loc start_pos p.prev_end_pos) in loop p ident -let parseModuleLongIdentTail ~lowercase p startPos ident = +let parse_module_long_ident_tail ~lowercase p start_pos ident = let rec loop p acc = match p.Parser.token with | Lident ident when lowercase -> Parser.next p; let lident = Longident.Ldot (acc, ident) in - Location.mkloc lident (mkLoc startPos p.prevEndPos) + Location.mkloc lident (mk_loc start_pos p.prev_end_pos) | Uident ident -> ( Parser.next p; - let endPos = p.prevEndPos in + let end_pos = p.prev_end_pos in let lident = Longident.Ldot (acc, ident) in match p.Parser.token with | Dot -> Parser.next p; loop p lident - | _ -> Location.mkloc lident (mkLoc startPos endPos)) + | _ -> Location.mkloc lident (mk_loc start_pos end_pos)) | t -> Parser.err p (Diagnostics.uident t); - Location.mkloc (Longident.Ldot (acc, "_")) (mkLoc startPos p.prevEndPos) + Location.mkloc + (Longident.Ldot (acc, "_")) + (mk_loc start_pos p.prev_end_pos) in loop p ident (* Parses module identifiers: Foo Foo.Bar *) -let parseModuleLongIdent ~lowercase p = +let parse_module_long_ident ~lowercase p = (* Parser.leaveBreadcrumb p Reporting.ModuleLongIdent; *) - let startPos = p.Parser.startPos in - let moduleIdent = + let start_pos = p.Parser.start_pos in + let module_ident = match p.Parser.token with | Lident ident when lowercase -> - let loc = mkLoc startPos p.endPos in + let loc = mk_loc start_pos p.end_pos in let lident = Longident.Lident ident in Parser.next p; Location.mkloc lident loc | Uident ident -> ( let lident = Longident.Lident ident in - let endPos = p.endPos in + let end_pos = p.end_pos in Parser.next p; match p.Parser.token with | Dot -> Parser.next p; - parseModuleLongIdentTail ~lowercase p startPos lident - | _ -> Location.mkloc lident (mkLoc startPos endPos)) + parse_module_long_ident_tail ~lowercase p start_pos lident + | _ -> Location.mkloc lident (mk_loc start_pos end_pos)) | t -> Parser.err p (Diagnostics.uident t); - Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) + Location.mkloc (Longident.Lident "_") (mk_loc start_pos p.prev_end_pos) in (* Parser.eatBreadcrumb p; *) - moduleIdent + module_ident -let verifyJsxOpeningClosingName p nameExpr = +let verify_jsx_opening_closing_name p name_expr = let closing = match p.Parser.token with | Lident lident -> Parser.next p; Longident.Lident lident - | Uident _ -> (parseModuleLongIdent ~lowercase:true p).txt + | Uident _ -> (parse_module_long_ident ~lowercase:true p).txt | _ -> Longident.Lident "" in - match nameExpr.Parsetree.pexp_desc with - | Pexp_ident openingIdent -> + match name_expr.Parsetree.pexp_desc with + | Pexp_ident opening_ident -> let opening = - let withoutCreateElement = - Longident.flatten openingIdent.txt + let without_create_element = + Longident.flatten opening_ident.txt |> List.filter (fun s -> s <> "createElement") in - match Longident.unflatten withoutCreateElement with + match Longident.unflatten without_create_element with | Some li -> li | None -> Longident.Lident "" in opening = closing | _ -> assert false -let string_of_pexp_ident nameExpr = - match nameExpr.Parsetree.pexp_desc with - | Pexp_ident openingIdent -> - Longident.flatten openingIdent.txt +let string_of_pexp_ident name_expr = + match name_expr.Parsetree.pexp_desc with + | Pexp_ident opening_ident -> + Longident.flatten opening_ident.txt |> List.filter (fun s -> s <> "createElement") |> String.concat "." | _ -> "" @@ -783,23 +792,23 @@ let string_of_pexp_ident nameExpr = (* open-def ::= * | open module-path * | open! module-path *) -let parseOpenDescription ~attrs p = - Parser.leaveBreadcrumb p Grammar.OpenDescription; - let startPos = p.Parser.startPos in +let parse_open_description ~attrs p = + Parser.leave_breadcrumb p Grammar.OpenDescription; + let start_pos = p.Parser.start_pos in Parser.expect Open p; let override = if Parser.optional p Token.Bang then Asttypes.Override else Asttypes.Fresh in - let modident = parseModuleLongIdent ~lowercase:false p in - let loc = mkLoc startPos p.prevEndPos in - Parser.eatBreadcrumb p; + let modident = parse_module_long_ident ~lowercase:false p in + let loc = mk_loc start_pos p.prev_end_pos in + Parser.eat_breadcrumb p; Ast_helper.Opn.mk ~loc ~attrs ~override modident (* constant ::= integer-literal *) (* ∣ float-literal *) (* ∣ string-literal *) -let parseConstant p = - let isNegative = +let parse_constant p = + let is_negative = match p.Parser.token with | Token.Minus -> Parser.next p; @@ -812,11 +821,17 @@ let parseConstant p = let constant = match p.Parser.token with | Int {i; suffix} -> - let intTxt = if isNegative then "-" ^ i else i in - Parsetree.Pconst_integer (intTxt, suffix) + (* Only decimal literal is allowed for bigint *) + if suffix = Some 'n' && not (Bigint_utils.is_valid i) then + Parser.err p + (Diagnostics.message + "Invalid bigint literal. Only decimal literal is allowed for \ + bigint."); + let int_txt = if is_negative then "-" ^ i else i in + Parsetree.Pconst_integer (int_txt, suffix) | Float {f; suffix} -> - let floatTxt = if isNegative then "-" ^ f else f in - Parsetree.Pconst_float (floatTxt, suffix) + let float_txt = if is_negative then "-" ^ f else f in + Parsetree.Pconst_float (float_txt, suffix) | String s -> Pconst_string (s, if p.mode = ParseForTypeChecker then Some "js" else None) | Codepoint {c; original} -> @@ -830,34 +845,34 @@ let parseConstant p = Parser.err p (Diagnostics.unexpected token p.breadcrumbs); Pconst_string ("", None) in - Parser.nextUnsafe p; + Parser.next_unsafe p; constant -let parseTemplateConstant ~prefix (p : Parser.t) = +let parse_template_constant ~prefix (p : Parser.t) = (* Arrived at the ` char *) - let startPos = p.startPos in - Parser.nextTemplateLiteralToken p; + let start_pos = p.start_pos in + Parser.next_template_literal_token p; match p.token with | TemplateTail (txt, _) -> Parser.next p; Parsetree.Pconst_string (txt, prefix) | _ -> - let rec skipTokens () = + let rec skip_tokens () = if p.token <> Eof then ( Parser.next p; match p.token with | Backtick -> Parser.next p; () - | _ -> skipTokens ()) + | _ -> skip_tokens ()) in - skipTokens (); - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.stringInterpolationInPattern); + skip_tokens (); + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message ErrorMessages.string_interpolation_in_pattern); Pconst_string ("", None) -let parseCommaDelimitedRegion p ~grammar ~closing ~f = - Parser.leaveBreadcrumb p grammar; +let parse_comma_delimited_region p ~grammar ~closing ~f = + Parser.leave_breadcrumb p grammar; let rec loop nodes = match f p with | Some node -> ( @@ -866,7 +881,7 @@ let parseCommaDelimitedRegion p ~grammar ~closing ~f = Parser.next p; loop (node :: nodes) | token when token = closing || token = Eof -> List.rev (node :: nodes) - | _ when Grammar.isListElement grammar p.token -> + | _ when Grammar.is_list_element grammar p.token -> (* missing comma between nodes in the region and the current token * looks like the start of something valid in the current region. * Example: @@ -885,12 +900,12 @@ let parseCommaDelimitedRegion p ~grammar ~closing ~f = if not (p.token = Eof || p.token = closing - || Recover.shouldAbortListParse p) + || Recover.should_abort_list_parse p) then Parser.expect Comma p; if p.token = Semicolon then Parser.next p; loop (node :: nodes)) | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p + if p.token = Eof || p.token = closing || Recover.should_abort_list_parse p then List.rev nodes else ( Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); @@ -898,11 +913,11 @@ let parseCommaDelimitedRegion p ~grammar ~closing ~f = loop nodes) in let nodes = loop [] in - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; nodes -let parseCommaDelimitedReversedList p ~grammar ~closing ~f = - Parser.leaveBreadcrumb p grammar; +let parse_comma_delimited_reversed_list p ~grammar ~closing ~f = + Parser.leave_breadcrumb p grammar; let rec loop nodes = match f p with | Some node -> ( @@ -911,7 +926,7 @@ let parseCommaDelimitedReversedList p ~grammar ~closing ~f = Parser.next p; loop (node :: nodes) | token when token = closing || token = Eof -> node :: nodes - | _ when Grammar.isListElement grammar p.token -> + | _ when Grammar.is_list_element grammar p.token -> (* missing comma between nodes in the region and the current token * looks like the start of something valid in the current region. * Example: @@ -930,12 +945,12 @@ let parseCommaDelimitedReversedList p ~grammar ~closing ~f = if not (p.token = Eof || p.token = closing - || Recover.shouldAbortListParse p) + || Recover.should_abort_list_parse p) then Parser.expect Comma p; if p.token = Semicolon then Parser.next p; loop (node :: nodes)) | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p + if p.token = Eof || p.token = closing || Recover.should_abort_list_parse p then nodes else ( Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); @@ -943,18 +958,18 @@ let parseCommaDelimitedReversedList p ~grammar ~closing ~f = loop nodes) in let nodes = loop [] in - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; nodes -let parseDelimitedRegion p ~grammar ~closing ~f = - Parser.leaveBreadcrumb p grammar; +let parse_delimited_region p ~grammar ~closing ~f = + Parser.leave_breadcrumb p grammar; let rec loop nodes = match f p with | Some node -> loop (node :: nodes) | None -> if p.Parser.token = Token.Eof || p.token = closing - || Recover.shouldAbortListParse p + || Recover.should_abort_list_parse p then List.rev nodes else ( Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); @@ -962,16 +977,16 @@ let parseDelimitedRegion p ~grammar ~closing ~f = loop nodes) in let nodes = loop [] in - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; nodes -let parseRegion p ~grammar ~f = - Parser.leaveBreadcrumb p grammar; +let parse_region p ~grammar ~f = + Parser.leave_breadcrumb p grammar; let rec loop nodes = match f p with | Some node -> loop (node :: nodes) | None -> - if p.Parser.token = Token.Eof || Recover.shouldAbortListParse p then + if p.Parser.token = Token.Eof || Recover.should_abort_list_parse p then List.rev nodes else ( Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); @@ -979,7 +994,7 @@ let parseRegion p ~grammar ~f = loop nodes) in let nodes = loop [] in - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; nodes (* let-binding ::= pattern = expr *) @@ -1003,180 +1018,177 @@ let parseRegion p ~grammar ~f = (* ∣ [| pattern { ; pattern } [ ; ] |] *) (* ∣ char-literal .. char-literal *) (* ∣ exception pattern *) -let rec parsePattern ?(alias = true) ?(or_ = true) p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in +let rec parse_pattern ?(alias = true) ?(or_ = true) p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in let pat = match p.Parser.token with | (True | False) as token -> - let endPos = p.endPos in + let end_pos = p.end_pos in Parser.next p; - let loc = mkLoc startPos endPos in + let loc = mk_loc start_pos end_pos in Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) + (Location.mkloc (Longident.Lident (Token.to_string token)) loc) None | Int _ | String _ | Float _ | Codepoint _ | Minus | Plus -> ( - let c = parseConstant p in + let c = parse_constant p in match p.token with | DotDot -> Parser.next p; - let c2 = parseConstant p in - Ast_helper.Pat.interval ~loc:(mkLoc startPos p.prevEndPos) c c2 - | _ -> Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) c) + let c2 = parse_constant p in + Ast_helper.Pat.interval ~loc:(mk_loc start_pos p.prev_end_pos) c c2 + | _ -> Ast_helper.Pat.constant ~loc:(mk_loc start_pos p.prev_end_pos) c) | Backtick -> - let constant = parseTemplateConstant ~prefix:(Some "js") p in - Ast_helper.Pat.constant ~attrs:[templateLiteralAttr] - ~loc:(mkLoc startPos p.prevEndPos) + let constant = parse_template_constant ~prefix:(Some "js") p in + Ast_helper.Pat.constant ~attrs:[template_literal_attr] + ~loc:(mk_loc start_pos p.prev_end_pos) constant | Lparen -> ( Parser.next p; match p.token with | Rparen -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in let lid = Location.mkloc (Longident.Lident "()") loc in Ast_helper.Pat.construct ~loc lid None | _ -> ( - let pat = parseConstrainedPattern p in + let pat = parse_constrained_pattern p in match p.token with | Comma -> Parser.next p; - parseTuplePattern ~attrs ~first:pat ~startPos p + parse_tuple_pattern ~attrs ~first:pat ~start_pos p | _ -> Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in { pat with ppat_loc = loc; ppat_attributes = attrs @ pat.Parsetree.ppat_attributes; })) - | Lbracket -> parseArrayPattern ~attrs p - | Lbrace -> parseRecordPattern ~attrs p + | Lbracket -> parse_array_pattern ~attrs p + | Lbrace -> parse_record_pattern ~attrs p | Underscore -> - let endPos = p.endPos in - let loc = mkLoc startPos endPos in + let end_pos = p.end_pos in + let loc = mk_loc start_pos end_pos in Parser.next p; Ast_helper.Pat.any ~loc ~attrs () | Lident ident -> ( - let endPos = p.endPos in - let loc = mkLoc startPos endPos in + let end_pos = p.end_pos in + let loc = mk_loc start_pos end_pos in Parser.next p; match p.token with | Backtick -> - let constant = parseTemplateConstant ~prefix:(Some ident) p in - Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant + let constant = parse_template_constant ~prefix:(Some ident) p in + Ast_helper.Pat.constant ~loc:(mk_loc start_pos p.prev_end_pos) constant | _ -> Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc)) | Uident _ -> ( - let constr = parseModuleLongIdent ~lowercase:false p in + let constr = parse_module_long_ident ~lowercase:false p in match p.Parser.token with - | Lparen -> parseConstructorPatternArgs p constr startPos attrs + | Lparen -> parse_constructor_pattern_args p constr start_pos attrs | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None) | Hash -> ( Parser.next p; if p.Parser.token == DotDotDot then ( Parser.next p; - let ident = parseValuePath p in - let loc = mkLoc startPos ident.loc.loc_end in + let ident = parse_value_path p in + let loc = mk_loc start_pos ident.loc.loc_end in Ast_helper.Pat.type_ ~loc ~attrs ident) else let ident, loc = match p.token with | String text -> Parser.next p; - (text, mkLoc startPos p.prevEndPos) + (text, mk_loc start_pos p.prev_end_pos) | Int {i; suffix} -> let () = match suffix with | Some _ -> Parser.err p - (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) + (Diagnostics.message + (ErrorMessages.poly_var_int_with_suffix i)) | None -> () in Parser.next p; - (i, mkLoc startPos p.prevEndPos) + (i, mk_loc start_pos p.prev_end_pos) | Eof -> - Parser.err ~startPos p + Parser.err ~start_pos p (Diagnostics.unexpected p.token p.breadcrumbs); - ("", mkLoc startPos p.prevEndPos) - | _ -> parseIdent ~msg:ErrorMessages.variantIdent ~startPos p + ("", mk_loc start_pos p.prev_end_pos) + | _ -> parse_ident ~msg:ErrorMessages.variant_ident ~start_pos p in match p.Parser.token with - | Lparen -> parseVariantPatternArgs p ident startPos attrs + | Lparen -> parse_variant_pattern_args p ident start_pos attrs | _ -> Ast_helper.Pat.variant ~loc ~attrs ident None) | Exception -> Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in + let pat = parse_pattern ~alias:false ~or_:false p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Pat.exception_ ~loc ~attrs pat - | Lazy -> - Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.lazy_ ~loc ~attrs pat | List -> Parser.next p; - parseListPattern ~startPos ~attrs p - | Module -> parseModulePattern ~attrs p + parse_list_pattern ~start_pos ~attrs p + | Module -> parse_module_pattern ~attrs p | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in + let extension = parse_extension p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Pat.extension ~loc ~attrs extension | Eof -> Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultPattern () + Recover.default_pattern () | token -> ( Parser.err p (Diagnostics.unexpected token p.breadcrumbs); match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicPatternStart + skip_tokens_and_maybe_retry p + ~is_start_of_grammar:Grammar.is_atomic_pattern_start with - | None -> Recover.defaultPattern () - | Some () -> parsePattern p) + | None -> Recover.default_pattern () + | Some () -> parse_pattern p) in - let pat = if alias then parseAliasPattern ~attrs pat p else pat in - if or_ then parseOrPattern pat p else pat + let pat = if alias then parse_alias_pattern ~attrs pat p else pat in + if or_ then parse_or_pattern pat p else pat -and skipTokensAndMaybeRetry p ~isStartOfGrammar = +and skip_tokens_and_maybe_retry p ~is_start_of_grammar = if - Token.isKeyword p.Parser.token - && p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum + Token.is_keyword p.Parser.token + && p.Parser.prev_end_pos.pos_lnum == p.start_pos.pos_lnum then ( Parser.next p; None) - else if Recover.shouldAbortListParse p then - if isStartOfGrammar p.Parser.token then ( + else if Recover.should_abort_list_parse p then + if is_start_of_grammar p.Parser.token then ( Parser.next p; Some ()) else None else ( Parser.next p; let rec loop p = - if not (Recover.shouldAbortListParse p) then ( + if not (Recover.should_abort_list_parse p) then ( Parser.next p; loop p) in loop p; - if isStartOfGrammar p.Parser.token then Some () else None) + if is_start_of_grammar p.Parser.token then Some () else None) (* alias ::= pattern as lident *) -and parseAliasPattern ~attrs pattern p = +and parse_alias_pattern ~attrs pattern p = match p.Parser.token with | As -> Parser.next p; - let name, loc = parseLident p in + let name, loc = parse_lident p in let name = Location.mkloc name loc in Ast_helper.Pat.alias - ~loc:{pattern.ppat_loc with loc_end = p.prevEndPos} + ~loc:{pattern.ppat_loc with loc_end = p.prev_end_pos} ~attrs pattern name | _ -> pattern (* or ::= pattern | pattern * precedence: Red | Blue | Green is interpreted as (Red | Blue) | Green *) -and parseOrPattern pattern1 p = +and parse_or_pattern pattern1 p = let rec loop pattern1 = match p.Parser.token with | Bar -> Parser.next p; - let pattern2 = parsePattern ~or_:false p in + let pattern2 = parse_pattern ~or_:false p in let loc = {pattern1.Parsetree.ppat_loc with loc_end = pattern2.ppat_loc.loc_end} in @@ -1185,7 +1197,7 @@ and parseOrPattern pattern1 p = in loop pattern1 -and parseNonSpreadPattern ~msg p = +and parse_non_spread_pattern ~msg p = let () = match p.Parser.token with | DotDotDot -> @@ -1194,33 +1206,34 @@ and parseNonSpreadPattern ~msg p = | _ -> () in match p.Parser.token with - | token when Grammar.isPatternStart token -> ( - let pat = parsePattern p in + | token when Grammar.is_pattern_start token -> ( + let pat = parse_pattern p in match p.Parser.token with | Colon -> Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in + let typ = parse_typ_expr p in + let loc = mk_loc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in Some (Ast_helper.Pat.constraint_ ~loc pat typ) | _ -> Some pat) | _ -> None -and parseConstrainedPattern p = - let pat = parsePattern p in +and parse_constrained_pattern p = + let pat = parse_pattern p in match p.Parser.token with | Colon -> Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in + let typ = parse_typ_expr p in + let loc = mk_loc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in Ast_helper.Pat.constraint_ ~loc pat typ | _ -> pat -and parseConstrainedPatternRegion p = +and parse_constrained_pattern_region p = match p.Parser.token with - | token when Grammar.isPatternStart token -> Some (parseConstrainedPattern p) + | token when Grammar.is_pattern_start token -> + Some (parse_constrained_pattern p) | _ -> None -and parseOptionalLabel p = +and parse_optional_label p = match p.Parser.token with | Question -> Parser.next p; @@ -1237,15 +1250,15 @@ and parseOptionalLabel p = * | field , _ * | field , _, *) -and parseRecordPatternRowField ~attrs p = - let label = parseValuePath p in +and parse_record_pattern_row_field ~attrs p = + let label = parse_value_path p in let pattern = match p.Parser.token with | Colon -> Parser.next p; - let optional = parseOptionalLabel p in - let pat = parsePattern p in - makePatternOptional ~optional pat + let optional = parse_optional_label p in + let pat = parse_pattern p in + make_pattern_optional ~optional pat | _ -> Ast_helper.Pat.var ~loc:label.loc ~attrs (Location.mkloc (Longident.last label.txt) label.loc) @@ -1253,90 +1266,90 @@ and parseRecordPatternRowField ~attrs p = (label, pattern) (* TODO: there are better representations than PatField|Underscore ? *) -and parseRecordPatternRow p = - let attrs = parseAttributes p in +and parse_record_pattern_row p = + let attrs = parse_attributes p in match p.Parser.token with | DotDotDot -> Parser.next p; - Some (true, PatField (parseRecordPatternRowField ~attrs p)) + Some (true, PatField (parse_record_pattern_row_field ~attrs p)) | Uident _ | Lident _ -> - Some (false, PatField (parseRecordPatternRowField ~attrs p)) + Some (false, PatField (parse_record_pattern_row_field ~attrs p)) | Question -> ( Parser.next p; match p.token with | Uident _ | Lident _ -> - let lid, pat = parseRecordPatternRowField ~attrs p in - Some (false, PatField (lid, makePatternOptional ~optional:true pat)) + let lid, pat = parse_record_pattern_row_field ~attrs p in + Some (false, PatField (lid, make_pattern_optional ~optional:true pat)) | _ -> None) | Underscore -> Parser.next p; Some (false, PatUnderscore) | _ -> None -and parseRecordPattern ~attrs p = - let startPos = p.startPos in +and parse_record_pattern ~attrs p = + let start_pos = p.start_pos in Parser.expect Lbrace p; - let rawFields = - parseCommaDelimitedReversedList p ~grammar:PatternRecord ~closing:Rbrace - ~f:parseRecordPatternRow + let raw_fields = + parse_comma_delimited_reversed_list p ~grammar:PatternRecord ~closing:Rbrace + ~f:parse_record_pattern_row in Parser.expect Rbrace p; - let fields, closedFlag = - let rawFields, flag = - match rawFields with + let fields, closed_flag = + let raw_fields, flag = + match raw_fields with | (_hasSpread, PatUnderscore) :: rest -> (rest, Asttypes.Open) - | rawFields -> (rawFields, Asttypes.Closed) + | raw_fields -> (raw_fields, Asttypes.Closed) in List.fold_left (fun (fields, flag) curr -> - let hasSpread, field = curr in + let has_spread, field = curr in match field with | PatField field -> - (if hasSpread then + (if has_spread then let _, pattern = field in - Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p - (Diagnostics.message ErrorMessages.recordPatternSpread)); + Parser.err ~start_pos:pattern.Parsetree.ppat_loc.loc_start p + (Diagnostics.message ErrorMessages.record_pattern_spread)); (field :: fields, flag) | PatUnderscore -> (fields, flag)) - ([], flag) rawFields + ([], flag) raw_fields in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.record ~loc ~attrs fields closedFlag + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Pat.record ~loc ~attrs fields closed_flag -and parseTuplePattern ~attrs ~first ~startPos p = +and parse_tuple_pattern ~attrs ~first ~start_pos p = let patterns = first - :: parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rparen - ~f:parseConstrainedPatternRegion + :: parse_comma_delimited_region p ~grammar:Grammar.PatternList + ~closing:Rparen ~f:parse_constrained_pattern_region in Parser.expect Rparen p; let () = match patterns with | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message ErrorMessages.tuple_single_element) | _ -> () in - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Pat.tuple ~loc ~attrs patterns -and parsePatternRegion p = +and parse_pattern_region p = match p.Parser.token with | DotDotDot -> Parser.next p; - Some (true, parseConstrainedPattern p) - | token when Grammar.isPatternStart token -> - Some (false, parseConstrainedPattern p) + Some (true, parse_constrained_pattern p) + | token when Grammar.is_pattern_start token -> + Some (false, parse_constrained_pattern p) | _ -> None -and parseModulePattern ~attrs p = - let startPos = p.Parser.startPos in +and parse_module_pattern ~attrs p = + let start_pos = p.Parser.start_pos in Parser.expect Module p; Parser.expect Lparen p; let uident = match p.token with | Uident uident -> - let loc = mkLoc p.startPos p.endPos in + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; Location.mkloc uident loc | _ -> @@ -1345,68 +1358,69 @@ and parseModulePattern ~attrs p = in match p.token with | Colon -> - let colonStart = p.Parser.startPos in + let colon_start = p.Parser.start_pos in Parser.next p; - let packageTypAttrs = parseAttributes p in - let packageType = - parsePackageType ~startPos:colonStart ~attrs:packageTypAttrs p + let package_typ_attrs = parse_attributes p in + let package_type = + parse_package_type ~start_pos:colon_start ~attrs:package_typ_attrs p in Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in let unpack = Ast_helper.Pat.unpack ~loc:uident.loc uident in - Ast_helper.Pat.constraint_ ~loc ~attrs unpack packageType + Ast_helper.Pat.constraint_ ~loc ~attrs unpack package_type | _ -> Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Pat.unpack ~loc ~attrs uident -and parseListPattern ~startPos ~attrs p = - let listPatterns = - parseCommaDelimitedReversedList p ~grammar:Grammar.PatternOcamlList - ~closing:Rbrace ~f:parsePatternRegion +and parse_list_pattern ~start_pos ~attrs p = + let list_patterns = + parse_comma_delimited_reversed_list p ~grammar:Grammar.PatternOcamlList + ~closing:Rbrace ~f:parse_pattern_region in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let filterSpread (hasSpread, pattern) = - if hasSpread then ( - Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p - (Diagnostics.message ErrorMessages.listPatternSpread); + let loc = mk_loc start_pos p.prev_end_pos in + let filter_spread (has_spread, pattern) = + if has_spread then ( + Parser.err ~start_pos:pattern.Parsetree.ppat_loc.loc_start p + (Diagnostics.message ErrorMessages.list_pattern_spread); pattern) else pattern in - match listPatterns with + match list_patterns with | (true, pattern) :: patterns -> - let patterns = patterns |> List.map filterSpread |> List.rev in - let pat = makeListPattern loc patterns (Some pattern) in + let patterns = patterns |> List.map filter_spread |> List.rev in + let pat = make_list_pattern loc patterns (Some pattern) in {pat with ppat_loc = loc; ppat_attributes = attrs} | patterns -> - let patterns = patterns |> List.map filterSpread |> List.rev in - let pat = makeListPattern loc patterns None in + let patterns = patterns |> List.map filter_spread |> List.rev in + let pat = make_list_pattern loc patterns None in {pat with ppat_loc = loc; ppat_attributes = attrs} -and parseArrayPattern ~attrs p = - let startPos = p.startPos in +and parse_array_pattern ~attrs p = + let start_pos = p.start_pos in Parser.expect Lbracket p; let patterns = - parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rbracket - ~f:(parseNonSpreadPattern ~msg:ErrorMessages.arrayPatternSpread) + parse_comma_delimited_region p ~grammar:Grammar.PatternList + ~closing:Rbracket + ~f:(parse_non_spread_pattern ~msg:ErrorMessages.array_pattern_spread) in Parser.expect Rbracket p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Pat.array ~loc ~attrs patterns -and parseConstructorPatternArgs p constr startPos attrs = - let lparen = p.startPos in +and parse_constructor_pattern_args p constr start_pos attrs = + let lparen = p.start_pos in Parser.expect Lparen p; let args = - parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rparen - ~f:parseConstrainedPatternRegion + parse_comma_delimited_region p ~grammar:Grammar.PatternList ~closing:Rparen + ~f:parse_constrained_pattern_region in Parser.expect Rparen p; let args = match args with | [] -> - let loc = mkLoc lparen p.prevEndPos in + let loc = mk_loc lparen p.prev_end_pos in Some (Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) @@ -1417,24 +1431,26 @@ and parseConstructorPatternArgs p constr startPos attrs = Some pat else (* Some((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) | [pattern] -> Some pattern | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) in - Ast_helper.Pat.construct ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args + Ast_helper.Pat.construct + ~loc:(mk_loc start_pos p.prev_end_pos) + ~attrs constr args -and parseVariantPatternArgs p ident startPos attrs = - let lparen = p.startPos in +and parse_variant_pattern_args p ident start_pos attrs = + let lparen = p.start_pos in Parser.expect Lparen p; let patterns = - parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rparen - ~f:parseConstrainedPatternRegion + parse_comma_delimited_region p ~grammar:Grammar.PatternList ~closing:Rparen + ~f:parse_constrained_pattern_region in let args = match patterns with | [] -> - let loc = mkLoc lparen p.prevEndPos in + let loc = mk_loc lparen p.prev_end_pos in Some (Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) @@ -1445,44 +1461,46 @@ and parseVariantPatternArgs p ident startPos attrs = Some pat else (* #ident((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) | [pattern] -> Some pattern | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) in Parser.expect Rparen p; - Ast_helper.Pat.variant ~loc:(mkLoc startPos p.prevEndPos) ~attrs ident args + Ast_helper.Pat.variant + ~loc:(mk_loc start_pos p.prev_end_pos) + ~attrs ident args -and parseExpr ?(context = OrdinaryExpr) p = - let expr = parseOperandExpr ~context p in - let expr = parseBinaryExpr ~context ~a:expr p 1 in - parseTernaryExpr expr p +and parse_expr ?(context = OrdinaryExpr) p = + let expr = parse_operand_expr ~context p in + let expr = parse_binary_expr ~context ~a:expr p 1 in + parse_ternary_expr expr p (* expr ? expr : expr *) -and parseTernaryExpr leftOperand p = +and parse_ternary_expr left_operand p = match p.Parser.token with | Question -> - Parser.leaveBreadcrumb p Grammar.Ternary; + Parser.leave_breadcrumb p Grammar.Ternary; Parser.next p; - let trueBranch = parseExpr ~context:TernaryTrueBranchExpr p in + let true_branch = parse_expr ~context:TernaryTrueBranchExpr p in Parser.expect Colon p; - let falseBranch = parseExpr p in - Parser.eatBreadcrumb p; + let false_branch = parse_expr p in + Parser.eat_breadcrumb p; let loc = { - leftOperand.Parsetree.pexp_loc with - loc_start = leftOperand.pexp_loc.loc_start; - loc_end = falseBranch.Parsetree.pexp_loc.loc_end; + left_operand.Parsetree.pexp_loc with + loc_start = left_operand.pexp_loc.loc_start; + loc_end = false_branch.Parsetree.pexp_loc.loc_end; } in - Ast_helper.Exp.ifthenelse ~attrs:[ternaryAttr] ~loc leftOperand trueBranch - (Some falseBranch) - | _ -> leftOperand - -and parseEs6ArrowExpression ?(arrowAttrs = []) ?(arrowStartPos = None) ?context - ?parameters p = - let startPos = p.Parser.startPos in - Parser.leaveBreadcrumb p Grammar.Es6ArrowExpr; + Ast_helper.Exp.ifthenelse ~attrs:[ternary_attr] ~loc left_operand + true_branch (Some false_branch) + | _ -> left_operand + +and parse_es6_arrow_expression ?(arrow_attrs = []) ?(arrow_start_pos = None) + ?context ?parameters p = + let start_pos = p.Parser.start_pos in + Parser.leave_breadcrumb p Grammar.Es6ArrowExpr; (* Parsing function parameters and attributes: 1. Basically, attributes outside of `(...)` are added to the function, except the uncurried attribute `(.)` is added to the function. e.g. async, uncurried @@ -1492,75 +1510,78 @@ and parseEs6ArrowExpression ?(arrowAttrs = []) ?(arrowStartPos = None) ?context let parameters = match parameters with | Some params -> params - | None -> parseParameters p + | None -> parse_parameters p in let parameters = - let updateAttrs attrs = arrowAttrs @ attrs in - let updatePos pos = - match arrowStartPos with - | Some startPos -> startPos + let update_attrs attrs = arrow_attrs @ attrs in + let update_pos pos = + match arrow_start_pos with + | Some start_pos -> start_pos | None -> pos in match parameters with | TermParameter p :: rest -> - TermParameter {p with attrs = updateAttrs p.attrs; pos = updatePos p.pos} + TermParameter + {p with attrs = update_attrs p.attrs; pos = update_pos p.pos} :: rest | TypeParameter p :: rest -> - TypeParameter {p with attrs = updateAttrs p.attrs; pos = updatePos p.pos} + TypeParameter + {p with attrs = update_attrs p.attrs; pos = update_pos p.pos} :: rest | [] -> parameters in let parameters = (* Propagate any dots from type parameters to the first term *) - let rec loop ~dotInType params = + let rec loop ~dot_in_type params = match params with | (TypeParameter {dotted} as p) :: _ -> - let rest = LoopProgress.listRest params in + let rest = LoopProgress.list_rest params in (* Tell termination checker about progress *) - p :: loop ~dotInType:(dotInType || dotted) rest - | TermParameter termParam :: rest -> - TermParameter {termParam with dotted = dotInType || termParam.dotted} + p :: loop ~dot_in_type:(dot_in_type || dotted) rest + | TermParameter term_param :: rest -> + TermParameter + {term_param with dotted = dot_in_type || term_param.dotted} :: rest | [] -> [] in - loop ~dotInType:false parameters + loop ~dot_in_type:false parameters in - let returnType = + let return_type = match p.Parser.token with | Colon -> Parser.next p; - Some (parseTypExpr ~es6Arrow:false p) + Some (parse_typ_expr ~es6_arrow:false p) | _ -> None in Parser.expect EqualGreater p; let body = - let expr = parseExpr ?context p in - match returnType with + let expr = parse_expr ?context p in + match return_type with | Some typ -> Ast_helper.Exp.constraint_ - ~loc:(mkLoc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) + ~loc:(mk_loc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) expr typ | None -> expr in - Parser.eatBreadcrumb p; - let endPos = p.prevEndPos in - let termParameters = + Parser.eat_breadcrumb p; + let end_pos = p.prev_end_pos in + let term_parameters = parameters |> List.filter (function | TermParameter _ -> true | TypeParameter _ -> false) in - let bodyNeedsBraces = - let isFun = + let body_needs_braces = + let is_fun = match body.pexp_desc with | Pexp_fun _ -> true | _ -> false in - match termParameters with + match term_parameters with | TermParameter {dotted} :: _ - when p.uncurried_config |> Res_uncurried.fromDotted ~dotted && isFun -> + when p.uncurried_config |> Res_uncurried.from_dotted ~dotted && is_fun -> true - | TermParameter _ :: rest when p.uncurried_config = Legacy && isFun -> + | TermParameter _ :: rest when p.uncurried_config = Legacy && is_fun -> rest |> List.exists (function | TermParameter {dotted} -> dotted @@ -1568,44 +1589,47 @@ and parseEs6ArrowExpression ?(arrowAttrs = []) ?(arrowStartPos = None) ?context | _ -> false in let body = - if bodyNeedsBraces then + if body_needs_braces then { body with - pexp_attributes = makeBracesAttr body.pexp_loc :: body.pexp_attributes; + pexp_attributes = make_braces_attr body.pexp_loc :: body.pexp_attributes; } else body in - let _paramNum, arrowExpr, _arity = + let _paramNum, arrow_expr, _arity = List.fold_right - (fun parameter (termParamNum, expr, arity) -> + (fun parameter (term_param_num, expr, arity) -> match parameter with | TermParameter { dotted; attrs; label = lbl; - expr = defaultExpr; + expr = default_expr; pat; - pos = startPos; + pos = start_pos; } -> - let loc = mkLoc startPos endPos in - let funExpr = - Ast_helper.Exp.fun_ ~loc ~attrs lbl defaultExpr pat expr + let loc = mk_loc start_pos end_pos in + let fun_expr = + Ast_helper.Exp.fun_ ~loc ~attrs lbl default_expr pat expr in let uncurried = - p.uncurried_config |> Res_uncurried.fromDotted ~dotted + p.uncurried_config |> Res_uncurried.from_dotted ~dotted in - if uncurried && (termParamNum = 1 || p.uncurried_config = Legacy) then - (termParamNum - 1, Ast_uncurried.uncurriedFun ~loc ~arity funExpr, 1) - else (termParamNum - 1, funExpr, arity + 1) - | TypeParameter {dotted = _; attrs; locs = newtypes; pos = startPos} -> - ( termParamNum, - makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr, + if uncurried && (term_param_num = 1 || p.uncurried_config = Legacy) + then + ( term_param_num - 1, + Ast_uncurried.uncurried_fun ~loc ~arity fun_expr, + 1 ) + else (term_param_num - 1, fun_expr, arity + 1) + | TypeParameter {dotted = _; attrs; locs = newtypes; pos = start_pos} -> + ( term_param_num, + make_newtypes ~attrs ~loc:(mk_loc start_pos end_pos) newtypes expr, arity )) parameters - (List.length termParameters, body, 1) + (List.length term_parameters, body, 1) in - {arrowExpr with pexp_loc = {arrowExpr.pexp_loc with loc_start = startPos}} + {arrow_expr with pexp_loc = {arrow_expr.pexp_loc with loc_start = start_pos}} (* * dotted_parameter ::= @@ -1626,65 +1650,65 @@ and parseEs6ArrowExpression ?(arrowAttrs = []) ?(arrowStartPos = None) ?context * * labelName ::= lident *) -and parseParameter p = +and parse_parameter p = if p.Parser.token = Token.Typ || p.token = Tilde || p.token = Dot - || Grammar.isPatternStart p.token + || Grammar.is_pattern_start p.token then - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in let dotted = Parser.optional p Token.Dot in - let attrs = parseAttributes p in + let attrs = parse_attributes p in if p.Parser.token = Typ then ( Parser.next p; - let lidents = parseLidentList p in - Some (TypeParameter {dotted; attrs; locs = lidents; pos = startPos})) + let lidents = parse_lident_list p in + Some (TypeParameter {dotted; attrs; locs = lidents; pos = start_pos})) else let attrs, lbl, pat = match p.Parser.token with | Tilde -> ( Parser.next p; - let lblName, loc = parseLident p in - let propLocAttr = + let lbl_name, loc = parse_lident p in + let prop_loc_attr = (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in match p.Parser.token with | Comma | Equal | Rparen -> - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in ( [], - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~attrs:(propLocAttr :: attrs) ~loc - (Location.mkloc lblName loc) ) + Asttypes.Labelled lbl_name, + Ast_helper.Pat.var ~attrs:(prop_loc_attr :: attrs) ~loc + (Location.mkloc lbl_name loc) ) | Colon -> - let lblEnd = p.prevEndPos in + let lbl_end = p.prev_end_pos in Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos lblEnd in + let typ = parse_typ_expr p in + let loc = mk_loc start_pos lbl_end in let pat = - let pat = Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.constraint_ ~attrs:(propLocAttr :: attrs) ~loc pat - typ + let pat = Ast_helper.Pat.var ~loc (Location.mkloc lbl_name loc) in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Pat.constraint_ ~attrs:(prop_loc_attr :: attrs) ~loc + pat typ in - ([], Asttypes.Labelled lblName, pat) + ([], Asttypes.Labelled lbl_name, pat) | As -> Parser.next p; let pat = - let pat = parseConstrainedPattern p in + let pat = parse_constrained_pattern p in { pat with - ppat_attributes = (propLocAttr :: attrs) @ pat.ppat_attributes; + ppat_attributes = (prop_loc_attr :: attrs) @ pat.ppat_attributes; } in - ([], Asttypes.Labelled lblName, pat) + ([], Asttypes.Labelled lbl_name, pat) | t -> Parser.err p (Diagnostics.unexpected t p.breadcrumbs); - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in ( [], - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~attrs:(propLocAttr :: attrs) ~loc - (Location.mkloc lblName loc) )) + Asttypes.Labelled lbl_name, + Ast_helper.Pat.var ~attrs:(prop_loc_attr :: attrs) ~loc + (Location.mkloc lbl_name loc) )) | _ -> - let pattern = parseConstrainedPattern p in + let pattern = parse_constrained_pattern p in let attrs = List.concat [pattern.ppat_attributes; attrs] in ([], Asttypes.Nolabel, {pattern with ppat_attributes = attrs}) in @@ -1693,17 +1717,17 @@ and parseParameter p = Parser.next p; let lbl = match lbl with - | Asttypes.Labelled lblName -> Asttypes.Optional lblName + | Asttypes.Labelled lbl_name -> Asttypes.Optional lbl_name | Asttypes.Nolabel -> - let lblName = + let lbl_name = match pat.ppat_desc with | Ppat_var var -> var.txt | _ -> "" in - Parser.err ~startPos ~endPos:p.prevEndPos p + Parser.err ~start_pos ~end_pos:p.prev_end_pos p (Diagnostics.message - (ErrorMessages.missingTildeLabeledParameter lblName)); - Asttypes.Optional lblName + (ErrorMessages.missing_tilde_labeled_parameter lbl_name)); + Asttypes.Optional lbl_name | lbl -> lbl in match p.Parser.token with @@ -1711,9 +1735,9 @@ and parseParameter p = Parser.next p; Some (TermParameter - {dotted; attrs; label = lbl; expr = None; pat; pos = startPos}) + {dotted; attrs; label = lbl; expr = None; pat; pos = start_pos}) | _ -> - let expr = parseConstrainedOrCoercedExpr p in + let expr = parse_constrained_or_coerced_expr p in Some (TermParameter { @@ -1722,18 +1746,18 @@ and parseParameter p = label = lbl; expr = Some expr; pat; - pos = startPos; + pos = start_pos; })) | _ -> Some (TermParameter - {dotted; attrs; label = lbl; expr = None; pat; pos = startPos}) + {dotted; attrs; label = lbl; expr = None; pat; pos = start_pos}) else None -and parseParameterList p = +and parse_parameter_list p = let parameters = - parseCommaDelimitedRegion ~grammar:Grammar.ParameterList ~f:parseParameter - ~closing:Rparen p + parse_comma_delimited_region ~grammar:Grammar.ParameterList + ~f:parse_parameter ~closing:Rparen p in Parser.expect Rparen p; parameters @@ -1745,12 +1769,12 @@ and parseParameterList p = * | (.) * | ( parameter {, parameter} [,] ) *) -and parseParameters p = - let startPos = p.Parser.startPos in +and parse_parameters p = + let start_pos = p.Parser.start_pos in match p.Parser.token with | Lident ident -> Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in + let loc = mk_loc start_pos p.Parser.prev_end_pos in [ TermParameter { @@ -1759,12 +1783,12 @@ and parseParameters p = label = Asttypes.Nolabel; expr = None; pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); - pos = startPos; + pos = start_pos; }; ] | Underscore -> Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in + let loc = mk_loc start_pos p.Parser.prev_end_pos in [ TermParameter { @@ -1773,7 +1797,7 @@ and parseParameters p = label = Asttypes.Nolabel; expr = None; pat = Ast_helper.Pat.any ~loc (); - pos = startPos; + pos = start_pos; }; ] | Lparen -> ( @@ -1781,8 +1805,8 @@ and parseParameters p = match p.Parser.token with | Rparen -> Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = + let loc = mk_loc start_pos p.Parser.prev_end_pos in + let unit_pattern = Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None @@ -1794,8 +1818,8 @@ and parseParameters p = attrs = []; label = Asttypes.Nolabel; expr = None; - pat = unitPattern; - pos = startPos; + pat = unit_pattern; + pos = start_pos; }; ] | Dot -> ( @@ -1803,8 +1827,8 @@ and parseParameters p = match p.token with | Rparen -> Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = + let loc = mk_loc start_pos p.Parser.prev_end_pos in + let unit_pattern = Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None @@ -1816,53 +1840,53 @@ and parseParameters p = attrs = []; label = Asttypes.Nolabel; expr = None; - pat = unitPattern; - pos = startPos; + pat = unit_pattern; + pos = start_pos; }; ] | _ -> ( - match parseParameterList p with + match parse_parameter_list p with | TermParameter p :: rest -> - TermParameter {p with dotted = true; pos = startPos} :: rest + TermParameter {p with dotted = true; pos = start_pos} :: rest | TypeParameter p :: rest -> - TypeParameter {p with dotted = true; pos = startPos} :: rest + TypeParameter {p with dotted = true; pos = start_pos} :: rest | parameters -> parameters)) - | _ -> parseParameterList p) + | _ -> parse_parameter_list p) | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); [] -and parseCoercedExpr ~(expr : Parsetree.expression) p = +and parse_coerced_expr ~(expr : Parsetree.expression) p = Parser.expect ColonGreaterThan p; - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start p.prevEndPos in + let typ = parse_typ_expr p in + let loc = mk_loc expr.pexp_loc.loc_start p.prev_end_pos in Ast_helper.Exp.coerce ~loc expr None typ -and parseConstrainedOrCoercedExpr p = - let expr = parseExpr p in +and parse_constrained_or_coerced_expr p = + let expr = parse_expr p in match p.Parser.token with - | ColonGreaterThan -> parseCoercedExpr ~expr p + | ColonGreaterThan -> parse_coerced_expr ~expr p | Colon -> ( Parser.next p; match p.token with | _ -> ( - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let typ = parse_typ_expr p in + let loc = mk_loc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in let expr = Ast_helper.Exp.constraint_ ~loc expr typ in match p.token with - | ColonGreaterThan -> parseCoercedExpr ~expr p + | ColonGreaterThan -> parse_coerced_expr ~expr p | _ -> expr)) | _ -> expr -and parseConstrainedExprRegion p = +and parse_constrained_expr_region p = match p.Parser.token with - | token when Grammar.isExprStart token -> ( - let expr = parseExpr p in + | token when Grammar.is_expr_start token -> ( + let expr = parse_expr p in match p.Parser.token with | Colon -> Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let typ = parse_typ_expr p in + let loc = mk_loc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in Some (Ast_helper.Exp.constraint_ ~loc expr typ) | _ -> Some expr) | _ -> None @@ -1870,41 +1894,41 @@ and parseConstrainedExprRegion p = (* Atomic expressions represent unambiguous expressions. * This means that regardless of the context, these expressions * are always interpreted correctly. *) -and parseAtomicExpr p = - Parser.leaveBreadcrumb p Grammar.ExprOperand; - let startPos = p.Parser.startPos in +and parse_atomic_expr p = + Parser.leave_breadcrumb p Grammar.ExprOperand; + let start_pos = p.Parser.start_pos in let expr = match p.Parser.token with | (True | False) as token -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) + (Location.mkloc (Longident.Lident (Token.to_string token)) loc) None | Int _ | String _ | Float _ | Codepoint _ -> - let c = parseConstant p in - let loc = mkLoc startPos p.prevEndPos in + let c = parse_constant p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.constant ~loc c | Backtick -> - let expr = parseTemplateExpr p in - {expr with pexp_loc = mkLoc startPos p.prevEndPos} - | Uident _ | Lident _ -> parseValueOrConstructor p - | Hash -> parsePolyVariantExpr p + let expr = parse_template_expr p in + {expr with pexp_loc = mk_loc start_pos p.prev_end_pos} + | Uident _ | Lident _ -> parse_value_or_constructor p + | Hash -> parse_poly_variant_expr p | Lparen -> ( Parser.next p; match p.Parser.token with | Rparen -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None | _t -> ( - let expr = parseConstrainedOrCoercedExpr p in + let expr = parse_constrained_or_coerced_expr p in match p.token with | Comma -> Parser.next p; - parseTupleExpr ~startPos ~first:expr p + parse_tuple_expr ~start_pos ~first:expr p | _ -> Parser.expect Rparen p; expr @@ -1916,123 +1940,125 @@ and parseAtomicExpr p = * with for comments. *))) | List -> Parser.next p; - parseListExpr ~startPos p + parse_list_expr ~start_pos p | Module -> Parser.next p; - parseFirstClassModuleExpr ~startPos p - | Lbracket -> parseArrayExp p - | Lbrace -> parseBracedOrRecordExpr p - | LessThan -> parseJsx p + parse_first_class_module_expr ~start_pos p + | Lbracket -> parse_array_exp p + | Lbrace -> parse_braced_or_record_expr p + | LessThan -> parse_jsx p | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in + let extension = parse_extension p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.extension ~loc extension | Underscore as token -> (* This case is for error recovery. Not sure if it's the correct place *) Parser.err p (Diagnostics.lident token); Parser.next p; - Recover.defaultExpr () + Recover.default_expr () | Eof -> - Parser.err ~startPos:p.prevEndPos p + Parser.err ~start_pos:p.prev_end_pos p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultExpr () + Recover.default_expr () | token -> ( - let errPos = p.prevEndPos in - Parser.err ~startPos:errPos p (Diagnostics.unexpected token p.breadcrumbs); + let err_pos = p.prev_end_pos in + Parser.err ~start_pos:err_pos p + (Diagnostics.unexpected token p.breadcrumbs); match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart + skip_tokens_and_maybe_retry p + ~is_start_of_grammar:Grammar.is_atomic_expr_start with - | None -> Recover.defaultExpr () - | Some () -> parseAtomicExpr p) + | None -> Recover.default_expr () + | Some () -> parse_atomic_expr p) in - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; expr (* module(module-expr) * module(module-expr : package-type) *) -and parseFirstClassModuleExpr ~startPos p = +and parse_first_class_module_expr ~start_pos p = Parser.expect Lparen p; - let modExpr = parseModuleExpr p in - let modEndLoc = p.prevEndPos in + let mod_expr = parse_module_expr p in + let mod_end_loc = p.prev_end_pos in match p.Parser.token with | Colon -> - let colonStart = p.Parser.startPos in + let colon_start = p.Parser.start_pos in Parser.next p; - let attrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs p in + let attrs = parse_attributes p in + let package_type = parse_package_type ~start_pos:colon_start ~attrs p in Parser.expect Rparen p; - let loc = mkLoc startPos modEndLoc in - let firstClassModule = Ast_helper.Exp.pack ~loc modExpr in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.constraint_ ~loc firstClassModule packageType + let loc = mk_loc start_pos mod_end_loc in + let first_class_module = Ast_helper.Exp.pack ~loc mod_expr in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.constraint_ ~loc first_class_module package_type | _ -> Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.pack ~loc modExpr + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.pack ~loc mod_expr -and parseBracketAccess p expr startPos = - Parser.leaveBreadcrumb p Grammar.ExprArrayAccess; - let lbracket = p.startPos in +and parse_bracket_access p expr start_pos = + Parser.leave_breadcrumb p Grammar.ExprArrayAccess; + let lbracket = p.start_pos in Parser.expect Lbracket p; - let stringStart = p.startPos in + let string_start = p.start_pos in match p.Parser.token with | String s -> ( Parser.next p; - let stringEnd = p.prevEndPos in + let string_end = p.prev_end_pos in Parser.expect Rbracket p; - Parser.eatBreadcrumb p; - let rbracket = p.prevEndPos in + Parser.eat_breadcrumb p; + let rbracket = p.prev_end_pos in let e = - let identLoc = mkLoc stringStart stringEnd in - let loc = mkLoc startPos rbracket in - Ast_helper.Exp.send ~loc expr (Location.mkloc s identLoc) + let ident_loc = mk_loc string_start string_end in + let loc = mk_loc start_pos rbracket in + Ast_helper.Exp.send ~loc expr (Location.mkloc s ident_loc) in - let e = parsePrimaryExpr ~operand:e p in - let equalStart = p.startPos in + let e = parse_primary_expr ~operand:e p in + let equal_start = p.start_pos in match p.token with | Equal -> Parser.next p; - let equalEnd = p.prevEndPos in - let rhsExpr = parseExpr p in - let loc = mkLoc startPos rhsExpr.pexp_loc.loc_end in - let operatorLoc = mkLoc equalStart equalEnd in + let equal_end = p.prev_end_pos in + let rhs_expr = parse_expr p in + let loc = mk_loc start_pos rhs_expr.pexp_loc.loc_end in + let operator_loc = mk_loc equal_start equal_end in Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc:operatorLoc - (Location.mkloc (Longident.Lident "#=") operatorLoc)) - [(Nolabel, e); (Nolabel, rhsExpr)] + (Ast_helper.Exp.ident ~loc:operator_loc + (Location.mkloc (Longident.Lident "#=") operator_loc)) + [(Nolabel, e); (Nolabel, rhs_expr)] | _ -> e) | _ -> ( - let accessExpr = parseConstrainedOrCoercedExpr p in + let access_expr = parse_constrained_or_coerced_expr p in Parser.expect Rbracket p; - Parser.eatBreadcrumb p; - let rbracket = p.prevEndPos in - let arrayLoc = mkLoc lbracket rbracket in + Parser.eat_breadcrumb p; + let rbracket = p.prev_end_pos in + let array_loc = mk_loc lbracket rbracket in match p.token with | Equal -> - Parser.leaveBreadcrumb p ExprArrayMutation; + Parser.leave_breadcrumb p ExprArrayMutation; Parser.next p; - let rhsExpr = parseExpr p in - let arraySet = - Location.mkloc (Longident.Ldot (Lident "Array", "set")) arrayLoc + let rhs_expr = parse_expr p in + let array_set = + Location.mkloc (Longident.Ldot (Lident "Array", "set")) array_loc in - let endPos = p.prevEndPos in - let arraySet = - Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident ~loc:arrayLoc arraySet) - [(Nolabel, expr); (Nolabel, accessExpr); (Nolabel, rhsExpr)] + let end_pos = p.prev_end_pos in + let array_set = + Ast_helper.Exp.apply ~loc:(mk_loc start_pos end_pos) + (Ast_helper.Exp.ident ~loc:array_loc array_set) + [(Nolabel, expr); (Nolabel, access_expr); (Nolabel, rhs_expr)] in - Parser.eatBreadcrumb p; - arraySet + Parser.eat_breadcrumb p; + array_set | _ -> - let endPos = p.prevEndPos in + let end_pos = p.prev_end_pos in let e = - Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident ~loc:arrayLoc - (Location.mkloc (Longident.Ldot (Lident "Array", "get")) arrayLoc)) - [(Nolabel, expr); (Nolabel, accessExpr)] + Ast_helper.Exp.apply ~loc:(mk_loc start_pos end_pos) + (Ast_helper.Exp.ident ~loc:array_loc + (Location.mkloc (Longident.Ldot (Lident "Array", "get")) array_loc)) + [(Nolabel, expr); (Nolabel, access_expr)] in - parsePrimaryExpr ~operand:e p) + parse_primary_expr ~operand:e p) (* * A primary expression represents * - atomic-expr @@ -2042,44 +2068,44 @@ and parseBracketAccess p expr startPos = * * The "operand" represents the expression that is operated on *) -and parsePrimaryExpr ~operand ?(noCall = false) p = - let startPos = operand.pexp_loc.loc_start in +and parse_primary_expr ~operand ?(no_call = false) p = + let start_pos = operand.pexp_loc.loc_start in let rec loop p expr = match p.Parser.token with | Dot -> ( Parser.next p; - let lident = parseValuePathAfterDot p in + let lident = parse_value_path_after_dot p in match p.Parser.token with - | Equal when noCall = false -> - Parser.leaveBreadcrumb p Grammar.ExprSetField; + | Equal when no_call = false -> + Parser.leave_breadcrumb p Grammar.ExprSetField; Parser.next p; - let targetExpr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in - let setfield = Ast_helper.Exp.setfield ~loc expr lident targetExpr in - Parser.eatBreadcrumb p; + let target_expr = parse_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + let setfield = Ast_helper.Exp.setfield ~loc expr lident target_expr in + Parser.eat_breadcrumb p; setfield | _ -> - let endPos = p.prevEndPos in - let loc = mkLoc startPos endPos in + let end_pos = p.prev_end_pos in + let loc = mk_loc start_pos end_pos in loop p (Ast_helper.Exp.field ~loc expr lident)) | Lbracket - when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - parseBracketAccess p expr startPos - | Lparen when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum - -> - loop p (parseCallExpr p expr) + when no_call = false && p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + parse_bracket_access p expr start_pos + | Lparen + when no_call = false && p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + loop p (parse_call_expr p expr) | Backtick - when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> ( + when no_call = false && p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum + -> ( match expr.pexp_desc with - | Pexp_ident {txt = Longident.Lident ident} -> - parseTemplateExpr ~prefix:ident p + | Pexp_ident long_ident -> parse_template_expr ~prefix:long_ident p | _ -> - Parser.err ~startPos:expr.pexp_loc.loc_start - ~endPos:expr.pexp_loc.loc_end p + Parser.err ~start_pos:expr.pexp_loc.loc_start + ~end_pos:expr.pexp_loc.loc_end p (Diagnostics.message "Tagged template literals are currently restricted to names like: \ json`null`."); - parseTemplateExpr p) + parse_template_expr p) | _ -> expr in loop p operand @@ -2090,31 +2116,31 @@ and parsePrimaryExpr ~operand ?(noCall = false) p = * !condition * -. 1.6 *) -and parseUnaryExpr p = - let startPos = p.Parser.startPos in +and parse_unary_expr p = + let start_pos = p.Parser.start_pos in match p.Parser.token with | (Minus | MinusDot | Plus | PlusDot | Bang) as token -> - Parser.leaveBreadcrumb p Grammar.ExprUnary; - let tokenEnd = p.endPos in + Parser.leave_breadcrumb p Grammar.ExprUnary; + let token_end = p.end_pos in Parser.next p; - let operand = parseUnaryExpr p in - let unaryExpr = makeUnaryExpr startPos tokenEnd token operand in - Parser.eatBreadcrumb p; - unaryExpr - | _ -> parsePrimaryExpr ~operand:(parseAtomicExpr p) p + let operand = parse_unary_expr p in + let unary_expr = make_unary_expr start_pos token_end token operand in + Parser.eat_breadcrumb p; + unary_expr + | _ -> parse_primary_expr ~operand:(parse_atomic_expr p) p (* Represents an "operand" in a binary expression. * If you have `a + b`, `a` and `b` both represent * the operands of the binary expression with opeartor `+` *) -and parseOperandExpr ~context p = - let startPos = p.Parser.startPos in - let attrs = ref (parseAttributes p) in +and parse_operand_expr ~context p = + let start_pos = p.Parser.start_pos in + let attrs = ref (parse_attributes p) in let expr = match p.Parser.token with | Assert -> Parser.next p; - let expr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in + let expr = parse_expr p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.assert_ ~loc expr | Lident "async" (* we need to be careful when we're in a ternary true branch: @@ -2122,31 +2148,29 @@ and parseOperandExpr ~context p = Arrow expressions could be of the form: `async (): int => stuff()` But if we're in a ternary, the `:` of the ternary takes precedence *) - when isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p - -> - let arrowAttrs = !attrs in + when is_es6_arrow_expression + ~in_ternary:(context = TernaryTrueBranchExpr) + p -> + let arrow_attrs = !attrs in let () = attrs := [] in - parseAsyncArrowExpression ~arrowAttrs p - | Await -> parseAwaitExpression p - | Lazy -> - Parser.next p; - let expr = parseUnaryExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.lazy_ ~loc expr - | Try -> parseTryExpression p - | If -> parseIfOrIfLetExpression p - | For -> parseForExpression p - | While -> parseWhileExpression p - | Switch -> parseSwitchExpression p + parse_async_arrow_expression ~arrow_attrs p + | Await -> parse_await_expression p + | Try -> parse_try_expression p + | If -> parse_if_or_if_let_expression p + | For -> parse_for_expression p + | While -> parse_while_expression p + | Switch -> parse_switch_expression p | _ -> if context != WhenExpr - && isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p + && is_es6_arrow_expression + ~in_ternary:(context = TernaryTrueBranchExpr) + p then - let arrowAttrs = !attrs in + let arrow_attrs = !attrs in let () = attrs := [] in - parseEs6ArrowExpression ~arrowAttrs ~context p - else parseUnaryExpr p + parse_es6_arrow_expression ~arrow_attrs ~context p + else parse_unary_expr p in (* let endPos = p.Parser.prevEndPos in *) { @@ -2160,15 +2184,15 @@ and parseOperandExpr ~context p = * a + b * f(x) |> g(y) *) -and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = +and parse_binary_expr ?(context = OrdinaryExpr) ?a p prec = let a = match a with | Some e -> e - | None -> parseOperandExpr ~context p + | None -> parse_operand_expr ~context p in let rec loop a = let token = p.Parser.token in - let tokenPrec = + let token_prec = match token with (* Can the minus be interpreted as a binary operator? Or is it a unary? * let w = { @@ -2185,37 +2209,37 @@ and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = * See Scanner.isBinaryOp *) | (Minus | MinusDot | LessThan) when (not - (Scanner.isBinaryOp p.scanner.src p.startPos.pos_cnum - p.endPos.pos_cnum)) - && p.startPos.pos_lnum > p.prevEndPos.pos_lnum -> + (Scanner.is_binary_op p.scanner.src p.start_pos.pos_cnum + p.end_pos.pos_cnum)) + && p.start_pos.pos_lnum > p.prev_end_pos.pos_lnum -> -1 | token -> Token.precedence token in - if tokenPrec < prec then a + if token_prec < prec then a else ( - Parser.leaveBreadcrumb p (Grammar.ExprBinaryAfterOp token); - let startPos = p.startPos in + Parser.leave_breadcrumb p (Grammar.ExprBinaryAfterOp token); + let start_pos = p.start_pos in Parser.next p; - let endPos = p.prevEndPos in - let tokenPrec = + let end_pos = p.prev_end_pos in + let token_prec = (* exponentiation operator is right-associative *) - if token = Exponentiation then tokenPrec else tokenPrec + 1 + if token = Exponentiation then token_prec else token_prec + 1 in - let b = parseBinaryExpr ~context p tokenPrec in - let loc = mkLoc a.Parsetree.pexp_loc.loc_start b.pexp_loc.loc_end in + let b = parse_binary_expr ~context p token_prec in + let loc = mk_loc a.Parsetree.pexp_loc.loc_start b.pexp_loc.loc_end in let expr = match (token, b.pexp_desc) with - | BarGreater, Pexp_apply (funExpr, args) + | BarGreater, Pexp_apply (fun_expr, args) when p.uncurried_config = Uncurried -> - {b with pexp_desc = Pexp_apply (funExpr, args @ [(Nolabel, a)])} + {b with pexp_desc = Pexp_apply (fun_expr, args @ [(Nolabel, a)])} | BarGreater, _ when p.uncurried_config = Uncurried -> Ast_helper.Exp.apply ~loc b [(Nolabel, a)] | _ -> Ast_helper.Exp.apply ~loc - (makeInfixOperator p token startPos endPos) + (make_infix_operator p token start_pos end_pos) [(Nolabel, a); (Nolabel, b)] in - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; loop expr) in loop a @@ -2253,36 +2277,38 @@ and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = (* | _ -> false *) (* ) *) -and parseTemplateExpr ?(prefix = "js") p = - let partPrefix = +and parse_template_expr ?prefix p = + let part_prefix = (* we could stop treating js and j prefix as something special for json, we would first need to remove @as(json`true`) feature *) match prefix with - | "js" | "j" | "json" -> Some prefix - | _ -> None + | Some {txt = Longident.Lident (("js" | "j" | "json") as prefix); _} -> + Some prefix + | Some _ -> None + | None -> Some "js" in - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in - let parseParts p = + let parse_parts p = let rec aux acc = - let startPos = p.Parser.startPos in - Parser.nextTemplateLiteralToken p; + let start_pos = p.Parser.start_pos in + Parser.next_template_literal_token p; match p.token with - | TemplateTail (txt, lastPos) -> + | TemplateTail (txt, last_pos) -> Parser.next p; - let loc = mkLoc startPos lastPos in + let loc = mk_loc start_pos last_pos in let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc - (Pconst_string (txt, partPrefix)) + Ast_helper.Exp.constant ~attrs:[template_literal_attr] ~loc + (Pconst_string (txt, part_prefix)) in List.rev ((str, None) :: acc) - | TemplatePart (txt, lastPos) -> + | TemplatePart (txt, last_pos) -> Parser.next p; - let loc = mkLoc startPos lastPos in - let expr = parseExprBlock p in + let loc = mk_loc start_pos last_pos in + let expr = parse_expr_block p in let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc - (Pconst_string (txt, partPrefix)) + Ast_helper.Exp.constant ~attrs:[template_literal_attr] ~loc + (Pconst_string (txt, part_prefix)) in aux ((str, Some expr) :: acc) | token -> @@ -2291,13 +2317,12 @@ and parseTemplateExpr ?(prefix = "js") p = in aux [] in - let parts = parseParts p in + let parts = parse_parts p in let strings = List.map fst parts in let values = Ext_list.filter_map parts snd in - let endPos = p.Parser.endPos in + let end_pos = p.Parser.end_pos in - let genTaggedTemplateCall () = - let lident = Longident.Lident prefix in + let gen_tagged_template_call lident = let ident = Ast_helper.Exp.ident ~attrs:[] ~loc:Location.none (Location.mknoloc lident) @@ -2309,21 +2334,21 @@ and parseTemplateExpr ?(prefix = "js") p = Ast_helper.Exp.array ~attrs:[] ~loc:Location.none values in Ast_helper.Exp.apply - ~attrs:[taggedTemplateLiteralAttr] - ~loc:(mkLoc startPos endPos) ident + ~attrs:[tagged_template_literal_attr] + ~loc:(mk_loc start_pos end_pos) ident [(Nolabel, strings_array); (Nolabel, values_array)] in - let hiddenOperator = + let hidden_operator = let op = Location.mknoloc (Longident.Lident "^") in Ast_helper.Exp.ident op in let concat (e1 : Parsetree.expression) (e2 : Parsetree.expression) = - let loc = mkLoc e1.pexp_loc.loc_start e2.pexp_loc.loc_end in - Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator + let loc = mk_loc e1.pexp_loc.loc_start e2.pexp_loc.loc_end in + Ast_helper.Exp.apply ~attrs:[template_literal_attr] ~loc hidden_operator [(Nolabel, e1); (Nolabel, e2)] in - let genInterpolatedString () = + let gen_interpolated_string () = let subparts = List.flatten (List.map @@ -2333,7 +2358,7 @@ and parseTemplateExpr ?(prefix = "js") p = | s, None -> [s]) parts) in - let exprOption = + let expr_option = List.fold_left (fun acc subpart -> Some @@ -2342,14 +2367,15 @@ and parseTemplateExpr ?(prefix = "js") p = | None -> subpart)) None subparts in - match exprOption with + match expr_option with | Some expr -> expr | None -> Ast_helper.Exp.constant (Pconst_string ("", None)) in match prefix with - | "js" | "j" | "json" -> genInterpolatedString () - | _ -> genTaggedTemplateCall () + | Some {txt = Longident.Lident ("js" | "j" | "json"); _} | None -> + gen_interpolated_string () + | Some {txt = lident} -> gen_tagged_template_call lident (* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int => * Also overparse constraints: @@ -2360,16 +2386,16 @@ and parseTemplateExpr ?(prefix = "js") p = * * We want to give a nice error message in these cases * *) -and overParseConstrainedOrCoercedOrArrowExpression p expr = +and over_parse_constrained_or_coerced_or_arrow_expression p expr = match p.Parser.token with - | ColonGreaterThan -> parseCoercedExpr ~expr p + | ColonGreaterThan -> parse_coerced_expr ~expr p | Colon -> ( Parser.next p; - let typ = parseTypExpr ~es6Arrow:false p in + let typ = parse_typ_expr ~es6_arrow:false p in match p.Parser.token with | EqualGreater -> Parser.next p; - let body = parseExpr p in + let body = parse_expr p in let pat = match expr.pexp_desc with | Pexp_ident longident -> @@ -2384,19 +2410,19 @@ and overParseConstrainedOrCoercedOrArrowExpression p expr = in let arrow1 = Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + ~loc:(mk_loc expr.pexp_loc.loc_start body.pexp_loc.loc_end) Asttypes.Nolabel None pat (Ast_helper.Exp.constraint_ body typ) in let arrow2 = Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + ~loc:(mk_loc expr.pexp_loc.loc_start body.pexp_loc.loc_end) Asttypes.Nolabel None (Ast_helper.Pat.constraint_ pat typ) body in let msg = - Doc.breakableGroup ~forceBreak:true + Doc.breakable_group ~force_break:true (Doc.concat [ Doc.text @@ -2407,25 +2433,25 @@ and overParseConstrainedOrCoercedOrArrowExpression p expr = [ Doc.line; Doc.text "1) "; - ResPrinter.printExpression arrow1 CommentTable.empty; + ResPrinter.print_expression arrow1 CommentTable.empty; Doc.line; Doc.text "2) "; - ResPrinter.printExpression arrow2 CommentTable.empty; + ResPrinter.print_expression arrow2 CommentTable.empty; ]); ]) - |> Doc.toString ~width:80 + |> Doc.to_string ~width:80 in - Parser.err ~startPos:expr.pexp_loc.loc_start ~endPos:body.pexp_loc.loc_end - p (Diagnostics.message msg); + Parser.err ~start_pos:expr.pexp_loc.loc_start + ~end_pos:body.pexp_loc.loc_end p (Diagnostics.message msg); arrow1 | _ -> - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let loc = mk_loc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in let expr = Ast_helper.Exp.constraint_ ~loc expr typ in let () = - Parser.err ~startPos:expr.pexp_loc.loc_start - ~endPos:typ.ptyp_loc.loc_end p + Parser.err ~start_pos:expr.pexp_loc.loc_start + ~end_pos:typ.ptyp_loc.loc_end p (Diagnostics.message - (Doc.breakableGroup ~forceBreak:true + (Doc.breakable_group ~force_break:true (Doc.concat [ Doc.text @@ -2435,23 +2461,23 @@ and overParseConstrainedOrCoercedOrArrowExpression p expr = (Doc.concat [ Doc.line; - ResPrinter.addParens - (ResPrinter.printExpression expr + ResPrinter.add_parens + (ResPrinter.print_expression expr CommentTable.empty); ]); ]) - |> Doc.toString ~width:80)) + |> Doc.to_string ~width:80)) in expr) | _ -> expr -and parseLetBindingBody ~startPos ~attrs p = - Parser.beginRegion p; - Parser.leaveBreadcrumb p Grammar.LetBinding; +and parse_let_binding_body ~start_pos ~attrs p = + Parser.begin_region p; + Parser.leave_breadcrumb p Grammar.LetBinding; let pat, exp = - Parser.leaveBreadcrumb p Grammar.Pattern; - let pat = parsePattern p in - Parser.eatBreadcrumb p; + Parser.leave_breadcrumb p Grammar.Pattern; + let pat = parse_pattern p in + Parser.eat_breadcrumb p; match p.Parser.token with | Colon -> ( Parser.next p; @@ -2459,36 +2485,36 @@ and parseLetBindingBody ~startPos ~attrs p = | Typ -> (* locally abstract types *) Parser.next p; - let newtypes = parseLidentList p in + let newtypes = parse_lident_list p in Parser.expect Dot p; - let typ = parseTypExpr p in + let typ = parse_typ_expr p in Parser.expect Equal p; - let expr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in - let exp, poly = wrapTypeAnnotation ~loc newtypes typ expr in + let expr = parse_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + let exp, poly = wrap_type_annotation ~loc newtypes typ expr in let pat = Ast_helper.Pat.constraint_ ~loc pat poly in (pat, exp) | _ -> - let polyType = parsePolyTypeExpr p in + let poly_type = parse_poly_type_expr p in let loc = - {pat.ppat_loc with loc_end = polyType.Parsetree.ptyp_loc.loc_end} + {pat.ppat_loc with loc_end = poly_type.Parsetree.ptyp_loc.loc_end} in - let pat = Ast_helper.Pat.constraint_ ~loc pat polyType in + let pat = Ast_helper.Pat.constraint_ ~loc pat poly_type in Parser.expect Token.Equal p; - let exp = parseExpr p in - let exp = overParseConstrainedOrCoercedOrArrowExpression p exp in + let exp = parse_expr p in + let exp = over_parse_constrained_or_coerced_or_arrow_expression p exp in (pat, exp)) | _ -> Parser.expect Token.Equal p; let exp = - overParseConstrainedOrCoercedOrArrowExpression p (parseExpr p) + over_parse_constrained_or_coerced_or_arrow_expression p (parse_expr p) in (pat, exp) in - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in let vb = Ast_helper.Vb.mk ~loc ~attrs pat exp in - Parser.eatBreadcrumb p; - Parser.endRegion p; + Parser.eat_breadcrumb p; + Parser.end_region p; vb (* TODO: find a better way? Is it possible? @@ -2506,18 +2532,18 @@ and parseLetBindingBody ~startPos ~attrs p = * Here @attr should attach to something "new": `let b = 1` * The parser state is forked, which is quite expensive… *) -and parseAttributesAndBinding (p : Parser.t) = +and parse_attributes_and_binding (p : Parser.t) = let err = p.scanner.err in let ch = p.scanner.ch in let offset = p.scanner.offset in let offset16 = p.scanner.offset16 in - let lineOffset = p.scanner.lineOffset in + let line_offset = p.scanner.line_offset in let lnum = p.scanner.lnum in let mode = p.scanner.mode in let token = p.token in - let startPos = p.startPos in - let endPos = p.endPos in - let prevEndPos = p.prevEndPos in + let start_pos = p.start_pos in + let end_pos = p.end_pos in + let prev_end_pos = p.prev_end_pos in let breadcrumbs = p.breadcrumbs in let errors = p.errors in let diagnostics = p.diagnostics in @@ -2525,7 +2551,7 @@ and parseAttributesAndBinding (p : Parser.t) = match p.Parser.token with | At -> ( - let attrs = parseAttributes p in + let attrs = parse_attributes p in match p.Parser.token with | And -> attrs | _ -> @@ -2533,13 +2559,13 @@ and parseAttributesAndBinding (p : Parser.t) = p.scanner.ch <- ch; p.scanner.offset <- offset; p.scanner.offset16 <- offset16; - p.scanner.lineOffset <- lineOffset; + p.scanner.line_offset <- line_offset; p.scanner.lnum <- lnum; p.scanner.mode <- mode; p.token <- token; - p.startPos <- startPos; - p.endPos <- endPos; - p.prevEndPos <- prevEndPos; + p.start_pos <- start_pos; + p.end_pos <- end_pos; + p.prev_end_pos <- prev_end_pos; p.breadcrumbs <- breadcrumbs; p.errors <- errors; p.diagnostics <- diagnostics; @@ -2548,45 +2574,44 @@ and parseAttributesAndBinding (p : Parser.t) = | _ -> [] (* definition ::= let [rec] let-binding { and let-binding } *) -and parseLetBindings ~attrs p = - let startPos = p.Parser.startPos in +and parse_let_bindings ~attrs ~start_pos p = Parser.optional p Let |> ignore; - let recFlag = + let rec_flag = if Parser.optional p Token.Rec then Asttypes.Recursive else Asttypes.Nonrecursive in - let first = parseLetBindingBody ~startPos ~attrs p in + let first = parse_let_binding_body ~start_pos ~attrs p in let rec loop p bindings = - let startPos = p.Parser.startPos in - let attrs = parseAttributesAndBinding p in + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes_and_binding p in match p.Parser.token with | And -> Parser.next p; ignore (Parser.optional p Let); (* overparse for fault tolerance *) - let letBinding = parseLetBindingBody ~startPos ~attrs p in - loop p (letBinding :: bindings) + let let_binding = parse_let_binding_body ~start_pos ~attrs p in + loop p (let_binding :: bindings) | _ -> List.rev bindings in - (recFlag, loop p [first]) + (rec_flag, loop p [first]) (* * div -> div * Foo -> Foo.createElement * Foo.Bar -> Foo.Bar.createElement *) -and parseJsxName p = +and parse_jsx_name p = let longident = match p.Parser.token with | Lident ident -> - let identStart = p.startPos in - let identEnd = p.endPos in + let ident_start = p.start_pos in + let ident_end = p.end_pos in Parser.next p; - let loc = mkLoc identStart identEnd in + let loc = mk_loc ident_start ident_end in Location.mkloc (Longident.Lident ident) loc | Uident _ -> - let longident = parseModuleLongIdent ~lowercase:true p in + let longident = parse_module_long_ident ~lowercase:true p in Location.mkloc (Longident.Ldot (longident.txt, "createElement")) longident.loc @@ -2600,74 +2625,76 @@ and parseJsxName p = in Ast_helper.Exp.ident ~loc:longident.loc longident -and parseJsxOpeningOrSelfClosingElement ~startPos p = - let jsxStartPos = p.Parser.startPos in - let name = parseJsxName p in - let jsxProps = parseJsxProps p in +and parse_jsx_opening_or_self_closing_element ~start_pos p = + let jsx_start_pos = p.Parser.start_pos in + let name = parse_jsx_name p in + let jsx_props = parse_jsx_props p in let children = match p.Parser.token with | Forwardslash -> (* *) - let childrenStartPos = p.Parser.startPos in + let children_start_pos = p.Parser.start_pos in Parser.next p; - let childrenEndPos = p.Parser.startPos in + let children_end_pos = p.Parser.start_pos in + Scanner.pop_mode p.scanner Jsx; Parser.expect GreaterThan p; - let loc = mkLoc childrenStartPos childrenEndPos in - makeListExpression loc [] None (* no children *) + let loc = mk_loc children_start_pos children_end_pos in + make_list_expression loc [] None (* no children *) | GreaterThan -> ( (* bar *) - let childrenStartPos = p.Parser.startPos in + let children_start_pos = p.Parser.start_pos in Parser.next p; - let spread, children = parseJsxChildren p in - let childrenEndPos = p.Parser.startPos in - Scanner.popMode p.scanner Jsx; - Scanner.setJsxMode p.scanner; + let spread, children = parse_jsx_children p in + let children_end_pos = p.Parser.start_pos in let () = match p.token with | LessThanSlash -> Parser.next p | LessThan -> Parser.next p; Parser.expect Forwardslash p - | token when Grammar.isStructureItemStart token -> () + | token when Grammar.is_structure_item_start token -> () | _ -> Parser.expect LessThanSlash p in match p.Parser.token with - | (Lident _ | Uident _) when verifyJsxOpeningClosingName p name -> ( + | (Lident _ | Uident _) when verify_jsx_opening_closing_name p name -> ( + Scanner.pop_mode p.scanner Jsx; Parser.expect GreaterThan p; - let loc = mkLoc childrenStartPos childrenEndPos in + let loc = mk_loc children_start_pos children_end_pos in match (spread, children) with | true, child :: _ -> child - | _ -> makeListExpression loc children None) + | _ -> make_list_expression loc children None) | token -> ( + Scanner.pop_mode p.scanner Jsx; let () = - if Grammar.isStructureItemStart token then + if Grammar.is_structure_item_start token then let closing = "" in let msg = Diagnostics.message ("Missing " ^ closing) in - Parser.err ~startPos ~endPos:p.prevEndPos p msg + Parser.err ~start_pos ~end_pos:p.prev_end_pos p msg else let opening = "" in let msg = "Closing jsx name should be the same as the opening name. Did \ you mean " ^ opening ^ " ?" in - Parser.err ~startPos ~endPos:p.prevEndPos p + Parser.err ~start_pos ~end_pos:p.prev_end_pos p (Diagnostics.message msg); Parser.expect GreaterThan p in - let loc = mkLoc childrenStartPos childrenEndPos in + let loc = mk_loc children_start_pos children_end_pos in match (spread, children) with | true, child :: _ -> child - | _ -> makeListExpression loc children None)) + | _ -> make_list_expression loc children None)) | token -> + Scanner.pop_mode p.scanner Jsx; Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - makeListExpression Location.none [] None + make_list_expression Location.none [] None in - let jsxEndPos = p.prevEndPos in - let loc = mkLoc jsxStartPos jsxEndPos in + let jsx_end_pos = p.prev_end_pos in + let loc = mk_loc jsx_start_pos jsx_end_pos in Ast_helper.Exp.apply ~loc name (List.concat [ - jsxProps; + jsx_props; [ (Asttypes.Labelled "children", children); ( Asttypes.Nolabel, @@ -2685,39 +2712,39 @@ and parseJsxOpeningOrSelfClosingElement ~startPos p = * * jsx-children ::= primary-expr* * => 0 or more *) -and parseJsx p = - Scanner.popMode p.scanner Jsx; - Scanner.setJsxMode p.Parser.scanner; - Parser.leaveBreadcrumb p Grammar.Jsx; - let startPos = p.Parser.startPos in +and parse_jsx p = + Scanner.set_jsx_mode p.Parser.scanner; + Parser.leave_breadcrumb p Grammar.Jsx; + let start_pos = p.Parser.start_pos in Parser.expect LessThan p; - let jsxExpr = + let jsx_expr = match p.Parser.token with - | Lident _ | Uident _ -> parseJsxOpeningOrSelfClosingElement ~startPos p + | Lident _ | Uident _ -> + parse_jsx_opening_or_self_closing_element ~start_pos p | GreaterThan -> (* fragment: <> foo *) - parseJsxFragment p - | _ -> parseJsxName p + parse_jsx_fragment p + | _ -> parse_jsx_name p in - Scanner.popMode p.scanner Jsx; - Parser.eatBreadcrumb p; - {jsxExpr with pexp_attributes = [jsxAttr]} + Parser.eat_breadcrumb p; + {jsx_expr with pexp_attributes = [jsx_attr]} (* * jsx-fragment ::= * | <> * | <> jsx-children *) -and parseJsxFragment p = - let childrenStartPos = p.Parser.startPos in +and parse_jsx_fragment p = + let children_start_pos = p.Parser.start_pos in Parser.expect GreaterThan p; - let _spread, children = parseJsxChildren p in - let childrenEndPos = p.Parser.startPos in + let _spread, children = parse_jsx_children p in + let children_end_pos = p.Parser.start_pos in + if p.token = LessThan then p.token <- Scanner.reconsider_less_than p.scanner; Parser.expect LessThanSlash p; + Scanner.pop_mode p.scanner Jsx; Parser.expect GreaterThan p; - Scanner.popMode p.scanner Jsx; - let loc = mkLoc childrenStartPos childrenEndPos in - makeListExpression loc children None + let loc = mk_loc children_start_pos children_end_pos in + make_list_expression loc children None (* * jsx-prop ::= @@ -2727,19 +2754,19 @@ and parseJsxFragment p = * | lident = ?jsx_expr * | {...jsx_expr} *) -and parseJsxProp p = +and parse_jsx_prop p = match p.Parser.token with | Question | Lident _ -> ( let optional = Parser.optional p Question in - let name, loc = parseLident p in - let propLocAttr = + let name, loc = parse_lident p in + let prop_loc_attr = (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in (* optional punning: *) if optional then Some ( Asttypes.Optional name, - Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc + Ast_helper.Exp.ident ~attrs:[prop_loc_attr] ~loc (Location.mkloc (Longident.Lident name) loc) ) else match p.Parser.token with @@ -2747,53 +2774,56 @@ and parseJsxProp p = Parser.next p; (* no punning *) let optional = Parser.optional p Question in - Scanner.popMode p.scanner Jsx; - let attrExpr = - let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in - {e with pexp_attributes = propLocAttr :: e.pexp_attributes} + Scanner.pop_mode p.scanner Jsx; + let attr_expr = + let e = parse_primary_expr ~operand:(parse_atomic_expr p) p in + {e with pexp_attributes = prop_loc_attr :: e.pexp_attributes} in let label = if optional then Asttypes.Optional name else Asttypes.Labelled name in - Some (label, attrExpr) + Some (label, attr_expr) | _ -> - let attrExpr = - Ast_helper.Exp.ident ~loc ~attrs:[propLocAttr] + let attr_expr = + Ast_helper.Exp.ident ~loc ~attrs:[prop_loc_attr] (Location.mkloc (Longident.Lident name) loc) in let label = if optional then Asttypes.Optional name else Asttypes.Labelled name in - Some (label, attrExpr)) + Some (label, attr_expr)) (* {...props} *) | Lbrace -> ( + Scanner.pop_mode p.scanner Jsx; Parser.next p; match p.Parser.token with | DotDotDot -> ( - Scanner.popMode p.scanner Jsx; + Scanner.pop_mode p.scanner Jsx; Parser.next p; - let loc = mkLoc p.Parser.startPos p.prevEndPos in - let propLocAttr = + let loc = mk_loc p.Parser.start_pos p.prev_end_pos in + let prop_loc_attr = (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in - let attrExpr = - let e = parsePrimaryExpr ~operand:(parseExpr p) p in - {e with pexp_attributes = propLocAttr :: e.pexp_attributes} + let attr_expr = + let e = parse_primary_expr ~operand:(parse_expr p) p in + {e with pexp_attributes = prop_loc_attr :: e.pexp_attributes} in (* using label "spreadProps" to distinguish from others *) let label = Asttypes.Labelled "_spreadProps" in match p.Parser.token with | Rbrace -> Parser.next p; - Some (label, attrExpr) + Scanner.set_jsx_mode p.scanner; + Some (label, attr_expr) | _ -> None) | _ -> None) | _ -> None -and parseJsxProps p = - parseRegion ~grammar:Grammar.JsxAttribute ~f:parseJsxProp p +and parse_jsx_props p = + parse_region ~grammar:Grammar.JsxAttribute ~f:parse_jsx_prop p -and parseJsxChildren p = +and parse_jsx_children p = + Scanner.pop_mode p.scanner Jsx; let rec loop p children = match p.Parser.token with | Token.Eof | LessThanSlash -> children @@ -2803,61 +2833,65 @@ and parseJsxChildren p = * or is it the start of a closing tag?
* reconsiderLessThan peeks at the next token and * determines the correct token to disambiguate *) - let token = Scanner.reconsiderLessThan p.scanner in + let token = Scanner.reconsider_less_than p.scanner in if token = LessThan then let child = - parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p + parse_primary_expr ~operand:(parse_atomic_expr p) ~no_call:true p in loop p (child :: children) else (* LessThanSlash *) let () = p.token <- token in children - | token when Grammar.isJsxChildStart token -> - let () = Scanner.popMode p.scanner Jsx in + | token when Grammar.is_jsx_child_start token -> let child = - parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p + parse_primary_expr ~operand:(parse_atomic_expr p) ~no_call:true p in loop p (child :: children) | _ -> children in - match p.Parser.token with - | DotDotDot -> - Parser.next p; - (true, [parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p]) - | _ -> - let children = List.rev (loop p []) in - Scanner.popMode p.scanner Jsx; - (false, children) + let spread, children = + match p.Parser.token with + | DotDotDot -> + Parser.next p; + (true, [parse_primary_expr ~operand:(parse_atomic_expr p) ~no_call:true p]) + | _ -> + let children = List.rev (loop p []) in + (false, children) + in + Scanner.set_jsx_mode p.scanner; + (spread, children) -and parseBracedOrRecordExpr p = - let startPos = p.Parser.startPos in +and parse_braced_or_record_expr p = + let start_pos = p.Parser.start_pos in Parser.expect Lbrace p; match p.Parser.token with | Rbrace -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.record ~loc [] None | DotDotDot -> (* beginning of record spread, parse record *) Parser.next p; - let spreadExpr = parseConstrainedOrCoercedExpr p in + let spread_expr = parse_constrained_or_coerced_expr p in Parser.expect Comma p; - let expr = parseRecordExpr ~startPos ~spread:(Some spreadExpr) [] p in + let expr = parse_record_expr ~start_pos ~spread:(Some spread_expr) [] p in Parser.expect Rbrace p; expr | String s -> ( let field = - let loc = mkLoc p.startPos p.endPos in + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; Location.mkloc (Longident.Lident s) loc in match p.Parser.token with | Colon -> Parser.next p; - let fieldExpr = parseExpr p in + let field_expr = parse_expr p in Parser.optional p Comma |> ignore; - let expr = parseRecordExprWithStringKeys ~startPos (field, fieldExpr) p in + let expr = + parse_record_expr_with_string_keys ~start_pos (field, field_expr) p + in Parser.expect Rbrace p; expr | _ -> ( @@ -2866,32 +2900,32 @@ and parseBracedOrRecordExpr p = Ast_helper.Exp.constant ~loc:field.loc (Parsetree.Pconst_string (s, tag)) in - let a = parsePrimaryExpr ~operand:constant p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in + let a = parse_primary_expr ~operand:constant p in + let e = parse_binary_expr ~a p 1 in + let e = parse_ternary_expr e p in match p.Parser.token with | Semicolon -> - let expr = parseExprBlock ~first:e p in + let expr = parse_expr_block ~first:e p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in { expr with Parsetree.pexp_attributes = braces :: expr.Parsetree.pexp_attributes; } | Rbrace -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {e with pexp_attributes = braces :: e.pexp_attributes} | _ -> - let expr = parseExprBlock ~first:e p in + let expr = parse_expr_block ~first:e p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes})) | Question -> - let expr = parseRecordExpr ~startPos [] p in + let expr = parse_record_expr ~start_pos [] p in Parser.expect Rbrace p; expr (* @@ -2902,80 +2936,85 @@ and parseBracedOrRecordExpr p = 2) expression x which happens to wrapped in braces Due to historical reasons, we always follow 2 *) - | Lident "async" when isEs6ArrowExpression ~inTernary:false p -> - let expr = parseAsyncArrowExpression p in - let expr = parseExprBlock ~first:expr p in + | Lident "async" when is_es6_arrow_expression ~in_ternary:false p -> + let expr = parse_async_arrow_expression p in + let expr = parse_expr_block ~first:expr p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes} | Uident _ | Lident _ -> ( - let startToken = p.token in - let valueOrConstructor = parseValueOrConstructor p in - match valueOrConstructor.pexp_desc with - | Pexp_ident pathIdent -> ( - let identEndPos = p.prevEndPos in + let start_token = p.token in + let value_or_constructor = parse_value_or_constructor p in + match value_or_constructor.pexp_desc with + | Pexp_ident path_ident -> ( + let ident_end_pos = p.prev_end_pos in match p.Parser.token with | Comma -> Parser.next p; - let valueOrConstructor = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue valueOrConstructor - | _ -> valueOrConstructor + let value_or_constructor = + match start_token with + | Uident _ -> + remove_module_name_from_punned_field_value value_or_constructor + | _ -> value_or_constructor in let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p + parse_record_expr ~start_pos [(path_ident, value_or_constructor)] p in Parser.expect Rbrace p; expr | Colon -> ( Parser.next p; - let optional = parseOptionalLabel p in - let fieldExpr = parseExpr p in - let fieldExpr = makeExpressionOptional ~optional fieldExpr in + let optional = parse_optional_label p in + let field_expr = parse_expr p in + let field_expr = make_expression_optional ~optional field_expr in match p.token with | Rbrace -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.record ~loc [(pathIdent, fieldExpr)] None + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.record ~loc [(path_ident, field_expr)] None | _ -> Parser.expect Comma p; - let expr = parseRecordExpr ~startPos [(pathIdent, fieldExpr)] p in + let expr = + parse_record_expr ~start_pos [(path_ident, field_expr)] p + in Parser.expect Rbrace p; expr) (* error case *) | Lident _ -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ( + if p.prev_end_pos.pos_lnum < p.start_pos.pos_lnum then ( Parser.expect Comma p; let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p + parse_record_expr ~start_pos [(path_ident, value_or_constructor)] p in Parser.expect Rbrace p; expr) else ( Parser.expect Colon p; let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p + parse_record_expr ~start_pos [(path_ident, value_or_constructor)] p in Parser.expect Rbrace p; expr) | Semicolon -> - let expr = parseExprBlock ~first:(Ast_helper.Exp.ident pathIdent) p in + let expr = + parse_expr_block ~first:(Ast_helper.Exp.ident path_ident) p + in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes} | Rbrace -> Parser.next p; - let expr = Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent in - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let expr = Ast_helper.Exp.ident ~loc:path_ident.loc path_ident in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes} | EqualGreater -> ( - let loc = mkLoc startPos identEndPos in - let ident = Location.mkloc (Longident.last pathIdent.txt) loc in + let loc = mk_loc start_pos ident_end_pos in + let ident = Location.mkloc (Longident.last path_ident.txt) loc in let a = - parseEs6ArrowExpression + parse_es6_arrow_expression ~parameters: [ TermParameter @@ -2985,129 +3024,129 @@ and parseBracedOrRecordExpr p = label = Asttypes.Nolabel; expr = None; pat = Ast_helper.Pat.var ~loc:ident.loc ident; - pos = startPos; + pos = start_pos; }; ] p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in + let e = parse_binary_expr ~a p 1 in + let e = parse_ternary_expr e p in match p.Parser.token with | Semicolon -> - let expr = parseExprBlock ~first:e p in + let expr = parse_expr_block ~first:e p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes} | Rbrace -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {e with pexp_attributes = braces :: e.pexp_attributes} | _ -> - let expr = parseExprBlock ~first:e p in + let expr = parse_expr_block ~first:e p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes}) | _ -> ( - Parser.leaveBreadcrumb p Grammar.ExprBlock; + Parser.leave_breadcrumb p Grammar.ExprBlock; let a = - parsePrimaryExpr - ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) + parse_primary_expr + ~operand:(Ast_helper.Exp.ident ~loc:path_ident.loc path_ident) p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - Parser.eatBreadcrumb p; + let e = parse_binary_expr ~a p 1 in + let e = parse_ternary_expr e p in + Parser.eat_breadcrumb p; match p.Parser.token with | Semicolon -> - let expr = parseExprBlock ~first:e p in + let expr = parse_expr_block ~first:e p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes} | Rbrace -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {e with pexp_attributes = braces :: e.pexp_attributes} | _ -> - let expr = parseExprBlock ~first:e p in + let expr = parse_expr_block ~first:e p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes})) | _ -> ( - Parser.leaveBreadcrumb p Grammar.ExprBlock; - let a = parsePrimaryExpr ~operand:valueOrConstructor p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - Parser.eatBreadcrumb p; + Parser.leave_breadcrumb p Grammar.ExprBlock; + let a = parse_primary_expr ~operand:value_or_constructor p in + let e = parse_binary_expr ~a p 1 in + let e = parse_ternary_expr e p in + Parser.eat_breadcrumb p; match p.Parser.token with | Semicolon -> - let expr = parseExprBlock ~first:e p in + let expr = parse_expr_block ~first:e p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes} | Rbrace -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {e with pexp_attributes = braces :: e.pexp_attributes} | _ -> - let expr = parseExprBlock ~first:e p in + let expr = parse_expr_block ~first:e p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes})) | _ -> - let expr = parseExprBlock p in + let expr = parse_expr_block p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes} -and parseRecordExprRowWithStringKey p = +and parse_record_expr_row_with_string_key p = match p.Parser.token with | String s -> ( - let loc = mkLoc p.startPos p.endPos in + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; let field = Location.mkloc (Longident.Lident s) loc in match p.Parser.token with | Colon -> Parser.next p; - let fieldExpr = parseExpr p in - Some (field, fieldExpr) + let field_expr = parse_expr p in + Some (field, field_expr) | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field)) | _ -> None -and parseRecordExprRow p = - let attrs = parseAttributes p in +and parse_record_expr_row p = + let attrs = parse_attributes p in let () = match p.Parser.token with | Token.DotDotDot -> - Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread); + Parser.err p (Diagnostics.message ErrorMessages.record_expr_spread); Parser.next p | _ -> () in match p.Parser.token with | Lident _ | Uident _ -> ( - let startToken = p.token in - let field = parseValuePath p in + let start_token = p.token in + let field = parse_value_path p in match p.Parser.token with | Colon -> Parser.next p; - let optional = parseOptionalLabel p in - let fieldExpr = parseExpr p in - let fieldExpr = makeExpressionOptional ~optional fieldExpr in - Some (field, fieldExpr) + let optional = parse_optional_label p in + let field_expr = parse_expr p in + let field_expr = make_expression_optional ~optional field_expr in + Some (field, field_expr) | _ -> let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in let value = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue value + match start_token with + | Uident _ -> remove_module_name_from_punned_field_value value | _ -> value in Some (field, value)) @@ -3115,35 +3154,35 @@ and parseRecordExprRow p = Parser.next p; match p.Parser.token with | Lident _ | Uident _ -> - let startToken = p.token in - let field = parseValuePath p in + let start_token = p.token in + let field = parse_value_path p in let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in let value = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue value + match start_token with + | Uident _ -> remove_module_name_from_punned_field_value value | _ -> value in - Some (field, makeExpressionOptional ~optional:true value) + Some (field, make_expression_optional ~optional:true value) | _ -> None) | _ -> None -and parseRecordExprWithStringKeys ~startPos firstRow p = +and parse_record_expr_with_string_keys ~start_pos first_row p = let rows = - firstRow - :: parseCommaDelimitedRegion ~grammar:Grammar.RecordRowsStringKey - ~closing:Rbrace ~f:parseRecordExprRowWithStringKey p + first_row + :: parse_comma_delimited_region ~grammar:Grammar.RecordRowsStringKey + ~closing:Rbrace ~f:parse_record_expr_row_with_string_key p in - let loc = mkLoc startPos p.endPos in - let recordStrExpr = + let loc = mk_loc start_pos p.end_pos in + let record_str_expr = Ast_helper.Str.eval ~loc (Ast_helper.Exp.record ~loc rows None) in Ast_helper.Exp.extension ~loc - (Location.mkloc "obj" loc, Parsetree.PStr [recordStrExpr]) + (Location.mkloc "obj" loc, Parsetree.PStr [record_str_expr]) -and parseRecordExpr ~startPos ?(spread = None) rows p = +and parse_record_expr ~start_pos ?(spread = None) rows p = let exprs = - parseCommaDelimitedRegion ~grammar:Grammar.RecordRows ~closing:Rbrace - ~f:parseRecordExprRow p + parse_comma_delimited_region ~grammar:Grammar.RecordRows ~closing:Rbrace + ~f:parse_record_expr_row p in let rows = List.concat [rows; exprs] in let () = @@ -3153,82 +3192,82 @@ and parseRecordExpr ~startPos ?(spread = None) rows p = Parser.err p (Diagnostics.message msg) | _rows -> () in - let loc = mkLoc startPos p.endPos in + let loc = mk_loc start_pos p.end_pos in Ast_helper.Exp.record ~loc rows spread -and parseNewlineOrSemicolonExprBlock p = +and parse_newline_or_semicolon_expr_block p = match p.Parser.token with | Semicolon -> Parser.next p - | token when Grammar.isBlockExprStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + | token when Grammar.is_block_expr_start token -> + if p.prev_end_pos.pos_lnum < p.start_pos.pos_lnum then () else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + Parser.err ~start_pos:p.prev_end_pos ~end_pos:p.end_pos p (Diagnostics.message "consecutive expressions on a line must be separated by ';' or a \ newline") | _ -> () -and parseExprBlockItem p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in +and parse_expr_block_item p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in match p.Parser.token with | Module -> ( Parser.next p; match p.token with | Lparen -> - let expr = parseFirstClassModuleExpr ~startPos p in - let a = parsePrimaryExpr ~operand:expr p in - let expr = parseBinaryExpr ~a p 1 in - parseTernaryExpr expr p + let expr = parse_first_class_module_expr ~start_pos p in + let a = parse_primary_expr ~operand:expr p in + let expr = parse_binary_expr ~a p 1 in + parse_ternary_expr expr p | _ -> let name = match p.Parser.token with | Uident ident -> - let loc = mkLoc p.startPos p.endPos in + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; Location.mkloc ident loc | t -> Parser.err p (Diagnostics.uident t); Location.mknoloc "_" in - let body = parseModuleBindingBody p in - parseNewlineOrSemicolonExprBlock p; - let expr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in + let body = parse_module_binding_body p in + parse_newline_or_semicolon_expr_block p; + let expr = parse_expr_block p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.letmodule ~loc name body expr) | Exception -> - let extensionConstructor = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonExprBlock p; - let blockExpr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.letexception ~loc extensionConstructor blockExpr + let extension_constructor = parse_exception_def ~attrs p in + parse_newline_or_semicolon_expr_block p; + let block_expr = parse_expr_block p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.letexception ~loc extension_constructor block_expr | Open -> - let od = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonExprBlock p; - let blockExpr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid blockExpr + let od = parse_open_description ~attrs p in + parse_newline_or_semicolon_expr_block p; + let block_expr = parse_expr_block p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid block_expr | Let -> - let recFlag, letBindings = parseLetBindings ~attrs p in - parseNewlineOrSemicolonExprBlock p; + let rec_flag, let_bindings = parse_let_bindings ~attrs ~start_pos p in + parse_newline_or_semicolon_expr_block p; let next = - if Grammar.isBlockExprStart p.Parser.token then parseExprBlock p + if Grammar.is_block_expr_start p.Parser.token then parse_expr_block p else - let loc = mkLoc p.startPos p.endPos in + let loc = mk_loc p.start_pos p.end_pos in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.let_ ~loc recFlag letBindings next + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.let_ ~loc rec_flag let_bindings next | _ -> let e1 = - let expr = parseExpr p in + let expr = parse_expr p in {expr with pexp_attributes = List.concat [attrs; expr.pexp_attributes]} in - parseNewlineOrSemicolonExprBlock p; - if Grammar.isBlockExprStart p.Parser.token then - let e2 = parseExprBlock p in + parse_newline_or_semicolon_expr_block p; + if Grammar.is_block_expr_start p.Parser.token then + let e2 = parse_expr_block p in let loc = {e1.pexp_loc with loc_end = e2.pexp_loc.loc_end} in Ast_helper.Exp.sequence ~loc e1 e2 else e1 @@ -3246,159 +3285,160 @@ and parseExprBlockItem p = * note: semi should be made optional * a block of expression is always *) -and parseExprBlock ?first p = - Parser.leaveBreadcrumb p Grammar.ExprBlock; +and parse_expr_block ?first p = + Parser.leave_breadcrumb p Grammar.ExprBlock; let item = match first with | Some e -> e - | None -> parseExprBlockItem p + | None -> parse_expr_block_item p in - parseNewlineOrSemicolonExprBlock p; - let blockExpr = - if Grammar.isBlockExprStart p.Parser.token then - let next = parseExprBlockItem p in + parse_newline_or_semicolon_expr_block p; + let block_expr = + if Grammar.is_block_expr_start p.Parser.token then + let next = parse_expr_block_item p in let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in Ast_helper.Exp.sequence ~loc item next else item in - Parser.eatBreadcrumb p; - overParseConstrainedOrCoercedOrArrowExpression p blockExpr + Parser.eat_breadcrumb p; + over_parse_constrained_or_coerced_or_arrow_expression p block_expr -and parseAsyncArrowExpression ?(arrowAttrs = []) p = - let startPos = p.Parser.startPos in +and parse_async_arrow_expression ?(arrow_attrs = []) p = + let start_pos = p.Parser.start_pos in Parser.expect (Lident "async") p; - let asyncAttr = makeAsyncAttr (mkLoc startPos p.prevEndPos) in - parseEs6ArrowExpression ~arrowAttrs:(asyncAttr :: arrowAttrs) - ~arrowStartPos:(Some startPos) p - -and parseAwaitExpression p = - let awaitLoc = mkLoc p.Parser.startPos p.endPos in - let awaitAttr = makeAwaitAttr awaitLoc in + let async_attr = make_async_attr (mk_loc start_pos p.prev_end_pos) in + parse_es6_arrow_expression + ~arrow_attrs:(async_attr :: arrow_attrs) + ~arrow_start_pos:(Some start_pos) p + +and parse_await_expression p = + let await_loc = mk_loc p.Parser.start_pos p.end_pos in + let await_attr = make_await_attr await_loc in Parser.expect Await p; - let tokenPrec = Token.precedence MinusGreater in - let expr = parseBinaryExpr ~context:OrdinaryExpr p tokenPrec in + let token_prec = Token.precedence MinusGreater in + let expr = parse_binary_expr ~context:OrdinaryExpr p token_prec in { expr with - pexp_attributes = awaitAttr :: expr.pexp_attributes; - pexp_loc = {expr.pexp_loc with loc_start = awaitLoc.loc_start}; + pexp_attributes = await_attr :: expr.pexp_attributes; + pexp_loc = {expr.pexp_loc with loc_start = await_loc.loc_start}; } -and parseTryExpression p = - let startPos = p.Parser.startPos in +and parse_try_expression p = + let start_pos = p.Parser.start_pos in Parser.expect Try p; - let expr = parseExpr ~context:WhenExpr p in + let expr = parse_expr ~context:WhenExpr p in Parser.expect Res_token.catch p; Parser.expect Lbrace p; - let cases = parsePatternMatching p in + let cases = parse_pattern_matching p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.try_ ~loc expr cases -and parseIfCondition p = - Parser.leaveBreadcrumb p Grammar.IfCondition; +and parse_if_condition p = + Parser.leave_breadcrumb p Grammar.IfCondition; (* doesn't make sense to try es6 arrow here? *) - let conditionExpr = parseExpr ~context:WhenExpr p in - Parser.eatBreadcrumb p; - conditionExpr + let condition_expr = parse_expr ~context:WhenExpr p in + Parser.eat_breadcrumb p; + condition_expr -and parseThenBranch p = - Parser.leaveBreadcrumb p IfBranch; +and parse_then_branch p = + Parser.leave_breadcrumb p IfBranch; Parser.expect Lbrace p; - let thenExpr = parseExprBlock p in + let then_expr = parse_expr_block p in Parser.expect Rbrace p; - Parser.eatBreadcrumb p; - thenExpr + Parser.eat_breadcrumb p; + then_expr -and parseElseBranch p = +and parse_else_branch p = Parser.expect Lbrace p; - let blockExpr = parseExprBlock p in + let block_expr = parse_expr_block p in Parser.expect Rbrace p; - blockExpr + block_expr -and parseIfExpr startPos p = - let conditionExpr = parseIfCondition p in - let thenExpr = parseThenBranch p in - let elseExpr = +and parse_if_expr start_pos p = + let condition_expr = parse_if_condition p in + let then_expr = parse_then_branch p in + let else_expr = match p.Parser.token with | Else -> - Parser.endRegion p; - Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.end_region p; + Parser.leave_breadcrumb p Grammar.ElseBranch; Parser.next p; - Parser.beginRegion p; - let elseExpr = + Parser.begin_region p; + let else_expr = match p.token with - | If -> parseIfOrIfLetExpression p - | _ -> parseElseBranch p + | If -> parse_if_or_if_let_expression p + | _ -> parse_else_branch p in - Parser.eatBreadcrumb p; - Parser.endRegion p; - Some elseExpr + Parser.eat_breadcrumb p; + Parser.end_region p; + Some else_expr | _ -> - Parser.endRegion p; + Parser.end_region p; None in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.ifthenelse ~loc conditionExpr thenExpr elseExpr + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.ifthenelse ~loc condition_expr then_expr else_expr -and parseIfLetExpr startPos p = - let pattern = parsePattern p in +and parse_if_let_expr start_pos p = + let pattern = parse_pattern p in Parser.expect Equal p; - let conditionExpr = parseIfCondition p in - let thenExpr = parseThenBranch p in - let elseExpr = + let condition_expr = parse_if_condition p in + let then_expr = parse_then_branch p in + let else_expr = match p.Parser.token with | Else -> - Parser.endRegion p; - Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.end_region p; + Parser.leave_breadcrumb p Grammar.ElseBranch; Parser.next p; - Parser.beginRegion p; - let elseExpr = + Parser.begin_region p; + let else_expr = match p.token with - | If -> parseIfOrIfLetExpression p - | _ -> parseElseBranch p + | If -> parse_if_or_if_let_expression p + | _ -> parse_else_branch p in - Parser.eatBreadcrumb p; - Parser.endRegion p; - elseExpr + Parser.eat_breadcrumb p; + Parser.end_region p; + else_expr | _ -> - Parser.endRegion p; - let startPos = p.Parser.startPos in - let loc = mkLoc startPos p.prevEndPos in + Parser.end_region p; + let start_pos = p.Parser.start_pos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None in - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.match_ - ~attrs:[ifLetAttr; suppressFragileMatchWarningAttr] - ~loc conditionExpr + ~attrs:[if_let_attr; suppress_fragile_match_warning_attr] + ~loc condition_expr [ - Ast_helper.Exp.case pattern thenExpr; - Ast_helper.Exp.case (Ast_helper.Pat.any ()) elseExpr; + Ast_helper.Exp.case pattern then_expr; + Ast_helper.Exp.case (Ast_helper.Pat.any ()) else_expr; ] -and parseIfOrIfLetExpression p = - Parser.beginRegion p; - Parser.leaveBreadcrumb p Grammar.ExprIf; - let startPos = p.Parser.startPos in +and parse_if_or_if_let_expression p = + Parser.begin_region p; + Parser.leave_breadcrumb p Grammar.ExprIf; + let start_pos = p.Parser.start_pos in Parser.expect If p; let expr = match p.Parser.token with | Let -> Parser.next p; - let ifLetExpr = parseIfLetExpr startPos p in - Parser.err ~startPos:ifLetExpr.pexp_loc.loc_start - ~endPos:ifLetExpr.pexp_loc.loc_end p - (Diagnostics.message (ErrorMessages.experimentalIfLet ifLetExpr)); - ifLetExpr - | _ -> parseIfExpr startPos p - in - Parser.eatBreadcrumb p; + let if_let_expr = parse_if_let_expr start_pos p in + Parser.err ~start_pos:if_let_expr.pexp_loc.loc_start + ~end_pos:if_let_expr.pexp_loc.loc_end p + (Diagnostics.message (ErrorMessages.experimental_if_let if_let_expr)); + if_let_expr + | _ -> parse_if_expr start_pos p + in + Parser.eat_breadcrumb p; expr -and parseForRest hasOpeningParen pattern startPos p = +and parse_for_rest has_opening_paren pattern start_pos p = Parser.expect In p; - let e1 = parseExpr p in + let e1 = parse_expr p in let direction = match p.Parser.token with | Lident "to" -> Asttypes.Upto @@ -3408,125 +3448,125 @@ and parseForRest hasOpeningParen pattern startPos p = Asttypes.Upto in if p.Parser.token = Eof then - Parser.err ~startPos:p.startPos p + Parser.err ~start_pos:p.start_pos p (Diagnostics.unexpected p.Parser.token p.breadcrumbs) else Parser.next p; - let e2 = parseExpr ~context:WhenExpr p in - if hasOpeningParen then Parser.expect Rparen p; + let e2 = parse_expr ~context:WhenExpr p in + if has_opening_paren then Parser.expect Rparen p; Parser.expect Lbrace p; - let bodyExpr = parseExprBlock p in + let body_expr = parse_expr_block p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.for_ ~loc pattern e1 e2 direction bodyExpr + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.for_ ~loc pattern e1 e2 direction body_expr -and parseForExpression p = - let startPos = p.Parser.startPos in - Parser.leaveBreadcrumb p Grammar.ExprFor; +and parse_for_expression p = + let start_pos = p.Parser.start_pos in + Parser.leave_breadcrumb p Grammar.ExprFor; Parser.expect For p; - Parser.beginRegion p; - let forExpr = + Parser.begin_region p; + let for_expr = match p.token with | Lparen -> ( - let lparen = p.startPos in + let lparen = p.start_pos in Parser.next p; match p.token with | Rparen -> Parser.next p; - let unitPattern = - let loc = mkLoc lparen p.prevEndPos in + let unit_pattern = + let loc = mk_loc lparen p.prev_end_pos in let lid = Location.mkloc (Longident.Lident "()") loc in Ast_helper.Pat.construct lid None in - parseForRest false - (parseAliasPattern ~attrs:[] unitPattern p) - startPos p + parse_for_rest false + (parse_alias_pattern ~attrs:[] unit_pattern p) + start_pos p | _ -> ( - Parser.leaveBreadcrumb p Grammar.Pattern; - let pat = parsePattern p in - Parser.eatBreadcrumb p; + Parser.leave_breadcrumb p Grammar.Pattern; + let pat = parse_pattern p in + Parser.eat_breadcrumb p; match p.token with | Comma -> Parser.next p; - let tuplePattern = - parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p + let tuple_pattern = + parse_tuple_pattern ~attrs:[] ~start_pos:lparen ~first:pat p in - let pattern = parseAliasPattern ~attrs:[] tuplePattern p in - parseForRest false pattern startPos p - | _ -> parseForRest true pat startPos p)) + let pattern = parse_alias_pattern ~attrs:[] tuple_pattern p in + parse_for_rest false pattern start_pos p + | _ -> parse_for_rest true pat start_pos p)) | _ -> - Parser.leaveBreadcrumb p Grammar.Pattern; - let pat = parsePattern p in - Parser.eatBreadcrumb p; - parseForRest false pat startPos p + Parser.leave_breadcrumb p Grammar.Pattern; + let pat = parse_pattern p in + Parser.eat_breadcrumb p; + parse_for_rest false pat start_pos p in - Parser.eatBreadcrumb p; - Parser.endRegion p; - forExpr + Parser.eat_breadcrumb p; + Parser.end_region p; + for_expr -and parseWhileExpression p = - let startPos = p.Parser.startPos in +and parse_while_expression p = + let start_pos = p.Parser.start_pos in Parser.expect While p; - let expr1 = parseExpr ~context:WhenExpr p in + let expr1 = parse_expr ~context:WhenExpr p in Parser.expect Lbrace p; - let expr2 = parseExprBlock p in + let expr2 = parse_expr_block p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.while_ ~loc expr1 expr2 -and parsePatternGuard p = +and parse_pattern_guard p = match p.Parser.token with | When | If -> Parser.next p; - Some (parseExpr ~context:WhenExpr p) + Some (parse_expr ~context:WhenExpr p) | _ -> None -and parsePatternMatchCase p = - Parser.beginRegion p; - Parser.leaveBreadcrumb p Grammar.PatternMatchCase; +and parse_pattern_match_case p = + Parser.begin_region p; + Parser.leave_breadcrumb p Grammar.PatternMatchCase; match p.Parser.token with | Token.Bar -> Parser.next p; - Parser.leaveBreadcrumb p Grammar.Pattern; - let lhs = parsePattern p in - Parser.eatBreadcrumb p; - let guard = parsePatternGuard p in + Parser.leave_breadcrumb p Grammar.Pattern; + let lhs = parse_pattern p in + Parser.eat_breadcrumb p; + let guard = parse_pattern_guard p in let () = match p.token with | EqualGreater -> Parser.next p - | _ -> Recover.recoverEqualGreater p + | _ -> Recover.recover_equal_greater p in - let rhs = parseExprBlock p in - Parser.endRegion p; - Parser.eatBreadcrumb p; + let rhs = parse_expr_block p in + Parser.end_region p; + Parser.eat_breadcrumb p; Some (Ast_helper.Exp.case lhs ?guard rhs) | _ -> - Parser.endRegion p; - Parser.eatBreadcrumb p; + Parser.end_region p; + Parser.eat_breadcrumb p; None -and parsePatternMatching p = +and parse_pattern_matching p = let cases = - parseDelimitedRegion ~grammar:Grammar.PatternMatching ~closing:Rbrace - ~f:parsePatternMatchCase p + parse_delimited_region ~grammar:Grammar.PatternMatching ~closing:Rbrace + ~f:parse_pattern_match_case p in let () = match cases with | [] -> - Parser.err ~startPos:p.prevEndPos p + Parser.err ~start_pos:p.prev_end_pos p (Diagnostics.message "Pattern matching needs at least one case") | _ -> () in cases -and parseSwitchExpression p = - let startPos = p.Parser.startPos in +and parse_switch_expression p = + let start_pos = p.Parser.start_pos in Parser.expect Switch p; - let switchExpr = parseExpr ~context:WhenExpr p in + let switch_expr = parse_expr ~context:WhenExpr p in Parser.expect Lbrace p; - let cases = parsePatternMatching p in + let cases = parse_pattern_matching p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.match_ ~loc switchExpr cases + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.match_ ~loc switch_expr cases (* * argument ::= @@ -3546,11 +3586,11 @@ and parseSwitchExpression p = * dotted_argument ::= * | . argument *) -and parseArgument p : argument option = +and parse_argument p : argument option = if p.Parser.token = Token.Tilde || p.token = Dot || p.token = Underscore - || Grammar.isExprStart p.token + || Grammar.is_expr_start p.token then match p.Parser.token with | Dot -> ( @@ -3559,21 +3599,21 @@ and parseArgument p : argument option = match p.token with (* apply(.) *) | Rparen -> - let unitExpr = + let unit_expr = Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident "()")) None in - Some {dotted; label = Asttypes.Nolabel; expr = unitExpr} - | _ -> parseArgument2 p ~dotted) - | _ -> parseArgument2 p ~dotted:false + Some {dotted; label = Asttypes.Nolabel; expr = unit_expr} + | _ -> parse_argument2 p ~dotted) + | _ -> parse_argument2 p ~dotted:false else None -and parseArgument2 p ~dotted : argument option = +and parse_argument2 p ~dotted : argument option = match p.Parser.token with (* foo(_), do not confuse with foo(_ => x), TODO: performance *) - | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> - let loc = mkLoc p.startPos p.endPos in + | Underscore when not (is_es6_arrow_expression ~in_ternary:false p) -> + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; let expr = Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "_") loc) @@ -3584,21 +3624,21 @@ and parseArgument2 p ~dotted : argument option = (* TODO: nesting of pattern matches not intuitive for error recovery *) match p.Parser.token with | Lident ident -> ( - let startPos = p.startPos in + let start_pos = p.start_pos in Parser.next p; - let endPos = p.prevEndPos in - let loc = mkLoc startPos endPos in - let propLocAttr = + let end_pos = p.prev_end_pos in + let loc = mk_loc start_pos end_pos in + let prop_loc_attr = (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in - let identExpr = - Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc + let ident_expr = + Ast_helper.Exp.ident ~attrs:[prop_loc_attr] ~loc (Location.mkloc (Longident.Lident ident) loc) in match p.Parser.token with | Question -> Parser.next p; - Some {dotted; label = Optional ident; expr = identExpr} + Some {dotted; label = Optional ident; expr = ident_expr} | Equal -> Parser.next p; let label = @@ -3610,43 +3650,44 @@ and parseArgument2 p ~dotted : argument option = in let expr = match p.Parser.token with - | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> - let loc = mkLoc p.startPos p.endPos in + | Underscore when not (is_es6_arrow_expression ~in_ternary:false p) -> + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "_") loc) | _ -> - let expr = parseConstrainedOrCoercedExpr p in - {expr with pexp_attributes = propLocAttr :: expr.pexp_attributes} + let expr = parse_constrained_or_coerced_expr p in + {expr with pexp_attributes = prop_loc_attr :: expr.pexp_attributes} in Some {dotted; label; expr} | Colon -> Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in + let typ = parse_typ_expr p in + let loc = mk_loc start_pos p.prev_end_pos in let expr = - Ast_helper.Exp.constraint_ ~attrs:[propLocAttr] ~loc identExpr typ + Ast_helper.Exp.constraint_ ~attrs:[prop_loc_attr] ~loc ident_expr typ in Some {dotted; label = Labelled ident; expr} - | _ -> Some {dotted; label = Labelled ident; expr = identExpr}) + | _ -> Some {dotted; label = Labelled ident; expr = ident_expr}) | t -> Parser.err p (Diagnostics.lident t); - Some {dotted; label = Nolabel; expr = Recover.defaultExpr ()}) - | _ -> Some {dotted; label = Nolabel; expr = parseConstrainedOrCoercedExpr p} + Some {dotted; label = Nolabel; expr = Recover.default_expr ()}) + | _ -> + Some {dotted; label = Nolabel; expr = parse_constrained_or_coerced_expr p} -and parseCallExpr p funExpr = +and parse_call_expr p fun_expr = Parser.expect Lparen p; - let startPos = p.Parser.startPos in - Parser.leaveBreadcrumb p Grammar.ExprCall; + let start_pos = p.Parser.start_pos in + Parser.leave_breadcrumb p Grammar.ExprCall; let args = - parseCommaDelimitedRegion ~grammar:Grammar.ArgumentList ~closing:Rparen - ~f:parseArgument p + parse_comma_delimited_region ~grammar:Grammar.ArgumentList ~closing:Rparen + ~f:parse_argument p in - let resPartialAttr = - let loc = mkLoc startPos p.prevEndPos in + let res_partial_attr = + let loc = mk_loc start_pos p.prev_end_pos in (Location.mkloc "res.partial" loc, Parsetree.PStr []) in - let isPartial = + let is_partial = match p.token with | DotDotDot when args <> [] -> Parser.next p; @@ -3657,7 +3698,7 @@ and parseCallExpr p funExpr = let args = match args with | [] -> - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in (* No args -> unit sugar: `foo()` *) [ { @@ -3681,7 +3722,7 @@ and parseCallExpr p funExpr = } as expr; }; ] - when (not loc.loc_ghost) && p.mode = ParseForTypeChecker && not isPartial + when (not loc.loc_ghost) && p.mode = ParseForTypeChecker && not is_partial -> (* Since there is no syntax space for arity zero vs arity one, * we expand @@ -3712,7 +3753,7 @@ and parseCallExpr p funExpr = ] | args -> args in - let loc = {funExpr.pexp_loc with loc_end = p.prevEndPos} in + let loc = {fun_expr.pexp_loc with loc_end = p.prev_end_pos} in let args = match args with | {dotted = d; label = lbl; expr} :: args -> @@ -3726,44 +3767,44 @@ and parseCallExpr p funExpr = | [] -> [] in let apply = - Ext_list.fold_left args funExpr (fun callBody group -> + Ext_list.fold_left args fun_expr (fun call_body group -> let dotted, args = group in - let args, wrap = processUnderscoreApplication p args in + let args, wrap = process_underscore_application p args in let exp = let uncurried = - p.uncurried_config |> Res_uncurried.fromDotted ~dotted + p.uncurried_config |> Res_uncurried.from_dotted ~dotted in - let attrs = if uncurried then [uncurriedAppAttr] else [] in - let attrs = if isPartial then resPartialAttr :: attrs else attrs in - Ast_helper.Exp.apply ~loc ~attrs callBody args + let attrs = if uncurried then [uncurried_app_attr] else [] in + let attrs = if is_partial then res_partial_attr :: attrs else attrs in + Ast_helper.Exp.apply ~loc ~attrs call_body args in wrap exp) in - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; apply -and parseValueOrConstructor p = - let startPos = p.Parser.startPos in +and parse_value_or_constructor p = + let start_pos = p.Parser.start_pos in let rec aux p acc = match p.Parser.token with | Uident ident -> ( - let endPosLident = p.endPos in + let end_pos_lident = p.end_pos in Parser.next p; match p.Parser.token with | Dot -> Parser.next p; aux p (ident :: acc) - | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let lparen = p.startPos in - let args = parseConstructorArgs p in - let rparen = p.prevEndPos in - let lident = buildLongident (ident :: acc) in + | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + let lparen = p.start_pos in + let args = parse_constructor_args p in + let rparen = p.prev_end_pos in + let lident = build_longident (ident :: acc) in let tail = match args with | [] -> None | [({Parsetree.pexp_desc = Pexp_tuple _} as arg)] as args -> - let loc = mkLoc lparen rparen in + let loc = mk_loc lparen rparen in if p.mode = ParseForTypeChecker then (* Some(1, 2) for type-checker *) Some arg @@ -3772,43 +3813,43 @@ and parseValueOrConstructor p = Some (Ast_helper.Exp.tuple ~loc args) | [arg] -> Some arg | args -> - let loc = mkLoc lparen rparen in + let loc = mk_loc lparen rparen in Some (Ast_helper.Exp.tuple ~loc args) in - let loc = mkLoc startPos p.prevEndPos in - let identLoc = mkLoc startPos endPosLident in - Ast_helper.Exp.construct ~loc (Location.mkloc lident identLoc) tail + let loc = mk_loc start_pos p.prev_end_pos in + let ident_loc = mk_loc start_pos end_pos_lident in + Ast_helper.Exp.construct ~loc (Location.mkloc lident ident_loc) tail | _ -> - let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident :: acc) in + let loc = mk_loc start_pos p.prev_end_pos in + let lident = build_longident (ident :: acc) in Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None) | Lident ident -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident :: acc) in + let loc = mk_loc start_pos p.prev_end_pos in + let lident = build_longident (ident :: acc) in Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) | token -> if acc = [] then ( - Parser.nextUnsafe p; + Parser.next_unsafe p; Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultExpr ()) + Recover.default_expr ()) else - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let lident = buildLongident ("_" :: acc) in + let lident = build_longident ("_" :: acc) in Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) in aux p [] -and parsePolyVariantExpr p = - let startPos = p.startPos in - let ident, _loc = parseHashIdent ~startPos p in +and parse_poly_variant_expr p = + let start_pos = p.start_pos in + let ident, _loc = parse_hash_ident ~start_pos p in match p.Parser.token with - | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let lparen = p.startPos in - let args = parseConstructorArgs p in - let rparen = p.prevEndPos in - let loc_paren = mkLoc lparen rparen in + | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + let lparen = p.start_pos in + let args = parse_constructor_args p in + let rparen = p.prev_end_pos in + let loc_paren = mk_loc lparen rparen in let tail = match args with | [] -> None @@ -3824,23 +3865,23 @@ and parsePolyVariantExpr p = (* #a((1, 2)) for printer *) Some (Ast_helper.Exp.tuple ~loc:loc_paren args) in - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.variant ~loc ident tail | _ -> - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.variant ~loc ident None -and parseConstructorArgs p = - let lparen = p.Parser.startPos in +and parse_constructor_args p = + let lparen = p.Parser.start_pos in Parser.expect Lparen p; let args = - parseCommaDelimitedRegion ~grammar:Grammar.ExprList - ~f:parseConstrainedExprRegion ~closing:Rparen p + parse_comma_delimited_region ~grammar:Grammar.ExprList + ~f:parse_constrained_expr_region ~closing:Rparen p in Parser.expect Rparen p; match args with | [] -> - let loc = mkLoc lparen p.prevEndPos in + let loc = mk_loc lparen p.prev_end_pos in [ Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) @@ -3848,105 +3889,105 @@ and parseConstructorArgs p = ] | args -> args -and parseTupleExpr ~first ~startPos p = +and parse_tuple_expr ~first ~start_pos p = let exprs = first - :: parseCommaDelimitedRegion p ~grammar:Grammar.ExprList ~closing:Rparen - ~f:parseConstrainedExprRegion + :: parse_comma_delimited_region p ~grammar:Grammar.ExprList ~closing:Rparen + ~f:parse_constrained_expr_region in Parser.expect Rparen p; let () = match exprs with | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message ErrorMessages.tuple_single_element) | _ -> () in - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.tuple ~loc exprs -and parseSpreadExprRegionWithLoc p = - let startPos = p.Parser.prevEndPos in +and parse_spread_expr_region_with_loc p = + let start_pos = p.Parser.prev_end_pos in match p.Parser.token with | DotDotDot -> Parser.next p; - let expr = parseConstrainedOrCoercedExpr p in - Some (true, expr, startPos, p.prevEndPos) - | token when Grammar.isExprStart token -> - Some (false, parseConstrainedOrCoercedExpr p, startPos, p.prevEndPos) + let expr = parse_constrained_or_coerced_expr p in + Some (true, expr, start_pos, p.prev_end_pos) + | token when Grammar.is_expr_start token -> + Some (false, parse_constrained_or_coerced_expr p, start_pos, p.prev_end_pos) | _ -> None -and parseListExpr ~startPos p = +and parse_list_expr ~start_pos p = let split_by_spread exprs = List.fold_left (fun acc curr -> match (curr, acc) with - | (true, expr, startPos, endPos), _ -> + | (true, expr, start_pos, end_pos), _ -> (* find a spread expression, prepend a new sublist *) - ([], Some expr, startPos, endPos) :: acc - | ( (false, expr, startPos, _endPos), - (no_spreads, spread, _accStartPos, accEndPos) :: acc ) -> + ([], Some expr, start_pos, end_pos) :: acc + | ( (false, expr, start_pos, _endPos), + (no_spreads, spread, _accStartPos, acc_end_pos) :: acc ) -> (* find a non-spread expression, and the accumulated is not empty, * prepend to the first sublist, and update the loc of the first sublist *) - (expr :: no_spreads, spread, startPos, accEndPos) :: acc - | (false, expr, startPos, endPos), [] -> + (expr :: no_spreads, spread, start_pos, acc_end_pos) :: acc + | (false, expr, start_pos, end_pos), [] -> (* find a non-spread expression, and the accumulated is empty *) - [([expr], None, startPos, endPos)]) + [([expr], None, start_pos, end_pos)]) [] exprs in let make_sub_expr = function - | exprs, Some spread, startPos, endPos -> - makeListExpression (mkLoc startPos endPos) exprs (Some spread) - | exprs, None, startPos, endPos -> - makeListExpression (mkLoc startPos endPos) exprs None + | exprs, Some spread, start_pos, end_pos -> + make_list_expression (mk_loc start_pos end_pos) exprs (Some spread) + | exprs, None, start_pos, end_pos -> + make_list_expression (mk_loc start_pos end_pos) exprs None in - let listExprsRev = - parseCommaDelimitedReversedList p ~grammar:Grammar.ListExpr ~closing:Rbrace - ~f:parseSpreadExprRegionWithLoc + let list_exprs_rev = + parse_comma_delimited_reversed_list p ~grammar:Grammar.ListExpr + ~closing:Rbrace ~f:parse_spread_expr_region_with_loc in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - match split_by_spread listExprsRev with - | [] -> makeListExpression loc [] None - | [(exprs, Some spread, _, _)] -> makeListExpression loc exprs (Some spread) - | [(exprs, None, _, _)] -> makeListExpression loc exprs None + let loc = mk_loc start_pos p.prev_end_pos in + match split_by_spread list_exprs_rev with + | [] -> make_list_expression loc [] None + | [(exprs, Some spread, _, _)] -> make_list_expression loc exprs (Some spread) + | [(exprs, None, _, _)] -> make_list_expression loc exprs None | exprs -> - let listExprs = List.map make_sub_expr exprs in + let list_exprs = List.map make_sub_expr exprs in Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc ~attrs:[spreadAttr] + (Ast_helper.Exp.ident ~loc ~attrs:[spread_attr] (Location.mkloc (Longident.Ldot (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany")) loc)) - [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc listExprs)] + [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc list_exprs)] -and parseArrayExp p = - let startPos = p.Parser.startPos in +and parse_array_exp p = + let start_pos = p.Parser.start_pos in Parser.expect Lbracket p; let split_by_spread exprs = List.fold_left (fun acc curr -> match (curr, acc) with - | (true, expr, startPos, endPos), _ -> + | (true, expr, start_pos, end_pos), _ -> (* find a spread expression, prepend a new sublist *) - ([], Some expr, startPos, endPos) :: acc - | ( (false, expr, startPos, _endPos), - (no_spreads, spread, _accStartPos, accEndPos) :: acc ) -> + ([], Some expr, start_pos, end_pos) :: acc + | ( (false, expr, start_pos, _endPos), + (no_spreads, spread, _accStartPos, acc_end_pos) :: acc ) -> (* find a non-spread expression, and the accumulated is not empty, * prepend to the first sublist, and update the loc of the first sublist *) - (expr :: no_spreads, spread, startPos, accEndPos) :: acc - | (false, expr, startPos, endPos), [] -> + (expr :: no_spreads, spread, start_pos, acc_end_pos) :: acc + | (false, expr, start_pos, end_pos), [] -> (* find a non-spread expression, and the accumulated is empty *) - [([expr], None, startPos, endPos)]) + [([expr], None, start_pos, end_pos)]) [] exprs in - let listExprsRev = - parseCommaDelimitedReversedList p ~grammar:Grammar.ExprList - ~closing:Rbracket ~f:parseSpreadExprRegionWithLoc + let list_exprs_rev = + parse_comma_delimited_reversed_list p ~grammar:Grammar.ExprList + ~closing:Rbracket ~f:parse_spread_expr_region_with_loc in Parser.expect Rbracket p; - let loc = mkLoc startPos p.prevEndPos in - let collectExprs = function + let loc = mk_loc start_pos p.prev_end_pos in + let collect_exprs = function | [], Some spread, _startPos, _endPos -> [spread] | exprs, Some spread, _startPos, _endPos -> let els = Ast_helper.Exp.array ~loc exprs in @@ -3955,204 +3996,208 @@ and parseArrayExp p = let els = Ast_helper.Exp.array ~loc exprs in [els] in - match split_by_spread listExprsRev with - | [] -> Ast_helper.Exp.array ~loc:(mkLoc startPos p.prevEndPos) [] + match split_by_spread list_exprs_rev with + | [] -> Ast_helper.Exp.array ~loc:(mk_loc start_pos p.prev_end_pos) [] | [(exprs, None, _, _)] -> - Ast_helper.Exp.array ~loc:(mkLoc startPos p.prevEndPos) exprs + Ast_helper.Exp.array ~loc:(mk_loc start_pos p.prev_end_pos) exprs | exprs -> - let xs = List.map collectExprs exprs in - let listExprs = + let xs = List.map collect_exprs exprs in + let list_exprs = List.fold_right (fun exprs1 acc -> List.fold_right (fun expr1 acc1 -> expr1 :: acc1) exprs1 acc) xs [] in Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc ~attrs:[spreadAttr] + (Ast_helper.Exp.ident ~loc ~attrs:[spread_attr] (Location.mkloc (Longident.Ldot (Longident.Ldot (Longident.Lident "Belt", "Array"), "concatMany")) loc)) - [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc listExprs)] + [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc list_exprs)] (* TODO: check attributes in the case of poly type vars, * might be context dependend: parseFieldDeclaration (see ocaml) *) -and parsePolyTypeExpr p = - let startPos = p.Parser.startPos in +and parse_poly_type_expr p = + let start_pos = p.Parser.start_pos in match p.Parser.token with | SingleQuote -> ( - let vars = parseTypeVarList p in + let vars = parse_type_var_list p in match vars with | _v1 :: _v2 :: _ -> Parser.expect Dot p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in + let typ = parse_typ_expr p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Typ.poly ~loc vars typ | [var] -> ( match p.Parser.token with | Dot -> Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in + let typ = parse_typ_expr p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Typ.poly ~loc vars typ | EqualGreater -> Parser.next p; let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in - let tFun = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in - if p.uncurried_config = Legacy then tFun - else Ast_uncurried.uncurriedType ~loc ~arity:1 tFun + let return_type = parse_typ_expr ~alias:false p in + let loc = mk_loc typ.Parsetree.ptyp_loc.loc_start p.prev_end_pos in + let t_fun = + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ return_type + in + if p.uncurried_config = Legacy then t_fun + else Ast_uncurried.uncurried_type ~loc ~arity:1 t_fun | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) | _ -> assert false) - | _ -> parseTypExpr p + | _ -> parse_typ_expr p (* 'a 'b 'c *) -and parseTypeVarList p = +and parse_type_var_list p = let rec loop p vars = match p.Parser.token with | SingleQuote -> Parser.next p; - let lident, loc = parseLident p in + let lident, loc = parse_lident p in let var = Location.mkloc lident loc in loop p (var :: vars) | _ -> List.rev vars in loop p [] -and parseLidentList p = +and parse_lident_list p = let rec loop p ls = match p.Parser.token with | Lident lident -> - let loc = mkLoc p.startPos p.endPos in + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; loop p (Location.mkloc lident loc :: ls) | _ -> List.rev ls in loop p [] -and parseAtomicTypExpr ~attrs p = - Parser.leaveBreadcrumb p Grammar.AtomicTypExpr; - let startPos = p.Parser.startPos in +and parse_atomic_typ_expr ~attrs p = + Parser.leave_breadcrumb p Grammar.AtomicTypExpr; + let start_pos = p.Parser.start_pos in let typ = match p.Parser.token with | SingleQuote -> Parser.next p; let ident, loc = if p.Parser.token = Eof then ( - Parser.err ~startPos:p.startPos p + Parser.err ~start_pos:p.start_pos p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("", mkLoc p.startPos p.prevEndPos)) - else parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p + ("", mk_loc p.start_pos p.prev_end_pos)) + else parse_ident ~msg:ErrorMessages.type_var ~start_pos:p.start_pos p in Ast_helper.Typ.var ~loc ~attrs ident | Underscore -> - let endPos = p.endPos in + let end_pos = p.end_pos in Parser.next p; - Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs () + Ast_helper.Typ.any ~loc:(mk_loc start_pos end_pos) ~attrs () | Lparen -> ( Parser.next p; match p.Parser.token with | Rparen -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let unitConstr = Location.mkloc (Longident.Lident "unit") loc in - Ast_helper.Typ.constr ~attrs unitConstr [] + let loc = mk_loc start_pos p.prev_end_pos in + let unit_constr = Location.mkloc (Longident.Lident "unit") loc in + Ast_helper.Typ.constr ~attrs unit_constr [] | _ -> ( - let t = parseTypExpr p in + let t = parse_typ_expr p in match p.token with | Comma -> Parser.next p; - parseTupleType ~attrs ~first:t ~startPos p + parse_tuple_type ~attrs ~first:t ~start_pos p | _ -> Parser.expect Rparen p; { t with - ptyp_loc = mkLoc startPos p.prevEndPos; + ptyp_loc = mk_loc start_pos p.prev_end_pos; ptyp_attributes = List.concat [attrs; t.ptyp_attributes]; })) - | Lbracket -> parsePolymorphicVariantType ~attrs p + | Lbracket -> parse_polymorphic_variant_type ~attrs p | Uident _ | Lident _ -> - let constr = parseValuePath p in - let args = parseTypeConstructorArgs ~constrName:constr p in + let constr = parse_value_path p in + let args = parse_type_constructor_args ~constr_name:constr p in Ast_helper.Typ.constr - ~loc:(mkLoc startPos p.prevEndPos) + ~loc:(mk_loc start_pos p.prev_end_pos) ~attrs constr args | Module -> Parser.next p; Parser.expect Lparen p; - let packageType = parsePackageType ~startPos ~attrs p in + let package_type = parse_package_type ~start_pos ~attrs p in Parser.expect Rparen p; - {packageType with ptyp_loc = mkLoc startPos p.prevEndPos} + {package_type with ptyp_loc = mk_loc start_pos p.prev_end_pos} | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in + let extension = parse_extension p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Typ.extension ~attrs ~loc extension - | Lbrace -> parseRecordOrObjectType ~attrs p + | Lbrace -> parse_record_or_object_type ~attrs p | Eof -> Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultType () + Recover.default_type () | token -> ( Parser.err p (Diagnostics.unexpected token p.breadcrumbs); match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicTypExprStart + skip_tokens_and_maybe_retry p + ~is_start_of_grammar:Grammar.is_atomic_typ_expr_start with - | Some () -> parseAtomicTypExpr ~attrs p + | Some () -> parse_atomic_typ_expr ~attrs p | None -> - Parser.err ~startPos:p.prevEndPos p + Parser.err ~start_pos:p.prev_end_pos p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultType ()) + Recover.default_type ()) in - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; typ (* package-type ::= | modtype-path ∣ modtype-path with package-constraint { and package-constraint } *) -and parsePackageType ~startPos ~attrs p = - let modTypePath = parseModuleLongIdent ~lowercase:true p in +and parse_package_type ~start_pos ~attrs p = + let mod_type_path = parse_module_long_ident ~lowercase:true p in match p.Parser.token with | Lident "with" -> Parser.next p; - let constraints = parsePackageConstraints p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.package ~loc ~attrs modTypePath constraints + let constraints = parse_package_constraints p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.package ~loc ~attrs mod_type_path constraints | _ -> - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.package ~loc ~attrs modTypePath [] + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.package ~loc ~attrs mod_type_path [] (* package-constraint { and package-constraint } *) -and parsePackageConstraints p = +and parse_package_constraints p = let first = Parser.expect Typ p; - let typeConstr = parseValuePath p in + let type_constr = parse_value_path p in Parser.expect Equal p; - let typ = parseTypExpr p in - (typeConstr, typ) + let typ = parse_typ_expr p in + (type_constr, typ) in let rest = - parseRegion ~grammar:Grammar.PackageConstraint ~f:parsePackageConstraint p + parse_region ~grammar:Grammar.PackageConstraint ~f:parse_package_constraint + p in first :: rest (* and type typeconstr = typexpr *) -and parsePackageConstraint p = +and parse_package_constraint p = match p.Parser.token with | And -> Parser.next p; Parser.expect Typ p; - let typeConstr = parseValuePath p in + let type_constr = parse_value_path p in Parser.expect Equal p; - let typ = parseTypExpr p in - Some (typeConstr, typ) + let typ = parse_typ_expr p in + Some (type_constr, typ) | _ -> None -and parseRecordOrObjectType ~attrs p = +and parse_record_or_object_type ~attrs p = (* for inline record in constructor *) - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in Parser.expect Lbrace p; - let closedFlag = + let closed_flag = match p.token with | DotDot -> Parser.next p; @@ -4166,27 +4211,27 @@ and parseRecordOrObjectType ~attrs p = match p.token with | Lident _ -> Parser.err p - (Diagnostics.message ErrorMessages.forbiddenInlineRecordDeclaration) + (Diagnostics.message ErrorMessages.forbidden_inline_record_declaration) | _ -> () in let fields = - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p + parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parse_string_field_declaration p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.object_ ~loc ~attrs fields closedFlag + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.object_ ~loc ~attrs fields closed_flag (* TODO: check associativity in combination with attributes *) -and parseTypeAlias p typ = +and parse_type_alias p typ = match p.Parser.token with | As -> Parser.next p; Parser.expect SingleQuote p; - let ident, _loc = parseLident p in + let ident, _loc = parse_lident p in (* TODO: how do we parse attributes here? *) Ast_helper.Typ.alias - ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) + ~loc:(mk_loc typ.Parsetree.ptyp_loc.loc_start p.prev_end_pos) typ ident | _ -> typ @@ -4202,112 +4247,118 @@ and parseTypeAlias p typ = * dotted_type_parameter ::= * | . type_parameter *) -and parseTypeParameter p = - let docAttr : Parsetree.attributes = +and parse_type_parameter p = + let doc_attr : Parsetree.attributes = match p.Parser.token with | DocComment (loc, s) -> Parser.next p; - [docCommentToAttribute loc s] + [doc_comment_to_attribute loc s] | _ -> [] in if p.Parser.token = Token.Tilde || p.token = Dot - || Grammar.isTypExprStart p.token + || Grammar.is_typ_expr_start p.token then - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in let dotted = Parser.optional p Dot in - let attrs = docAttr @ parseAttributes p in + let attrs = doc_attr @ parse_attributes p in match p.Parser.token with | Tilde -> ( Parser.next p; - let name, loc = parseLident p in - let lblLocAttr = + let name, loc = parse_lident p in + let lbl_loc_attr = (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in Parser.expect ~grammar:Grammar.TypeExpression Colon p; let typ = - let typ = parseTypExpr p in - {typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes} + let typ = parse_typ_expr p in + {typ with ptyp_attributes = lbl_loc_attr :: typ.ptyp_attributes} in match p.Parser.token with | Equal -> Parser.next p; Parser.expect Question p; - Some {dotted; attrs; label = Optional name; typ; startPos} - | _ -> Some {dotted; attrs; label = Labelled name; typ; startPos}) + Some {dotted; attrs; label = Optional name; typ; start_pos} + | _ -> Some {dotted; attrs; label = Labelled name; typ; start_pos}) | Lident _ -> ( - let name, loc = parseLident p in + let name, loc = parse_lident p in match p.token with | Colon -> ( let () = let error = Diagnostics.message - (ErrorMessages.missingTildeLabeledParameter name) + (ErrorMessages.missing_tilde_labeled_parameter name) in - Parser.err ~startPos:loc.loc_start ~endPos:loc.loc_end p error + Parser.err ~start_pos:loc.loc_start ~end_pos:loc.loc_end p error in Parser.next p; - let typ = parseTypExpr p in + let typ = parse_typ_expr p in match p.Parser.token with | Equal -> Parser.next p; Parser.expect Question p; - Some {dotted; attrs; label = Optional name; typ; startPos} - | _ -> Some {dotted; attrs; label = Labelled name; typ; startPos}) + Some {dotted; attrs; label = Optional name; typ; start_pos} + | _ -> Some {dotted; attrs; label = Labelled name; typ; start_pos}) | _ -> let constr = Location.mkloc (Longident.Lident name) loc in - let args = parseTypeConstructorArgs ~constrName:constr p in + let args = parse_type_constructor_args ~constr_name:constr p in let typ = Ast_helper.Typ.constr - ~loc:(mkLoc startPos p.prevEndPos) + ~loc:(mk_loc start_pos p.prev_end_pos) ~attrs constr args in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - let typ = parseTypeAlias p typ in - Some {dotted; attrs = []; label = Nolabel; typ; startPos}) + let typ = parse_arrow_type_rest ~es6_arrow:true ~start_pos typ p in + let typ = parse_type_alias p typ in + Some {dotted; attrs = []; label = Nolabel; typ; start_pos}) | _ -> - let typ = parseTypExpr p in - let typWithAttributes = + let typ = parse_typ_expr p in + let typ_with_attributes = {typ with ptyp_attributes = List.concat [attrs; typ.ptyp_attributes]} in Some - {dotted; attrs = []; label = Nolabel; typ = typWithAttributes; startPos} + { + dotted; + attrs = []; + label = Nolabel; + typ = typ_with_attributes; + start_pos; + } else None (* (int, ~x:string, float) *) -and parseTypeParameters p = - let startPos = p.Parser.startPos in +and parse_type_parameters p = + let start_pos = p.Parser.start_pos in Parser.expect Lparen p; match p.Parser.token with | Rparen -> Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let unitConstr = Location.mkloc (Longident.Lident "unit") loc in - let typ = Ast_helper.Typ.constr unitConstr [] in - [{dotted = false; attrs = []; label = Nolabel; typ; startPos}] + let loc = mk_loc start_pos p.prev_end_pos in + let unit_constr = Location.mkloc (Longident.Lident "unit") loc in + let typ = Ast_helper.Typ.constr unit_constr [] in + [{dotted = false; attrs = []; label = Nolabel; typ; start_pos}] | _ -> let params = - parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters ~closing:Rparen - ~f:parseTypeParameter p + parse_comma_delimited_region ~grammar:Grammar.TypeParameters + ~closing:Rparen ~f:parse_type_parameter p in Parser.expect Rparen p; params -and parseEs6ArrowType ~attrs p = - let startPos = p.Parser.startPos in +and parse_es6_arrow_type ~attrs p = + let start_pos = p.Parser.start_pos in match p.Parser.token with | Tilde -> Parser.next p; - let name, loc = parseLident p in - let lblLocAttr = + let name, loc = parse_lident p in + let lbl_loc_attr = (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in Parser.expect ~grammar:Grammar.TypeExpression Colon p; let typ = - let typ = parseTypExpr ~alias:false ~es6Arrow:false p in - {typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes} + let typ = parse_typ_expr ~alias:false ~es6_arrow:false p in + {typ with ptyp_attributes = lbl_loc_attr :: typ.ptyp_attributes} in let arg = match p.Parser.token with @@ -4318,35 +4369,36 @@ and parseEs6ArrowType ~attrs p = | _ -> Asttypes.Labelled name in Parser.expect EqualGreater p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.arrow ~loc ~attrs arg typ returnType + let return_type = parse_typ_expr ~alias:false p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.arrow ~loc ~attrs arg typ return_type | DocComment _ -> assert false | _ -> - let parameters = parseTypeParameters p in + let parameters = parse_type_parameters p in Parser.expect EqualGreater p; - let returnType = parseTypExpr ~alias:false p in - let endPos = p.prevEndPos in - let returnTypeArity = + let return_type = parse_typ_expr ~alias:false p in + let end_pos = p.prev_end_pos in + let return_type_arity = match parameters with | _ when p.uncurried_config <> Legacy -> 0 | _ -> if parameters |> List.exists (function {dotted; typ = _} -> dotted) then 0 else - let _, args, _ = Res_parsetree_viewer.arrowType returnType in + let _, args, _ = Res_parsetree_viewer.arrow_type return_type in List.length args in let _paramNum, typ, _arity = List.fold_right - (fun {dotted; attrs; label = argLbl; typ; startPos} (paramNum, t, arity) -> + (fun {dotted; attrs; label = arg_lbl; typ; start_pos} + (param_num, t, arity) -> let uncurried = - p.uncurried_config |> Res_uncurried.fromDotted ~dotted + p.uncurried_config |> Res_uncurried.from_dotted ~dotted in - let loc = mkLoc startPos endPos in + let loc = mk_loc start_pos end_pos in let arity = (* Workaround for ~lbl: @as(json`false`) _, which changes the arity *) - match argLbl with + match arg_lbl with | Labelled _s -> let typ_is_any = match typ.ptyp_desc with @@ -4360,17 +4412,17 @@ and parseEs6ArrowType ~attrs p = else arity | _ -> arity in - let tArg = Ast_helper.Typ.arrow ~loc ~attrs argLbl typ t in - if uncurried && (paramNum = 1 || p.uncurried_config = Legacy) then - (paramNum - 1, Ast_uncurried.uncurriedType ~loc ~arity tArg, 1) - else (paramNum - 1, tArg, arity + 1)) + let t_arg = Ast_helper.Typ.arrow ~loc ~attrs arg_lbl typ t in + if uncurried && (param_num = 1 || p.uncurried_config = Legacy) then + (param_num - 1, Ast_uncurried.uncurried_type ~loc ~arity t_arg, 1) + else (param_num - 1, t_arg, arity + 1)) parameters - (List.length parameters, returnType, returnTypeArity + 1) + (List.length parameters, return_type, return_type_arity + 1) in { typ with ptyp_attributes = List.concat [typ.ptyp_attributes; attrs]; - ptyp_loc = mkLoc startPos p.prevEndPos; + ptyp_loc = mk_loc start_pos p.prev_end_pos; } (* @@ -4393,159 +4445,165 @@ and parseEs6ArrowType ~attrs p = * | uident.lident * | uident.uident.lident --> long module path *) -and parseTypExpr ?attrs ?(es6Arrow = true) ?(alias = true) p = +and parse_typ_expr ?attrs ?(es6_arrow = true) ?(alias = true) p = (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *) - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in let attrs = match attrs with | Some attrs -> attrs - | None -> parseAttributes p + | None -> parse_attributes p in let typ = - if es6Arrow && isEs6ArrowType p then parseEs6ArrowType ~attrs p + if es6_arrow && is_es6_arrow_type p then parse_es6_arrow_type ~attrs p else - let typ = parseAtomicTypExpr ~attrs p in - parseArrowTypeRest ~es6Arrow ~startPos typ p + let typ = parse_atomic_typ_expr ~attrs p in + parse_arrow_type_rest ~es6_arrow ~start_pos typ p in - let typ = if alias then parseTypeAlias p typ else typ in + let typ = if alias then parse_type_alias p typ else typ in (* Parser.eatBreadcrumb p; *) typ -and parseArrowTypeRest ~es6Arrow ~startPos typ p = +and parse_arrow_type_rest ~es6_arrow ~start_pos typ p = match p.Parser.token with - | (EqualGreater | MinusGreater) as token when es6Arrow == true -> + | (EqualGreater | MinusGreater) as token when es6_arrow == true -> (* error recovery *) if token = MinusGreater then Parser.expect EqualGreater p; Parser.next p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc startPos p.prevEndPos in - let arrowTyp = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in - if p.uncurried_config = Legacy then arrowTyp - else Ast_uncurried.uncurriedType ~loc ~arity:1 arrowTyp + let return_type = parse_typ_expr ~alias:false p in + let loc = mk_loc start_pos p.prev_end_pos in + let arrow_typ = + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ return_type + in + if p.uncurried_config = Legacy then arrow_typ + else Ast_uncurried.uncurried_type ~loc ~arity:1 arrow_typ | _ -> typ -and parseTypExprRegion p = - if Grammar.isTypExprStart p.Parser.token then Some (parseTypExpr p) else None +and parse_typ_expr_region p = + if Grammar.is_typ_expr_start p.Parser.token then Some (parse_typ_expr p) + else None -and parseTupleType ~attrs ~first ~startPos p = +and parse_tuple_type ~attrs ~first ~start_pos p = let typexprs = first - :: parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen - ~f:parseTypExprRegion p + :: parse_comma_delimited_region ~grammar:Grammar.TypExprList ~closing:Rparen + ~f:parse_typ_expr_region p in Parser.expect Rparen p; let () = match typexprs with | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message ErrorMessages.tuple_single_element) | _ -> () in - let tupleLoc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.tuple ~attrs ~loc:tupleLoc typexprs + let tuple_loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.tuple ~attrs ~loc:tuple_loc typexprs -and parseTypeConstructorArgRegion p = - if Grammar.isTypExprStart p.Parser.token then Some (parseTypExpr p) +and parse_type_constructor_arg_region p = + if Grammar.is_typ_expr_start p.Parser.token then Some (parse_typ_expr p) else if p.token = LessThan then ( Parser.next p; - parseTypeConstructorArgRegion p) + parse_type_constructor_arg_region p) else None (* Js.Nullable.value<'a> *) -and parseTypeConstructorArgs ~constrName p = +and parse_type_constructor_args ~constr_name p = let opening = p.Parser.token in - let openingStartPos = p.startPos in + let opening_start_pos = p.start_pos in match opening with | LessThan | Lparen -> - Scanner.setDiamondMode p.scanner; + Scanner.set_diamond_mode p.scanner; Parser.next p; - let typeArgs = + let type_args = (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:GreaterThan ~f:parseTypeConstructorArgRegion p + parse_comma_delimited_region ~grammar:Grammar.TypExprList + ~closing:GreaterThan ~f:parse_type_constructor_arg_region p in let () = match p.token with | Rparen when opening = Token.Lparen -> - let typ = Ast_helper.Typ.constr constrName typeArgs in + let typ = Ast_helper.Typ.constr constr_name type_args in let msg = - Doc.breakableGroup ~forceBreak:true + Doc.breakable_group ~force_break:true (Doc.concat [ Doc.text "Type parameters require angle brackets:"; Doc.indent (Doc.concat - [Doc.line; ResPrinter.printTypExpr typ CommentTable.empty]); + [ + Doc.line; + ResPrinter.print_typ_expr typ CommentTable.empty; + ]); ]) - |> Doc.toString ~width:80 + |> Doc.to_string ~width:80 in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.err ~start_pos:opening_start_pos p (Diagnostics.message msg); Parser.next p | _ -> Parser.expect GreaterThan p in - Scanner.popMode p.scanner Diamond; - typeArgs + Scanner.pop_mode p.scanner Diamond; + type_args | _ -> [] (* string-field-decl ::= * | string: poly-typexpr * | attributes string-field-decl *) -and parseStringFieldDeclaration p = - let attrs = parseAttributes p in +and parse_string_field_declaration p = + let attrs = parse_attributes p in match p.Parser.token with | String name -> - let nameStartPos = p.startPos in - let nameEndPos = p.endPos in + let name_start_pos = p.start_pos in + let name_end_pos = p.end_pos in Parser.next p; - let fieldName = Location.mkloc name (mkLoc nameStartPos nameEndPos) in + let field_name = Location.mkloc name (mk_loc name_start_pos name_end_pos) in Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parsePolyTypeExpr p in - Some (Parsetree.Otag (fieldName, attrs, typ)) + let typ = parse_poly_type_expr p in + Some (Parsetree.Otag (field_name, attrs, typ)) | DotDotDot -> Parser.next p; - let typ = parseTypExpr p in + let typ = parse_typ_expr p in Some (Parsetree.Oinherit typ) | Lident name -> - let nameLoc = mkLoc p.startPos p.endPos in + let name_loc = mk_loc p.start_pos p.end_pos in Parser.err p - (Diagnostics.message (ErrorMessages.objectQuotedFieldName name)); + (Diagnostics.message (ErrorMessages.object_quoted_field_name name)); Parser.next p; - let fieldName = Location.mkloc name nameLoc in + let field_name = Location.mkloc name name_loc in Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parsePolyTypeExpr p in - Some (Parsetree.Otag (fieldName, attrs, typ)) + let typ = parse_poly_type_expr p in + Some (Parsetree.Otag (field_name, attrs, typ)) | _token -> None (* field-decl ::= * | [mutable] field-name : poly-typexpr * | attributes field-decl *) -and parseFieldDeclaration p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in +and parse_field_declaration p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in let mut = if Parser.optional p Token.Mutable then Asttypes.Mutable else Asttypes.Immutable in let lident, loc = match p.token with - | _ -> parseLident p + | _ -> parse_lident p in - let optional = parseOptionalLabel p in + let optional = parse_optional_label p in let name = Location.mkloc lident loc in let typ = match p.Parser.token with | Colon -> Parser.next p; - parsePolyTypeExpr p + parse_poly_type_expr p | _ -> Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in + let loc = mk_loc start_pos typ.ptyp_loc.loc_end in (optional, Ast_helper.Type.field ~attrs ~loc ~mut name typ) -and parseFieldDeclarationRegion ?foundObjectField p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in +and parse_field_declaration_region ?found_object_field p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in let mut = if Parser.optional p Token.Mutable then Asttypes.Mutable else Asttypes.Immutable @@ -4553,43 +4611,43 @@ and parseFieldDeclarationRegion ?foundObjectField p = match p.token with | DotDotDot -> Parser.next p; - let name = Location.mkloc "..." (mkLoc startPos p.prevEndPos) in - let typ = parsePolyTypeExpr p in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in + let name = Location.mkloc "..." (mk_loc start_pos p.prev_end_pos) in + let typ = parse_poly_type_expr p in + let loc = mk_loc start_pos typ.ptyp_loc.loc_end in Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) - | String s when foundObjectField <> None -> - Option.get foundObjectField := true; + | String s when found_object_field <> None -> + Option.get found_object_field := true; Parser.next p; - let name = Location.mkloc s (mkLoc startPos p.prevEndPos) in + let name = Location.mkloc s (mk_loc start_pos p.prev_end_pos) in Parser.expect Colon p; - let typ = parsePolyTypeExpr p in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in + let typ = parse_poly_type_expr p in + let loc = mk_loc start_pos typ.ptyp_loc.loc_end in Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) | Lident _ -> - let lident, loc = parseLident p in + let lident, loc = parse_lident p in let name = Location.mkloc lident loc in - let optional = parseOptionalLabel p in + let optional = parse_optional_label p in let typ = match p.Parser.token with | Colon -> Parser.next p; - parsePolyTypeExpr p + parse_poly_type_expr p | _ -> Ast_helper.Typ.constr ~loc:name.loc ~attrs {name with txt = Lident name.txt} [] in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in - let attrs = if optional then optionalAttr :: attrs else attrs in + let loc = mk_loc start_pos typ.ptyp_loc.loc_end in + let attrs = if optional then optional_attr :: attrs else attrs in Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) | _ -> if attrs <> [] then - Parser.err ~startPos p + Parser.err ~start_pos p (Diagnostics.message "Attributes and doc comments can only be used at the beginning of a \ field declaration"); if mut = Mutable then - Parser.err ~startPos p + Parser.err ~start_pos p (Diagnostics.message "The `mutable` qualifier can only be used at the beginning of a \ field declaration"); @@ -4600,15 +4658,15 @@ and parseFieldDeclarationRegion ?foundObjectField p = * | { field-decl, field-decl } * | { field-decl, field-decl, field-decl, } *) -and parseRecordDeclaration p = - Parser.leaveBreadcrumb p Grammar.RecordDecl; +and parse_record_declaration p = + Parser.leave_breadcrumb p Grammar.RecordDecl; Parser.expect Lbrace p; let rows = - parseCommaDelimitedRegion ~grammar:Grammar.RecordDecl ~closing:Rbrace - ~f:parseFieldDeclarationRegion p + parse_comma_delimited_region ~grammar:Grammar.RecordDecl ~closing:Rbrace + ~f:parse_field_declaration_region p in Parser.expect Rbrace p; - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; rows (* constr-args ::= @@ -4620,8 +4678,8 @@ and parseRecordDeclaration p = * TODO: should we overparse inline-records in every position? * Give a good error message afterwards? *) -and parseConstrDeclArgs p = - let constrArgs = +and parse_constr_decl_args p = + let constr_args = match p.Parser.token with | Lparen -> ( Parser.next p; @@ -4629,10 +4687,10 @@ and parseConstrDeclArgs p = match p.Parser.token with | Lbrace -> ( Parser.next p; - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in match p.Parser.token with | DotDot | Dot -> - let closedFlag = + let closed_flag = match p.token with | DotDot -> Parser.next p; @@ -4643,25 +4701,26 @@ and parseConstrDeclArgs p = | _ -> Asttypes.Closed in let fields = - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p + parse_comma_delimited_region + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parse_string_field_declaration p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag in + let loc = mk_loc start_pos p.prev_end_pos in + let typ = Ast_helper.Typ.object_ ~loc ~attrs:[] fields closed_flag in Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:Rparen ~f:parseTypExprRegion p + let more_args = + parse_comma_delimited_region ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parse_typ_expr_region p in Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) + Parsetree.Pcstr_tuple (typ :: more_args) | DotDotDot -> - let dotdotdotStart = p.startPos in - let dotdotdotEnd = p.endPos in + let dotdotdot_start = p.start_pos in + let dotdotdot_end = p.end_pos in (* start of object type spreading, e.g. `User({...a, "u": int})` *) Parser.next p; - let typ = parseTypExpr p in + let typ = parse_typ_expr p in let () = match p.token with | Rbrace -> @@ -4672,46 +4731,46 @@ and parseConstrDeclArgs p = let () = match p.token with | Lident _ -> - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) + Parser.err ~start_pos:dotdotdot_start ~end_pos:dotdotdot_end p + (Diagnostics.message ErrorMessages.spread_in_record_declaration) | _ -> () in let fields = Parsetree.Oinherit typ - :: parseCommaDelimitedRegion + :: parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p + ~f:parse_string_field_declaration p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in let typ = Ast_helper.Typ.object_ ~loc fields Asttypes.Closed - |> parseTypeAlias p + |> parse_type_alias p in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + let typ = parse_arrow_type_rest ~es6_arrow:true ~start_pos typ p in Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:Rparen ~f:parseTypExprRegion p + let more_args = + parse_comma_delimited_region ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parse_typ_expr_region p in Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) + Parsetree.Pcstr_tuple (typ :: more_args) | _ -> ( - let attrs = parseAttributes p in + let attrs = parse_attributes p in match p.Parser.token with | String _ -> - let closedFlag = Asttypes.Closed in + let closed_flag = Asttypes.Closed in let fields = match attrs with | [] -> - parseCommaDelimitedRegion + parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p + ~f:parse_string_field_declaration p | attrs -> let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; + Parser.leave_breadcrumb p Grammar.StringFieldDeclarations; let field = - match parseStringFieldDeclaration p with + match parse_string_field_declaration p with | Some field -> field | None -> assert false in @@ -4722,42 +4781,42 @@ and parseConstrDeclArgs p = | Comma -> Parser.next p | _ -> Parser.expect Comma p in - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; match field with | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) | Oinherit ct -> Oinherit ct in first - :: parseCommaDelimitedRegion + :: parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p + ~f:parse_string_field_declaration p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in let typ = - Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag - |> parseTypeAlias p + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closed_flag + |> parse_type_alias p in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + let typ = parse_arrow_type_rest ~es6_arrow:true ~start_pos typ p in Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:Rparen ~f:parseTypExprRegion p + let more_args = + parse_comma_delimited_region ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parse_typ_expr_region p in Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) + Parsetree.Pcstr_tuple (typ :: more_args) | _ -> let fields = match attrs with | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p + parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parse_field_declaration_region p | attrs -> let first = - let optional, field = parseFieldDeclaration p in + let optional, field = parse_field_declaration p in let attrs = - if optional then optionalAttr :: attrs else attrs + if optional then optional_attr :: attrs else attrs in {field with Parsetree.pld_attributes = attrs} in @@ -4765,9 +4824,9 @@ and parseConstrDeclArgs p = else ( Parser.expect Comma p; first - :: parseCommaDelimitedRegion + :: parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations ~closing:Rbrace - ~f:parseFieldDeclarationRegion p) + ~f:parse_field_declaration_region p) in Parser.expect Rbrace p; Parser.optional p Comma |> ignore; @@ -4775,8 +4834,8 @@ and parseConstrDeclArgs p = Parsetree.Pcstr_record fields)) | _ -> let args = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen - ~f:parseTypExprRegion p + parse_comma_delimited_region ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parse_typ_expr_region p in Parser.expect Rparen p; Parsetree.Pcstr_tuple args) @@ -4786,59 +4845,59 @@ and parseConstrDeclArgs p = match p.Parser.token with | Colon -> Parser.next p; - Some (parseTypExpr p) + Some (parse_typ_expr p) | _ -> None in - (constrArgs, res) + (constr_args, res) (* constr-decl ::= * | constr-name * | attrs constr-name * | constr-name const-args * | attrs constr-name const-args *) -and parseTypeConstructorDeclarationWithBar p = +and parse_type_constructor_declaration_with_bar p = match p.Parser.token with | Bar -> - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in Parser.next p; - Some (parseTypeConstructorDeclaration ~startPos p) + Some (parse_type_constructor_declaration ~start_pos p) | _ -> None -and parseTypeConstructorDeclaration ~startPos p = - Parser.leaveBreadcrumb p Grammar.ConstructorDeclaration; - let attrs = parseAttributes p in +and parse_type_constructor_declaration ~start_pos p = + Parser.leave_breadcrumb p Grammar.ConstructorDeclaration; + let attrs = parse_attributes p in match p.Parser.token with | DotDotDot -> Parser.next p; - let name = Location.mkloc "..." (mkLoc startPos p.prevEndPos) in - let typ = parsePolyTypeExpr p in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in + let name = Location.mkloc "..." (mk_loc start_pos p.prev_end_pos) in + let typ = parse_poly_type_expr p in + let loc = mk_loc start_pos typ.ptyp_loc.loc_end in Ast_helper.Type.constructor ~loc ~attrs ~args:(Pcstr_tuple [typ]) name | Uident uident -> - let uidentLoc = mkLoc p.startPos p.endPos in + let uident_loc = mk_loc p.start_pos p.end_pos in Parser.next p; - let args, res = parseConstrDeclArgs p in - Parser.eatBreadcrumb p; - let loc = mkLoc startPos p.prevEndPos in + let args, res = parse_constr_decl_args p in + Parser.eat_breadcrumb p; + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Type.constructor ~loc ~attrs ?res ~args - (Location.mkloc uident uidentLoc) + (Location.mkloc uident uident_loc) | t -> Parser.err p (Diagnostics.uident t); Ast_helper.Type.constructor (Location.mknoloc "_") (* [|] constr-decl { | constr-decl } *) -and parseTypeConstructorDeclarations ?first p = - let firstConstrDecl = +and parse_type_constructor_declarations ?first p = + let first_constr_decl = match first with | None -> - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in ignore (Parser.optional p Token.Bar); - parseTypeConstructorDeclaration ~startPos p - | Some firstConstrDecl -> firstConstrDecl + parse_type_constructor_declaration ~start_pos p + | Some first_constr_decl -> first_constr_decl in - firstConstrDecl - :: parseRegion ~grammar:Grammar.ConstructorDeclaration - ~f:parseTypeConstructorDeclarationWithBar p + first_constr_decl + :: parse_region ~grammar:Grammar.ConstructorDeclaration + ~f:parse_type_constructor_declaration_with_bar p (* * type-representation ::= @@ -4850,18 +4909,18 @@ and parseTypeConstructorDeclarations ?first p = * ∣ = private record-decl * | = .. *) -and parseTypeRepresentation p = - Parser.leaveBreadcrumb p Grammar.TypeRepresentation; +and parse_type_representation p = + Parser.leave_breadcrumb p Grammar.TypeRepresentation; (* = consumed *) - let privateFlag = + let private_flag = if Parser.optional p Token.Private then Asttypes.Private else Asttypes.Public in let kind = match p.Parser.token with | Bar | Uident _ -> - Parsetree.Ptype_variant (parseTypeConstructorDeclarations p) - | Lbrace -> Parsetree.Ptype_record (parseRecordDeclaration p) + Parsetree.Ptype_variant (parse_type_constructor_declarations p) + | Lbrace -> Parsetree.Ptype_record (parse_record_declaration p) | DotDot -> Parser.next p; Ptype_open @@ -4870,8 +4929,8 @@ and parseTypeRepresentation p = (* TODO: I have no idea if this is even remotely a good idea *) Parsetree.Ptype_variant [] in - Parser.eatBreadcrumb p; - (privateFlag, kind) + Parser.eat_breadcrumb p; + (private_flag, kind) (* type-param ::= * | variance 'lident @@ -4883,7 +4942,7 @@ and parseTypeRepresentation p = * | - * | (* empty *) *) -and parseTypeParam p = +and parse_type_param p = let variance = match p.Parser.token with | Plus -> @@ -4899,22 +4958,22 @@ and parseTypeParam p = Parser.next p; let ident, loc = if p.Parser.token = Eof then ( - Parser.err ~startPos:p.startPos p + Parser.err ~start_pos:p.start_pos p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("", mkLoc p.startPos p.prevEndPos)) - else parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p + ("", mk_loc p.start_pos p.prev_end_pos)) + else parse_ident ~msg:ErrorMessages.type_param ~start_pos:p.start_pos p in Some (Ast_helper.Typ.var ~loc ident, variance) | Underscore -> - let loc = mkLoc p.startPos p.endPos in + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; Some (Ast_helper.Typ.any ~loc (), variance) | (Uident _ | Lident _) as token -> Parser.err p (Diagnostics.message - ("Type params start with a singlequote: '" ^ Token.toString token)); + ("Type params start with a singlequote: '" ^ Token.to_string token)); let ident, loc = - parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p + parse_ident ~msg:ErrorMessages.type_param ~start_pos:p.start_pos p in Some (Ast_helper.Typ.var ~loc ident, variance) | _token -> None @@ -4927,23 +4986,23 @@ and parseTypeParam p = * * TODO: when we have pretty-printer show an error * with the actual code corrected. *) -and parseTypeParams ~parent p = +and parse_type_params ~parent p = let opening = p.Parser.token in match opening with - | (LessThan | Lparen) when p.startPos.pos_lnum == p.prevEndPos.pos_lnum -> - Scanner.setDiamondMode p.scanner; - let openingStartPos = p.startPos in - Parser.leaveBreadcrumb p Grammar.TypeParams; + | (LessThan | Lparen) when p.start_pos.pos_lnum == p.prev_end_pos.pos_lnum -> + Scanner.set_diamond_mode p.scanner; + let opening_start_pos = p.start_pos in + Parser.leave_breadcrumb p Grammar.TypeParams; Parser.next p; let params = - parseCommaDelimitedRegion ~grammar:Grammar.TypeParams ~closing:GreaterThan - ~f:parseTypeParam p + parse_comma_delimited_region ~grammar:Grammar.TypeParams + ~closing:GreaterThan ~f:parse_type_param p in let () = match p.token with | Rparen when opening = Token.Lparen -> let msg = - Doc.breakableGroup ~forceBreak:true + Doc.breakable_group ~force_break:true (Doc.concat [ Doc.text "Type parameters require angle brackets:"; @@ -4953,41 +5012,42 @@ and parseTypeParams ~parent p = Doc.line; Doc.concat [ - ResPrinter.printLongident parent.Location.txt; - ResPrinter.printTypeParams params CommentTable.empty; + ResPrinter.print_longident parent.Location.txt; + ResPrinter.print_type_params params + CommentTable.empty; ]; ]); ]) - |> Doc.toString ~width:80 + |> Doc.to_string ~width:80 in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.err ~start_pos:opening_start_pos p (Diagnostics.message msg); Parser.next p | _ -> Parser.expect GreaterThan p in - Scanner.popMode p.scanner Diamond; - Parser.eatBreadcrumb p; + Scanner.pop_mode p.scanner Diamond; + Parser.eat_breadcrumb p; params | _ -> [] (* type-constraint ::= constraint ' ident = typexpr *) -and parseTypeConstraint p = - let startPos = p.Parser.startPos in +and parse_type_constraint p = + let start_pos = p.Parser.start_pos in match p.Parser.token with | Token.Constraint -> ( Parser.next p; Parser.expect SingleQuote p; match p.Parser.token with | Lident ident -> - let identLoc = mkLoc startPos p.endPos in + let ident_loc = mk_loc start_pos p.end_pos in Parser.next p; Parser.expect Equal p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Typ.var ~loc:identLoc ident, typ, loc) + let typ = parse_typ_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Typ.var ~loc:ident_loc ident, typ, loc) | t -> Parser.err p (Diagnostics.lident t); - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Typ.any (), parseTypExpr p, loc)) + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Typ.any (), parse_typ_expr p, loc)) | _ -> None (* type-constraints ::= @@ -4996,71 +5056,73 @@ and parseTypeConstraint p = * | type-constraint type-constraint * | type-constraint type-constraint type-constraint (* 0 or more *) *) -and parseTypeConstraints p = - parseRegion ~grammar:Grammar.TypeConstraint ~f:parseTypeConstraint p +and parse_type_constraints p = + parse_region ~grammar:Grammar.TypeConstraint ~f:parse_type_constraint p -and parseTypeEquationOrConstrDecl p = - let uidentStartPos = p.Parser.startPos in +and parse_type_equation_or_constr_decl p = + let uident_start_pos = p.Parser.start_pos in match p.Parser.token with | Uident uident -> ( Parser.next p; match p.Parser.token with | Dot -> ( Parser.next p; - let typeConstr = - parseValuePathTail p uidentStartPos (Longident.Lident uident) + let type_constr = + parse_value_path_tail p uident_start_pos (Longident.Lident uident) in - let loc = mkLoc uidentStartPos p.prevEndPos in + let loc = mk_loc uident_start_pos p.prev_end_pos in let typ = - parseTypeAlias p - (Ast_helper.Typ.constr ~loc typeConstr - (parseTypeConstructorArgs ~constrName:typeConstr p)) + parse_type_alias p + (Ast_helper.Typ.constr ~loc type_constr + (parse_type_constructor_args ~constr_name:type_constr p)) in match p.token with | Equal -> Parser.next p; - let priv, kind = parseTypeRepresentation p in + let priv, kind = parse_type_representation p in (Some typ, priv, kind) | EqualGreater -> Parser.next p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc uidentStartPos p.prevEndPos in - let arrowType = - Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + let return_type = parse_typ_expr ~alias:false p in + let loc = mk_loc uident_start_pos p.prev_end_pos in + let arrow_type = + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ return_type in let uncurried = p.uncurried_config <> Legacy in - let arrowType = - if uncurried then Ast_uncurried.uncurriedType ~loc ~arity:1 arrowType - else arrowType + let arrow_type = + if uncurried then + Ast_uncurried.uncurried_type ~loc ~arity:1 arrow_type + else arrow_type in - let typ = parseTypeAlias p arrowType in + let typ = parse_type_alias p arrow_type in (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)) | _ -> - let uidentEndPos = p.prevEndPos in - let args, res = parseConstrDeclArgs p in + let uident_end_pos = p.prev_end_pos in + let args, res = parse_constr_decl_args p in let first = Some - (let uidentLoc = mkLoc uidentStartPos uidentEndPos in + (let uident_loc = mk_loc uident_start_pos uident_end_pos in Ast_helper.Type.constructor - ~loc:(mkLoc uidentStartPos p.prevEndPos) + ~loc:(mk_loc uident_start_pos p.prev_end_pos) ?res ~args - (Location.mkloc uident uidentLoc)) + (Location.mkloc uident uident_loc)) in ( None, Asttypes.Public, - Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first) )) + Parsetree.Ptype_variant (parse_type_constructor_declarations p ?first) + )) | t -> Parser.err p (Diagnostics.uident t); (* TODO: is this a good idea? *) (None, Asttypes.Public, Parsetree.Ptype_abstract) -and parseRecordOrObjectDecl p = - let startPos = p.Parser.startPos in +and parse_record_or_object_decl p = + let start_pos = p.Parser.start_pos in Parser.expect Lbrace p; match p.Parser.token with | DotDot | Dot -> - let closedFlag = + let closed_flag = match p.token with | DotDot -> Parser.next p; @@ -5071,80 +5133,82 @@ and parseRecordOrObjectDecl p = | _ -> Asttypes.Closed in let fields = - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p + parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parse_string_field_declaration p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in let typ = - Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag - |> parseTypeAlias p + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closed_flag + |> parse_type_alias p in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + let typ = parse_arrow_type_rest ~es6_arrow:true ~start_pos typ p in (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) | DotDotDot -> ( - let dotdotdotStart = p.startPos in - let dotdotdotEnd = p.endPos in + let dotdotdot_start = p.start_pos in + let dotdotdot_end = p.end_pos in (* start of object type spreading, e.g. `type u = {...a, "u": int}` *) Parser.next p; - let typ = parseTypExpr p in + let typ = parse_typ_expr p in match p.token with | Rbrace -> (* {...x}, spread without extra fields *) Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let dotField = + let loc = mk_loc start_pos p.prev_end_pos in + let dot_field = Ast_helper.Type.field ~loc - {txt = "..."; loc = mkLoc dotdotdotStart dotdotdotEnd} + {txt = "..."; loc = mk_loc dotdotdot_start dotdotdot_end} typ in - let kind = Parsetree.Ptype_record [dotField] in + let kind = Parsetree.Ptype_record [dot_field] in (None, Public, kind) | _ -> Parser.expect Comma p; - let loc = mkLoc startPos p.prevEndPos in - let dotField = + let loc = mk_loc start_pos p.prev_end_pos in + let dot_field = Ast_helper.Type.field ~loc - {txt = "..."; loc = mkLoc dotdotdotStart dotdotdotEnd} + {txt = "..."; loc = mk_loc dotdotdot_start dotdotdot_end} typ in - let foundObjectField = ref false in + let found_object_field = ref false in let fields = - parseCommaDelimitedRegion ~grammar:Grammar.RecordDecl ~closing:Rbrace - ~f:(parseFieldDeclarationRegion ~foundObjectField) + parse_comma_delimited_region ~grammar:Grammar.RecordDecl ~closing:Rbrace + ~f:(parse_field_declaration_region ~found_object_field) p in Parser.expect Rbrace p; - if !foundObjectField then + if !found_object_field then let fields = Ext_list.map fields (fun ld -> match ld.pld_name.txt with | "..." -> Parsetree.Oinherit ld.pld_type | _ -> Otag (ld.pld_name, ld.pld_attributes, ld.pld_type)) in - let dotField = Parsetree.Oinherit typ in - let typ_obj = Ast_helper.Typ.object_ (dotField :: fields) Closed in - let typ_obj = parseTypeAlias p typ_obj in - let typ_obj = parseArrowTypeRest ~es6Arrow:true ~startPos typ_obj p in + let dot_field = Parsetree.Oinherit typ in + let typ_obj = Ast_helper.Typ.object_ (dot_field :: fields) Closed in + let typ_obj = parse_type_alias p typ_obj in + let typ_obj = + parse_arrow_type_rest ~es6_arrow:true ~start_pos typ_obj p + in (Some typ_obj, Public, Ptype_abstract) else - let kind = Parsetree.Ptype_record (dotField :: fields) in + let kind = Parsetree.Ptype_record (dot_field :: fields) in (None, Public, kind)) | _ -> ( - let attrs = parseAttributes p in + let attrs = parse_attributes p in match p.Parser.token with | String _ -> - let closedFlag = Asttypes.Closed in + let closed_flag = Asttypes.Closed in let fields = match attrs with | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p + parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parse_string_field_declaration p | attrs -> let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; + Parser.leave_breadcrumb p Grammar.StringFieldDeclarations; let field = - match parseStringFieldDeclaration p with + match parse_string_field_declaration p with | Some field -> field | None -> assert false in @@ -5155,35 +5219,36 @@ and parseRecordOrObjectDecl p = | Comma -> Parser.next p | _ -> Parser.expect Comma p in - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; match field with | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) | Oinherit ct -> Oinherit ct in first - :: parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p + :: parse_comma_delimited_region + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parse_string_field_declaration p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in let typ = - Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag - |> parseTypeAlias p + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closed_flag + |> parse_type_alias p in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + let typ = parse_arrow_type_rest ~es6_arrow:true ~start_pos typ p in (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) | _ -> - Parser.leaveBreadcrumb p Grammar.RecordDecl; + Parser.leave_breadcrumb p Grammar.RecordDecl; let fields = (* XXX *) match attrs with | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p + parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parse_field_declaration_region p | attr :: _ as attrs -> let first = - let optional, field = parseFieldDeclaration p in - let attrs = if optional then optionalAttr :: attrs else attrs in + let optional, field = parse_field_declaration p in + let attrs = if optional then optional_attr :: attrs else attrs in Parser.optional p Comma |> ignore; { field with @@ -5196,29 +5261,29 @@ and parseRecordOrObjectDecl p = } in first - :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p + :: parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parse_field_declaration_region p in Parser.expect Rbrace p; - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; (None, Asttypes.Public, Parsetree.Ptype_record fields)) -and parsePrivateEqOrRepr p = +and parse_private_eq_or_repr p = Parser.expect Private p; match p.Parser.token with | Lbrace -> - let manifest, _, kind = parseRecordOrObjectDecl p in + let manifest, _, kind = parse_record_or_object_decl p in (manifest, Asttypes.Private, kind) | Uident _ -> - let manifest, _, kind = parseTypeEquationOrConstrDecl p in + let manifest, _, kind = parse_type_equation_or_constr_decl p in (manifest, Asttypes.Private, kind) | Bar | DotDot -> - let _, kind = parseTypeRepresentation p in + let _, kind = parse_type_representation p in (None, Asttypes.Private, kind) - | t when Grammar.isTypExprStart t -> - (Some (parseTypExpr p), Asttypes.Private, Parsetree.Ptype_abstract) + | t when Grammar.is_typ_expr_start t -> + (Some (parse_typ_expr p), Asttypes.Private, Parsetree.Ptype_abstract) | _ -> - let _, kind = parseTypeRepresentation p in + let _, kind = parse_type_representation p in (None, Asttypes.Private, kind) (* @@ -5236,149 +5301,150 @@ and parsePrivateEqOrRepr p = tag-spec-full ::= `tag-name [ of [&] typexpr { & typexpr } ] | typexpr *) -and parsePolymorphicVariantType ~attrs p = - let startPos = p.Parser.startPos in +and parse_polymorphic_variant_type ~attrs p = + let start_pos = p.Parser.start_pos in Parser.expect Lbracket p; match p.token with | GreaterThan -> Parser.next p; - let rowFields = + let row_fields = match p.token with | Rbracket -> [] - | Bar -> parseTagSpecs p + | Bar -> parse_tag_specs p | _ -> - let rowField = parseTagSpec p in - rowField :: parseTagSpecs p + let row_field = parse_tag_spec p in + row_field :: parse_tag_specs p in let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc rowFields Open None + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.variant ~attrs ~loc row_fields Open None in Parser.expect Rbracket p; variant | LessThan -> Parser.next p; Parser.optional p Bar |> ignore; - let rowField = parseTagSpecFull p in - let rowFields = parseTagSpecFulls p in - let tagNames = parseTagNames p in + let row_field = parse_tag_spec_full p in + let row_fields = parse_tag_spec_fulls p in + let tag_names = parse_tag_names p in let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed - (Some tagNames) + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.variant ~attrs ~loc (row_field :: row_fields) Closed + (Some tag_names) in Parser.expect Rbracket p; variant | _ -> - let rowFields1 = parseTagSpecFirst p in - let rowFields2 = parseTagSpecs p in + let row_fields1 = parse_tag_spec_first p in + let row_fields2 = parse_tag_specs p in let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.variant ~attrs ~loc (row_fields1 @ row_fields2) Closed None in Parser.expect Rbracket p; variant -and parseTagName p = +and parse_tag_name p = match p.Parser.token with | Hash -> - let ident, _loc = parseHashIdent ~startPos:p.startPos p in + let ident, _loc = parse_hash_ident ~start_pos:p.start_pos p in Some ident | _ -> None -and parseTagNames p = +and parse_tag_names p = if p.Parser.token == GreaterThan then ( Parser.next p; - parseRegion p ~grammar:Grammar.TagNames ~f:parseTagName) + parse_region p ~grammar:Grammar.TagNames ~f:parse_tag_name) else [] -and parseTagSpecFulls p = +and parse_tag_spec_fulls p = match p.Parser.token with | Rbracket -> [] | GreaterThan -> [] | Bar -> Parser.next p; - let rowField = parseTagSpecFull p in - rowField :: parseTagSpecFulls p + let row_field = parse_tag_spec_full p in + row_field :: parse_tag_spec_fulls p | _ -> [] -and parseTagSpecFull p = - let attrs = parseAttributes p in +and parse_tag_spec_full p = + let attrs = parse_attributes p in match p.Parser.token with - | Hash -> parsePolymorphicVariantTypeSpecHash ~attrs ~full:true p + | Hash -> parse_polymorphic_variant_type_spec_hash ~attrs ~full:true p | _ -> - let typ = parseTypExpr ~attrs p in + let typ = parse_typ_expr ~attrs p in Parsetree.Rinherit typ -and parseTagSpecs p = +and parse_tag_specs p = match p.Parser.token with | Bar -> Parser.next p; - let rowField = parseTagSpec p in - rowField :: parseTagSpecs p + let row_field = parse_tag_spec p in + row_field :: parse_tag_specs p | _ -> [] -and parseTagSpec p = - let attrs = parseAttributes p in +and parse_tag_spec p = + let attrs = parse_attributes p in match p.Parser.token with - | Hash -> parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p + | Hash -> parse_polymorphic_variant_type_spec_hash ~attrs ~full:false p | _ -> - let typ = parseTypExpr ~attrs p in + let typ = parse_typ_expr ~attrs p in Parsetree.Rinherit typ -and parseTagSpecFirst p = - let attrs = parseAttributes p in +and parse_tag_spec_first p = + let attrs = parse_attributes p in match p.Parser.token with | Bar -> Parser.next p; - [parseTagSpec p] - | Hash -> [parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p] + [parse_tag_spec p] + | Hash -> [parse_polymorphic_variant_type_spec_hash ~attrs ~full:false p] | _ -> ( - let typ = parseTypExpr ~attrs p in + let typ = parse_typ_expr ~attrs p in match p.token with | Rbracket -> (* example: [ListStyleType.t] *) [Parsetree.Rinherit typ] | _ -> Parser.expect Bar p; - [Parsetree.Rinherit typ; parseTagSpec p]) + [Parsetree.Rinherit typ; parse_tag_spec p]) -and parsePolymorphicVariantTypeSpecHash ~attrs ~full p : Parsetree.row_field = - let startPos = p.Parser.startPos in - let ident, loc = parseHashIdent ~startPos p in +and parse_polymorphic_variant_type_spec_hash ~attrs ~full p : + Parsetree.row_field = + let start_pos = p.Parser.start_pos in + let ident, loc = parse_hash_ident ~start_pos p in let rec loop p = match p.Parser.token with | Band when full -> Parser.next p; - let rowField = parsePolymorphicVariantTypeArgs p in - rowField :: loop p + let row_field = parse_polymorphic_variant_type_args p in + row_field :: loop p | _ -> [] in - let firstTuple, tagContainsAConstantEmptyConstructor = + let first_tuple, tag_contains_a_constant_empty_constructor = match p.Parser.token with | Band when full -> Parser.next p; - ([parsePolymorphicVariantTypeArgs p], true) - | Lparen -> ([parsePolymorphicVariantTypeArgs p], false) + ([parse_polymorphic_variant_type_args p], true) + | Lparen -> ([parse_polymorphic_variant_type_args p], false) | _ -> ([], true) in - let tuples = firstTuple @ loop p in + let tuples = first_tuple @ loop p in Parsetree.Rtag ( Location.mkloc ident loc, attrs, - tagContainsAConstantEmptyConstructor, + tag_contains_a_constant_empty_constructor, tuples ) -and parsePolymorphicVariantTypeArgs p = - let startPos = p.Parser.startPos in +and parse_polymorphic_variant_type_args p = + let start_pos = p.Parser.start_pos in Parser.expect Lparen p; let args = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen - ~f:parseTypExprRegion p + parse_comma_delimited_region ~grammar:Grammar.TypExprList ~closing:Rparen + ~f:parse_typ_expr_region p in Parser.expect Rparen p; let attrs = [] in - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in match args with | [({ptyp_desc = Ptyp_tuple _} as typ)] as types -> if p.mode = ParseForTypeChecker then typ @@ -5386,24 +5452,24 @@ and parsePolymorphicVariantTypeArgs p = | [typ] -> typ | types -> Ast_helper.Typ.tuple ~loc ~attrs types -and parseTypeEquationAndRepresentation p = +and parse_type_equation_and_representation p = match p.Parser.token with | (Equal | Bar) as token -> ( if token = Bar then Parser.expect Equal p; Parser.next p; match p.Parser.token with - | Uident _ -> parseTypeEquationOrConstrDecl p - | Lbrace -> parseRecordOrObjectDecl p - | Private -> parsePrivateEqOrRepr p + | Uident _ -> parse_type_equation_or_constr_decl p + | Lbrace -> parse_record_or_object_decl p + | Private -> parse_private_eq_or_repr p | Bar | DotDot -> - let priv, kind = parseTypeRepresentation p in + let priv, kind = parse_type_representation p in (None, priv, kind) | _ -> ( - let manifest = Some (parseTypExpr p) in + let manifest = Some (parse_typ_expr p) in match p.Parser.token with | Equal -> Parser.next p; - let priv, kind = parseTypeRepresentation p in + let priv, kind = parse_type_representation p in (manifest, priv, kind) | _ -> (manifest, Public, Parsetree.Ptype_abstract))) | _ -> (None, Public, Parsetree.Ptype_abstract) @@ -5412,91 +5478,91 @@ and parseTypeEquationAndRepresentation p = * typedef ::= typeconstr-name [type-params] type-information * type-information ::= [type-equation] [type-representation] { type-constraint } * type-equation ::= = typexpr *) -and parseTypeDef ~attrs ~startPos p = - Parser.leaveBreadcrumb p Grammar.TypeDef; +and parse_type_def ~attrs ~start_pos p = + Parser.leave_breadcrumb p Grammar.TypeDef; (* let attrs = match attrs with | Some attrs -> attrs | None -> parseAttributes p in *) - Parser.leaveBreadcrumb p Grammar.TypeConstrName; - let name, loc = parseLident p in - let typeConstrName = Location.mkloc name loc in - Parser.eatBreadcrumb p; + Parser.leave_breadcrumb p Grammar.TypeConstrName; + let name, loc = parse_lident p in + let type_constr_name = Location.mkloc name loc in + Parser.eat_breadcrumb p; let params = - let constrName = Location.mkloc (Longident.Lident name) loc in - parseTypeParams ~parent:constrName p + let constr_name = Location.mkloc (Longident.Lident name) loc in + parse_type_params ~parent:constr_name p in - let typeDef = - let manifest, priv, kind = parseTypeEquationAndRepresentation p in - let cstrs = parseTypeConstraints p in - let loc = mkLoc startPos p.prevEndPos in + let type_def = + let manifest, priv, kind = parse_type_equation_and_representation p in + let cstrs = parse_type_constraints p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest - typeConstrName + type_constr_name in - Parser.eatBreadcrumb p; - typeDef + Parser.eat_breadcrumb p; + type_def -and parseTypeExtension ~params ~attrs ~name p = +and parse_type_extension ~params ~attrs ~name p = Parser.expect PlusEqual p; let priv = if Parser.optional p Token.Private then Asttypes.Private else Asttypes.Public in - let constrStart = p.Parser.startPos in + let constr_start = p.Parser.start_pos in Parser.optional p Bar |> ignore; let first = let attrs, name, kind = match p.Parser.token with | Bar -> Parser.next p; - parseConstrDef ~parseAttrs:true p - | _ -> parseConstrDef ~parseAttrs:true p + parse_constr_def ~parse_attrs:true p + | _ -> parse_constr_def ~parse_attrs:true p in - let loc = mkLoc constrStart p.prevEndPos in + let loc = mk_loc constr_start p.prev_end_pos in Ast_helper.Te.constructor ~loc ~attrs name kind in let rec loop p cs = match p.Parser.token with | Bar -> - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in Parser.next p; - let attrs, name, kind = parseConstrDef ~parseAttrs:true p in - let extConstr = + let attrs, name, kind = parse_constr_def ~parse_attrs:true p in + let ext_constr = Ast_helper.Te.constructor ~attrs - ~loc:(mkLoc startPos p.prevEndPos) + ~loc:(mk_loc start_pos p.prev_end_pos) name kind in - loop p (extConstr :: cs) + loop p (ext_constr :: cs) | _ -> List.rev cs in let constructors = loop p [first] in Ast_helper.Te.mk ~attrs ~params ~priv name constructors -and parseTypeDefinitions ~attrs ~name ~params ~startPos p = - let typeDef = - let manifest, priv, kind = parseTypeEquationAndRepresentation p in - let cstrs = parseTypeConstraints p in - let loc = mkLoc startPos p.prevEndPos in +and parse_type_definitions ~attrs ~name ~params ~start_pos p = + let type_def = + let manifest, priv, kind = parse_type_equation_and_representation p in + let cstrs = parse_type_constraints p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest - {name with txt = lidentOfPath name.Location.txt} + {name with txt = lident_of_path name.Location.txt} in let rec loop p defs = - let startPos = p.Parser.startPos in - let attrs = parseAttributesAndBinding p in + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes_and_binding p in match p.Parser.token with | And -> Parser.next p; - let typeDef = parseTypeDef ~attrs ~startPos p in - loop p (typeDef :: defs) + let type_def = parse_type_def ~attrs ~start_pos p in + loop p (type_def :: defs) | _ -> List.rev defs in - loop p [typeDef] + loop p [type_def] (* TODO: decide if we really want type extensions (eg. type x += Blue) * It adds quite a bit of complexity that can be avoided, * implemented for now. Needed to get a feel for the complexities of * this territory of the grammar *) -and parseTypeDefinitionOrExtension ~attrs p = - let startPos = p.Parser.startPos in +and parse_type_definition_or_extension ~attrs p = + let start_pos = p.Parser.start_pos in Parser.expect Token.Typ p; - let recFlag = + let rec_flag = match p.token with | Rec -> Parser.next p; @@ -5506,35 +5572,35 @@ and parseTypeDefinitionOrExtension ~attrs p = Asttypes.Nonrecursive | _ -> Asttypes.Nonrecursive in - let name = parseValuePath p in - let params = parseTypeParams ~parent:name p in + let name = parse_value_path p in + let params = parse_type_params ~parent:name p in match p.Parser.token with - | PlusEqual -> TypeExt (parseTypeExtension ~params ~attrs ~name p) + | PlusEqual -> TypeExt (parse_type_extension ~params ~attrs ~name p) | _ -> (* shape of type name should be Lident, i.e. `t` is accepted. `User.t` not *) let () = match name.Location.txt with | Lident _ -> () | longident -> - Parser.err ~startPos:name.loc.loc_start ~endPos:name.loc.loc_end p - (longident |> ErrorMessages.typeDeclarationNameLongident + Parser.err ~start_pos:name.loc.loc_start ~end_pos:name.loc.loc_end p + (longident |> ErrorMessages.type_declaration_name_longident |> Diagnostics.message) in - let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in - TypeDef {recFlag; types = typeDefs} + let type_defs = parse_type_definitions ~attrs ~name ~params ~start_pos p in + TypeDef {rec_flag; types = type_defs} (* external value-name : typexp = external-declaration *) -and parseExternalDef ~attrs ~startPos p = - let inExternal = !InExternal.status in +and parse_external_def ~attrs ~start_pos p = + let in_external = !InExternal.status in InExternal.status := true; - Parser.leaveBreadcrumb p Grammar.External; + Parser.leave_breadcrumb p Grammar.External; Parser.expect Token.External p; - let name, loc = parseLident p in + let name, loc = parse_lident p in let name = Location.mkloc name loc in Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typExpr = parseTypExpr p in - let equalStart = p.startPos in - let equalEnd = p.endPos in + let typ_expr = parse_typ_expr p in + let equal_start = p.start_pos in + let equal_end = p.end_pos in Parser.expect Equal p; let prim = match p.token with @@ -5542,16 +5608,16 @@ and parseExternalDef ~attrs ~startPos p = Parser.next p; [s] | _ -> - Parser.err ~startPos:equalStart ~endPos:equalEnd p + Parser.err ~start_pos:equal_start ~end_pos:equal_end p (Diagnostics.message ("An external requires the name of the JS value you're referring \ to, like \"" ^ name.txt ^ "\".")); [] in - let loc = mkLoc startPos p.prevEndPos in - let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typExpr in - Parser.eatBreadcrumb p; - InExternal.status := inExternal; + let loc = mk_loc start_pos p.prev_end_pos in + let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typ_expr in + Parser.eat_breadcrumb p; + InExternal.status := in_external; vb (* constr-def ::= @@ -5561,12 +5627,12 @@ and parseExternalDef ~attrs ~startPos p = * constr-decl ::= constr-name constr-args * constr-name ::= uident * constr ::= path-uident *) -and parseConstrDef ~parseAttrs p = - let attrs = if parseAttrs then parseAttributes p else [] in +and parse_constr_def ~parse_attrs p = + let attrs = if parse_attrs then parse_attributes p else [] in let name = match p.Parser.token with | Uident name -> - let loc = mkLoc p.startPos p.endPos in + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; Location.mkloc name loc | t -> @@ -5576,15 +5642,15 @@ and parseConstrDef ~parseAttrs p = let kind = match p.Parser.token with | Lparen -> - let args, res = parseConstrDeclArgs p in + let args, res = parse_constr_decl_args p in Parsetree.Pext_decl (args, res) | Equal -> Parser.next p; - let longident = parseModuleLongIdent ~lowercase:false p in + let longident = parse_module_long_ident ~lowercase:false p in Parsetree.Pext_rebind longident | Colon -> Parser.next p; - let typ = parseTypExpr p in + let typ = parse_typ_expr p in Parsetree.Pext_decl (Pcstr_tuple [], Some typ) | _ -> Parsetree.Pext_decl (Pcstr_tuple [], None) in @@ -5597,74 +5663,76 @@ and parseConstrDef ~parseAttrs p = * * constr-name ::= uident * constr ::= long_uident *) -and parseExceptionDef ~attrs p = - let startPos = p.Parser.startPos in +and parse_exception_def ~attrs p = + let start_pos = p.Parser.start_pos in Parser.expect Token.Exception p; - let _, name, kind = parseConstrDef ~parseAttrs:false p in - let loc = mkLoc startPos p.prevEndPos in + let _, name, kind = parse_constr_def ~parse_attrs:false p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Te.constructor ~loc ~attrs name kind -and parseNewlineOrSemicolonStructure p = +and parse_newline_or_semicolon_structure p = match p.Parser.token with | Semicolon -> Parser.next p - | token when Grammar.isStructureItemStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + | token when Grammar.is_structure_item_start token -> + if p.prev_end_pos.pos_lnum < p.start_pos.pos_lnum then () else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + Parser.err ~start_pos:p.prev_end_pos ~end_pos:p.end_pos p (Diagnostics.message "consecutive statements on a line must be separated by ';' or a \ newline") | _ -> () -and parseStructureItemRegion p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in +and parse_structure_item_region p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in match p.Parser.token with | Open -> - let openDescription = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.open_ ~loc openDescription) + let open_description = parse_open_description ~attrs p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.open_ ~loc open_description) | Let -> - let recFlag, letBindings = parseLetBindings ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.value ~loc recFlag letBindings) + let rec_flag, let_bindings = parse_let_bindings ~attrs ~start_pos p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.value ~loc rec_flag let_bindings) | Typ -> ( - Parser.beginRegion p; - match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Str.type_ ~loc recFlag types) + Parser.begin_region p; + match parse_type_definition_or_extension ~attrs p with + | TypeDef {rec_flag; types} -> + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Str.type_ ~loc rec_flag types) | TypeExt ext -> - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; Some (Ast_helper.Str.type_extension ~loc ext)) | External -> - let externalDef = parseExternalDef ~attrs ~startPos p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.primitive ~loc externalDef) + let external_def = parse_external_def ~attrs ~start_pos p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.primitive ~loc external_def) | Exception -> - let exceptionDef = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.exception_ ~loc exceptionDef) + let exception_def = parse_exception_def ~attrs p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.exception_ ~loc exception_def) | Include -> - let includeStatement = parseIncludeStatement ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.include_ ~loc includeStatement) + let include_statement = parse_include_statement ~attrs p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.include_ ~loc include_statement) | Module -> - Parser.beginRegion p; - let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some {structureItem with pstr_loc = loc} + Parser.begin_region p; + let structure_item = + parse_module_or_module_type_impl_or_pack_expr ~attrs p + in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some {structure_item with pstr_loc = loc} | ModuleComment (loc, s) -> Parser.next p; Some @@ -5676,105 +5744,108 @@ and parseStructureItemRegion p = (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); ] )) | AtAt -> - let attr = parseStandaloneAttribute p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in + let attr = parse_standalone_attribute p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in Some (Ast_helper.Str.attribute ~loc attr) | PercentPercent -> - let extension = parseExtension ~moduleLanguage:true p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in + let extension = parse_extension ~module_language:true p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in Some (Ast_helper.Str.extension ~attrs ~loc extension) - | token when Grammar.isExprStart token -> - let prevEndPos = p.Parser.endPos in - let exp = parseExpr p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.checkProgress ~prevEndPos + | token when Grammar.is_expr_start token -> + let prev_end_pos = p.Parser.end_pos in + let exp = parse_expr p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.check_progress ~prev_end_pos ~result:(Ast_helper.Str.eval ~loc ~attrs exp) p | _ -> ( match attrs with - | (({Asttypes.loc = attrLoc}, _) as attr) :: _ -> - Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p - (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); - let expr = parseExpr p in + | (({Asttypes.loc = attr_loc}, _) as attr) :: _ -> + Parser.err ~start_pos:attr_loc.loc_start ~end_pos:attr_loc.loc_end p + (Diagnostics.message (ErrorMessages.attribute_without_node attr)); + let expr = parse_expr p in Some - (Ast_helper.Str.eval ~loc:(mkLoc p.startPos p.prevEndPos) ~attrs expr) + (Ast_helper.Str.eval + ~loc:(mk_loc p.start_pos p.prev_end_pos) + ~attrs expr) | _ -> None) -[@@progress Parser.next, Parser.expect, LoopProgress.listRest] +[@@progress Parser.next, Parser.expect, LoopProgress.list_rest] (* include-statement ::= include module-expr *) -and parseIncludeStatement ~attrs p = - let startPos = p.Parser.startPos in +and parse_include_statement ~attrs p = + let start_pos = p.Parser.start_pos in Parser.expect Token.Include p; - let modExpr = parseModuleExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Incl.mk ~loc ~attrs modExpr + let mod_expr = parse_module_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Incl.mk ~loc ~attrs mod_expr -and parseAtomicModuleExpr p = - let startPos = p.Parser.startPos in +and parse_atomic_module_expr p = + let start_pos = p.Parser.start_pos in match p.Parser.token with | Uident _ident -> - let longident = parseModuleLongIdent ~lowercase:false p in + let longident = parse_module_long_ident ~lowercase:false p in Ast_helper.Mod.ident ~loc:longident.loc longident | Lbrace -> Parser.next p; let structure = Ast_helper.Mod.structure - (parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rbrace - ~f:parseStructureItemRegion p) + (parse_delimited_region ~grammar:Grammar.Structure ~closing:Rbrace + ~f:parse_structure_item_region p) in Parser.expect Rbrace p; - let endPos = p.prevEndPos in - {structure with pmod_loc = mkLoc startPos endPos} + let end_pos = p.prev_end_pos in + {structure with pmod_loc = mk_loc start_pos end_pos} | Lparen -> Parser.next p; - let modExpr = + let mod_expr = match p.token with - | Rparen -> Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) [] - | _ -> parseConstrainedModExpr p + | Rparen -> + Ast_helper.Mod.structure ~loc:(mk_loc start_pos p.prev_end_pos) [] + | _ -> parse_constrained_mod_expr p in Parser.expect Rparen p; - modExpr + mod_expr | Lident "unpack" -> ( (* TODO: should this be made a keyword?? *) Parser.next p; Parser.expect Lparen p; - let expr = parseExpr p in + let expr = parse_expr p in match p.Parser.token with | Colon -> - let colonStart = p.Parser.startPos in + let colon_start = p.Parser.start_pos in Parser.next p; - let attrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs p in + let attrs = parse_attributes p in + let package_type = parse_package_type ~start_pos:colon_start ~attrs p in Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - let constraintExpr = Ast_helper.Exp.constraint_ ~loc expr packageType in - Ast_helper.Mod.unpack ~loc constraintExpr + let loc = mk_loc start_pos p.prev_end_pos in + let constraint_expr = Ast_helper.Exp.constraint_ ~loc expr package_type in + Ast_helper.Mod.unpack ~loc constraint_expr | _ -> Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Mod.unpack ~loc expr) | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in + let extension = parse_extension p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Mod.extension ~loc extension | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleExpr () + Recover.default_module_expr () -and parsePrimaryModExpr p = - let startPos = p.Parser.startPos in - let modExpr = parseAtomicModuleExpr p in - let rec loop p modExpr = +and parse_primary_mod_expr p = + let start_pos = p.Parser.start_pos in + let mod_expr = parse_atomic_module_expr p in + let rec loop p mod_expr = match p.Parser.token with - | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - loop p (parseModuleApplication p modExpr) - | _ -> modExpr + | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + loop p (parse_module_application p mod_expr) + | _ -> mod_expr in - let modExpr = loop p modExpr in - {modExpr with pmod_loc = mkLoc startPos p.prevEndPos} + let mod_expr = loop p mod_expr in + {mod_expr with pmod_loc = mk_loc start_pos p.prev_end_pos} (* * functor-arg ::= @@ -5783,93 +5854,96 @@ and parsePrimaryModExpr p = * | modtype --> "punning" for _ : modtype * | attributes functor-arg *) -and parseFunctorArg p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in +and parse_functor_arg p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in match p.Parser.token with | Uident ident -> ( Parser.next p; - let uidentEndPos = p.prevEndPos in + let uident_end_pos = p.prev_end_pos in match p.Parser.token with | Colon -> Parser.next p; - let moduleType = parseModuleType p in - let loc = mkLoc startPos uidentEndPos in - let argName = Location.mkloc ident loc in - Some (attrs, argName, Some moduleType, startPos) + let module_type = parse_module_type p in + let loc = mk_loc start_pos uident_end_pos in + let arg_name = Location.mkloc ident loc in + Some (attrs, arg_name, Some module_type, start_pos) | Dot -> Parser.next p; - let moduleType = - let moduleLongIdent = - parseModuleLongIdentTail ~lowercase:false p startPos + let module_type = + let module_long_ident = + parse_module_long_ident_tail ~lowercase:false p start_pos (Longident.Lident ident) in - Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent + Ast_helper.Mty.ident ~loc:module_long_ident.loc module_long_ident in - let argName = Location.mknoloc "_" in - Some (attrs, argName, Some moduleType, startPos) + let arg_name = Location.mknoloc "_" in + Some (attrs, arg_name, Some module_type, start_pos) | _ -> - let loc = mkLoc startPos uidentEndPos in - let modIdent = Location.mkloc (Longident.Lident ident) loc in - let moduleType = Ast_helper.Mty.ident ~loc modIdent in - let argName = Location.mknoloc "_" in - Some (attrs, argName, Some moduleType, startPos)) + let loc = mk_loc start_pos uident_end_pos in + let mod_ident = Location.mkloc (Longident.Lident ident) loc in + let module_type = Ast_helper.Mty.ident ~loc mod_ident in + let arg_name = Location.mknoloc "_" in + Some (attrs, arg_name, Some module_type, start_pos)) | Underscore -> Parser.next p; - let argName = Location.mkloc "_" (mkLoc startPos p.prevEndPos) in + let arg_name = Location.mkloc "_" (mk_loc start_pos p.prev_end_pos) in Parser.expect Colon p; - let moduleType = parseModuleType p in - Some (attrs, argName, Some moduleType, startPos) + let module_type = parse_module_type p in + Some (attrs, arg_name, Some module_type, start_pos) | Lparen -> Parser.next p; Parser.expect Rparen p; - let argName = Location.mkloc "*" (mkLoc startPos p.prevEndPos) in - Some (attrs, argName, None, startPos) + let arg_name = Location.mkloc "*" (mk_loc start_pos p.prev_end_pos) in + Some (attrs, arg_name, None, start_pos) | _ -> None -and parseFunctorArgs p = - let startPos = p.Parser.startPos in +and parse_functor_args p = + let start_pos = p.Parser.start_pos in Parser.expect Lparen p; let args = - parseCommaDelimitedRegion ~grammar:Grammar.FunctorArgs ~closing:Rparen - ~f:parseFunctorArg p + parse_comma_delimited_region ~grammar:Grammar.FunctorArgs ~closing:Rparen + ~f:parse_functor_arg p in Parser.expect Rparen p; match args with | [] -> - [([], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos)] + [ + ([], Location.mkloc "*" (mk_loc start_pos p.prev_end_pos), None, start_pos); + ] | args -> args -and parseFunctorModuleExpr p = - let startPos = p.Parser.startPos in - let args = parseFunctorArgs p in - let returnType = +and parse_functor_module_expr p = + let start_pos = p.Parser.start_pos in + let args = parse_functor_args p in + let return_type = match p.Parser.token with | Colon -> Parser.next p; - Some (parseModuleType ~es6Arrow:false p) + Some (parse_module_type ~es6_arrow:false p) | _ -> None in Parser.expect EqualGreater p; - let rhsModuleExpr = - let modExpr = parseModuleExpr p in - match returnType with - | Some modType -> + let rhs_module_expr = + let mod_expr = parse_module_expr p in + match return_type with + | Some mod_type -> Ast_helper.Mod.constraint_ ~loc: - (mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end) - modExpr modType - | None -> modExpr + (mk_loc mod_expr.pmod_loc.loc_start + mod_type.Parsetree.pmty_loc.loc_end) + mod_expr mod_type + | None -> mod_expr in - let endPos = p.prevEndPos in - let modExpr = + let end_pos = p.prev_end_pos in + let mod_expr = List.fold_right - (fun (attrs, name, moduleType, startPos) acc -> - Ast_helper.Mod.functor_ ~loc:(mkLoc startPos endPos) ~attrs name - moduleType acc) - args rhsModuleExpr + (fun (attrs, name, module_type, start_pos) acc -> + Ast_helper.Mod.functor_ ~loc:(mk_loc start_pos end_pos) ~attrs name + module_type acc) + args rhs_module_expr in - {modExpr with pmod_loc = mkLoc startPos endPos} + {mod_expr with pmod_loc = mk_loc start_pos end_pos} (* module-expr ::= * | module-path @@ -5880,229 +5954,233 @@ and parseFunctorModuleExpr p = * ∣ ( module-expr : module-type ) * | extension * | attributes module-expr *) -and parseModuleExpr p = - let hasAwait, loc_await = - let startPos = p.startPos in +and parse_module_expr p = + let has_await, loc_await = + let start_pos = p.start_pos in match p.Parser.token with | Await -> Parser.expect Await p; - let endPos = p.endPos in - (true, mkLoc startPos endPos) - | _ -> (false, mkLoc startPos startPos) + let end_pos = p.end_pos in + (true, mk_loc start_pos end_pos) + | _ -> (false, mk_loc start_pos start_pos) in - let attrs = parseAttributes p in + let attrs = parse_attributes p in let attrs = - if hasAwait then + if has_await then (({txt = "res.await"; loc = loc_await}, PStr []) : Parsetree.attribute) :: attrs else attrs in - let modExpr = - if isEs6ArrowFunctor p then parseFunctorModuleExpr p - else parsePrimaryModExpr p + let mod_expr = + if is_es6_arrow_functor p then parse_functor_module_expr p + else parse_primary_mod_expr p in - {modExpr with pmod_attributes = List.concat [modExpr.pmod_attributes; attrs]} + { + mod_expr with + pmod_attributes = List.concat [mod_expr.pmod_attributes; attrs]; + } -and parseConstrainedModExpr p = - let modExpr = parseModuleExpr p in +and parse_constrained_mod_expr p = + let mod_expr = parse_module_expr p in match p.Parser.token with | Colon -> Parser.next p; - let modType = parseModuleType p in - let loc = mkLoc modExpr.pmod_loc.loc_start modType.pmty_loc.loc_end in - Ast_helper.Mod.constraint_ ~loc modExpr modType - | _ -> modExpr - -and parseConstrainedModExprRegion p = - if Grammar.isModExprStart p.Parser.token then Some (parseConstrainedModExpr p) + let mod_type = parse_module_type p in + let loc = mk_loc mod_expr.pmod_loc.loc_start mod_type.pmty_loc.loc_end in + Ast_helper.Mod.constraint_ ~loc mod_expr mod_type + | _ -> mod_expr + +and parse_constrained_mod_expr_region p = + if Grammar.is_mod_expr_start p.Parser.token then + Some (parse_constrained_mod_expr p) else None -and parseModuleApplication p modExpr = - let startPos = p.Parser.startPos in +and parse_module_application p mod_expr = + let start_pos = p.Parser.start_pos in Parser.expect Lparen p; let args = - parseCommaDelimitedRegion ~grammar:Grammar.ModExprList ~closing:Rparen - ~f:parseConstrainedModExprRegion p + parse_comma_delimited_region ~grammar:Grammar.ModExprList ~closing:Rparen + ~f:parse_constrained_mod_expr_region p in Parser.expect Rparen p; let args = match args with | [] -> - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in [Ast_helper.Mod.structure ~loc []] | args -> args in List.fold_left - (fun modExpr arg -> + (fun mod_expr arg -> Ast_helper.Mod.apply ~loc: - (mkLoc modExpr.Parsetree.pmod_loc.loc_start + (mk_loc mod_expr.Parsetree.pmod_loc.loc_start arg.Parsetree.pmod_loc.loc_end) - modExpr arg) - modExpr args + mod_expr arg) + mod_expr args -and parseModuleOrModuleTypeImplOrPackExpr ~attrs p = - let startPos = p.Parser.startPos in +and parse_module_or_module_type_impl_or_pack_expr ~attrs p = + let start_pos = p.Parser.start_pos in Parser.expect Module p; match p.Parser.token with - | Typ -> parseModuleTypeImpl ~attrs startPos p + | Typ -> parse_module_type_impl ~attrs start_pos p | Lparen -> - let expr = parseFirstClassModuleExpr ~startPos p in - let a = parsePrimaryExpr ~operand:expr p in - let expr = parseBinaryExpr ~a p 1 in - let expr = parseTernaryExpr expr p in + let expr = parse_first_class_module_expr ~start_pos p in + let a = parse_primary_expr ~operand:expr p in + let expr = parse_binary_expr ~a p 1 in + let expr = parse_ternary_expr expr p in Ast_helper.Str.eval ~attrs expr - | _ -> parseMaybeRecModuleBinding ~attrs ~startPos p + | _ -> parse_maybe_rec_module_binding ~attrs ~start_pos p -and parseModuleTypeImpl ~attrs startPos p = +and parse_module_type_impl ~attrs start_pos p = Parser.expect Typ p; - let nameStart = p.Parser.startPos in + let name_start = p.Parser.start_pos in let name = match p.Parser.token with | Lident ident -> Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in + let loc = mk_loc name_start p.prev_end_pos in Location.mkloc ident loc | Uident ident -> Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in + let loc = mk_loc name_start p.prev_end_pos in Location.mkloc ident loc | t -> Parser.err p (Diagnostics.uident t); Location.mknoloc "_" in Parser.expect Equal p; - let moduleType = parseModuleType p in - let moduleTypeDeclaration = + let module_type = parse_module_type p in + let module_type_declaration = Ast_helper.Mtd.mk ~attrs - ~loc:(mkLoc nameStart p.prevEndPos) - ~typ:moduleType name + ~loc:(mk_loc name_start p.prev_end_pos) + ~typ:module_type name in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Str.modtype ~loc moduleTypeDeclaration + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Str.modtype ~loc module_type_declaration (* definition ::= ∣ module rec module-name : module-type = module-expr { and module-name : module-type = module-expr } *) -and parseMaybeRecModuleBinding ~attrs ~startPos p = +and parse_maybe_rec_module_binding ~attrs ~start_pos p = match p.Parser.token with | Token.Rec -> Parser.next p; - Ast_helper.Str.rec_module (parseModuleBindings ~startPos ~attrs p) + Ast_helper.Str.rec_module (parse_module_bindings ~start_pos ~attrs p) | _ -> Ast_helper.Str.module_ - (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p) + (parse_module_binding ~attrs ~start_pos:p.Parser.start_pos p) -and parseModuleBinding ~attrs ~startPos p = +and parse_module_binding ~attrs ~start_pos p = let name = match p.Parser.token with | Uident ident -> - let startPos = p.Parser.startPos in + let start_pos = p.Parser.start_pos in Parser.next p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Location.mkloc ident loc | t -> Parser.err p (Diagnostics.uident t); Location.mknoloc "_" in - let body = parseModuleBindingBody p in - let loc = mkLoc startPos p.prevEndPos in + let body = parse_module_binding_body p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Mb.mk ~attrs ~loc name body -and parseModuleBindingBody p = +and parse_module_binding_body p = (* TODO: make required with good error message when rec module binding *) - let returnModType = + let return_mod_type = match p.Parser.token with | Colon -> Parser.next p; - Some (parseModuleType p) + Some (parse_module_type p) | _ -> None in Parser.expect Equal p; - let modExpr = parseModuleExpr p in - match returnModType with - | Some modType -> + let mod_expr = parse_module_expr p in + match return_mod_type with + | Some mod_type -> Ast_helper.Mod.constraint_ - ~loc:(mkLoc modType.pmty_loc.loc_start modExpr.pmod_loc.loc_end) - modExpr modType - | None -> modExpr + ~loc:(mk_loc mod_type.pmty_loc.loc_start mod_expr.pmod_loc.loc_end) + mod_expr mod_type + | None -> mod_expr (* module-name : module-type = module-expr * { and module-name : module-type = module-expr } *) -and parseModuleBindings ~attrs ~startPos p = +and parse_module_bindings ~attrs ~start_pos p = let rec loop p acc = - let startPos = p.Parser.startPos in - let docAttr : Parsetree.attributes = + let start_pos = p.Parser.start_pos in + let doc_attr : Parsetree.attributes = match p.Parser.token with | DocComment (loc, s) -> Parser.next p; - [docCommentToAttribute loc s] + [doc_comment_to_attribute loc s] | _ -> [] in - let attrs = docAttr @ parseAttributesAndBinding p in + let attrs = doc_attr @ parse_attributes_and_binding p in match p.Parser.token with | And -> Parser.next p; ignore (Parser.optional p Module); (* over-parse for fault-tolerance *) - let modBinding = parseModuleBinding ~attrs ~startPos p in - loop p (modBinding :: acc) + let mod_binding = parse_module_binding ~attrs ~start_pos p in + loop p (mod_binding :: acc) | _ -> List.rev acc in - let first = parseModuleBinding ~attrs ~startPos p in + let first = parse_module_binding ~attrs ~start_pos p in loop p [first] -and parseAtomicModuleType p = - let startPos = p.Parser.startPos in - let moduleType = +and parse_atomic_module_type p = + let start_pos = p.Parser.start_pos in + let module_type = match p.Parser.token with | Uident _ | Lident _ -> (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } * lets go with uppercase terminal for now *) - let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in - Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent + let module_long_ident = parse_module_long_ident ~lowercase:true p in + Ast_helper.Mty.ident ~loc:module_long_ident.loc module_long_ident | Lparen -> Parser.next p; - let mty = parseModuleType p in + let mty = parse_module_type p in Parser.expect Rparen p; - {mty with pmty_loc = mkLoc startPos p.prevEndPos} + {mty with pmty_loc = mk_loc start_pos p.prev_end_pos} | Lbrace -> Parser.next p; let spec = - parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rbrace - ~f:parseSignatureItemRegion p + parse_delimited_region ~grammar:Grammar.Signature ~closing:Rbrace + ~f:parse_signature_item_region p in Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Mty.signature ~loc spec | Module -> (* TODO: check if this is still atomic when implementing first class modules*) - parseModuleTypeOf p + parse_module_type_of p | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in + let extension = parse_extension p in + let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Mty.extension ~loc extension | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType () + Recover.default_module_type () in - let moduleTypeLoc = mkLoc startPos p.prevEndPos in - {moduleType with pmty_loc = moduleTypeLoc} + let module_type_loc = mk_loc start_pos p.prev_end_pos in + {module_type with pmty_loc = module_type_loc} -and parseFunctorModuleType p = - let startPos = p.Parser.startPos in - let args = parseFunctorArgs p in +and parse_functor_module_type p = + let start_pos = p.Parser.start_pos in + let args = parse_functor_args p in Parser.expect EqualGreater p; - let rhs = parseModuleType p in - let endPos = p.prevEndPos in - let modType = + let rhs = parse_module_type p in + let end_pos = p.prev_end_pos in + let mod_type = List.fold_right - (fun (attrs, name, moduleType, startPos) acc -> - Ast_helper.Mty.functor_ ~loc:(mkLoc startPos endPos) ~attrs name - moduleType acc) + (fun (attrs, name, module_type, start_pos) acc -> + Ast_helper.Mty.functor_ ~loc:(mk_loc start_pos end_pos) ~attrs name + module_type acc) args rhs in - {modType with pmty_loc = mkLoc startPos endPos} + {mod_type with pmty_loc = mk_loc start_pos end_pos} (* Module types are the module-level equivalent of type expressions: they * specify the general shape and type properties of modules. @@ -6118,42 +6196,42 @@ and parseFunctorModuleType p = * | module-type with-mod-constraints * | extension *) -and parseModuleType ?(es6Arrow = true) ?(with_ = true) p = - let attrs = parseAttributes p in +and parse_module_type ?(es6_arrow = true) ?(with_ = true) p = + let attrs = parse_attributes p in let modty = - if es6Arrow && isEs6ArrowFunctor p then parseFunctorModuleType p + if es6_arrow && is_es6_arrow_functor p then parse_functor_module_type p else - let modty = parseAtomicModuleType p in + let modty = parse_atomic_module_type p in match p.Parser.token with - | EqualGreater when es6Arrow == true -> + | EqualGreater when es6_arrow == true -> Parser.next p; - let rhs = parseModuleType ~with_:false p in + let rhs = parse_module_type ~with_:false p in let str = Location.mknoloc "_" in - let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in + let loc = mk_loc modty.pmty_loc.loc_start p.prev_end_pos in Ast_helper.Mty.functor_ ~loc str (Some modty) rhs | _ -> modty in - let moduleType = + let module_type = {modty with pmty_attributes = List.concat [modty.pmty_attributes; attrs]} in - if with_ then parseWithConstraints moduleType p else moduleType + if with_ then parse_with_constraints module_type p else module_type -and parseWithConstraints moduleType p = +and parse_with_constraints module_type p = match p.Parser.token with | Lident "with" -> Parser.next p; - let first = parseWithConstraint p in + let first = parse_with_constraint p in let rec loop p acc = match p.Parser.token with | And -> Parser.next p; - loop p (parseWithConstraint p :: acc) + loop p (parse_with_constraint p :: acc) | _ -> List.rev acc in let constraints = loop p [first] in - let loc = mkLoc moduleType.pmty_loc.loc_start p.prevEndPos in - Ast_helper.Mty.with_ ~loc moduleType constraints - | _ -> moduleType + let loc = mk_loc module_type.pmty_loc.loc_start p.prev_end_pos in + Ast_helper.Mty.with_ ~loc module_type constraints + | _ -> module_type (* mod-constraint ::= * | type typeconstr type-equation type-constraints? @@ -6162,162 +6240,164 @@ and parseWithConstraints moduleType p = * ∣ module module-path := extended-module-path * * TODO: split this up into multiple functions, better errors *) -and parseWithConstraint p = +and parse_with_constraint p = match p.Parser.token with | Module -> ( Parser.next p; - let modulePath = parseModuleLongIdent ~lowercase:false p in + let module_path = parse_module_long_ident ~lowercase:false p in match p.Parser.token with | ColonEqual -> Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_modsubst (modulePath, lident) + let lident = parse_module_long_ident ~lowercase:false p in + Parsetree.Pwith_modsubst (module_path, lident) | Equal -> Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_module (modulePath, lident) + let lident = parse_module_long_ident ~lowercase:false p in + Parsetree.Pwith_module (module_path, lident) | token -> (* TODO: revisit *) Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_modsubst (modulePath, lident)) + let lident = parse_module_long_ident ~lowercase:false p in + Parsetree.Pwith_modsubst (module_path, lident)) | Typ -> ( Parser.next p; - let typeConstr = parseValuePath p in - let params = parseTypeParams ~parent:typeConstr p in + let type_constr = parse_value_path p in + let params = parse_type_params ~parent:type_constr p in match p.Parser.token with | ColonEqual -> Parser.next p; - let typExpr = parseTypExpr p in + let typ_expr = parse_typ_expr p in Parsetree.Pwith_typesubst - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) ) + ( type_constr, + Ast_helper.Type.mk ~loc:type_constr.loc ~params ~manifest:typ_expr + (Location.mkloc (Longident.last type_constr.txt) type_constr.loc) ) | Equal -> Parser.next p; - let typExpr = parseTypExpr p in - let typeConstraints = parseTypeConstraints p in + let typ_expr = parse_typ_expr p in + let type_constraints = parse_type_constraints p in Parsetree.Pwith_type - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) ) + ( type_constr, + Ast_helper.Type.mk ~loc:type_constr.loc ~params ~manifest:typ_expr + ~cstrs:type_constraints + (Location.mkloc (Longident.last type_constr.txt) type_constr.loc) ) | token -> (* TODO: revisit *) Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let typExpr = parseTypExpr p in - let typeConstraints = parseTypeConstraints p in + let typ_expr = parse_typ_expr p in + let type_constraints = parse_type_constraints p in Parsetree.Pwith_type - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) )) + ( type_constr, + Ast_helper.Type.mk ~loc:type_constr.loc ~params ~manifest:typ_expr + ~cstrs:type_constraints + (Location.mkloc (Longident.last type_constr.txt) type_constr.loc) )) | token -> (* TODO: implement recovery strategy *) Parser.err p (Diagnostics.unexpected token p.breadcrumbs); Parsetree.Pwith_type ( Location.mknoloc (Longident.Lident ""), - Ast_helper.Type.mk ~params:[] ~manifest:(Recover.defaultType ()) + Ast_helper.Type.mk ~params:[] ~manifest:(Recover.default_type ()) ~cstrs:[] (Location.mknoloc "") ) -and parseModuleTypeOf p = - let startPos = p.Parser.startPos in +and parse_module_type_of p = + let start_pos = p.Parser.start_pos in Parser.expect Module p; Parser.expect Typ p; Parser.expect Of p; - let moduleExpr = parseModuleExpr p in - Ast_helper.Mty.typeof_ ~loc:(mkLoc startPos p.prevEndPos) moduleExpr + let module_expr = parse_module_expr p in + Ast_helper.Mty.typeof_ ~loc:(mk_loc start_pos p.prev_end_pos) module_expr -and parseNewlineOrSemicolonSignature p = +and parse_newline_or_semicolon_signature p = match p.Parser.token with | Semicolon -> Parser.next p - | token when Grammar.isSignatureItemStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + | token when Grammar.is_signature_item_start token -> + if p.prev_end_pos.pos_lnum < p.start_pos.pos_lnum then () else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p + Parser.err ~start_pos:p.prev_end_pos ~end_pos:p.end_pos p (Diagnostics.message "consecutive specifications on a line must be separated by ';' or a \ newline") | _ -> () -and parseSignatureItemRegion p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in +and parse_signature_item_region p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in match p.Parser.token with | Let -> - Parser.beginRegion p; - let valueDesc = parseSignLetDesc ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.value ~loc valueDesc) + Parser.begin_region p; + let value_desc = parse_sign_let_desc ~attrs p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Sig.value ~loc value_desc) | Typ -> ( - Parser.beginRegion p; - match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.type_ ~loc recFlag types) + Parser.begin_region p; + match parse_type_definition_or_extension ~attrs p with + | TypeDef {rec_flag; types} -> + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Sig.type_ ~loc rec_flag types) | TypeExt ext -> - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; Some (Ast_helper.Sig.type_extension ~loc ext)) | External -> - let externalDef = parseExternalDef ~attrs ~startPos p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.value ~loc externalDef) + let external_def = parse_external_def ~attrs ~start_pos p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Sig.value ~loc external_def) | Exception -> - let exceptionDef = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.exception_ ~loc exceptionDef) + let exception_def = parse_exception_def ~attrs p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Sig.exception_ ~loc exception_def) | Open -> - let openDescription = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.open_ ~loc openDescription) + let open_description = parse_open_description ~attrs p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Sig.open_ ~loc open_description) | Include -> Parser.next p; - let moduleType = parseModuleType p in - let includeDescription = - Ast_helper.Incl.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs moduleType + let module_type = parse_module_type p in + let include_description = + Ast_helper.Incl.mk + ~loc:(mk_loc start_pos p.prev_end_pos) + ~attrs module_type in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.include_ ~loc includeDescription) + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Sig.include_ ~loc include_description) | Module -> ( - Parser.beginRegion p; + Parser.begin_region p; Parser.next p; match p.Parser.token with | Uident _ -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.module_ ~loc modDecl) + let mod_decl = parse_module_declaration_or_alias ~attrs p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Sig.module_ ~loc mod_decl) | Rec -> - let recModule = parseRecModuleSpec ~attrs ~startPos p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.rec_module ~loc recModule) + let rec_module = parse_rec_module_spec ~attrs ~start_pos p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Sig.rec_module ~loc rec_module) | Typ -> - let modTypeDecl = parseModuleTypeDeclaration ~attrs ~startPos p in - Parser.endRegion p; - Some modTypeDecl + let mod_type_decl = parse_module_type_declaration ~attrs ~start_pos p in + Parser.end_region p; + Some mod_type_decl | _t -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.module_ ~loc modDecl)) + let mod_decl = parse_module_declaration_or_alias ~attrs p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Sig.module_ ~loc mod_decl)) | AtAt -> - let attr = parseStandaloneAttribute p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in + let attr = parse_standalone_attribute p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in Some (Ast_helper.Sig.attribute ~loc attr) | ModuleComment (loc, s) -> Parser.next p; @@ -6330,25 +6410,25 @@ and parseSignatureItemRegion p = (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); ] )) | PercentPercent -> - let extension = parseExtension ~moduleLanguage:true p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in + let extension = parse_extension ~module_language:true p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in Some (Ast_helper.Sig.extension ~attrs ~loc extension) | _ -> ( match attrs with - | (({Asttypes.loc = attrLoc}, _) as attr) :: _ -> - Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p - (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); - Some Recover.defaultSignatureItem + | (({Asttypes.loc = attr_loc}, _) as attr) :: _ -> + Parser.err ~start_pos:attr_loc.loc_start ~end_pos:attr_loc.loc_end p + (Diagnostics.message (ErrorMessages.attribute_without_node attr)); + Some Recover.default_signature_item | _ -> None) -[@@progress Parser.next, Parser.expect, LoopProgress.listRest] +[@@progress Parser.next, Parser.expect, LoopProgress.list_rest] (* module rec module-name : module-type { and module-name: module-type } *) -and parseRecModuleSpec ~attrs ~startPos p = +and parse_rec_module_spec ~attrs ~start_pos p = Parser.expect Rec p; let rec loop p spec = - let startPos = p.Parser.startPos in - let attrs = parseAttributesAndBinding p in + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes_and_binding p in match p.Parser.token with | And -> (* TODO: give a good error message when with constraint, no parens @@ -6358,35 +6438,35 @@ and parseRecModuleSpec ~attrs ~startPos p = * `with-constraint` *) Parser.expect And p; - let decl = parseRecModuleDeclaration ~attrs ~startPos p in + let decl = parse_rec_module_declaration ~attrs ~start_pos p in loop p (decl :: spec) | _ -> List.rev spec in - let first = parseRecModuleDeclaration ~attrs ~startPos p in + let first = parse_rec_module_declaration ~attrs ~start_pos p in loop p [first] (* module-name : module-type *) -and parseRecModuleDeclaration ~attrs ~startPos p = +and parse_rec_module_declaration ~attrs ~start_pos p = let name = match p.Parser.token with - | Uident modName -> - let loc = mkLoc p.startPos p.endPos in + | Uident mod_name -> + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; - Location.mkloc modName loc + Location.mkloc mod_name loc | t -> Parser.err p (Diagnostics.uident t); Location.mknoloc "_" in Parser.expect Colon p; - let modType = parseModuleType p in - Ast_helper.Md.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs name modType + let mod_type = parse_module_type p in + Ast_helper.Md.mk ~loc:(mk_loc start_pos p.prev_end_pos) ~attrs name mod_type -and parseModuleDeclarationOrAlias ~attrs p = - let startPos = p.Parser.startPos in - let moduleName = +and parse_module_declaration_or_alias ~attrs p = + let start_pos = p.Parser.start_pos in + let module_name = match p.Parser.token with | Uident ident -> - let loc = mkLoc p.Parser.startPos p.endPos in + let loc = mk_loc p.Parser.start_pos p.end_pos in Parser.next p; Location.mkloc ident loc | t -> @@ -6397,28 +6477,28 @@ and parseModuleDeclarationOrAlias ~attrs p = match p.Parser.token with | Colon -> Parser.next p; - parseModuleType p + parse_module_type p | Equal -> Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in + let lident = parse_module_long_ident ~lowercase:false p in Ast_helper.Mty.alias lident | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType () + Recover.default_module_type () in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Md.mk ~loc ~attrs moduleName body + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Md.mk ~loc ~attrs module_name body -and parseModuleTypeDeclaration ~attrs ~startPos p = +and parse_module_type_declaration ~attrs ~start_pos p = Parser.expect Typ p; - let moduleName = + let module_name = match p.Parser.token with | Uident ident -> - let loc = mkLoc p.startPos p.endPos in + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; Location.mkloc ident loc | Lident ident -> - let loc = mkLoc p.startPos p.endPos in + let loc = mk_loc p.start_pos p.end_pos in Parser.next p; Location.mkloc ident loc | t -> @@ -6429,26 +6509,26 @@ and parseModuleTypeDeclaration ~attrs ~startPos p = match p.Parser.token with | Equal -> Parser.next p; - Some (parseModuleType p) + Some (parse_module_type p) | _ -> None in - let moduleDecl = Ast_helper.Mtd.mk ~attrs ?typ moduleName in - Ast_helper.Sig.modtype ~loc:(mkLoc startPos p.prevEndPos) moduleDecl + let module_decl = Ast_helper.Mtd.mk ~attrs ?typ module_name in + Ast_helper.Sig.modtype ~loc:(mk_loc start_pos p.prev_end_pos) module_decl -and parseSignLetDesc ~attrs p = - let startPos = p.Parser.startPos in +and parse_sign_let_desc ~attrs p = + let start_pos = p.Parser.start_pos in Parser.optional p Let |> ignore; - let name, loc = parseLident p in + let name, loc = parse_lident p in let name = Location.mkloc name loc in Parser.expect Colon p; - let typExpr = parsePolyTypeExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Val.mk ~loc ~attrs name typExpr + let typ_expr = parse_poly_type_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Val.mk ~loc ~attrs name typ_expr (* attr-id ::= lowercase-ident ∣ capitalized-ident ∣ attr-id . attr-id *) -and parseAttributeId ~startPos p = +and parse_attribute_id ~start_pos p = let rec loop p acc = match p.Parser.token with | Lident ident | Uident ident -> ( @@ -6459,9 +6539,9 @@ and parseAttributeId ~startPos p = Parser.next p; loop p (id ^ ".") | _ -> id) - | token when Token.isKeyword token -> ( + | token when Token.is_keyword token -> ( Parser.next p; - let id = acc ^ Token.toString token in + let id = acc ^ Token.to_string token in match p.Parser.token with | Dot -> Parser.next p; @@ -6472,8 +6552,8 @@ and parseAttributeId ~startPos p = acc in let id = loop p "" in - let endPos = p.prevEndPos in - Location.mkloc id (mkLoc startPos endPos) + let end_pos = p.prev_end_pos in + Location.mkloc id (mk_loc start_pos end_pos) (* * payload ::= empty @@ -6485,62 +6565,62 @@ and parseAttributeId ~startPos p = * Also what about type-expressions and specifications? * @attr(:myType) ??? *) -and parsePayload p = +and parse_payload p = match p.Parser.token with - | Lparen when p.startPos.pos_cnum = p.prevEndPos.pos_cnum -> ( - Parser.leaveBreadcrumb p Grammar.AttributePayload; + | Lparen when p.start_pos.pos_cnum = p.prev_end_pos.pos_cnum -> ( + Parser.leave_breadcrumb p Grammar.AttributePayload; Parser.next p; match p.token with | Colon -> Parser.next p; let payload = - if Grammar.isSignatureItemStart p.token then + if Grammar.is_signature_item_start p.token then Parsetree.PSig - (parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rparen - ~f:parseSignatureItemRegion p) - else Parsetree.PTyp (parseTypExpr p) + (parse_delimited_region ~grammar:Grammar.Signature ~closing:Rparen + ~f:parse_signature_item_region p) + else Parsetree.PTyp (parse_typ_expr p) in Parser.expect Rparen p; - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; payload | Question -> Parser.next p; - let pattern = parsePattern p in + let pattern = parse_pattern p in let expr = match p.token with | When | If -> Parser.next p; - Some (parseExpr p) + Some (parse_expr p) | _ -> None in Parser.expect Rparen p; - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; Parsetree.PPat (pattern, expr) | _ -> let items = - parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rparen - ~f:parseStructureItemRegion p + parse_delimited_region ~grammar:Grammar.Structure ~closing:Rparen + ~f:parse_structure_item_region p in Parser.expect Rparen p; - Parser.eatBreadcrumb p; + Parser.eat_breadcrumb p; Parsetree.PStr items) | _ -> Parsetree.PStr [] (* type attribute = string loc * payload *) -and parseAttribute p = +and parse_attribute p = match p.Parser.token with | At -> - let startPos = p.startPos in + let start_pos = p.start_pos in Parser.next p; - let attrId = parseAttributeId ~startPos p in - let payload = parsePayload p in - Some (attrId, payload) + let attr_id = parse_attribute_id ~start_pos p in + let payload = parse_payload p in + Some (attr_id, payload) | DocComment (loc, s) -> Parser.next p; - Some (docCommentToAttribute loc s) + Some (doc_comment_to_attribute loc s) | _ -> None -and docCommentToAttribute loc s : Parsetree.attribute = +and doc_comment_to_attribute loc s : Parsetree.attribute = ( {txt = "res.doc"; loc}, PStr [ @@ -6548,30 +6628,30 @@ and docCommentToAttribute loc s : Parsetree.attribute = (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); ] ) -and parseAttributes p = - parseRegion p ~grammar:Grammar.Attribute ~f:parseAttribute +and parse_attributes p = + parse_region p ~grammar:Grammar.Attribute ~f:parse_attribute (* * standalone-attribute ::= * | @@ atribute-id * | @@ attribute-id ( structure-item ) *) -and parseStandaloneAttribute p = - let startPos = p.startPos in +and parse_standalone_attribute p = + let start_pos = p.start_pos in Parser.expect AtAt p; - let attrId = parseAttributeId ~startPos p in - let attrId = - match attrId.txt with + let attr_id = parse_attribute_id ~start_pos p in + let attr_id = + match attr_id.txt with | "uncurried.swap" -> p.uncurried_config <- Config.Swap; - attrId + attr_id | "uncurried" -> p.uncurried_config <- Config.Uncurried; - attrId - | _ -> attrId + attr_id + | _ -> attr_id in - let payload = parsePayload p in - (attrId, payload) + let payload = parse_payload p in + (attr_id, payload) (* extension ::= % attr-id attr-payload * | %% attr-id( @@ -6606,18 +6686,18 @@ and parseStandaloneAttribute p = * * ~moduleLanguage represents whether we're on the module level or not *) -and parseExtension ?(moduleLanguage = false) p = - let startPos = p.Parser.startPos in - if moduleLanguage then Parser.expect PercentPercent p +and parse_extension ?(module_language = false) p = + let start_pos = p.Parser.start_pos in + if module_language then Parser.expect PercentPercent p else Parser.expect Percent p; - let attrId = parseAttributeId ~startPos p in - let payload = parsePayload p in - (attrId, payload) + let attr_id = parse_attribute_id ~start_pos p in + let payload = parse_payload p in + (attr_id, payload) (* module signature on the file level *) -let parseSpecification p : Parsetree.signature = - parseRegion p ~grammar:Grammar.Specification ~f:parseSignatureItemRegion +let parse_specification p : Parsetree.signature = + parse_region p ~grammar:Grammar.Specification ~f:parse_signature_item_region (* module structure on the file level *) -let parseImplementation p : Parsetree.structure = - parseRegion p ~grammar:Grammar.Implementation ~f:parseStructureItemRegion +let parse_implementation p : Parsetree.structure = + parse_region p ~grammar:Grammar.Implementation ~f:parse_structure_item_region diff --git a/analysis/vendor/res_syntax/res_core.mli b/analysis/vendor/res_syntax/res_core.mli index e77ca30bb..30d1e5f5e 100644 --- a/analysis/vendor/res_syntax/res_core.mli +++ b/analysis/vendor/res_syntax/res_core.mli @@ -1,2 +1,2 @@ -val parseImplementation : Res_parser.t -> Parsetree.structure -val parseSpecification : Res_parser.t -> Parsetree.signature +val parse_implementation : Res_parser.t -> Parsetree.structure +val parse_specification : Res_parser.t -> Parsetree.signature diff --git a/analysis/vendor/res_syntax/res_diagnostics.ml b/analysis/vendor/res_syntax/res_diagnostics.ml index 3b1da1521..7df65840b 100644 --- a/analysis/vendor/res_syntax/res_diagnostics.ml +++ b/analysis/vendor/res_syntax/res_diagnostics.ml @@ -17,45 +17,45 @@ type category = | UnknownUchar of Char.t type t = { - startPos: Lexing.position; - endPos: Lexing.position; + start_pos: Lexing.position; + end_pos: Lexing.position; category: category; } type report = t list -let getStartPos t = t.startPos -let getEndPos t = t.endPos +let get_start_pos t = t.start_pos +let get_end_pos t = t.end_pos -let defaultUnexpected token = - "I'm not sure what to parse here when looking at \"" ^ Token.toString token +let default_unexpected token = + "I'm not sure what to parse here when looking at \"" ^ Token.to_string token ^ "\"." -let reservedKeyword token = - let tokenTxt = Token.toString token in - "`" ^ tokenTxt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" - ^ tokenTxt ^ "\"" +let reserved_keyword token = + let token_txt = Token.to_string token in + "`" ^ token_txt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" + ^ token_txt ^ "\"" let explain t = match t.category with - | Uident currentToken -> ( - match currentToken with + | Uident current_token -> ( + match current_token with | Lident lident -> let guess = String.capitalize_ascii lident in "Did you mean `" ^ guess ^ "` instead of `" ^ lident ^ "`?" - | t when Token.isKeyword t -> - let token = Token.toString t in + | t when Token.is_keyword t -> + let token = Token.to_string t in "`" ^ token ^ "` is a reserved keyword." | _ -> "At this point, I'm looking for an uppercased name like `Belt` or `Array`" ) - | Lident currentToken -> ( - match currentToken with + | Lident current_token -> ( + match current_token with | Uident uident -> let guess = String.uncapitalize_ascii uident in "Did you mean `" ^ guess ^ "` instead of `" ^ uident ^ "`?" - | t when Token.isKeyword t -> - let token = Token.toString t in + | t when Token.is_keyword t -> + let token = Token.to_string t in "`" ^ token ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ token ^ "\"" | Underscore -> "`_` isn't a valid name." @@ -76,21 +76,21 @@ let explain t = | Expected {context; token = t} -> let hint = match context with - | Some grammar -> " It signals the start of " ^ Grammar.toString grammar + | Some grammar -> " It signals the start of " ^ Grammar.to_string grammar | None -> "" in - "Did you forget a `" ^ Token.toString t ^ "` here?" ^ hint + "Did you forget a `" ^ Token.to_string t ^ "` here?" ^ hint | Unexpected {token = t; context = breadcrumbs} -> ( - let name = Token.toString t in + let name = Token.to_string t in match breadcrumbs with | (AtomicTypExpr, _) :: breadcrumbs -> ( match (breadcrumbs, t) with | ( ((StringFieldDeclarations | FieldDeclarations), _) :: _, (String _ | At | Rbrace | Comma | Eof) ) -> "I'm missing a type here" - | _, t when Grammar.isStructureItemStart t || t = Eof -> + | _, t when Grammar.is_structure_item_start t || t = Eof -> "Missing a type here" - | _ -> defaultUnexpected t) + | _ -> default_unexpected t) | (ExprOperand, _) :: breadcrumbs -> ( match (breadcrumbs, t) with | (ExprBlock, _) :: _, Rbrace -> @@ -125,19 +125,19 @@ let explain t = to supply a name before `in`?" | EqualGreater, (PatternMatchCase, _) :: _ -> "I was expecting a pattern to match on before the `=>`" - | token, _ when Token.isKeyword t -> reservedKeyword token - | token, _ -> defaultUnexpected token) + | token, _ when Token.is_keyword t -> reserved_keyword token + | token, _ -> default_unexpected token) | _ -> (* TODO: match on circumstance to verify Lident needed ? *) - if Token.isKeyword t then + if Token.is_keyword t then "`" ^ name ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" - ^ Token.toString t ^ "\"" + ^ Token.to_string t ^ "\"" else "I'm not sure what to parse here when looking at \"" ^ name ^ "\".") -let make ~startPos ~endPos category = {startPos; endPos; category} +let make ~start_pos ~end_pos category = {start_pos; end_pos; category} -let printReport diagnostics src = +let print_report diagnostics src = let rec print diagnostics src = match diagnostics with | [] -> () @@ -145,7 +145,8 @@ let printReport diagnostics src = Location.report_error ~src:(Some src) Format.err_formatter Location. { - loc = {loc_start = d.startPos; loc_end = d.endPos; loc_ghost = false}; + loc = + {loc_start = d.start_pos; loc_end = d.end_pos; loc_ghost = false}; msg = explain d; sub = []; if_highlight = ""; @@ -163,10 +164,10 @@ let unexpected token context = Unexpected {token; context} let expected ?grammar pos token = Expected {context = grammar; pos; token} -let uident currentToken = Uident currentToken -let lident currentToken = Lident currentToken -let unclosedString = UnclosedString -let unclosedComment = UnclosedComment -let unclosedTemplate = UnclosedTemplate -let unknownUchar code = UnknownUchar code +let uident current_token = Uident current_token +let lident current_token = Lident current_token +let unclosed_string = UnclosedString +let unclosed_comment = UnclosedComment +let unclosed_template = UnclosedTemplate +let unknown_uchar code = UnknownUchar code let message txt = Message txt diff --git a/analysis/vendor/res_syntax/res_diagnostics.mli b/analysis/vendor/res_syntax/res_diagnostics.mli index 0ae74cec2..4fd915566 100644 --- a/analysis/vendor/res_syntax/res_diagnostics.mli +++ b/analysis/vendor/res_syntax/res_diagnostics.mli @@ -5,8 +5,8 @@ type t type category type report -val getStartPos : t -> Lexing.position [@@live] (* for playground *) -val getEndPos : t -> Lexing.position [@@live] (* for playground *) +val get_start_pos : t -> Lexing.position [@@live] (* for playground *) +val get_end_pos : t -> Lexing.position [@@live] (* for playground *) val explain : t -> string [@@live] (* for playground *) @@ -14,12 +14,12 @@ val unexpected : Token.t -> (Grammar.t * Lexing.position) list -> category val expected : ?grammar:Grammar.t -> Lexing.position -> Token.t -> category val uident : Token.t -> category val lident : Token.t -> category -val unclosedString : category -val unclosedTemplate : category -val unclosedComment : category -val unknownUchar : Char.t -> category +val unclosed_string : category +val unclosed_template : category +val unclosed_comment : category +val unknown_uchar : Char.t -> category val message : string -> category -val make : startPos:Lexing.position -> endPos:Lexing.position -> category -> t +val make : start_pos:Lexing.position -> end_pos:Lexing.position -> category -> t -val printReport : t list -> string -> unit +val print_report : t list -> string -> unit diff --git a/analysis/vendor/res_syntax/res_doc.ml b/analysis/vendor/res_syntax/res_doc.ml index fe626e479..301c0520b 100644 --- a/analysis/vendor/res_syntax/res_doc.ml +++ b/analysis/vendor/res_syntax/res_doc.ml @@ -2,7 +2,7 @@ module MiniBuffer = Res_minibuffer type mode = Break | Flat -type lineStyle = +type line_style = | Classic (* fits? -> replace with space *) | Soft (* fits? -> replaced with nothing *) | Hard @@ -19,16 +19,16 @@ type t = | IfBreaks of {yes: t; no: t; mutable broken: bool} (* when broken is true, treat as the yes branch *) | LineSuffix of t - | LineBreak of lineStyle - | Group of {mutable shouldBreak: bool; doc: t} + | LineBreak of line_style + | Group of {mutable should_break: bool; doc: t} | CustomLayout of t list | BreakParent let nil = Nil let line = LineBreak Classic -let hardLine = LineBreak Hard -let softLine = LineBreak Soft -let literalLine = LineBreak Literal +let hard_line = LineBreak Hard +let soft_line = LineBreak Soft +let literal_line = LineBreak Literal let text s = Text s (* Optimization. We eagerly collapse and reduce whatever allocation we can *) @@ -46,20 +46,20 @@ let rec _concat acc l = let concat l = Concat (_concat [] l) let indent d = Indent d -let ifBreaks t f = IfBreaks {yes = t; no = f; broken = false} -let lineSuffix d = LineSuffix d -let group d = Group {shouldBreak = false; doc = d} -let breakableGroup ~forceBreak d = Group {shouldBreak = forceBreak; doc = d} -let customLayout gs = CustomLayout gs -let breakParent = BreakParent +let if_breaks t f = IfBreaks {yes = t; no = f; broken = false} +let line_suffix d = LineSuffix d +let group d = Group {should_break = false; doc = d} +let breakable_group ~force_break d = Group {should_break = force_break; doc = d} +let custom_layout gs = CustomLayout gs +let break_parent = BreakParent let space = Text " " let comma = Text "," let dot = Text "." let dotdot = Text ".." let dotdotdot = Text "..." -let lessThan = Text "<" -let greaterThan = Text ">" +let less_than = Text "<" +let greater_than = Text ">" let lbrace = Text "{" let rbrace = Text "}" let lparen = Text "(" @@ -69,10 +69,10 @@ let rbracket = Text "]" let question = Text "?" let tilde = Text "~" let equal = Text "=" -let trailingComma = ifBreaks comma nil -let doubleQuote = Text "\"" +let trailing_comma = if_breaks comma nil +let double_quote = Text "\"" -let propagateForcedBreaks doc = +let propagate_forced_breaks doc = let rec walk doc = match doc with | Text _ | Nil | LineSuffix _ -> false @@ -80,27 +80,27 @@ let propagateForcedBreaks doc = | LineBreak (Hard | Literal) -> true | LineBreak (Classic | Soft) -> false | Indent children -> - let childForcesBreak = walk children in - childForcesBreak - | IfBreaks ({yes = trueDoc; no = falseDoc} as ib) -> - let falseForceBreak = walk falseDoc in - if falseForceBreak then ( - let _ = walk trueDoc in + let child_forces_break = walk children in + child_forces_break + | IfBreaks ({yes = true_doc; no = false_doc} as ib) -> + let false_force_break = walk false_doc in + if false_force_break then ( + let _ = walk true_doc in ib.broken <- true; true) else - let forceBreak = walk trueDoc in - forceBreak - | Group ({shouldBreak = forceBreak; doc = children} as gr) -> - let childForcesBreak = walk children in - let shouldBreak = forceBreak || childForcesBreak in - gr.shouldBreak <- shouldBreak; - shouldBreak + let force_break = walk true_doc in + force_break + | Group ({should_break = force_break; doc = children} as gr) -> + let child_forces_break = walk children in + let should_break = force_break || child_forces_break in + gr.should_break <- should_break; + should_break | Concat children -> List.fold_left - (fun forceBreak child -> - let childForcesBreak = walk child in - forceBreak || childForcesBreak) + (fun force_break child -> + let child_forces_break = walk child in + force_break || child_forces_break) false children | CustomLayout children -> (* When using CustomLayout, we don't want to propagate forced breaks @@ -115,13 +115,13 @@ let propagateForcedBreaks doc = () (* See documentation in interface file *) -let rec willBreak doc = +let rec will_break doc = match doc with - | LineBreak (Hard | Literal) | BreakParent | Group {shouldBreak = true} -> + | LineBreak (Hard | Literal) | BreakParent | Group {should_break = true} -> true - | Group {doc} | Indent doc | CustomLayout (doc :: _) -> willBreak doc - | Concat docs -> List.exists willBreak docs - | IfBreaks {yes; no} -> willBreak yes || willBreak no + | Group {doc} | Indent doc | CustomLayout (doc :: _) -> will_break doc + | Concat docs -> List.exists will_break docs + | IfBreaks {yes; no} -> will_break yes || will_break no | _ -> false let join ~sep docs = @@ -133,14 +133,14 @@ let join ~sep docs = in concat (loop [] sep docs) -let joinWithSep docsWithSep = +let join_with_sep docs_with_sep = let rec loop acc docs = match docs with | [] -> List.rev acc | [(x, _sep)] -> List.rev (x :: acc) | (x, sep) :: xs -> loop (sep :: x :: acc) xs in - concat (loop [] docsWithSep) + concat (loop [] docs_with_sep) let fits w stack = let width = ref w in @@ -157,63 +157,63 @@ let fits w stack = | Flat, LineBreak Classic -> width := width.contents - 1 | Flat, LineBreak Soft -> () | Break, LineBreak _ -> result := Some true - | _, Group {shouldBreak = true; doc} -> calculate indent Break doc + | _, Group {should_break = true; doc} -> calculate indent Break doc | _, Group {doc} -> calculate indent mode doc - | _, IfBreaks {yes = breakDoc; broken = true} -> - calculate indent mode breakDoc - | Break, IfBreaks {yes = breakDoc} -> calculate indent mode breakDoc - | Flat, IfBreaks {no = flatDoc} -> calculate indent mode flatDoc - | _, Concat docs -> calculateConcat indent mode docs + | _, IfBreaks {yes = break_doc; broken = true} -> + calculate indent mode break_doc + | Break, IfBreaks {yes = break_doc} -> calculate indent mode break_doc + | Flat, IfBreaks {no = flat_doc} -> calculate indent mode flat_doc + | _, Concat docs -> calculate_concat indent mode docs | _, CustomLayout (hd :: _) -> (* TODO: if we have nested custom layouts, what we should do here? *) calculate indent mode hd | _, CustomLayout [] -> () - and calculateConcat indent mode docs = + and calculate_concat indent mode docs = if result.contents == None then match docs with | [] -> () | doc :: rest -> calculate indent mode doc; - calculateConcat indent mode rest + calculate_concat indent mode rest in - let rec calculateAll stack = + let rec calculate_all stack = match (result.contents, stack) with | Some r, _ -> r | None, [] -> !width >= 0 | None, (indent, mode, doc) :: rest -> calculate indent mode doc; - calculateAll rest + calculate_all rest in - calculateAll stack + calculate_all stack -let toString ~width doc = - propagateForcedBreaks doc; +let to_string ~width doc = + propagate_forced_breaks doc; let buffer = MiniBuffer.create 1000 in - let rec process ~pos lineSuffices stack = + let rec process ~pos line_suffices stack = match stack with | ((ind, mode, doc) as cmd) :: rest -> ( match doc with - | Nil | BreakParent -> process ~pos lineSuffices rest + | Nil | BreakParent -> process ~pos line_suffices rest | Text txt -> MiniBuffer.add_string buffer txt; - process ~pos:(String.length txt + pos) lineSuffices rest - | LineSuffix doc -> process ~pos ((ind, mode, doc) :: lineSuffices) rest + process ~pos:(String.length txt + pos) line_suffices rest + | LineSuffix doc -> process ~pos ((ind, mode, doc) :: line_suffices) rest | Concat docs -> let ops = List.map (fun doc -> (ind, mode, doc)) docs in - process ~pos lineSuffices (List.append ops rest) - | Indent doc -> process ~pos lineSuffices ((ind + 2, mode, doc) :: rest) - | IfBreaks {yes = breakDoc; broken = true} -> - process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) - | IfBreaks {yes = breakDoc; no = flatDoc} -> + process ~pos line_suffices (List.append ops rest) + | Indent doc -> process ~pos line_suffices ((ind + 2, mode, doc) :: rest) + | IfBreaks {yes = break_doc; broken = true} -> + process ~pos line_suffices ((ind, mode, break_doc) :: rest) + | IfBreaks {yes = break_doc; no = flat_doc} -> if mode = Break then - process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) - else process ~pos lineSuffices ((ind, mode, flatDoc) :: rest) - | LineBreak lineStyle -> + process ~pos line_suffices ((ind, mode, break_doc) :: rest) + else process ~pos line_suffices ((ind, mode, flat_doc) :: rest) + | LineBreak line_style -> if mode = Break then - match lineSuffices with + match line_suffices with | [] -> - if lineStyle = Literal then ( + if line_style = Literal then ( MiniBuffer.add_char buffer '\n'; process ~pos:0 [] rest) else ( @@ -222,11 +222,11 @@ let toString ~width doc = process ~pos:ind [] rest) | _docs -> process ~pos:ind [] - (List.concat [List.rev lineSuffices; cmd :: rest]) + (List.concat [List.rev line_suffices; cmd :: rest]) else (* mode = Flat *) let pos = - match lineStyle with + match line_style with | Classic -> MiniBuffer.add_string buffer " "; pos + 1 @@ -238,24 +238,24 @@ let toString ~width doc = 0 | Soft -> pos in - process ~pos lineSuffices rest - | Group {shouldBreak; doc} -> - if shouldBreak || not (fits (width - pos) ((ind, Flat, doc) :: rest)) - then process ~pos lineSuffices ((ind, Break, doc) :: rest) - else process ~pos lineSuffices ((ind, Flat, doc) :: rest) + process ~pos line_suffices rest + | Group {should_break; doc} -> + if should_break || not (fits (width - pos) ((ind, Flat, doc) :: rest)) + then process ~pos line_suffices ((ind, Break, doc) :: rest) + else process ~pos line_suffices ((ind, Flat, doc) :: rest) | CustomLayout docs -> - let rec findGroupThatFits groups = + let rec find_group_that_fits groups = match groups with | [] -> Nil - | [lastGroup] -> lastGroup + | [last_group] -> last_group | doc :: docs -> if fits (width - pos) ((ind, Flat, doc) :: rest) then doc - else findGroupThatFits docs + else find_group_that_fits docs in - let doc = findGroupThatFits docs in - process ~pos lineSuffices ((ind, Flat, doc) :: rest)) + let doc = find_group_that_fits docs in + process ~pos line_suffices ((ind, Flat, doc) :: rest)) | [] -> ( - match lineSuffices with + match line_suffices with | [] -> () | suffices -> process ~pos:0 [] (List.rev suffices)) in @@ -263,7 +263,7 @@ let toString ~width doc = MiniBuffer.contents buffer let debug t = - let rec toDoc = function + let rec to_doc = function | Nil -> text "nil" | BreakParent -> text "breakparent" | Text txt -> text ("text(\"" ^ txt ^ "\")") @@ -272,7 +272,7 @@ let debug t = (concat [ text "linesuffix("; - indent (concat [line; toDoc doc]); + indent (concat [line; to_doc doc]); line; text ")"; ]) @@ -286,7 +286,7 @@ let debug t = (concat [ line; - join ~sep:(concat [text ","; line]) (List.map toDoc docs); + join ~sep:(concat [text ","; line]) (List.map to_doc docs); ]); line; text ")"; @@ -300,35 +300,40 @@ let debug t = (concat [ line; - join ~sep:(concat [text ","; line]) (List.map toDoc docs); + join ~sep:(concat [text ","; line]) (List.map to_doc docs); ]); line; text ")"; ]) | Indent doc -> - concat [text "indent("; softLine; toDoc doc; softLine; text ")"] - | IfBreaks {yes = trueDoc; broken = true} -> toDoc trueDoc - | IfBreaks {yes = trueDoc; no = falseDoc} -> + concat [text "indent("; soft_line; to_doc doc; soft_line; text ")"] + | IfBreaks {yes = true_doc; broken = true} -> to_doc true_doc + | IfBreaks {yes = true_doc; no = false_doc} -> group (concat [ text "ifBreaks("; indent (concat - [line; toDoc trueDoc; concat [text ","; line]; toDoc falseDoc]); + [ + line; + to_doc true_doc; + concat [text ","; line]; + to_doc false_doc; + ]); line; text ")"; ]) | LineBreak break -> - let breakTxt = + let break_txt = match break with | Classic -> "Classic" | Soft -> "Soft" | Hard -> "Hard" | Literal -> "Liteal" in - text ("LineBreak(" ^ breakTxt ^ ")") - | Group {shouldBreak; doc} -> + text ("LineBreak(" ^ break_txt ^ ")") + | Group {should_break; doc} -> group (concat [ @@ -337,14 +342,14 @@ let debug t = (concat [ line; - text ("{shouldBreak: " ^ string_of_bool shouldBreak ^ "}"); + text ("{shouldBreak: " ^ string_of_bool should_break ^ "}"); concat [text ","; line]; - toDoc doc; + to_doc doc; ]); line; text ")"; ]) in - let doc = toDoc t in - toString ~width:10 doc |> print_endline + let doc = to_doc t in + to_string ~width:10 doc |> print_endline [@@live] diff --git a/analysis/vendor/res_syntax/res_doc.mli b/analysis/vendor/res_syntax/res_doc.mli index f1a0c6ea6..763c20220 100644 --- a/analysis/vendor/res_syntax/res_doc.mli +++ b/analysis/vendor/res_syntax/res_doc.mli @@ -2,34 +2,34 @@ type t val nil : t val line : t -val hardLine : t -val softLine : t -val literalLine : t +val hard_line : t +val soft_line : t +val literal_line : t val text : string -> t val concat : t list -> t val indent : t -> t -val ifBreaks : t -> t -> t -val lineSuffix : t -> t +val if_breaks : t -> t -> t +val line_suffix : t -> t val group : t -> t -val breakableGroup : forceBreak:bool -> t -> t +val breakable_group : force_break:bool -> t -> t (* `customLayout docs` will pick the layout that fits from `docs`. * This is a very expensive computation as every layout from the list * will be checked until one fits. *) -val customLayout : t list -> t -val breakParent : t +val custom_layout : t list -> t +val break_parent : t val join : sep:t -> t list -> t (* [(doc1, sep1); (doc2,sep2)] joins as doc1 sep1 doc2 *) -val joinWithSep : (t * t) list -> t +val join_with_sep : (t * t) list -> t val space : t val comma : t val dot : t val dotdot : t val dotdotdot : t -val lessThan : t -val greaterThan : t +val less_than : t +val greater_than : t val lbrace : t val rbrace : t val lparen : t @@ -39,8 +39,8 @@ val rbracket : t val question : t val tilde : t val equal : t -val trailingComma : t -val doubleQuote : t [@@live] +val trailing_comma : t +val double_quote : t [@@live] (* * `willBreak doc` checks whether `doc` contains forced line breaks. @@ -61,7 +61,7 @@ val doubleQuote : t [@@live] * The consumer can then manually insert a `breakParent` doc, to manually propagate the * force breaks from bottom to top. *) -val willBreak : t -> bool +val will_break : t -> bool -val toString : width:int -> t -> string +val to_string : width:int -> t -> string val debug : t -> unit [@@live] diff --git a/analysis/vendor/res_syntax/res_driver.ml b/analysis/vendor/res_syntax/res_driver.ml index a82c9a2a1..64039e765 100644 --- a/analysis/vendor/res_syntax/res_driver.ml +++ b/analysis/vendor/res_syntax/res_driver.ml @@ -1,6 +1,6 @@ module IO = Res_io -type ('ast, 'diagnostics) parseResult = { +type ('ast, 'diagnostics) parse_result = { filename: string; [@live] source: string; parsetree: 'ast; @@ -9,26 +9,27 @@ type ('ast, 'diagnostics) parseResult = { comments: Res_comment.t list; } -type 'diagnostics parsingEngine = { - parseImplementation: - forPrinter:bool -> +type 'diagnostics parsing_engine = { + parse_implementation: + for_printer:bool -> filename:string -> - (Parsetree.structure, 'diagnostics) parseResult; - parseInterface: - forPrinter:bool -> + (Parsetree.structure, 'diagnostics) parse_result; + parse_interface: + for_printer:bool -> filename:string -> - (Parsetree.signature, 'diagnostics) parseResult; - stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit; + (Parsetree.signature, 'diagnostics) parse_result; + string_of_diagnostics: + source:string -> filename:string -> 'diagnostics -> unit; } -type printEngine = { - printImplementation: +type print_engine = { + print_implementation: width:int -> filename:string -> comments:Res_comment.t list -> Parsetree.structure -> unit; - printInterface: + print_interface: width:int -> filename:string -> comments:Res_comment.t list -> @@ -36,21 +37,21 @@ type printEngine = { unit; } -let setup ~filename ~forPrinter () = - let src = IO.readFile ~filename in - let mode = if forPrinter then Res_parser.Default else ParseForTypeChecker in +let setup ~filename ~for_printer () = + let src = IO.read_file ~filename in + let mode = if for_printer then Res_parser.Default else ParseForTypeChecker in Res_parser.make ~mode src filename -let setupFromSource ~displayFilename ~source ~forPrinter () = - let mode = if forPrinter then Res_parser.Default else ParseForTypeChecker in - Res_parser.make ~mode source displayFilename +let setup_from_source ~display_filename ~source ~for_printer () = + let mode = if for_printer then Res_parser.Default else ParseForTypeChecker in + Res_parser.make ~mode source display_filename -let parsingEngine = +let parsing_engine = { - parseImplementation = - (fun ~forPrinter ~filename -> - let engine = setup ~filename ~forPrinter () in - let structure = Res_core.parseImplementation engine in + parse_implementation = + (fun ~for_printer ~filename -> + let engine = setup ~filename ~for_printer () in + let structure = Res_core.parse_implementation engine in let invalid, diagnostics = match engine.diagnostics with | [] as diagnostics -> (false, diagnostics) @@ -64,10 +65,10 @@ let parsingEngine = invalid; comments = List.rev engine.comments; }); - parseInterface = - (fun ~forPrinter ~filename -> - let engine = setup ~filename ~forPrinter () in - let signature = Res_core.parseSpecification engine in + parse_interface = + (fun ~for_printer ~filename -> + let engine = setup ~filename ~for_printer () in + let signature = Res_core.parse_specification engine in let invalid, diagnostics = match engine.diagnostics with | [] as diagnostics -> (false, diagnostics) @@ -81,14 +82,14 @@ let parsingEngine = invalid; comments = List.rev engine.comments; }); - stringOfDiagnostics = + string_of_diagnostics = (fun ~source ~filename:_ diagnostics -> - Res_diagnostics.printReport diagnostics source); + Res_diagnostics.print_report diagnostics source); } -let parseImplementationFromSource ~forPrinter ~displayFilename ~source = - let engine = setupFromSource ~displayFilename ~source ~forPrinter () in - let structure = Res_core.parseImplementation engine in +let parse_implementation_from_source ~for_printer ~display_filename ~source = + let engine = setup_from_source ~display_filename ~source ~for_printer () in + let structure = Res_core.parse_implementation engine in let invalid, diagnostics = match engine.diagnostics with | [] as diagnostics -> (false, diagnostics) @@ -103,9 +104,9 @@ let parseImplementationFromSource ~forPrinter ~displayFilename ~source = comments = List.rev engine.comments; } -let parseInterfaceFromSource ~forPrinter ~displayFilename ~source = - let engine = setupFromSource ~displayFilename ~source ~forPrinter () in - let signature = Res_core.parseSpecification engine in +let parse_interface_from_source ~for_printer ~display_filename ~source = + let engine = setup_from_source ~display_filename ~source ~for_printer () in + let signature = Res_core.parse_specification engine in let invalid, diagnostics = match engine.diagnostics with | [] as diagnostics -> (false, diagnostics) @@ -120,42 +121,42 @@ let parseInterfaceFromSource ~forPrinter ~displayFilename ~source = comments = List.rev engine.comments; } -let printEngine = +let print_engine = { - printImplementation = + print_implementation = (fun ~width ~filename:_ ~comments structure -> print_string - (Res_printer.printImplementation ~width structure ~comments)); - printInterface = + (Res_printer.print_implementation ~width structure ~comments)); + print_interface = (fun ~width ~filename:_ ~comments signature -> - print_string (Res_printer.printInterface ~width signature ~comments)); + print_string (Res_printer.print_interface ~width signature ~comments)); } -let parse_implementation ?(ignoreParseErrors = false) sourcefile = +let parse_implementation ?(ignore_parse_errors = false) sourcefile = Location.input_name := sourcefile; - let parseResult = - parsingEngine.parseImplementation ~forPrinter:false ~filename:sourcefile + let parse_result = + parsing_engine.parse_implementation ~for_printer:false ~filename:sourcefile in - if parseResult.invalid then ( - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - if not ignoreParseErrors then exit 1); - parseResult.parsetree + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics parse_result.source; + if not ignore_parse_errors then exit 1); + parse_result.parsetree [@@raises exit] -let parse_interface ?(ignoreParseErrors = false) sourcefile = +let parse_interface ?(ignore_parse_errors = false) sourcefile = Location.input_name := sourcefile; - let parseResult = - parsingEngine.parseInterface ~forPrinter:false ~filename:sourcefile + let parse_result = + parsing_engine.parse_interface ~for_printer:false ~filename:sourcefile in - if parseResult.invalid then ( - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - if not ignoreParseErrors then exit 1); - parseResult.parsetree + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics parse_result.source; + if not ignore_parse_errors then exit 1); + parse_result.parsetree [@@raises exit] (* suppress unused optional arg *) let _ = fun s -> - ( parse_implementation ~ignoreParseErrors:false s, - parse_interface ~ignoreParseErrors:false s ) + ( parse_implementation ~ignore_parse_errors:false s, + parse_interface ~ignore_parse_errors:false s ) [@@raises exit] diff --git a/analysis/vendor/res_syntax/res_driver.mli b/analysis/vendor/res_syntax/res_driver.mli index ddc264739..2b717013c 100644 --- a/analysis/vendor/res_syntax/res_driver.mli +++ b/analysis/vendor/res_syntax/res_driver.mli @@ -1,4 +1,4 @@ -type ('ast, 'diagnostics) parseResult = { +type ('ast, 'diagnostics) parse_result = { filename: string; [@live] source: string; parsetree: 'ast; @@ -7,40 +7,41 @@ type ('ast, 'diagnostics) parseResult = { comments: Res_comment.t list; } -type 'diagnostics parsingEngine = { - parseImplementation: - forPrinter:bool -> +type 'diagnostics parsing_engine = { + parse_implementation: + for_printer:bool -> filename:string -> - (Parsetree.structure, 'diagnostics) parseResult; - parseInterface: - forPrinter:bool -> + (Parsetree.structure, 'diagnostics) parse_result; + parse_interface: + for_printer:bool -> filename:string -> - (Parsetree.signature, 'diagnostics) parseResult; - stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit; + (Parsetree.signature, 'diagnostics) parse_result; + string_of_diagnostics: + source:string -> filename:string -> 'diagnostics -> unit; } -val parseImplementationFromSource : - forPrinter:bool -> - displayFilename:string -> +val parse_implementation_from_source : + for_printer:bool -> + display_filename:string -> source:string -> - (Parsetree.structure, Res_diagnostics.t list) parseResult + (Parsetree.structure, Res_diagnostics.t list) parse_result [@@live] -val parseInterfaceFromSource : - forPrinter:bool -> - displayFilename:string -> +val parse_interface_from_source : + for_printer:bool -> + display_filename:string -> source:string -> - (Parsetree.signature, Res_diagnostics.t list) parseResult + (Parsetree.signature, Res_diagnostics.t list) parse_result [@@live] -type printEngine = { - printImplementation: +type print_engine = { + print_implementation: width:int -> filename:string -> comments:Res_comment.t list -> Parsetree.structure -> unit; - printInterface: + print_interface: width:int -> filename:string -> comments:Res_comment.t list -> @@ -48,15 +49,15 @@ type printEngine = { unit; } -val parsingEngine : Res_diagnostics.t list parsingEngine +val parsing_engine : Res_diagnostics.t list parsing_engine -val printEngine : printEngine +val print_engine : print_engine (* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *) val parse_implementation : - ?ignoreParseErrors:bool -> string -> Parsetree.structure + ?ignore_parse_errors:bool -> string -> Parsetree.structure [@@live] [@@raises Location.Error] (* ReScript interface parsing compatible with ocaml pparse driver. Used by the compiler *) -val parse_interface : ?ignoreParseErrors:bool -> string -> Parsetree.signature +val parse_interface : ?ignore_parse_errors:bool -> string -> Parsetree.signature [@@live] [@@raises Location.Error] diff --git a/analysis/vendor/res_syntax/res_driver_binary.ml b/analysis/vendor/res_syntax/res_driver_binary.ml index 58a815363..71eb12bd4 100644 --- a/analysis/vendor/res_syntax/res_driver_binary.ml +++ b/analysis/vendor/res_syntax/res_driver_binary.ml @@ -1,12 +1,12 @@ -let printEngine = +let print_engine = Res_driver. { - printImplementation = + print_implementation = (fun ~width:_ ~filename ~comments:_ structure -> output_string stdout Config.ast_impl_magic_number; output_value stdout filename; output_value stdout structure); - printInterface = + print_interface = (fun ~width:_ ~filename ~comments:_ signature -> output_string stdout Config.ast_intf_magic_number; output_value stdout filename; diff --git a/analysis/vendor/res_syntax/res_driver_binary.mli b/analysis/vendor/res_syntax/res_driver_binary.mli index 7991ba8db..46358ea37 100644 --- a/analysis/vendor/res_syntax/res_driver_binary.mli +++ b/analysis/vendor/res_syntax/res_driver_binary.mli @@ -1 +1 @@ -val printEngine : Res_driver.printEngine +val print_engine : Res_driver.print_engine diff --git a/analysis/vendor/res_syntax/res_driver_ml_parser.ml b/analysis/vendor/res_syntax/res_driver_ml_parser.ml index 0d6a99e9a..b910d49fa 100644 --- a/analysis/vendor/res_syntax/res_driver_ml_parser.ml +++ b/analysis/vendor/res_syntax/res_driver_ml_parser.ml @@ -4,23 +4,25 @@ module IO = Res_io let setup ~filename = if String.length filename > 0 then ( Location.input_name := filename; - IO.readFile ~filename |> Lexing.from_string) + IO.read_file ~filename |> Lexing.from_string) else Lexing.from_channel stdin -let extractOcamlConcreteSyntax filename = +let extract_ocaml_concrete_syntax filename = let lexbuf = if String.length filename > 0 then - IO.readFile ~filename |> Lexing.from_string + IO.read_file ~filename |> Lexing.from_string else Lexing.from_channel stdin in - let stringLocs = ref [] in - let commentData = ref [] in - let rec next (prevTokEndPos : Lexing.position) () = + let string_locs = ref [] in + let comment_data = ref [] in + let rec next (prev_tok_end_pos : Lexing.position) () = let token = Lexer.token_with_comments lexbuf in match token with | OcamlParser.COMMENT (txt, loc) -> - let comment = Res_comment.fromOcamlComment ~loc ~prevTokEndPos ~txt in - commentData := comment :: !commentData; + let comment = + Res_comment.from_ocaml_comment ~loc ~prev_tok_end_pos ~txt + in + comment_data := comment :: !comment_data; next loc.Location.loc_end () | OcamlParser.STRING (_txt, None) -> let open Location in @@ -37,25 +39,25 @@ let extractOcamlConcreteSyntax filename = ((Bytes.sub [@doesNotRaise]) lexbuf.Lexing.lex_buffer loc.loc_start.pos_cnum len) in - stringLocs := (txt, loc) :: !stringLocs; + string_locs := (txt, loc) :: !string_locs; next lexbuf.Lexing.lex_curr_p () | OcamlParser.EOF -> () | _ -> next lexbuf.Lexing.lex_curr_p () in next lexbuf.Lexing.lex_start_p (); - (List.rev !stringLocs, List.rev !commentData) + (List.rev !string_locs, List.rev !comment_data) -let parsingEngine = +let parsing_engine = { - Res_driver.parseImplementation = - (fun ~forPrinter:_ ~filename -> + Res_driver.parse_implementation = + (fun ~for_printer:_ ~filename -> let lexbuf = setup ~filename in - let stringData, comments = - extractOcamlConcreteSyntax !Location.input_name + let string_data, comments = + extract_ocaml_concrete_syntax !Location.input_name in let structure = Parse.implementation lexbuf - |> Res_ast_conversion.replaceStringLiteralStructure stringData + |> Res_ast_conversion.replace_string_literal_structure string_data |> Res_ast_conversion.structure in { @@ -66,15 +68,15 @@ let parsingEngine = invalid = false; comments; }); - parseInterface = - (fun ~forPrinter:_ ~filename -> + parse_interface = + (fun ~for_printer:_ ~filename -> let lexbuf = setup ~filename in - let stringData, comments = - extractOcamlConcreteSyntax !Location.input_name + let string_data, comments = + extract_ocaml_concrete_syntax !Location.input_name in let signature = Parse.interface lexbuf - |> Res_ast_conversion.replaceStringLiteralSignature stringData + |> Res_ast_conversion.replace_string_literal_signature string_data |> Res_ast_conversion.signature in { @@ -85,16 +87,16 @@ let parsingEngine = invalid = false; comments; }); - stringOfDiagnostics = (fun ~source:_ ~filename:_ _diagnostics -> ()); + string_of_diagnostics = (fun ~source:_ ~filename:_ _diagnostics -> ()); } -let printEngine = +let print_engine = Res_driver. { - printImplementation = + print_implementation = (fun ~width:_ ~filename:_ ~comments:_ structure -> Pprintast.structure Format.std_formatter structure); - printInterface = + print_interface = (fun ~width:_ ~filename:_ ~comments:_ signature -> Pprintast.signature Format.std_formatter signature); } diff --git a/analysis/vendor/res_syntax/res_driver_ml_parser.mli b/analysis/vendor/res_syntax/res_driver_ml_parser.mli index 55a99c4d5..e104f6e63 100644 --- a/analysis/vendor/res_syntax/res_driver_ml_parser.mli +++ b/analysis/vendor/res_syntax/res_driver_ml_parser.mli @@ -1,10 +1,10 @@ (* This module represents a general interface to parse marshalled reason ast *) (* extracts comments and the original string data from an ocaml file *) -val extractOcamlConcreteSyntax : +val extract_ocaml_concrete_syntax : string -> (string * Location.t) list * Res_comment.t list [@@live] -val parsingEngine : unit Res_driver.parsingEngine +val parsing_engine : unit Res_driver.parsing_engine -val printEngine : Res_driver.printEngine +val print_engine : Res_driver.print_engine diff --git a/analysis/vendor/res_syntax/res_grammar.ml b/analysis/vendor/res_syntax/res_grammar.ml index 61e6f4ea8..daf9a788e 100644 --- a/analysis/vendor/res_syntax/res_grammar.ml +++ b/analysis/vendor/res_syntax/res_grammar.ml @@ -60,7 +60,7 @@ type t = | AttributePayload | TagNames -let toString = function +let to_string = function | OpenDescription -> "an open description" | ModuleLongIdent -> "a module path" | Ternary -> "a ternary expression" @@ -70,7 +70,7 @@ let toString = function | ExprOperand -> "a basic expression" | ExprUnary -> "a unary expression" | ExprBinaryAfterOp op -> - "an expression after the operator \"" ^ Token.toString op ^ "\"" + "an expression after the operator \"" ^ Token.to_string op ^ "\"" | ExprIf -> "an if expression" | IfCondition -> "the condition of an if expression" | IfBranch -> "the true-branch of an if expression" @@ -121,181 +121,181 @@ let toString = function | AttributePayload -> "an attribute payload" | TagNames -> "tag names" -let isSignatureItemStart = function +let is_signature_item_start = function | Token.At | Let | Typ | External | Exception | Open | Include | Module | AtAt | PercentPercent -> true | _ -> false -let isAtomicPatternStart = function +let is_atomic_pattern_start = function | Token.Int _ | String _ | Codepoint _ | Backtick | Lparen | Lbracket | Lbrace - | Underscore | Lident _ | Uident _ | List | Exception | Lazy | Percent -> + | Underscore | Lident _ | Uident _ | List | Exception | Percent -> true | _ -> false -let isAtomicExprStart = function +let is_atomic_expr_start = function | Token.True | False | Int _ | String _ | Float _ | Codepoint _ | Backtick | Uident _ | Lident _ | Hash | Lparen | List | Lbracket | Lbrace | LessThan | Module | Percent -> true | _ -> false -let isAtomicTypExprStart = function +let is_atomic_typ_expr_start = function | Token.SingleQuote | Underscore | Lparen | Lbrace | Uident _ | Lident _ | Percent -> true | _ -> false -let isExprStart = function +let is_expr_start = function | Token.Assert | At | Await | Backtick | Bang | Codepoint _ | False | Float _ - | For | Hash | If | Int _ | Lazy | Lbrace | Lbracket | LessThan | Lident _ - | List | Lparen | Minus | MinusDot | Module | Percent | Plus | PlusDot - | String _ | Switch | True | Try | Uident _ | Underscore (* _ => doThings() *) + | For | Hash | If | Int _ | Lbrace | Lbracket | LessThan | Lident _ | List + | Lparen | Minus | MinusDot | Module | Percent | Plus | PlusDot | String _ + | Switch | True | Try | Uident _ | Underscore (* _ => doThings() *) | While -> true | _ -> false -let isJsxAttributeStart = function +let is_jsx_attribute_start = function | Token.Lident _ | Question | Lbrace -> true | _ -> false -let isStructureItemStart = function +let is_structure_item_start = function | Token.Open | Let | Typ | External | Exception | Include | Module | AtAt | PercentPercent | At -> true - | t when isExprStart t -> true + | t when is_expr_start t -> true | _ -> false -let isPatternStart = function +let is_pattern_start = function | Token.Int _ | Float _ | String _ | Codepoint _ | Backtick | True | False | Minus | Plus | Lparen | Lbracket | Lbrace | List | Underscore | Lident _ - | Uident _ | Hash | Exception | Lazy | Percent | Module | At -> + | Uident _ | Hash | Exception | Percent | Module | At -> true | _ -> false -let isParameterStart = function +let is_parameter_start = function | Token.Typ | Tilde | Dot -> true - | token when isPatternStart token -> true + | token when is_pattern_start token -> true | _ -> false (* TODO: overparse Uident ? *) -let isStringFieldDeclStart = function +let is_string_field_decl_start = function | Token.String _ | Lident _ | At | DotDotDot -> true | _ -> false (* TODO: overparse Uident ? *) -let isFieldDeclStart = function +let is_field_decl_start = function | Token.At | Mutable | Lident _ -> true (* recovery, TODO: this is not ideal… *) | Uident _ -> true - | t when Token.isKeyword t -> true + | t when Token.is_keyword t -> true | _ -> false -let isRecordDeclStart = function +let is_record_decl_start = function | Token.At | Mutable | Lident _ | DotDotDot | String _ -> true | _ -> false -let isTypExprStart = function +let is_typ_expr_start = function | Token.At | SingleQuote | Underscore | Lparen | Lbracket | Uident _ | Lident _ | Module | Percent | Lbrace -> true | _ -> false -let isTypeParameterStart = function +let is_type_parameter_start = function | Token.Tilde | Dot -> true - | token when isTypExprStart token -> true + | token when is_typ_expr_start token -> true | _ -> false -let isTypeParamStart = function +let is_type_param_start = function | Token.Plus | Minus | SingleQuote | Underscore -> true | _ -> false -let isFunctorArgStart = function +let is_functor_arg_start = function | Token.At | Uident _ | Underscore | Percent | Lbrace | Lparen -> true | _ -> false -let isModExprStart = function +let is_mod_expr_start = function | Token.At | Percent | Uident _ | Lbrace | Lparen | Lident "unpack" | Await -> true | _ -> false -let isRecordRowStart = function +let is_record_row_start = function | Token.DotDotDot -> true | Token.Uident _ | Lident _ -> true (* TODO *) - | t when Token.isKeyword t -> true + | t when Token.is_keyword t -> true | _ -> false -let isRecordRowStringKeyStart = function +let is_record_row_string_key_start = function | Token.String _ -> true | _ -> false -let isArgumentStart = function +let is_argument_start = function | Token.Tilde | Dot | Underscore -> true - | t when isExprStart t -> true + | t when is_expr_start t -> true | _ -> false -let isPatternMatchStart = function +let is_pattern_match_start = function | Token.Bar -> true - | t when isPatternStart t -> true + | t when is_pattern_start t -> true | _ -> false -let isPatternOcamlListStart = function +let is_pattern_ocaml_list_start = function | Token.DotDotDot -> true - | t when isPatternStart t -> true + | t when is_pattern_start t -> true | _ -> false -let isPatternRecordItemStart = function +let is_pattern_record_item_start = function | Token.DotDotDot | Uident _ | Lident _ | Underscore -> true | _ -> false -let isAttributeStart = function +let is_attribute_start = function | Token.At -> true | _ -> false -let isJsxChildStart = isAtomicExprStart +let is_jsx_child_start = is_atomic_expr_start -let isBlockExprStart = function +let is_block_expr_start = function | Token.Assert | At | Await | Backtick | Bang | Codepoint _ | Exception - | False | Float _ | For | Forwardslash | Hash | If | Int _ | Lazy | Lbrace - | Lbracket | LessThan | Let | Lident _ | List | Lparen | Minus | MinusDot - | Module | Open | Percent | Plus | PlusDot | String _ | Switch | True | Try - | Uident _ | Underscore | While -> + | False | Float _ | For | Forwardslash | Hash | If | Int _ | Lbrace | Lbracket + | LessThan | Let | Lident _ | List | Lparen | Minus | MinusDot | Module | Open + | Percent | Plus | PlusDot | String _ | Switch | True | Try | Uident _ + | Underscore | While -> true | _ -> false -let isListElement grammar token = +let is_list_element grammar token = match grammar with - | ExprList -> token = Token.DotDotDot || isExprStart token - | ListExpr -> token = DotDotDot || isExprStart token - | PatternList -> token = DotDotDot || isPatternStart token - | ParameterList -> isParameterStart token - | StringFieldDeclarations -> isStringFieldDeclStart token - | FieldDeclarations -> isFieldDeclStart token - | RecordDecl -> isRecordDeclStart token - | TypExprList -> isTypExprStart token || token = Token.LessThan - | TypeParams -> isTypeParamStart token - | FunctorArgs -> isFunctorArgStart token - | ModExprList -> isModExprStart token - | TypeParameters -> isTypeParameterStart token - | RecordRows -> isRecordRowStart token - | RecordRowsStringKey -> isRecordRowStringKeyStart token - | ArgumentList -> isArgumentStart token - | Signature | Specification -> isSignatureItemStart token - | Structure | Implementation -> isStructureItemStart token - | PatternMatching -> isPatternMatchStart token - | PatternOcamlList -> isPatternOcamlListStart token - | PatternRecord -> isPatternRecordItemStart token - | Attribute -> isAttributeStart token + | ExprList -> token = Token.DotDotDot || is_expr_start token + | ListExpr -> token = DotDotDot || is_expr_start token + | PatternList -> token = DotDotDot || is_pattern_start token + | ParameterList -> is_parameter_start token + | StringFieldDeclarations -> is_string_field_decl_start token + | FieldDeclarations -> is_field_decl_start token + | RecordDecl -> is_record_decl_start token + | TypExprList -> is_typ_expr_start token || token = Token.LessThan + | TypeParams -> is_type_param_start token + | FunctorArgs -> is_functor_arg_start token + | ModExprList -> is_mod_expr_start token + | TypeParameters -> is_type_parameter_start token + | RecordRows -> is_record_row_start token + | RecordRowsStringKey -> is_record_row_string_key_start token + | ArgumentList -> is_argument_start token + | Signature | Specification -> is_signature_item_start token + | Structure | Implementation -> is_structure_item_start token + | PatternMatching -> is_pattern_match_start token + | PatternOcamlList -> is_pattern_ocaml_list_start token + | PatternRecord -> is_pattern_record_item_start token + | Attribute -> is_attribute_start token | TypeConstraint -> token = Constraint | PackageConstraint -> token = And | ConstructorDeclaration -> token = Bar - | JsxAttribute -> isJsxAttributeStart token + | JsxAttribute -> is_jsx_attribute_start token | AttributePayload -> token = Lparen | TagNames -> token = Hash | _ -> false -let isListTerminator grammar token = +let is_list_terminator grammar token = match (grammar, token) with | _, Token.Eof | ExprList, (Rparen | Forwardslash | Rbracket) @@ -322,5 +322,5 @@ let isListTerminator grammar token = | TagNames, Rbracket -> true | _ -> false -let isPartOfList grammar token = - isListElement grammar token || isListTerminator grammar token +let is_part_of_list grammar token = + is_list_element grammar token || is_list_terminator grammar token diff --git a/analysis/vendor/res_syntax/res_io.ml b/analysis/vendor/res_syntax/res_io.ml index e5934b848..1d55da831 100644 --- a/analysis/vendor/res_syntax/res_io.ml +++ b/analysis/vendor/res_syntax/res_io.ml @@ -1,4 +1,4 @@ -let readFile ~filename = +let read_file ~filename = let chan = open_in_bin filename in let content = try really_input_string chan (in_channel_length chan) @@ -7,7 +7,7 @@ let readFile ~filename = close_in_noerr chan; content -let writeFile ~filename ~contents:txt = +let write_file ~filename ~contents:txt = let chan = open_out_bin filename in output_string chan txt; close_out chan diff --git a/analysis/vendor/res_syntax/res_io.mli b/analysis/vendor/res_syntax/res_io.mli index dcc6e1425..65e399e15 100644 --- a/analysis/vendor/res_syntax/res_io.mli +++ b/analysis/vendor/res_syntax/res_io.mli @@ -1,7 +1,7 @@ (* utilities to read and write to/from files or stdin *) (* reads the contents of "filename" into a string *) -val readFile : filename:string -> string +val read_file : filename:string -> string (* writes "content" into file with name "filename" *) -val writeFile : filename:string -> contents:string -> unit +val write_file : filename:string -> contents:string -> unit diff --git a/analysis/vendor/res_syntax/res_multi_printer.ml b/analysis/vendor/res_syntax/res_multi_printer.ml index 98cd1d423..fd212eb45 100644 --- a/analysis/vendor/res_syntax/res_multi_printer.ml +++ b/analysis/vendor/res_syntax/res_multi_printer.ml @@ -1,28 +1,28 @@ -let defaultPrintWidth = 100 +let default_print_width = 100 (* Look at rescript.json (or bsconfig.json) to set Uncurried or Legacy mode if it contains "uncurried": false *) -let getUncurriedFromConfig ~filename = - let rec findConfig ~dir = +let get_uncurried_from_config ~filename = + let rec find_config ~dir = let config = Filename.concat dir "rescript.json" in - if Sys.file_exists config then Some (Res_io.readFile ~filename:config) + if Sys.file_exists config then Some (Res_io.read_file ~filename:config) else let config = Filename.concat dir "bsconfig.json" in - if Sys.file_exists config then Some (Res_io.readFile ~filename:config) + if Sys.file_exists config then Some (Res_io.read_file ~filename:config) else let parent = Filename.dirname dir in - if parent = dir then None else findConfig ~dir:parent + if parent = dir then None else find_config ~dir:parent in - let rec findFromNodeModules ~dir = + let rec find_from_node_modules ~dir = let parent = Filename.dirname dir in if Filename.basename dir = "node_modules" then let config = Filename.concat parent "rescript.json" in - if Sys.file_exists config then Some (Res_io.readFile ~filename:config) + if Sys.file_exists config then Some (Res_io.read_file ~filename:config) else let config = Filename.concat parent "bsconfig.json" in - if Sys.file_exists config then Some (Res_io.readFile ~filename:config) + if Sys.file_exists config then Some (Res_io.read_file ~filename:config) else None else if parent = dir then None - else findFromNodeModules ~dir:parent + else find_from_node_modules ~dir:parent in let dir = if Filename.is_relative filename then @@ -30,12 +30,12 @@ let getUncurriedFromConfig ~filename = else Filename.dirname filename in let config () = - match findConfig ~dir with + match find_config ~dir with | None -> (* The editor calls format on a temporary file. So bsconfig can't be found. This looks outside the node_modules containing the bsc binary *) let dir = (Filename.dirname Sys.argv.(0) [@doesNotRaise]) in - findFromNodeModules ~dir + find_from_node_modules ~dir | x -> x in match config () with @@ -65,55 +65,55 @@ let getUncurriedFromConfig ~filename = if not is_legacy_uncurried then Config.uncurried := Uncurried (* print res files to res syntax *) -let printRes ~ignoreParseErrors ~isInterface ~filename = - getUncurriedFromConfig ~filename; - if isInterface then ( - let parseResult = - Res_driver.parsingEngine.parseInterface ~forPrinter:true ~filename +let print_res ~ignore_parse_errors ~is_interface ~filename = + get_uncurried_from_config ~filename; + if is_interface then ( + let parse_result = + Res_driver.parsing_engine.parse_interface ~for_printer:true ~filename in - if parseResult.invalid then ( - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - if not ignoreParseErrors then exit 1); - Res_printer.printInterface ~width:defaultPrintWidth - ~comments:parseResult.comments parseResult.parsetree) + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics parse_result.source; + if not ignore_parse_errors then exit 1); + Res_printer.print_interface ~width:default_print_width + ~comments:parse_result.comments parse_result.parsetree) else - let parseResult = - Res_driver.parsingEngine.parseImplementation ~forPrinter:true ~filename + let parse_result = + Res_driver.parsing_engine.parse_implementation ~for_printer:true ~filename in - if parseResult.invalid then ( - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - if not ignoreParseErrors then exit 1); - Res_printer.printImplementation ~width:defaultPrintWidth - ~comments:parseResult.comments parseResult.parsetree + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics parse_result.source; + if not ignore_parse_errors then exit 1); + Res_printer.print_implementation ~width:default_print_width + ~comments:parse_result.comments parse_result.parsetree [@@raises exit] (* print ocaml files to res syntax *) -let printMl ~isInterface ~filename = - if isInterface then - let parseResult = - Res_driver_ml_parser.parsingEngine.parseInterface ~forPrinter:true +let print_ml ~is_interface ~filename = + if is_interface then + let parse_result = + Res_driver_ml_parser.parsing_engine.parse_interface ~for_printer:true ~filename in - Res_printer.printInterface ~width:defaultPrintWidth - ~comments:parseResult.comments parseResult.parsetree + Res_printer.print_interface ~width:default_print_width + ~comments:parse_result.comments parse_result.parsetree else - let parseResult = - Res_driver_ml_parser.parsingEngine.parseImplementation ~forPrinter:true + let parse_result = + Res_driver_ml_parser.parsing_engine.parse_implementation ~for_printer:true ~filename in - Res_printer.printImplementation ~width:defaultPrintWidth - ~comments:parseResult.comments parseResult.parsetree + Res_printer.print_implementation ~width:default_print_width + ~comments:parse_result.comments parse_result.parsetree (* print the given file named input to from "language" to res, general interface exposed by the compiler *) -let print ?(ignoreParseErrors = false) language ~input = - let isInterface = +let print ?(ignore_parse_errors = false) language ~input = + let is_interface = let len = String.length input in len > 0 && String.unsafe_get input (len - 1) = 'i' in match language with - | `res -> printRes ~ignoreParseErrors ~isInterface ~filename:input - | `ml -> printMl ~isInterface ~filename:input + | `res -> print_res ~ignore_parse_errors ~is_interface ~filename:input + | `ml -> print_ml ~is_interface ~filename:input [@@raises exit] (* suppress unused optional arg *) -let _ = fun s -> print ~ignoreParseErrors:false s [@@raises exit] +let _ = fun s -> print ~ignore_parse_errors:false s [@@raises exit] diff --git a/analysis/vendor/res_syntax/res_multi_printer.mli b/analysis/vendor/res_syntax/res_multi_printer.mli index 1d15c71e2..ff3da3b3a 100644 --- a/analysis/vendor/res_syntax/res_multi_printer.mli +++ b/analysis/vendor/res_syntax/res_multi_printer.mli @@ -1,3 +1,3 @@ (* Interface to print source code from different languages to res. * Takes a filename called "input" and returns the corresponding formatted res syntax *) -val print : ?ignoreParseErrors:bool -> [`ml | `res] -> input:string -> string +val print : ?ignore_parse_errors:bool -> [`ml | `res] -> input:string -> string diff --git a/analysis/vendor/res_syntax/res_outcome_printer.ml b/analysis/vendor/res_syntax/res_outcome_printer.ml index 7ea56d942..08f260c36 100644 --- a/analysis/vendor/res_syntax/res_outcome_printer.ml +++ b/analysis/vendor/res_syntax/res_outcome_printer.ml @@ -8,77 +8,14 @@ * In general it represent messages to show results or errors to the user. *) module Doc = Res_doc -module Token = Res_token - -let rec unsafe_for_all_range s ~start ~finish p = - start > finish - || p (String.unsafe_get s start) - && unsafe_for_all_range s ~start:(start + 1) ~finish p - -let for_all_from s start p = - let len = String.length s in - unsafe_for_all_range s ~start ~finish:(len - 1) p - -(* See https://github.com/rescript-lang/rescript-compiler/blob/726cfa534314b586e5b5734471bc2023ad99ebd9/jscomp/ext/ext_string.ml#L510 *) -let isValidNumericPolyvarNumber (x : string) = - let len = String.length x in - len > 0 - && - let a = Char.code (String.unsafe_get x 0) in - a <= 57 - && - if len > 1 then - a > 48 - && for_all_from x 1 (function - | '0' .. '9' -> true - | _ -> false) - else a >= 48 - -type identifierStyle = ExoticIdent | NormalIdent - -let classifyIdentContent ~allowUident txt = - let len = String.length txt in - let rec go i = - if i == len then NormalIdent - else - let c = String.unsafe_get txt i in - if - i == 0 - && not - ((allowUident && c >= 'A' && c <= 'Z') - || (c >= 'a' && c <= 'z') - || c = '_') - then ExoticIdent - else if - not - ((c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') - || c = '\'' || c = '_' - || (c >= '0' && c <= '9')) - then ExoticIdent - else go (i + 1) - in - if Token.isKeywordTxt txt then ExoticIdent else go 0 - -let printIdentLike ~allowUident txt = - match classifyIdentContent ~allowUident txt with - | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] - | NormalIdent -> Doc.text txt - -let printPolyVarIdent txt = - (* numeric poly-vars don't need quotes: #644 *) - if isValidNumericPolyvarNumber txt then Doc.text txt - else - match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] - | NormalIdent -> Doc.text txt +module Printer = Res_printer (* ReScript doesn't have parenthesized identifiers. * We don't support custom operators. *) let parenthesized_ident _name = true (* TODO: better allocation strategy for the buffer *) -let escapeStringContents s = +let escape_string_contents s = let len = String.length s in let b = Buffer.create len in for i = 0 to len - 1 do @@ -117,59 +54,64 @@ let escapeStringContents s = print_ident fmt id2; Format.pp_print_char fmt ')' *) -let rec printOutIdentDoc ?(allowUident = true) (ident : Outcometree.out_ident) = +let rec print_out_ident_doc ?(allow_uident = true) + (ident : Outcometree.out_ident) = match ident with - | Oide_ident s -> printIdentLike ~allowUident s + | Oide_ident s -> Printer.print_ident_like ~allow_uident s | Oide_dot (ident, s) -> - Doc.concat [printOutIdentDoc ident; Doc.dot; Doc.text s] + Doc.concat [print_out_ident_doc ident; Doc.dot; Doc.text s] | Oide_apply (call, arg) -> Doc.concat - [printOutIdentDoc call; Doc.lparen; printOutIdentDoc arg; Doc.rparen] + [ + print_out_ident_doc call; Doc.lparen; print_out_ident_doc arg; Doc.rparen; + ] -let printOutAttributeDoc (outAttribute : Outcometree.out_attribute) = - Doc.concat [Doc.text "@"; Doc.text outAttribute.oattr_name] +let print_out_attribute_doc (out_attribute : Outcometree.out_attribute) = + Doc.concat [Doc.text "@"; Doc.text out_attribute.oattr_name] -let printOutAttributesDoc (attrs : Outcometree.out_attribute list) = +let print_out_attributes_doc (attrs : Outcometree.out_attribute list) = match attrs with | [] -> Doc.nil | attrs -> Doc.concat [ - Doc.group (Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs)); + Doc.group + (Doc.join ~sep:Doc.line (List.map print_out_attribute_doc attrs)); Doc.line; ] -let rec collectArrowArgs (outType : Outcometree.out_type) args = - match outType with - | Otyp_arrow (label, argType, returnType) -> - let arg = (label, argType) in - collectArrowArgs returnType (arg :: args) - | _ as returnType -> (List.rev args, returnType) +let rec collect_arrow_args (out_type : Outcometree.out_type) args = + match out_type with + | Otyp_arrow (label, arg_type, return_type) -> + let arg = (label, arg_type) in + collect_arrow_args return_type (arg :: args) + | _ as return_type -> (List.rev args, return_type) -let rec collectFunctorArgs (outModuleType : Outcometree.out_module_type) args = - match outModuleType with - | Omty_functor (lbl, optModType, returnModType) -> - let arg = (lbl, optModType) in - collectFunctorArgs returnModType (arg :: args) - | _ -> (List.rev args, outModuleType) +let rec collect_functor_args (out_module_type : Outcometree.out_module_type) + args = + match out_module_type with + | Omty_functor (lbl, opt_mod_type, return_mod_type) -> + let arg = (lbl, opt_mod_type) in + collect_functor_args return_mod_type (arg :: args) + | _ -> (List.rev args, out_module_type) -let rec printOutTypeDoc (outType : Outcometree.out_type) = - match outType with +let rec print_out_type_doc (out_type : Outcometree.out_type) = + match out_type with | Otyp_abstract | Otyp_open -> Doc.nil - | Otyp_variant (nonGen, outVariant, closed, labels) -> + | Otyp_variant (non_gen, out_variant, closed, labels) -> (* bool * out_variant * bool * (string list) option *) let opening = match (closed, labels) with - | true, None -> (* [#A | #B] *) Doc.softLine + | true, None -> (* [#A | #B] *) Doc.soft_line | false, None -> (* [> #A | #B] *) - Doc.concat [Doc.greaterThan; Doc.line] + Doc.concat [Doc.greater_than; Doc.line] | true, Some [] -> (* [< #A | #B] *) - Doc.concat [Doc.lessThan; Doc.line] + Doc.concat [Doc.less_than; Doc.line] | true, Some _ -> (* [< #A | #B > #X #Y ] *) - Doc.concat [Doc.lessThan; Doc.line] + Doc.concat [Doc.less_than; Doc.line] | false, Some _ -> (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *) Doc.concat [Doc.text "?"; Doc.line] @@ -177,9 +119,9 @@ let rec printOutTypeDoc (outType : Outcometree.out_type) = Doc.group (Doc.concat [ - (if nonGen then Doc.text "_" else Doc.nil); + (if non_gen then Doc.text "_" else Doc.nil); Doc.lbracket; - Doc.indent (Doc.concat [opening; printOutVariant outVariant]); + Doc.indent (Doc.concat [opening; print_out_variant out_variant]); (match labels with | None | Some [] -> Doc.nil | Some tags -> @@ -189,80 +131,83 @@ let rec printOutTypeDoc (outType : Outcometree.out_type) = Doc.space; Doc.join ~sep:Doc.space (List.map - (fun lbl -> printIdentLike ~allowUident:true lbl) + (fun lbl -> + Printer.print_ident_like ~allow_uident:true lbl) tags); ])); - Doc.softLine; + Doc.soft_line; Doc.rbracket; ]) - | Otyp_alias (typ, aliasTxt) -> + | Otyp_alias (typ, alias_txt) -> Doc.concat [ Doc.lparen; - printOutTypeDoc typ; + print_out_type_doc typ; Doc.text " as '"; - Doc.text aliasTxt; + Doc.text alias_txt; Doc.rparen; ] | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), "arity0"), [typ]) -> (* Compatibility with compiler up to v10.x *) - Doc.concat [Doc.text "(. ()) => "; printOutTypeDoc typ] + Doc.concat [Doc.text "(. ()) => "; print_out_type_doc typ] | Otyp_constr ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), _), - [(Otyp_arrow _ as arrowType)] ) -> + [(Otyp_arrow _ as arrow_type)] ) -> (* Compatibility with compiler up to v10.x *) - printOutArrowType ~uncurried:true arrowType - | Otyp_constr (Oide_ident "function$", [(Otyp_arrow _ as arrowType); _arity]) + print_out_arrow_type ~uncurried:true arrow_type + | Otyp_constr (Oide_ident "function$", [(Otyp_arrow _ as arrow_type); _arity]) -> (* function$<(int, int) => int, [#2]> -> (. int, int) => int *) - printOutArrowType ~uncurried:true arrowType + print_out_arrow_type ~uncurried:true arrow_type | Otyp_constr (Oide_ident "function$", [Otyp_var _; _arity]) -> (* function$<'a, arity> -> _ => _ *) - printOutTypeDoc (Otyp_stuff "_ => _") - | Otyp_constr (outIdent, []) -> printOutIdentDoc ~allowUident:false outIdent + print_out_type_doc (Otyp_stuff "_ => _") + | Otyp_constr (out_ident, []) -> + print_out_ident_doc ~allow_uident:false out_ident | Otyp_manifest (typ1, typ2) -> - Doc.concat [printOutTypeDoc typ1; Doc.text " = "; printOutTypeDoc typ2] - | Otyp_record record -> printRecordDeclarationDoc ~inline:true record + Doc.concat + [print_out_type_doc typ1; Doc.text " = "; print_out_type_doc typ2] + | Otyp_record record -> print_record_declaration_doc ~inline:true record | Otyp_stuff txt -> Doc.text txt | Otyp_var (ng, s) -> Doc.concat [Doc.text ("'" ^ if ng then "_" else ""); Doc.text s] - | Otyp_object (fields, rest) -> printObjectFields fields rest + | Otyp_object (fields, rest) -> print_object_fields fields rest | Otyp_class _ -> Doc.nil | Otyp_attribute (typ, attribute) -> Doc.group (Doc.concat - [printOutAttributeDoc attribute; Doc.line; printOutTypeDoc typ]) + [print_out_attribute_doc attribute; Doc.line; print_out_type_doc typ]) (* example: Red | Blue | Green | CustomColour(float, float, float) *) - | Otyp_sum constructors -> printOutConstructorsDoc constructors + | Otyp_sum constructors -> print_out_constructors_doc constructors (* example: {"name": string, "age": int} *) | Otyp_constr (Oide_dot (Oide_ident "Js", "t"), [Otyp_object (fields, rest)]) -> - printObjectFields fields rest + print_object_fields fields rest (* example: node *) - | Otyp_constr (outIdent, args) -> - let argsDoc = + | Otyp_constr (out_ident, args) -> + let args_doc = match args with | [] -> Doc.nil | args -> Doc.concat [ - Doc.lessThan; + Doc.less_than; Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc args); + (List.map print_out_type_doc args); ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; + Doc.trailing_comma; + Doc.soft_line; + Doc.greater_than; ] in - Doc.group (Doc.concat [printOutIdentDoc outIdent; argsDoc]) - | Otyp_tuple tupleArgs -> + Doc.group (Doc.concat [print_out_ident_doc out_ident; args_doc]) + | Otyp_tuple tuple_args -> Doc.group (Doc.concat [ @@ -270,16 +215,16 @@ let rec printOutTypeDoc (outType : Outcometree.out_type) = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc tupleArgs); + (List.map print_out_type_doc tuple_args); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ]) - | Otyp_poly (vars, outType) -> + | Otyp_poly (vars, out_type) -> Doc.group (Doc.concat [ @@ -287,12 +232,12 @@ let rec printOutTypeDoc (outType : Outcometree.out_type) = (List.map (fun var -> Doc.text ("'" ^ var)) vars); Doc.dot; Doc.space; - printOutTypeDoc outType; + print_out_type_doc out_type; ]) - | Otyp_arrow _ as typ -> printOutArrowType ~uncurried:false typ - | Otyp_module (modName, stringList, outTypes) -> - let packageTypeDoc = - match (stringList, outTypes) with + | Otyp_arrow _ as typ -> print_out_arrow_type ~uncurried:false typ + | Otyp_module (mod_name, string_list, out_types) -> + let package_type_doc = + match (string_list, out_types) with | [], [] -> Doc.nil | labels, types -> let i = ref 0 in @@ -306,7 +251,7 @@ let rec printOutTypeDoc (outType : Outcometree.out_type) = (if i.contents > 0 then "and type " else "with type "); Doc.text lbl; Doc.text " = "; - printOutTypeDoc typ; + print_out_type_doc typ; ]) labels types) in @@ -316,41 +261,42 @@ let rec printOutTypeDoc (outType : Outcometree.out_type) = [ Doc.text "module"; Doc.lparen; - Doc.text modName; - packageTypeDoc; + Doc.text mod_name; + package_type_doc; Doc.rparen; ] -and printOutArrowType ~uncurried typ = - let uncurried = Res_uncurried.getDotted ~uncurried !Config.uncurried in - let typArgs, typ = collectArrowArgs typ [] in +and print_out_arrow_type ~uncurried typ = + let uncurried = Res_uncurried.get_dotted ~uncurried !Config.uncurried in + let typ_args, typ = collect_arrow_args typ [] in let args = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun (lbl, typ) -> - let lblLen = String.length lbl in - if lblLen = 0 then printOutTypeDoc typ + let lbl_len = String.length lbl in + if lbl_len = 0 then print_out_type_doc typ else - let lbl, optionalIndicator = + let lbl, optional_indicator = (* the ocaml compiler hardcodes the optional label inside the string of the label in printtyp.ml *) match String.unsafe_get lbl 0 with | '?' -> - ((String.sub [@doesNotRaise]) lbl 1 (lblLen - 1), Doc.text "=?") + ( (String.sub [@doesNotRaise]) lbl 1 (lbl_len - 1), + Doc.text "=?" ) | _ -> (lbl, Doc.nil) in Doc.group (Doc.concat [ Doc.text ("~" ^ lbl ^ ": "); - printOutTypeDoc typ; - optionalIndicator; + print_out_type_doc typ; + optional_indicator; ])) - typArgs) + typ_args) in - let argsDoc = - let needsParens = - match typArgs with + let args_doc = + let needs_parens = + match typ_args with | _ when uncurried -> true | [ ( _, @@ -362,21 +308,21 @@ and printOutArrowType ~uncurried typ = | [("", _)] -> false | _ -> true in - if needsParens then + if needs_parens then Doc.group (Doc.concat [ (if uncurried then Doc.text "(. " else Doc.lparen); - Doc.indent (Doc.concat [Doc.softLine; args]); - Doc.trailingComma; - Doc.softLine; + Doc.indent (Doc.concat [Doc.soft_line; args]); + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ]) else args in - Doc.concat [argsDoc; Doc.text " => "; printOutTypeDoc typ] + Doc.concat [args_doc; Doc.text " => "; print_out_type_doc typ] -and printOutVariant variant = +and print_out_variant variant = match variant with | Ovar_fields fields -> (* (string * bool * out_type list) list *) @@ -387,7 +333,7 @@ and printOutVariant variant = *) List.mapi (fun i (name, ampersand, types) -> - let needsParens = + let needs_parens = match types with | [Outcometree.Otyp_tuple _] -> false | _ -> true @@ -395,12 +341,12 @@ and printOutVariant variant = Doc.concat [ (if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil); + else Doc.if_breaks (Doc.text "| ") Doc.nil); Doc.group (Doc.concat [ Doc.text "#"; - printPolyVarIdent name; + Printer.print_poly_var_ident name; (match types with | [] -> Doc.nil | types -> @@ -414,26 +360,26 @@ and printOutVariant variant = ~sep:(Doc.concat [Doc.text " &"; Doc.line]) (List.map (fun typ -> - let outTypeDoc = - printOutTypeDoc typ + let out_type_doc = + print_out_type_doc typ in - if needsParens then + if needs_parens then Doc.concat [ Doc.lparen; - outTypeDoc; + out_type_doc; Doc.rparen; ] - else outTypeDoc) + else out_type_doc) types); ]); ]); ]); ]) fields) - | Ovar_typ typ -> printOutTypeDoc typ + | Ovar_typ typ -> print_out_type_doc typ -and printObjectFields fields rest = +and print_object_fields fields rest = let dots = match rest with | Some non_gen -> Doc.text ((if non_gen then "_" else "") ^ "..") @@ -447,49 +393,49 @@ and printObjectFields fields rest = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun (lbl, outType) -> + (fun (lbl, out_type) -> Doc.group (Doc.concat [ Doc.text ("\"" ^ lbl ^ "\": "); - printOutTypeDoc outType; + print_out_type_doc out_type; ])) fields); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbrace; ]) -and printOutConstructorsDoc constructors = +and print_out_constructors_doc constructors = Doc.group (Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:Doc.line (List.mapi (fun i constructor -> Doc.concat [ (if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil); - printOutConstructorDoc constructor; + else Doc.if_breaks (Doc.text "| ") Doc.nil); + print_out_constructor_doc constructor; ]) constructors); ])) -and printOutConstructorDoc (name, args, gadt) = - let gadtDoc = +and print_out_constructor_doc (name, args, gadt) = + let gadt_doc = match gadt with - | Some outType -> Doc.concat [Doc.text ": "; printOutTypeDoc outType] + | Some out_type -> Doc.concat [Doc.text ": "; print_out_type_doc out_type] | None -> Doc.nil in - let argsDoc = + let args_doc = match args with | [] -> Doc.nil | [Otyp_record record] -> @@ -502,7 +448,7 @@ and printOutConstructorDoc (name, args, gadt) = Doc.concat [ Doc.lparen; - Doc.indent (printRecordDeclarationDoc ~inline:true record); + Doc.indent (print_record_declaration_doc ~inline:true record); Doc.rparen; ] | _types -> @@ -513,30 +459,30 @@ and printOutConstructorDoc (name, args, gadt) = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc args); + (List.map print_out_type_doc args); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ]) in - Doc.group (Doc.concat [Doc.text name; argsDoc; gadtDoc]) + Doc.group (Doc.concat [Doc.text name; args_doc; gadt_doc]) -and printRecordDeclRowDoc (name, mut, opt, arg) = +and print_record_decl_row_doc (name, mut, opt, arg) = Doc.group (Doc.concat [ (if mut then Doc.text "mutable " else Doc.nil); - printIdentLike ~allowUident:false name; + Printer.print_ident_like ~allow_uident:false name; (if opt then Doc.text "?" else Doc.nil); Doc.text ": "; - printOutTypeDoc arg; + print_out_type_doc arg; ]) -and printRecordDeclarationDoc ~inline rows = +and print_record_declaration_doc ~inline rows = let content = Doc.concat [ @@ -544,47 +490,48 @@ and printRecordDeclarationDoc ~inline rows = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printRecordDeclRowDoc rows); + (List.map print_record_decl_row_doc rows); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbrace; ] in if not inline then Doc.group content else content -let printOutType fmt outType = - Format.pp_print_string fmt (Doc.toString ~width:80 (printOutTypeDoc outType)) +let print_out_type fmt out_type = + Format.pp_print_string fmt + (Doc.to_string ~width:80 (print_out_type_doc out_type)) -let printTypeParameterDoc (typ, (co, cn)) = +let print_type_parameter_doc (typ, (co, cn)) = Doc.concat [ (if not cn then Doc.text "+" else if not co then Doc.text "-" else Doc.nil); (if typ = "_" then Doc.text "_" else Doc.text ("'" ^ typ)); ] -let rec printOutSigItemDoc ?(printNameAsIs = false) - (outSigItem : Outcometree.out_sig_item) = - match outSigItem with +let rec print_out_sig_item_doc ?(print_name_as_is = false) + (out_sig_item : Outcometree.out_sig_item) = + match out_sig_item with | Osig_class _ | Osig_class_type _ -> Doc.nil | Osig_ellipsis -> Doc.dotdotdot - | Osig_value valueDecl -> + | Osig_value value_decl -> Doc.group (Doc.concat [ - printOutAttributesDoc valueDecl.oval_attributes; + print_out_attributes_doc value_decl.oval_attributes; Doc.text - (match valueDecl.oval_prims with + (match value_decl.oval_prims with | [] -> "let " | _ -> "external "); - Doc.text valueDecl.oval_name; + Doc.text value_decl.oval_name; Doc.text ":"; Doc.space; - printOutTypeDoc valueDecl.oval_type; - (match valueDecl.oval_prims with + print_out_type_doc value_decl.oval_type; + (match value_decl.oval_prims with | [] -> Doc.nil | primitives -> Doc.indent @@ -608,46 +555,46 @@ let rec printOutSigItemDoc ?(printNameAsIs = false) primitives)); ])); ]) - | Osig_typext (outExtensionConstructor, _outExtStatus) -> - printOutExtensionConstructorDoc outExtensionConstructor - | Osig_modtype (modName, Omty_signature []) -> - Doc.concat [Doc.text "module type "; Doc.text modName] - | Osig_modtype (modName, outModuleType) -> + | Osig_typext (out_extension_constructor, _outExtStatus) -> + print_out_extension_constructor_doc out_extension_constructor + | Osig_modtype (mod_name, Omty_signature []) -> + Doc.concat [Doc.text "module type "; Doc.text mod_name] + | Osig_modtype (mod_name, out_module_type) -> Doc.group (Doc.concat [ Doc.text "module type "; - Doc.text modName; + Doc.text mod_name; Doc.text " = "; - printOutModuleTypeDoc outModuleType; + print_out_module_type_doc out_module_type; ]) - | Osig_module (modName, Omty_alias ident, _) -> + | Osig_module (mod_name, Omty_alias ident, _) -> Doc.group (Doc.concat [ Doc.text "module "; - Doc.text modName; + Doc.text mod_name; Doc.text " ="; Doc.line; - printOutIdentDoc ident; + print_out_ident_doc ident; ]) - | Osig_module (modName, outModType, outRecStatus) -> + | Osig_module (mod_name, out_mod_type, out_rec_status) -> Doc.group (Doc.concat [ Doc.text - (match outRecStatus with + (match out_rec_status with | Orec_not -> "module " | Orec_first -> "module rec " | Orec_next -> "and "); - Doc.text modName; + Doc.text mod_name; Doc.text ": "; - printOutModuleTypeDoc outModType; + print_out_module_type_doc out_mod_type; ]) - | Osig_type (outTypeDecl, outRecStatus) -> + | Osig_type (out_type_decl, out_rec_status) -> (* TODO: manifest ? *) let attrs = - match (outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed) with + match (out_type_decl.otype_immediate, out_type_decl.otype_unboxed) with | false, false -> Doc.nil | true, false -> Doc.concat [Doc.text "@immediate"; Doc.line] | false, true -> Doc.concat [Doc.text "@unboxed"; Doc.line] @@ -655,59 +602,60 @@ let rec printOutSigItemDoc ?(printNameAsIs = false) in let kw = Doc.text - (match outRecStatus with + (match out_rec_status with | Orec_not -> "type " | Orec_first -> "type rec " | Orec_next -> "and ") in - let typeParams = - match outTypeDecl.otype_params with + let type_params = + match out_type_decl.otype_params with | [] -> Doc.nil | _params -> Doc.group (Doc.concat [ - Doc.lessThan; + Doc.less_than; Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printTypeParameterDoc outTypeDecl.otype_params); + (List.map print_type_parameter_doc + out_type_decl.otype_params); ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; + Doc.trailing_comma; + Doc.soft_line; + Doc.greater_than; ]) in - let privateDoc = - match outTypeDecl.otype_private with + let private_doc = + match out_type_decl.otype_private with | Asttypes.Private -> Doc.text "private " | Public -> Doc.nil in let kind = - match outTypeDecl.otype_type with - | Otyp_open -> Doc.concat [Doc.text " = "; privateDoc; Doc.text ".."] + match out_type_decl.otype_type with + | Otyp_open -> Doc.concat [Doc.text " = "; private_doc; Doc.text ".."] | Otyp_abstract -> Doc.nil | Otyp_record record -> Doc.concat [ Doc.text " = "; - privateDoc; - printRecordDeclarationDoc ~inline:false record; + private_doc; + print_record_declaration_doc ~inline:false record; ] - | typ -> Doc.concat [Doc.text " = "; printOutTypeDoc typ] + | typ -> Doc.concat [Doc.text " = "; print_out_type_doc typ] in let constraints = - match outTypeDecl.otype_cstrs with + match out_type_decl.otype_cstrs with | [] -> Doc.nil | _ -> Doc.group (Doc.indent (Doc.concat [ - Doc.hardLine; + Doc.hard_line; Doc.join ~sep:Doc.line (List.map (fun (typ1, typ2) -> @@ -715,12 +663,12 @@ let rec printOutSigItemDoc ?(printNameAsIs = false) (Doc.concat [ Doc.text "constraint "; - printOutTypeDoc typ1; + print_out_type_doc typ1; Doc.text " ="; Doc.space; - printOutTypeDoc typ2; + print_out_type_doc typ2; ])) - outTypeDecl.otype_cstrs); + out_type_decl.otype_cstrs); ])) in Doc.group @@ -732,22 +680,24 @@ let rec printOutSigItemDoc ?(printNameAsIs = false) [ attrs; kw; - (if printNameAsIs then Doc.text outTypeDecl.otype_name - else printIdentLike ~allowUident:false outTypeDecl.otype_name); - typeParams; + (if print_name_as_is then Doc.text out_type_decl.otype_name + else + Printer.print_ident_like ~allow_uident:false + out_type_decl.otype_name); + type_params; kind; ]); constraints; ]) -and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = - match outModType with +and print_out_module_type_doc (out_mod_type : Outcometree.out_module_type) = + match out_mod_type with | Omty_abstract -> Doc.nil - | Omty_ident ident -> printOutIdentDoc ident + | Omty_ident ident -> print_out_ident_doc ident (* example: module Increment = (M: X_int) => X_int *) | Omty_functor _ -> - let args, returnModType = collectFunctorArgs outModType [] in - let argsDoc = + let args, return_mod_type = collect_functor_args out_mod_type [] in + let args_doc = match args with | [(_, None)] -> Doc.text "()" | args -> @@ -758,47 +708,47 @@ and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun (lbl, optModType) -> + (fun (lbl, opt_mod_type) -> Doc.group (Doc.concat [ Doc.text lbl; - (match optModType with + (match opt_mod_type with | None -> Doc.nil - | Some modType -> + | Some mod_type -> Doc.concat [ Doc.text ": "; - printOutModuleTypeDoc modType; + print_out_module_type_doc mod_type; ]); ])) args); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ]) in Doc.group (Doc.concat - [argsDoc; Doc.text " => "; printOutModuleTypeDoc returnModType]) + [args_doc; Doc.text " => "; print_out_module_type_doc return_mod_type]) | Omty_signature [] -> Doc.nil | Omty_signature signature -> - Doc.breakableGroup ~forceBreak:true + Doc.breakable_group ~force_break:true (Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [Doc.line; printOutSignatureDoc signature]); - Doc.softLine; + Doc.indent (Doc.concat [Doc.line; print_out_signature_doc signature]); + Doc.soft_line; Doc.rbrace; ]) | Omty_alias _ident -> Doc.nil -and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = +and print_out_signature_doc (signature : Outcometree.out_sig_item list) = let rec loop signature acc = match signature with | [] -> List.rev acc @@ -825,30 +775,30 @@ and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = otyext_private = ext.oext_private; } in - let doc = printOutTypeExtensionDoc te in + let doc = print_out_type_extension_doc te in loop items (doc :: acc) | item :: items -> - let doc = printOutSigItemDoc ~printNameAsIs:false item in + let doc = print_out_sig_item_doc ~print_name_as_is:false item in loop items (doc :: acc) in match loop signature [] with | [doc] -> doc - | docs -> Doc.breakableGroup ~forceBreak:true (Doc.join ~sep:Doc.line docs) + | docs -> Doc.breakable_group ~force_break:true (Doc.join ~sep:Doc.line docs) -and printOutExtensionConstructorDoc - (outExt : Outcometree.out_extension_constructor) = - let typeParams = - match outExt.oext_type_params with +and print_out_extension_constructor_doc + (out_ext : Outcometree.out_extension_constructor) = + let type_params = + match out_ext.oext_type_params with | [] -> Doc.nil | params -> Doc.group (Doc.concat [ - Doc.lessThan; + Doc.less_than; Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map @@ -856,8 +806,8 @@ and printOutExtensionConstructorDoc Doc.text (if ty = "_" then ty else "'" ^ ty)) params); ]); - Doc.softLine; - Doc.greaterThan; + Doc.soft_line; + Doc.greater_than; ]) in @@ -865,29 +815,30 @@ and printOutExtensionConstructorDoc (Doc.concat [ Doc.text "type "; - printIdentLike ~allowUident:false outExt.oext_type_name; - typeParams; + Printer.print_ident_like ~allow_uident:false out_ext.oext_type_name; + type_params; Doc.text " += "; Doc.line; - (if outExt.oext_private = Asttypes.Private then Doc.text "private " + (if out_ext.oext_private = Asttypes.Private then Doc.text "private " else Doc.nil); - printOutConstructorDoc - (outExt.oext_name, outExt.oext_args, outExt.oext_ret_type); + print_out_constructor_doc + (out_ext.oext_name, out_ext.oext_args, out_ext.oext_ret_type); ]) -and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = - let typeParams = - match typeExtension.otyext_params with +and print_out_type_extension_doc + (type_extension : Outcometree.out_type_extension) = + let type_params = + match type_extension.otyext_params with | [] -> Doc.nil | params -> Doc.group (Doc.concat [ - Doc.lessThan; + Doc.less_than; Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map @@ -895,8 +846,8 @@ and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = Doc.text (if ty = "_" then ty else "'" ^ ty)) params); ]); - Doc.softLine; - Doc.greaterThan; + Doc.soft_line; + Doc.greater_than; ]) in @@ -904,24 +855,24 @@ and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = (Doc.concat [ Doc.text "type "; - printIdentLike ~allowUident:false typeExtension.otyext_name; - typeParams; + Printer.print_ident_like ~allow_uident:false type_extension.otyext_name; + type_params; Doc.text " += "; - (if typeExtension.otyext_private = Asttypes.Private then + (if type_extension.otyext_private = Asttypes.Private then Doc.text "private " else Doc.nil); - printOutConstructorsDoc typeExtension.otyext_constructors; + print_out_constructors_doc type_extension.otyext_constructors; ]) -let printOutSigItem fmt outSigItem = +let print_out_sig_item fmt out_sig_item = Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutSigItemDoc outSigItem)) + (Doc.to_string ~width:80 (print_out_sig_item_doc out_sig_item)) -let printOutSignature fmt signature = +let print_out_signature fmt signature = Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutSignatureDoc signature)) + (Doc.to_string ~width:80 (print_out_signature_doc signature)) -let validFloatLexeme s = +let valid_float_lexeme s = let l = String.length s in let rec loop i = if i >= l then s ^ "." @@ -932,7 +883,7 @@ let validFloatLexeme s = in loop 0 -let floatRepres f = +let float_repres f = match classify_float f with | FP_nan -> "nan" | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" @@ -945,11 +896,11 @@ let floatRepres f = if f = (float_of_string [@doesNotRaise]) s2 then s2 else Printf.sprintf "%.18g" f in - validFloatLexeme float_val + valid_float_lexeme float_val -let rec printOutValueDoc (outValue : Outcometree.out_value) = - match outValue with - | Oval_array outValues -> +let rec print_out_value_doc (out_value : Outcometree.out_value) = + match out_value with + | Oval_array out_values -> Doc.group (Doc.concat [ @@ -957,32 +908,32 @@ let rec printOutValueDoc (outValue : Outcometree.out_value) = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); + (List.map print_out_value_doc out_values); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbracket; ]) | Oval_char c -> Doc.text ("'" ^ Char.escaped c ^ "'") - | Oval_constr (outIdent, outValues) -> + | Oval_constr (out_ident, out_values) -> Doc.group (Doc.concat [ - printOutIdentDoc outIdent; + print_out_ident_doc out_ident; Doc.lparen; Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); + (List.map print_out_value_doc out_values); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ]) | Oval_ellipsis -> Doc.text "..." @@ -990,8 +941,8 @@ let rec printOutValueDoc (outValue : Outcometree.out_value) = | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i) | Oval_int64 i -> Doc.text (Format.sprintf "%LiL" i) | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i) - | Oval_float f -> Doc.text (floatRepres f) - | Oval_list outValues -> + | Oval_float f -> Doc.text (float_repres f) + | Oval_list out_values -> Doc.group (Doc.concat [ @@ -999,13 +950,13 @@ let rec printOutValueDoc (outValue : Outcometree.out_value) = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); + (List.map print_out_value_doc out_values); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbracket; ]) | Oval_printer fn -> @@ -1021,28 +972,28 @@ let rec printOutValueDoc (outValue : Outcometree.out_value) = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun (outIdent, outValue) -> + (fun (out_ident, out_value) -> Doc.group (Doc.concat [ - printOutIdentDoc outIdent; + print_out_ident_doc out_ident; Doc.text ": "; - printOutValueDoc outValue; + print_out_value_doc out_value; ])) rows); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ]) | Oval_string (txt, _sizeToPrint, _kind) -> - Doc.text (escapeStringContents txt) + Doc.text (escape_string_contents txt) | Oval_stuff txt -> Doc.text txt - | Oval_tuple outValues -> + | Oval_tuple out_values -> Doc.group (Doc.concat [ @@ -1050,19 +1001,19 @@ let rec printOutValueDoc (outValue : Outcometree.out_value) = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); + (List.map print_out_value_doc out_values); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ]) (* Not supported by ReScript *) | Oval_variant _ -> Doc.nil -let printOutExceptionDoc exc outValue = +let print_out_exception_doc exc out_value = match exc with | Sys.Break -> Doc.text "Interrupted." | Out_of_memory -> Doc.text "Out of memory during evaluation." @@ -1072,9 +1023,9 @@ let printOutExceptionDoc exc outValue = Doc.group (Doc.indent (Doc.concat - [Doc.text "Exception:"; Doc.line; printOutValueDoc outValue])) + [Doc.text "Exception:"; Doc.line; print_out_value_doc out_value])) -let printOutPhraseSignature signature = +let print_out_phrase_signature signature = let rec loop signature acc = match signature with | [] -> List.rev acc @@ -1101,65 +1052,65 @@ let printOutPhraseSignature signature = otyext_private = ext.oext_private; } in - let doc = printOutTypeExtensionDoc te in + let doc = print_out_type_extension_doc te in loop signature (doc :: acc) - | (sigItem, optOutValue) :: signature -> + | (sig_item, opt_out_value) :: signature -> let doc = - match optOutValue with - | None -> printOutSigItemDoc sigItem - | Some outValue -> + match opt_out_value with + | None -> print_out_sig_item_doc sig_item + | Some out_value -> Doc.group (Doc.concat [ - printOutSigItemDoc sigItem; + print_out_sig_item_doc sig_item; Doc.text " = "; - printOutValueDoc outValue; + print_out_value_doc out_value; ]) in loop signature (doc :: acc) in - Doc.breakableGroup ~forceBreak:true + Doc.breakable_group ~force_break:true (Doc.join ~sep:Doc.line (loop signature [])) -let printOutPhraseDoc (outPhrase : Outcometree.out_phrase) = - match outPhrase with - | Ophr_eval (outValue, outType) -> +let print_out_phrase_doc (out_phrase : Outcometree.out_phrase) = + match out_phrase with + | Ophr_eval (out_value, out_type) -> Doc.group (Doc.concat [ Doc.text "- : "; - printOutTypeDoc outType; + print_out_type_doc out_type; Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printOutValueDoc outValue]); + Doc.indent (Doc.concat [Doc.line; print_out_value_doc out_value]); ]) | Ophr_signature [] -> Doc.nil - | Ophr_signature signature -> printOutPhraseSignature signature - | Ophr_exception (exc, outValue) -> printOutExceptionDoc exc outValue + | Ophr_signature signature -> print_out_phrase_signature signature + | Ophr_exception (exc, out_value) -> print_out_exception_doc exc out_value -let printOutPhrase fmt outPhrase = +let print_out_phrase fmt out_phrase = Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutPhraseDoc outPhrase)) + (Doc.to_string ~width:80 (print_out_phrase_doc out_phrase)) -let printOutModuleType fmt outModuleType = +let print_out_module_type fmt out_module_type = Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutModuleTypeDoc outModuleType)) + (Doc.to_string ~width:80 (print_out_module_type_doc out_module_type)) -let printOutTypeExtension fmt typeExtension = +let print_out_type_extension fmt type_extension = Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutTypeExtensionDoc typeExtension)) + (Doc.to_string ~width:80 (print_out_type_extension_doc type_extension)) -let printOutValue fmt outValue = +let print_out_value fmt out_value = Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutValueDoc outValue)) + (Doc.to_string ~width:80 (print_out_value_doc out_value)) (* Not supported in ReScript *) (* Oprint.out_class_type *) let setup = lazy - (Oprint.out_value := printOutValue; - Oprint.out_type := printOutType; - Oprint.out_module_type := printOutModuleType; - Oprint.out_sig_item := printOutSigItem; - Oprint.out_signature := printOutSignature; - Oprint.out_type_extension := printOutTypeExtension; - Oprint.out_phrase := printOutPhrase) + (Oprint.out_value := print_out_value; + Oprint.out_type := print_out_type; + Oprint.out_module_type := print_out_module_type; + Oprint.out_sig_item := print_out_sig_item; + Oprint.out_signature := print_out_signature; + Oprint.out_type_extension := print_out_type_extension; + Oprint.out_phrase := print_out_phrase) diff --git a/analysis/vendor/res_syntax/res_outcome_printer.mli b/analysis/vendor/res_syntax/res_outcome_printer.mli index c51bb0931..609644e77 100644 --- a/analysis/vendor/res_syntax/res_outcome_printer.mli +++ b/analysis/vendor/res_syntax/res_outcome_printer.mli @@ -12,7 +12,7 @@ val parenthesized_ident : string -> bool [@@live] val setup : unit lazy_t [@@live] (* Needed for e.g. the playground to print typedtree data *) -val printOutTypeDoc : Outcometree.out_type -> Res_doc.t [@@live] -val printOutSigItemDoc : - ?printNameAsIs:bool -> Outcometree.out_sig_item -> Res_doc.t +val print_out_type_doc : Outcometree.out_type -> Res_doc.t [@@live] +val print_out_sig_item_doc : + ?print_name_as_is:bool -> Outcometree.out_sig_item -> Res_doc.t [@@live] diff --git a/analysis/vendor/res_syntax/res_parens.ml b/analysis/vendor/res_syntax/res_parens.ml index 5fc2ab9ff..bf946c315 100644 --- a/analysis/vendor/res_syntax/res_parens.ml +++ b/analysis/vendor/res_syntax/res_parens.ml @@ -2,9 +2,9 @@ module ParsetreeViewer = Res_parsetree_viewer type kind = Parenthesized | Braced of Location.t | Nothing let expr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | _ -> ( match expr with | { @@ -15,38 +15,38 @@ let expr expr = | {pexp_desc = Pexp_constraint _} -> Parenthesized | _ -> Nothing) -let exprRecordRowRhs e = +let expr_record_row_rhs e = let kind = expr e in match kind with - | Nothing when Res_parsetree_viewer.hasOptionalAttribute e.pexp_attributes + | Nothing when Res_parsetree_viewer.has_optional_attribute e.pexp_attributes -> ( match e.pexp_desc with | Pexp_ifthenelse _ | Pexp_fun _ -> Parenthesized | _ -> kind) | _ -> kind -let callExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc +let call_expr expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | _ -> ( match expr with | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with + when match ParsetreeViewer.filter_parsing_attrs attrs with | _ :: _ -> true | [] -> false -> Parenthesized | _ - when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> + when ParsetreeViewer.is_unary_expression expr + || ParsetreeViewer.is_binary_expression expr -> Parenthesized | { Parsetree.pexp_desc = Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); } -> Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.is_underscore_apply_sugar expr -> Nothing | { pexp_desc = @@ -55,20 +55,20 @@ let callExpr expr = | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); } -> Parenthesized - | _ when Ast_uncurried.exprIsUncurriedFun expr -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + | _ when Ast_uncurried.expr_is_uncurried_fun expr -> Parenthesized + | _ when ParsetreeViewer.has_await_attribute expr.pexp_attributes -> Parenthesized | _ -> Nothing) -let structureExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc +let structure_expr expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | _ - when ParsetreeViewer.hasAttributes expr.pexp_attributes - && not (ParsetreeViewer.isJsxExpression expr) -> + when ParsetreeViewer.has_attributes expr.pexp_attributes + && not (ParsetreeViewer.is_jsx_expression expr) -> Parenthesized | { Parsetree.pexp_desc = @@ -78,28 +78,28 @@ let structureExpr expr = | {pexp_desc = Pexp_constraint _} -> Parenthesized | _ -> Nothing) -let unaryExprOperand expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc +let unary_expr_operand expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with + when match ParsetreeViewer.filter_parsing_attrs attrs with | _ :: _ -> true | [] -> false -> Parenthesized | expr - when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> + when ParsetreeViewer.is_unary_expression expr + || ParsetreeViewer.is_binary_expression expr -> Parenthesized | { pexp_desc = Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); } -> Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.is_underscore_apply_sugar expr -> Nothing | { pexp_desc = @@ -109,14 +109,14 @@ let unaryExprOperand expr = | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); } -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + | _ when ParsetreeViewer.has_await_attribute expr.pexp_attributes -> Parenthesized | _ -> Nothing) -let binaryExprOperand ~isLhs expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc +let binary_expr_operand ~is_lhs expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | { @@ -124,81 +124,83 @@ let binaryExprOperand ~isLhs expr = Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); } -> Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.is_underscore_apply_sugar expr -> Nothing | { pexp_desc = Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _; } -> Parenthesized - | _ when Ast_uncurried.exprIsUncurriedFun expr -> Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized - | {pexp_desc = Pexp_lazy _ | Pexp_assert _} when isLhs -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + | _ when Ast_uncurried.expr_is_uncurried_fun expr -> Parenthesized + | expr when ParsetreeViewer.is_binary_expression expr -> Parenthesized + | expr when ParsetreeViewer.is_ternary_expr expr -> Parenthesized + | {pexp_desc = Pexp_lazy _ | Pexp_assert _} when is_lhs -> Parenthesized + | _ when ParsetreeViewer.has_await_attribute expr.pexp_attributes -> Parenthesized | {Parsetree.pexp_attributes = attrs} -> - if ParsetreeViewer.hasPrintableAttributes attrs then Parenthesized + if ParsetreeViewer.has_printable_attributes attrs then Parenthesized else Nothing) -let subBinaryExprOperand parentOperator childOperator = - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence childOperator in - precParent > precChild - || precParent == precChild - && not (ParsetreeViewer.flattenableOperators parentOperator childOperator) +let sub_binary_expr_operand parent_operator child_operator = + let prec_parent = ParsetreeViewer.operator_precedence parent_operator in + let prec_child = ParsetreeViewer.operator_precedence child_operator in + prec_parent > prec_child + || prec_parent == prec_child + && not + (ParsetreeViewer.flattenable_operators parent_operator child_operator) || (* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… *) - (parentOperator = "||" && childOperator = "&&") + (parent_operator = "||" && child_operator = "&&") -let rhsBinaryExprOperand parentOperator rhs = +let rhs_binary_expr_operand parent_operator rhs = match rhs.Parsetree.pexp_desc with | Parsetree.Pexp_apply ( { pexp_attributes = []; pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident {txt = Longident.Lident operator; loc = operator_loc}; }, [(_, _left); (_, _right)] ) - when ParsetreeViewer.isBinaryOperator operator - && not (operatorLoc.loc_ghost && operator = "^") -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent == precChild + when ParsetreeViewer.is_binary_operator operator + && not (operator_loc.loc_ghost && operator = "^") -> + let prec_parent = ParsetreeViewer.operator_precedence parent_operator in + let prec_child = ParsetreeViewer.operator_precedence operator in + prec_parent == prec_child | _ -> false -let flattenOperandRhs parentOperator rhs = +let flatten_operand_rhs parent_operator rhs = match rhs.Parsetree.pexp_desc with | Parsetree.Pexp_apply ( { pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident {txt = Longident.Lident operator; loc = operator_loc}; }, [(_, _left); (_, _right)] ) - when ParsetreeViewer.isBinaryOperator operator - && not (operatorLoc.loc_ghost && operator = "^") -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent >= precChild || rhs.pexp_attributes <> [] + when ParsetreeViewer.is_binary_operator operator + && not (operator_loc.loc_ghost && operator = "^") -> + let prec_parent = ParsetreeViewer.operator_precedence parent_operator in + let prec_child = ParsetreeViewer.operator_precedence operator in + prec_parent >= prec_child || rhs.pexp_attributes <> [] + | Pexp_construct ({txt = Lident "Function$"}, Some _) -> true | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> false - | Pexp_fun _ when ParsetreeViewer.isUnderscoreApplySugar rhs -> false + | Pexp_fun _ when ParsetreeViewer.is_underscore_apply_sugar rhs -> false | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_constraint _ -> true - | _ when ParsetreeViewer.isTernaryExpr rhs -> true + | _ when ParsetreeViewer.is_ternary_expr rhs -> true | _ -> false -let binaryOperatorInsideAwaitNeedsParens operator = - ParsetreeViewer.operatorPrecedence operator - < ParsetreeViewer.operatorPrecedence "|." +let binary_operator_inside_await_needs_parens operator = + ParsetreeViewer.operator_precedence operator + < ParsetreeViewer.operator_precedence "|." -let lazyOrAssertOrAwaitExprRhs ?(inAwait = false) expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc +let lazy_or_assert_or_await_expr_rhs ?(in_await = false) expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with + when match ParsetreeViewer.filter_parsing_attrs attrs with | _ :: _ -> true | [] -> false -> Parenthesized @@ -206,17 +208,17 @@ let lazyOrAssertOrAwaitExprRhs ?(inAwait = false) expr = pexp_desc = Pexp_apply ({pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, _); } - when ParsetreeViewer.isBinaryExpression expr -> - if inAwait && not (binaryOperatorInsideAwaitNeedsParens operator) then - Nothing + when ParsetreeViewer.is_binary_expression expr -> + if in_await && not (binary_operator_inside_await_needs_parens operator) + then Nothing else Parenthesized | { pexp_desc = Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); } -> Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.is_underscore_apply_sugar expr -> Nothing | { pexp_desc = @@ -226,43 +228,44 @@ let lazyOrAssertOrAwaitExprRhs ?(inAwait = false) expr = } -> Parenthesized | _ - when (not inAwait) - && ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + when (not in_await) + && ParsetreeViewer.has_await_attribute expr.pexp_attributes -> Parenthesized | _ -> Nothing) -let isNegativeConstant constant = - let isNeg txt = +let is_negative_constant constant = + let is_neg txt = let len = String.length txt in len > 0 && (String.get [@doesNotRaise]) txt 0 = '-' in match constant with - | (Parsetree.Pconst_integer (i, _) | Pconst_float (i, _)) when isNeg i -> true + | (Parsetree.Pconst_integer (i, _) | Pconst_float (i, _)) when is_neg i -> + true | _ -> false -let fieldExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc +let field_expr expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with + when match ParsetreeViewer.filter_parsing_attrs attrs with | _ :: _ -> true | [] -> false -> Parenthesized | expr - when ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isUnaryExpression expr -> + when ParsetreeViewer.is_binary_expression expr + || ParsetreeViewer.is_unary_expression expr -> Parenthesized | { pexp_desc = Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); } -> Nothing - | {pexp_desc = Pexp_constant c} when isNegativeConstant c -> Parenthesized - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> + | {pexp_desc = Pexp_constant c} when is_negative_constant c -> Parenthesized + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.is_underscore_apply_sugar expr -> Nothing | { pexp_desc = @@ -273,14 +276,14 @@ let fieldExpr expr = | Pexp_ifthenelse _ ); } -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + | _ when ParsetreeViewer.has_await_attribute expr.pexp_attributes -> Parenthesized | _ -> Nothing) -let setFieldExprRhs expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc +let set_field_expr_rhs expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | { @@ -291,10 +294,10 @@ let setFieldExprRhs expr = | {pexp_desc = Pexp_constraint _} -> Parenthesized | _ -> Nothing) -let ternaryOperand expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc +let ternary_operand expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | { @@ -303,31 +306,31 @@ let ternaryOperand expr = } -> Nothing | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ when Res_parsetree_viewer.isFunNewtype expr -> ( - let _uncurried, _attrsOnArrow, _parameters, returnExpr = - ParsetreeViewer.funExpr expr + | _ when Res_parsetree_viewer.is_fun_newtype expr -> ( + let _uncurried, _attrsOnArrow, _parameters, return_expr = + ParsetreeViewer.fun_expr expr in - match returnExpr.pexp_desc with + match return_expr.pexp_desc with | Pexp_constraint _ -> Parenthesized | _ -> Nothing) | _ -> Nothing) -let startsWithMinus txt = +let starts_with_minus txt = let len = String.length txt in if len == 0 then false else let s = (String.get [@doesNotRaise]) txt 0 in s = '-' -let jsxPropExpr expr = +let jsx_prop_expr expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_open _ -> Nothing | _ -> ( - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | { @@ -335,9 +338,9 @@ let jsxPropExpr expr = Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); pexp_attributes = []; } - when startsWithMinus x -> + when starts_with_minus x -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + | _ when ParsetreeViewer.has_await_attribute expr.pexp_attributes -> Parenthesized | { Parsetree.pexp_desc = @@ -357,15 +360,15 @@ let jsxPropExpr expr = Nothing | _ -> Parenthesized)) -let jsxChildExpr expr = +let jsx_child_expr expr = match expr.Parsetree.pexp_desc with | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ | Pexp_letmodule _ | Pexp_open _ -> Nothing | _ -> ( - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | _ -> ( match expr with | { @@ -373,9 +376,9 @@ let jsxChildExpr expr = Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); pexp_attributes = []; } - when startsWithMinus x -> + when starts_with_minus x -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> + | _ when ParsetreeViewer.has_await_attribute expr.pexp_attributes -> Parenthesized | { Parsetree.pexp_desc = @@ -393,22 +396,22 @@ let jsxChildExpr expr = pexp_attributes = []; } -> Nothing - | expr when ParsetreeViewer.isJsxExpression expr -> Nothing + | expr when ParsetreeViewer.is_jsx_expression expr -> Nothing | _ -> Parenthesized)) -let binaryExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc +let binary_expr expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc | None -> ( match expr with | {Parsetree.pexp_attributes = _ :: _} as expr - when ParsetreeViewer.isBinaryExpression expr -> + when ParsetreeViewer.is_binary_expression expr -> Parenthesized | _ -> Nothing) -let modTypeFunctorReturn modType = - match modType with +let mod_type_functor_return mod_type = + match mod_type with | {Parsetree.pmty_desc = Pmty_with _} -> true | _ -> false @@ -417,35 +420,35 @@ let modTypeFunctorReturn modType = This is actually: module type Functor = (SetLike => Set) with type t = A.t *) -let modTypeWithOperand modType = - match modType with +let mod_type_with_operand mod_type = + match mod_type with | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true | _ -> false -let modExprFunctorConstraint modType = - match modType with +let mod_expr_functor_constraint mod_type = + match mod_type with | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true | _ -> false -let bracedExpr expr = +let braced_expr expr = match expr.Parsetree.pexp_desc with | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> false | Pexp_constraint _ -> true | _ -> false -let includeModExpr modExpr = - match modExpr.Parsetree.pmod_desc with +let include_mod_expr mod_expr = + match mod_expr.Parsetree.pmod_desc with | Parsetree.Pmod_constraint _ -> true | _ -> false -let arrowReturnTypExpr typExpr = - match typExpr.Parsetree.ptyp_desc with +let arrow_return_typ_expr typ_expr = + match typ_expr.Parsetree.ptyp_desc with | Parsetree.Ptyp_arrow _ -> true - | _ when Ast_uncurried.coreTypeIsUncurriedFun typExpr -> true + | _ when Ast_uncurried.core_type_is_uncurried_fun typ_expr -> true | _ -> false -let patternRecordRowRhs (pattern : Parsetree.pattern) = +let pattern_record_row_rhs (pattern : Parsetree.pattern) = match pattern.ppat_desc with | Ppat_constraint ({ppat_desc = Ppat_unpack _}, {ptyp_desc = Ptyp_package _}) -> diff --git a/analysis/vendor/res_syntax/res_parens.mli b/analysis/vendor/res_syntax/res_parens.mli index 9b60b815f..28e35a634 100644 --- a/analysis/vendor/res_syntax/res_parens.mli +++ b/analysis/vendor/res_syntax/res_parens.mli @@ -1,39 +1,40 @@ type kind = Parenthesized | Braced of Location.t | Nothing val expr : Parsetree.expression -> kind -val structureExpr : Parsetree.expression -> kind +val structure_expr : Parsetree.expression -> kind -val unaryExprOperand : Parsetree.expression -> kind +val unary_expr_operand : Parsetree.expression -> kind -val binaryExprOperand : isLhs:bool -> Parsetree.expression -> kind -val subBinaryExprOperand : string -> string -> bool -val rhsBinaryExprOperand : string -> Parsetree.expression -> bool -val flattenOperandRhs : string -> Parsetree.expression -> bool +val binary_expr_operand : is_lhs:bool -> Parsetree.expression -> kind +val sub_binary_expr_operand : string -> string -> bool +val rhs_binary_expr_operand : string -> Parsetree.expression -> bool +val flatten_operand_rhs : string -> Parsetree.expression -> bool -val binaryOperatorInsideAwaitNeedsParens : string -> bool -val lazyOrAssertOrAwaitExprRhs : ?inAwait:bool -> Parsetree.expression -> kind +val binary_operator_inside_await_needs_parens : string -> bool +val lazy_or_assert_or_await_expr_rhs : + ?in_await:bool -> Parsetree.expression -> kind -val fieldExpr : Parsetree.expression -> kind +val field_expr : Parsetree.expression -> kind -val setFieldExprRhs : Parsetree.expression -> kind +val set_field_expr_rhs : Parsetree.expression -> kind -val ternaryOperand : Parsetree.expression -> kind +val ternary_operand : Parsetree.expression -> kind -val jsxPropExpr : Parsetree.expression -> kind -val jsxChildExpr : Parsetree.expression -> kind +val jsx_prop_expr : Parsetree.expression -> kind +val jsx_child_expr : Parsetree.expression -> kind -val binaryExpr : Parsetree.expression -> kind -val modTypeFunctorReturn : Parsetree.module_type -> bool -val modTypeWithOperand : Parsetree.module_type -> bool -val modExprFunctorConstraint : Parsetree.module_type -> bool +val binary_expr : Parsetree.expression -> kind +val mod_type_functor_return : Parsetree.module_type -> bool +val mod_type_with_operand : Parsetree.module_type -> bool +val mod_expr_functor_constraint : Parsetree.module_type -> bool -val bracedExpr : Parsetree.expression -> bool -val callExpr : Parsetree.expression -> kind +val braced_expr : Parsetree.expression -> bool +val call_expr : Parsetree.expression -> kind -val includeModExpr : Parsetree.module_expr -> bool +val include_mod_expr : Parsetree.module_expr -> bool -val arrowReturnTypExpr : Parsetree.core_type -> bool +val arrow_return_typ_expr : Parsetree.core_type -> bool -val patternRecordRowRhs : Parsetree.pattern -> bool +val pattern_record_row_rhs : Parsetree.pattern -> bool -val exprRecordRowRhs : Parsetree.expression -> kind +val expr_record_row_rhs : Parsetree.expression -> kind diff --git a/analysis/vendor/res_syntax/res_parser.ml b/analysis/vendor/res_syntax/res_parser.ml index ca39cfcf8..424629092 100644 --- a/analysis/vendor/res_syntax/res_parser.ml +++ b/analysis/vendor/res_syntax/res_parser.ml @@ -8,54 +8,54 @@ module Comment = Res_comment type mode = ParseForTypeChecker | Default -type regionStatus = Report | Silent +type region_status = Report | Silent type t = { mode: mode; mutable scanner: Scanner.t; mutable token: Token.t; - mutable startPos: Lexing.position; - mutable endPos: Lexing.position; - mutable prevEndPos: Lexing.position; + mutable start_pos: Lexing.position; + mutable end_pos: Lexing.position; + mutable prev_end_pos: Lexing.position; mutable breadcrumbs: (Grammar.t * Lexing.position) list; - mutable errors: Reporting.parseError list; + mutable errors: Reporting.parse_error list; mutable diagnostics: Diagnostics.t list; mutable comments: Comment.t list; - mutable regions: regionStatus ref list; + mutable regions: region_status ref list; mutable uncurried_config: Config.uncurried; } -let err ?startPos ?endPos p error = +let err ?start_pos ?end_pos p error = match p.regions with | ({contents = Report} as region) :: _ -> let d = Diagnostics.make - ~startPos: - (match startPos with + ~start_pos: + (match start_pos with | Some pos -> pos - | None -> p.startPos) - ~endPos: - (match endPos with + | None -> p.start_pos) + ~end_pos: + (match end_pos with | Some pos -> pos - | None -> p.endPos) + | None -> p.end_pos) error in p.diagnostics <- d :: p.diagnostics; region := Silent | _ -> () -let beginRegion p = p.regions <- ref Report :: p.regions -let endRegion p = +let begin_region p = p.regions <- ref Report :: p.regions +let end_region p = match p.regions with | [] -> () | _ :: rest -> p.regions <- rest -let docCommentToAttributeToken comment = +let doc_comment_to_attribute_token comment = let txt = Comment.txt comment in let loc = Comment.loc comment in Token.DocComment (loc, txt) -let moduleCommentToAttributeToken comment = +let module_comment_to_attribute_token comment = let txt = Comment.txt comment in let loc = Comment.loc comment in Token.ModuleComment (loc, txt) @@ -63,60 +63,62 @@ let moduleCommentToAttributeToken comment = (* Advance to the next non-comment token and store any encountered comment * in the parser's state. Every comment contains the end position of its * previous token to facilite comment interleaving *) -let rec next ?prevEndPos p = +let rec next ?prev_end_pos p = if p.token = Eof then assert false; - let prevEndPos = - match prevEndPos with + let prev_end_pos = + match prev_end_pos with | Some pos -> pos - | None -> p.endPos + | None -> p.end_pos in - let startPos, endPos, token = Scanner.scan p.scanner in + let start_pos, end_pos, token = Scanner.scan p.scanner in match token with | Comment c -> - if Comment.isDocComment c then ( - p.token <- docCommentToAttributeToken c; - p.prevEndPos <- prevEndPos; - p.startPos <- startPos; - p.endPos <- endPos) - else if Comment.isModuleComment c then ( - p.token <- moduleCommentToAttributeToken c; - p.prevEndPos <- prevEndPos; - p.startPos <- startPos; - p.endPos <- endPos) + if Comment.is_doc_comment c then ( + p.token <- doc_comment_to_attribute_token c; + p.prev_end_pos <- prev_end_pos; + p.start_pos <- start_pos; + p.end_pos <- end_pos) + else if Comment.is_module_comment c then ( + p.token <- module_comment_to_attribute_token c; + p.prev_end_pos <- prev_end_pos; + p.start_pos <- start_pos; + p.end_pos <- end_pos) else ( - Comment.setPrevTokEndPos c p.endPos; + Comment.set_prev_tok_end_pos c p.end_pos; p.comments <- c :: p.comments; - p.prevEndPos <- p.endPos; - p.endPos <- endPos; - next ~prevEndPos p) + p.prev_end_pos <- p.end_pos; + p.end_pos <- end_pos; + next ~prev_end_pos p) | _ -> p.token <- token; - p.prevEndPos <- prevEndPos; - p.startPos <- startPos; - p.endPos <- endPos + p.prev_end_pos <- prev_end_pos; + p.start_pos <- start_pos; + p.end_pos <- end_pos -let nextUnsafe p = if p.token <> Eof then next p +let next_unsafe p = if p.token <> Eof then next p -let nextTemplateLiteralToken p = - let startPos, endPos, token = Scanner.scanTemplateLiteralToken p.scanner in +let next_template_literal_token p = + let start_pos, end_pos, token = + Scanner.scan_template_literal_token p.scanner + in p.token <- token; - p.prevEndPos <- p.endPos; - p.startPos <- startPos; - p.endPos <- endPos + p.prev_end_pos <- p.end_pos; + p.start_pos <- start_pos; + p.end_pos <- end_pos -let checkProgress ~prevEndPos ~result p = - if p.endPos == prevEndPos then None else Some result +let check_progress ~prev_end_pos ~result p = + if p.end_pos == prev_end_pos then None else Some result let make ?(mode = ParseForTypeChecker) src filename = let scanner = Scanner.make ~filename src in - let parserState = + let parser_state = { mode; scanner; token = Token.Semicolon; - startPos = Lexing.dummy_pos; - prevEndPos = Lexing.dummy_pos; - endPos = Lexing.dummy_pos; + start_pos = Lexing.dummy_pos; + prev_end_pos = Lexing.dummy_pos; + end_pos = Lexing.dummy_pos; breadcrumbs = []; errors = []; diagnostics = []; @@ -125,18 +127,18 @@ let make ?(mode = ParseForTypeChecker) src filename = uncurried_config = !Config.uncurried; } in - parserState.scanner.err <- - (fun ~startPos ~endPos error -> - let diagnostic = Diagnostics.make ~startPos ~endPos error in - parserState.diagnostics <- diagnostic :: parserState.diagnostics); - next parserState; - parserState - -let leaveBreadcrumb p circumstance = - let crumb = (circumstance, p.startPos) in + parser_state.scanner.err <- + (fun ~start_pos ~end_pos error -> + let diagnostic = Diagnostics.make ~start_pos ~end_pos error in + parser_state.diagnostics <- diagnostic :: parser_state.diagnostics); + next parser_state; + parser_state + +let leave_breadcrumb p circumstance = + let crumb = (circumstance, p.start_pos) in p.breadcrumbs <- crumb :: p.breadcrumbs -let eatBreadcrumb p = +let eat_breadcrumb p = match p.breadcrumbs with | [] -> () | _ :: crumbs -> p.breadcrumbs <- crumbs @@ -150,8 +152,8 @@ let optional p token = let expect ?grammar token p = if p.token = token then next p else - let error = Diagnostics.expected ?grammar p.prevEndPos token in - err ~startPos:p.prevEndPos p error + let error = Diagnostics.expected ?grammar p.prev_end_pos token in + err ~start_pos:p.prev_end_pos p error (* Don't use immutable copies here, it trashes certain heuristics * in the ocaml compiler, resulting in massive slowdowns of the parser *) @@ -160,13 +162,13 @@ let lookahead p callback = let ch = p.scanner.ch in let offset = p.scanner.offset in let offset16 = p.scanner.offset16 in - let lineOffset = p.scanner.lineOffset in + let line_offset = p.scanner.line_offset in let lnum = p.scanner.lnum in let mode = p.scanner.mode in let token = p.token in - let startPos = p.startPos in - let endPos = p.endPos in - let prevEndPos = p.prevEndPos in + let start_pos = p.start_pos in + let end_pos = p.end_pos in + let prev_end_pos = p.prev_end_pos in let breadcrumbs = p.breadcrumbs in let errors = p.errors in let diagnostics = p.diagnostics in @@ -179,13 +181,13 @@ let lookahead p callback = p.scanner.ch <- ch; p.scanner.offset <- offset; p.scanner.offset16 <- offset16; - p.scanner.lineOffset <- lineOffset; + p.scanner.line_offset <- line_offset; p.scanner.lnum <- lnum; p.scanner.mode <- mode; p.token <- token; - p.startPos <- startPos; - p.endPos <- endPos; - p.prevEndPos <- prevEndPos; + p.start_pos <- start_pos; + p.end_pos <- end_pos; + p.prev_end_pos <- prev_end_pos; p.breadcrumbs <- breadcrumbs; p.errors <- errors; p.diagnostics <- diagnostics; diff --git a/analysis/vendor/res_syntax/res_parser.mli b/analysis/vendor/res_syntax/res_parser.mli index 9544a7cc2..9e1c73381 100644 --- a/analysis/vendor/res_syntax/res_parser.mli +++ b/analysis/vendor/res_syntax/res_parser.mli @@ -7,20 +7,20 @@ module Comment = Res_comment type mode = ParseForTypeChecker | Default -type regionStatus = Report | Silent +type region_status = Report | Silent type t = { mode: mode; mutable scanner: Scanner.t; mutable token: Token.t; - mutable startPos: Lexing.position; - mutable endPos: Lexing.position; - mutable prevEndPos: Lexing.position; + mutable start_pos: Lexing.position; + mutable end_pos: Lexing.position; + mutable prev_end_pos: Lexing.position; mutable breadcrumbs: (Grammar.t * Lexing.position) list; - mutable errors: Reporting.parseError list; + mutable errors: Reporting.parse_error list; mutable diagnostics: Diagnostics.t list; mutable comments: Comment.t list; - mutable regions: regionStatus ref list; + mutable regions: region_status ref list; mutable uncurried_config: Config.uncurried; } @@ -28,21 +28,21 @@ val make : ?mode:mode -> string -> string -> t val expect : ?grammar:Grammar.t -> Token.t -> t -> unit val optional : t -> Token.t -> bool -val next : ?prevEndPos:Lexing.position -> t -> unit -val nextUnsafe : t -> unit (* Does not assert on Eof, makes no progress *) -val nextTemplateLiteralToken : t -> unit +val next : ?prev_end_pos:Lexing.position -> t -> unit +val next_unsafe : t -> unit (* Does not assert on Eof, makes no progress *) +val next_template_literal_token : t -> unit val lookahead : t -> (t -> 'a) -> 'a val err : - ?startPos:Lexing.position -> - ?endPos:Lexing.position -> + ?start_pos:Lexing.position -> + ?end_pos:Lexing.position -> t -> Diagnostics.category -> unit -val leaveBreadcrumb : t -> Grammar.t -> unit -val eatBreadcrumb : t -> unit +val leave_breadcrumb : t -> Grammar.t -> unit +val eat_breadcrumb : t -> unit -val beginRegion : t -> unit -val endRegion : t -> unit +val begin_region : t -> unit +val end_region : t -> unit -val checkProgress : prevEndPos:Lexing.position -> result:'a -> t -> 'a option +val check_progress : prev_end_pos:Lexing.position -> result:'a -> t -> 'a option diff --git a/analysis/vendor/res_syntax/res_parsetree_viewer.ml b/analysis/vendor/res_syntax/res_parsetree_viewer.ml index 0186a7352..35e02d872 100644 --- a/analysis/vendor/res_syntax/res_parsetree_viewer.ml +++ b/analysis/vendor/res_syntax/res_parsetree_viewer.ml @@ -1,33 +1,33 @@ open Parsetree -let arrowType ?(arity = max_int) ct = - let rec process attrsBefore acc typ arity = +let arrow_type ?(arity = max_int) ct = + let rec process attrs_before acc typ arity = match typ with - | typ when arity <= 0 -> (attrsBefore, List.rev acc, typ) + | typ when arity <= 0 -> (attrs_before, List.rev acc, typ) | { ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); ptyp_attributes = []; } -> let arg = ([], lbl, typ1) in - process attrsBefore (arg :: acc) typ2 (arity - 1) + process attrs_before (arg :: acc) typ2 (arity - 1) | { ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = [({txt = "bs"}, _)]; } -> (* stop here, the uncurried attribute always indicates the beginning of an arrow function * e.g. `(. int) => (. int)` instead of `(. int, . int)` *) - (attrsBefore, List.rev acc, typ) + (attrs_before, List.rev acc, typ) | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} - as returnType -> + as return_type -> let args = List.rev acc in - (attrsBefore, args, returnType) + (attrs_before, args, return_type) | { ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2); ptyp_attributes = attrs; } -> let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 (arity - 1) - | typ -> (attrsBefore, List.rev acc, typ) + process attrs_before (arg :: acc) typ2 (arity - 1) + | typ -> (attrs_before, List.rev acc, typ) in match ct with | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as @@ -35,32 +35,32 @@ let arrowType ?(arity = max_int) ct = process attrs [] {typ with ptyp_attributes = []} arity | typ -> process [] [] typ arity -let functorType modtype = +let functor_type modtype = let rec process acc modtype = match modtype with | { - pmty_desc = Pmty_functor (lbl, argType, returnType); + pmty_desc = Pmty_functor (lbl, arg_type, return_type); pmty_attributes = attrs; } -> - let arg = (attrs, lbl, argType) in - process (arg :: acc) returnType - | modType -> (List.rev acc, modType) + let arg = (attrs, lbl, arg_type) in + process (arg :: acc) return_type + | mod_type -> (List.rev acc, mod_type) in process [] modtype -let processBsAttribute attrs = - let rec process bsSpotted acc attrs = +let process_bs_attribute attrs = + let rec process bs_spotted acc attrs = match attrs with - | [] -> (bsSpotted, List.rev acc) + | [] -> (bs_spotted, List.rev acc) | ({Location.txt = "bs"}, _) :: rest -> process true acc rest - | attr :: rest -> process bsSpotted (attr :: acc) rest + | attr :: rest -> process bs_spotted (attr :: acc) rest in process false [] attrs -let processUncurriedAppAttribute attrs = - let rec process uncurriedApp acc attrs = +let process_uncurried_app_attribute attrs = + let rec process uncurried_app acc attrs = match attrs with - | [] -> (uncurriedApp, List.rev acc) + | [] -> (uncurried_app, List.rev acc) | ( { Location.txt = "bs" (* still support @bs to convert .ml files *) | "res.uapp"; @@ -68,26 +68,26 @@ let processUncurriedAppAttribute attrs = _ ) :: rest -> process true acc rest - | attr :: rest -> process uncurriedApp (attr :: acc) rest + | attr :: rest -> process uncurried_app (attr :: acc) rest in process false [] attrs -let processPartialAppAttribute attrs = - let rec process partialApp acc attrs = +let process_partial_app_attribute attrs = + let rec process partial_app acc attrs = match attrs with - | [] -> (partialApp, List.rev acc) + | [] -> (partial_app, List.rev acc) | ({Location.txt = "res.partial"}, _) :: rest -> process true acc rest - | attr :: rest -> process partialApp (attr :: acc) rest + | attr :: rest -> process partial_app (attr :: acc) rest in process false [] attrs -type functionAttributesInfo = { +type function_attributes_info = { async: bool; bs: bool; attributes: Parsetree.attributes; } -let processFunctionAttributes attrs = +let process_function_attributes attrs = let rec process async bs acc attrs = match attrs with | [] -> {async; bs; attributes = List.rev acc} @@ -97,19 +97,19 @@ let processFunctionAttributes attrs = in process false false [] attrs -let hasAwaitAttribute attrs = +let has_await_attribute attrs = List.exists (function | {Location.txt = "res.await"}, _ -> true | _ -> false) attrs -let collectArrayExpressions expr = +let collect_array_expressions expr = match expr.pexp_desc with | Pexp_array exprs -> (exprs, None) | _ -> ([], Some expr) -let collectListExpressions expr = +let collect_list_expressions expr = let rec collect acc expr = match expr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> (List.rev acc, None) @@ -122,10 +122,10 @@ let collectListExpressions expr = collect [] expr (* (__x) => f(a, __x, c) -----> f(a, _, c) *) -let rewriteUnderscoreApply expr = +let rewrite_underscore_apply expr = let expr_fun = - if Ast_uncurried.exprIsUncurriedFun expr then - Ast_uncurried.exprExtractUncurriedFun expr + if Ast_uncurried.expr_is_uncurried_fun expr then + Ast_uncurried.expr_extract_uncurried_fun expr else expr in match expr_fun.pexp_desc with @@ -133,44 +133,44 @@ let rewriteUnderscoreApply expr = ( Nolabel, None, {ppat_desc = Ppat_var {txt = "__x"}}, - ({pexp_desc = Pexp_apply (callExpr, args)} as e) ) -> - let newArgs = + ({pexp_desc = Pexp_apply (call_expr, args)} as e) ) -> + let new_args = List.map (fun arg -> match arg with | ( lbl, ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} - as argExpr) ) -> + as arg_expr) ) -> ( lbl, { - argExpr with + arg_expr with pexp_desc = Pexp_ident {lid with txt = Longident.Lident "_"}; } ) | arg -> arg) args in - {e with pexp_desc = Pexp_apply (callExpr, newArgs)} + {e with pexp_desc = Pexp_apply (call_expr, new_args)} | _ -> expr -type funParamKind = +type fun_param_kind = | Parameter of { attrs: Parsetree.attributes; lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; + default_expr: Parsetree.expression option; pat: Parsetree.pattern; } | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} -let funExpr expr = +let fun_expr expr = (* Turns (type t, type u, type z) into "type t u z" *) - let rec collectNewTypes acc returnExpr = - match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} + let rec collect_new_types acc return_expr = + match return_expr with + | {pexp_desc = Pexp_newtype (string_loc, return_expr); pexp_attributes = []} -> - collectNewTypes (stringLoc :: acc) returnExpr - | returnExpr -> (List.rev acc, returnExpr) + collect_new_types (string_loc :: acc) return_expr + | return_expr -> (List.rev acc, return_expr) in - let rec collect ~uncurried ~nFun attrsBefore acc expr = + let rec collect ~uncurried ~n_fun attrs_before acc expr = match expr with | { pexp_desc = @@ -180,43 +180,45 @@ let funExpr expr = {ppat_desc = Ppat_var {txt = "__x"}}, {pexp_desc = Pexp_apply _} ); } -> - (uncurried, attrsBefore, List.rev acc, rewriteUnderscoreApply expr) - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let stringLocs, returnExpr = collectNewTypes [stringLoc] rest in - let param = NewTypes {attrs; locs = stringLocs} in - collect ~uncurried ~nFun attrsBefore (param :: acc) returnExpr + (uncurried, attrs_before, List.rev acc, rewrite_underscore_apply expr) + | {pexp_desc = Pexp_newtype (string_loc, rest); pexp_attributes = attrs} -> + let string_locs, return_expr = collect_new_types [string_loc] rest in + let param = NewTypes {attrs; locs = string_locs} in + collect ~uncurried ~n_fun attrs_before (param :: acc) return_expr | { - pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); + pexp_desc = Pexp_fun (lbl, default_expr, pattern, return_expr); pexp_attributes = []; } -> - let parameter = Parameter {attrs = []; lbl; defaultExpr; pat = pattern} in - collect ~uncurried ~nFun:(nFun + 1) attrsBefore (parameter :: acc) - returnExpr + let parameter = + Parameter {attrs = []; lbl; default_expr; pat = pattern} + in + collect ~uncurried ~n_fun:(n_fun + 1) attrs_before (parameter :: acc) + return_expr (* If a fun has an attribute, then it stops here and makes currying. i.e attributes outside of (...), uncurried `(.)` and `async` make currying *) - | {pexp_desc = Pexp_fun _} -> (uncurried, attrsBefore, List.rev acc, expr) - | expr when nFun = 0 && Ast_uncurried.exprIsUncurriedFun expr -> - let expr = Ast_uncurried.exprExtractUncurriedFun expr in - collect ~uncurried:true ~nFun attrsBefore acc expr - | expr -> (uncurried, attrsBefore, List.rev acc, expr) + | {pexp_desc = Pexp_fun _} -> (uncurried, attrs_before, List.rev acc, expr) + | expr when n_fun = 0 && Ast_uncurried.expr_is_uncurried_fun expr -> + let expr = Ast_uncurried.expr_extract_uncurried_fun expr in + collect ~uncurried:true ~n_fun attrs_before acc expr + | expr -> (uncurried, attrs_before, List.rev acc, expr) in match expr with | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> - collect ~uncurried:false ~nFun:0 expr.pexp_attributes [] + collect ~uncurried:false ~n_fun:0 expr.pexp_attributes [] {expr with pexp_attributes = []} - | _ when Ast_uncurried.exprIsUncurriedFun expr -> - let expr = Ast_uncurried.exprExtractUncurriedFun expr in - collect ~uncurried:true ~nFun:0 expr.pexp_attributes [] + | _ when Ast_uncurried.expr_is_uncurried_fun expr -> + let expr = Ast_uncurried.expr_extract_uncurried_fun expr in + collect ~uncurried:true ~n_fun:0 expr.pexp_attributes [] {expr with pexp_attributes = []} - | _ -> collect ~uncurried:false ~nFun:0 [] [] expr + | _ -> collect ~uncurried:false ~n_fun:0 [] [] expr -let processBracesAttr expr = +let process_braces_attr expr = match expr.pexp_attributes with | (({txt = "res.braces" | "ns.braces"}, _) as attr) :: attrs -> (Some attr, {expr with pexp_attributes = attrs}) | _ -> (None, expr) -let filterParsingAttrs attrs = +let filter_parsing_attrs attrs = List.filter (fun attr -> match attr with @@ -224,26 +226,27 @@ let filterParsingAttrs attrs = Location.txt = ( "bs" | "res.uapp" | "res.arity" | "res.braces" | "ns.braces" | "res.iflet" | "res.namedArgLoc" | "res.optional" | "res.ternary" - | "res.async" | "res.await" | "res.template" ); + | "res.async" | "res.await" | "res.template" + | "res.taggedTemplate" ); }, _ ) -> false | _ -> true) attrs -let isBlockExpr expr = +let is_block_expr expr = match expr.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ | Pexp_sequence _ -> true | _ -> false -let isBracedExpr expr = - match processBracesAttr expr with +let is_braced_expr expr = + match process_braces_attr expr with | Some _, _ -> true | _ -> false -let isMultilineText txt = +let is_multiline_text txt = let len = String.length txt in let rec check i = if i >= len then false @@ -256,36 +259,36 @@ let isMultilineText txt = in check 0 -let isHuggableExpression expr = +let is_huggable_expression expr = match expr.pexp_desc with | Pexp_array _ | Pexp_tuple _ | Pexp_constant (Pconst_string (_, Some _)) | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) - | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_extension ({txt = "obj"}, _) | Pexp_record _ -> true - | _ when isBlockExpr expr -> true - | _ when isBracedExpr expr -> true - | Pexp_constant (Pconst_string (txt, None)) when isMultilineText txt -> true + | _ when is_block_expr expr -> true + | _ when is_braced_expr expr -> true + | Pexp_constant (Pconst_string (txt, None)) when is_multiline_text txt -> true | _ -> false -let isHuggableRhs expr = +let is_huggable_rhs expr = match expr.pexp_desc with | Pexp_array _ | Pexp_tuple _ - | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_extension ({txt = "obj"}, _) | Pexp_record _ -> true - | _ when isBracedExpr expr -> true + | _ when is_braced_expr expr -> true | _ -> false -let isHuggablePattern pattern = +let is_huggable_pattern pattern = match pattern.ppat_desc with | Ppat_array _ | Ppat_tuple _ | Ppat_record _ | Ppat_variant _ | Ppat_construct _ -> true | _ -> false -let operatorPrecedence operator = +let operator_precedence operator = match operator with | ":=" -> 1 | "||" -> 2 @@ -297,22 +300,22 @@ let operatorPrecedence operator = | "#" | "##" | "|." | "|.u" -> 8 | _ -> 0 -let isUnaryOperator operator = +let is_unary_operator operator = match operator with | "~+" | "~+." | "~-" | "~-." | "not" -> true | _ -> false -let isUnaryExpression expr = +let is_unary_expression expr = match expr.pexp_desc with | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, [(Nolabel, _arg)] ) - when isUnaryOperator operator -> + when is_unary_operator operator -> true | _ -> false (* TODO: tweak this to check for ghost ^ as template literal *) -let isBinaryOperator operator = +let is_binary_operator operator = match operator with | ":=" | "||" | "&&" | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>" | "+" | "+." | "-" | "-." | "^" | "*" | "*." | "/" | "/." | "**" | "|." @@ -320,57 +323,59 @@ let isBinaryOperator operator = true | _ -> false -let isBinaryExpression expr = +let is_binary_expression expr = match expr.pexp_desc with | Pexp_apply ( { pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; + Pexp_ident {txt = Longident.Lident operator; loc = operator_loc}; }, [(Nolabel, _operand1); (Nolabel, _operand2)] ) - when isBinaryOperator operator - && not (operatorLoc.loc_ghost && operator = "^") + when is_binary_operator operator + && not (operator_loc.loc_ghost && operator = "^") (* template literal *) -> true | _ -> false -let isEqualityOperator operator = +let is_equality_operator operator = match operator with | "=" | "==" | "<>" | "!=" -> true | _ -> false -let isRhsBinaryOperator operator = +let is_rhs_binary_operator operator = match operator with | "**" -> true | _ -> false -let flattenableOperators parentOperator childOperator = - let precParent = operatorPrecedence parentOperator in - let precChild = operatorPrecedence childOperator in - if precParent == precChild then - not (isEqualityOperator parentOperator && isEqualityOperator childOperator) +let flattenable_operators parent_operator child_operator = + let prec_parent = operator_precedence parent_operator in + let prec_child = operator_precedence child_operator in + if prec_parent == prec_child then + not + (is_equality_operator parent_operator + && is_equality_operator child_operator) else false -let rec hasIfLetAttribute attrs = +let rec has_if_let_attribute attrs = match attrs with | [] -> false | ({Location.txt = "res.iflet"}, _) :: _ -> true - | _ :: attrs -> hasIfLetAttribute attrs + | _ :: attrs -> has_if_let_attribute attrs -let isIfLetExpr expr = +let is_if_let_expr expr = match expr with | {pexp_attributes = attrs; pexp_desc = Pexp_match _} - when hasIfLetAttribute attrs -> + when has_if_let_attribute attrs -> true | _ -> false -let rec hasOptionalAttribute attrs = +let rec has_optional_attribute attrs = match attrs with | [] -> false | ({Location.txt = "ns.optional" | "res.optional"}, _) :: _ -> true - | _ :: attrs -> hasOptionalAttribute attrs + | _ :: attrs -> has_optional_attribute attrs -let hasAttributes attrs = +let has_attributes attrs = List.exists (fun attr -> match attr with @@ -392,11 +397,11 @@ let hasAttributes attrs = ({pexp_desc = Pexp_constant (Pconst_string ("-4", None))}, _); }; ] ) -> - not (hasIfLetAttribute attrs) + not (has_if_let_attribute attrs) | _ -> true) attrs -let isArrayAccess expr = +let is_array_access expr = match expr.pexp_desc with | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, @@ -404,79 +409,81 @@ let isArrayAccess expr = true | _ -> false -type ifConditionKind = +type if_condition_kind = | If of Parsetree.expression | IfLet of Parsetree.pattern * Parsetree.expression -let collectIfExpressions expr = +let collect_if_expressions expr = let rec collect acc expr = - let exprLoc = expr.pexp_loc in + let expr_loc = expr.pexp_loc in match expr.pexp_desc with - | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) -> - collect ((exprLoc, If ifExpr, thenExpr) :: acc) elseExpr - | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) -> - let ifs = List.rev ((exprLoc, If ifExpr, thenExpr) :: acc) in - (ifs, elseExpr) + | Pexp_ifthenelse (if_expr, then_expr, Some else_expr) -> + collect ((expr_loc, If if_expr, then_expr) :: acc) else_expr + | Pexp_ifthenelse (if_expr, then_expr, (None as else_expr)) -> + let ifs = List.rev ((expr_loc, If if_expr, then_expr) :: acc) in + (ifs, else_expr) | Pexp_match ( condition, [ - {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; + {pc_lhs = pattern; pc_guard = None; pc_rhs = then_expr}; { pc_rhs = {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}; }; ] ) - when isIfLetExpr expr -> + when is_if_let_expr expr -> let ifs = - List.rev ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) + List.rev ((expr_loc, IfLet (pattern, condition), then_expr) :: acc) in (ifs, None) | Pexp_match ( condition, [ - {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; - {pc_rhs = elseExpr}; + {pc_lhs = pattern; pc_guard = None; pc_rhs = then_expr}; + {pc_rhs = else_expr}; ] ) - when isIfLetExpr expr -> - collect ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) elseExpr + when is_if_let_expr expr -> + collect + ((expr_loc, IfLet (pattern, condition), then_expr) :: acc) + else_expr | _ -> (List.rev acc, Some expr) in collect [] expr -let rec hasTernaryAttribute attrs = +let rec has_ternary_attribute attrs = match attrs with | [] -> false | ({Location.txt = "res.ternary"}, _) :: _ -> true - | _ :: attrs -> hasTernaryAttribute attrs + | _ :: attrs -> has_ternary_attribute attrs -let isTernaryExpr expr = +let is_ternary_expr expr = match expr with | {pexp_attributes = attrs; pexp_desc = Pexp_ifthenelse _} - when hasTernaryAttribute attrs -> + when has_ternary_attribute attrs -> true | _ -> false -let collectTernaryParts expr = +let collect_ternary_parts expr = let rec collect acc expr = match expr with | { pexp_attributes = attrs; pexp_desc = Pexp_ifthenelse (condition, consequent, Some alternate); } - when hasTernaryAttribute attrs -> + when has_ternary_attribute attrs -> collect ((condition, consequent) :: acc) alternate | alternate -> (List.rev acc, alternate) in collect [] expr -let parametersShouldHug parameters = +let parameters_should_hug parameters = match parameters with - | [Parameter {attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; pat}] - when isHuggablePattern pat -> + | [Parameter {attrs = []; lbl = Asttypes.Nolabel; default_expr = None; pat}] + when is_huggable_pattern pat -> true | _ -> false -let filterTernaryAttributes attrs = +let filter_ternary_attributes attrs = List.filter (fun attr -> match attr with @@ -484,7 +491,7 @@ let filterTernaryAttributes attrs = | _ -> true) attrs -let filterFragileMatchAttributes attrs = +let filter_fragile_match_attributes attrs = List.filter (fun attr -> match attr with @@ -501,7 +508,7 @@ let filterFragileMatchAttributes attrs = | _ -> true) attrs -let isJsxExpression expr = +let is_jsx_expression expr = let rec loop attrs = match attrs with | [] -> false @@ -512,7 +519,7 @@ let isJsxExpression expr = | Pexp_apply _ -> loop expr.Parsetree.pexp_attributes | _ -> false -let hasJsxAttribute attributes = +let has_jsx_attribute attributes = let rec loop attrs = match attrs with | [] -> false @@ -521,17 +528,17 @@ let hasJsxAttribute attributes = in loop attributes -let shouldIndentBinaryExpr expr = - let samePrecedenceSubExpression operator subExpression = - match subExpression with +let should_indent_binary_expr expr = + let same_precedence_sub_expression operator sub_expression = + match sub_expression with | { pexp_desc = Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}}, + ( {pexp_desc = Pexp_ident {txt = Longident.Lident sub_operator}}, [(Nolabel, _lhs); (Nolabel, _rhs)] ); } - when isBinaryOperator subOperator -> - flattenableOperators operator subOperator + when is_binary_operator sub_operator -> + flattenable_operators operator sub_operator | _ -> true in match expr with @@ -541,13 +548,13 @@ let shouldIndentBinaryExpr expr = ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, [(Nolabel, lhs); (Nolabel, _rhs)] ); } - when isBinaryOperator operator -> - isEqualityOperator operator - || (not (samePrecedenceSubExpression operator lhs)) + when is_binary_operator operator -> + is_equality_operator operator + || (not (same_precedence_sub_expression operator lhs)) || operator = ":=" | _ -> false -let shouldInlineRhsBinaryExpr rhs = +let should_inline_rhs_binary_expr rhs = match rhs.pexp_desc with | Parsetree.Pexp_constant _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_sequence _ | Pexp_open _ | Pexp_ifthenelse _ @@ -555,7 +562,7 @@ let shouldInlineRhsBinaryExpr rhs = true | _ -> false -let isPrintableAttribute attr = +let is_printable_attribute attr = match attr with | ( { Location.txt = @@ -567,71 +574,71 @@ let isPrintableAttribute attr = false | _ -> true -let hasPrintableAttributes attrs = List.exists isPrintableAttribute attrs +let has_printable_attributes attrs = List.exists is_printable_attribute attrs -let filterPrintableAttributes attrs = List.filter isPrintableAttribute attrs +let filter_printable_attributes attrs = List.filter is_printable_attribute attrs -let partitionPrintableAttributes attrs = - List.partition isPrintableAttribute attrs +let partition_printable_attributes attrs = + List.partition is_printable_attribute attrs -let isFunNewtype expr = +let is_fun_newtype expr = match expr.pexp_desc with | Pexp_fun _ | Pexp_newtype _ -> true - | _ -> Ast_uncurried.exprIsUncurriedFun expr + | _ -> Ast_uncurried.expr_is_uncurried_fun expr -let requiresSpecialCallbackPrintingLastArg args = +let requires_special_callback_printing_last_arg args = let rec loop args = match args with | [] -> false - | [(_, expr)] when isFunNewtype expr -> true - | (_, expr) :: _ when isFunNewtype expr -> false + | [(_, expr)] when is_fun_newtype expr -> true + | (_, expr) :: _ when is_fun_newtype expr -> false | _ :: rest -> loop rest in loop args -let requiresSpecialCallbackPrintingFirstArg args = +let requires_special_callback_printing_first_arg args = let rec loop args = match args with | [] -> true - | (_, expr) :: _ when isFunNewtype expr -> false + | (_, expr) :: _ when is_fun_newtype expr -> false | _ :: rest -> loop rest in match args with - | [(_, expr)] when isFunNewtype expr -> false - | (_, expr) :: rest when isFunNewtype expr -> loop rest + | [(_, expr)] when is_fun_newtype expr -> false + | (_, expr) :: rest when is_fun_newtype expr -> loop rest | _ -> false -let modExprApply modExpr = - let rec loop acc modExpr = - match modExpr with +let mod_expr_apply mod_expr = + let rec loop acc mod_expr = + match mod_expr with | {pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next - | _ -> (acc, modExpr) + | _ -> (acc, mod_expr) in - loop [] modExpr + loop [] mod_expr -let modExprFunctor modExpr = - let rec loop acc modExpr = - match modExpr with +let mod_expr_functor mod_expr = + let rec loop acc mod_expr = + match mod_expr with | { - pmod_desc = Pmod_functor (lbl, modType, returnModExpr); + pmod_desc = Pmod_functor (lbl, mod_type, return_mod_expr); pmod_attributes = attrs; } -> - let param = (attrs, lbl, modType) in - loop (param :: acc) returnModExpr - | returnModExpr -> (List.rev acc, returnModExpr) + let param = (attrs, lbl, mod_type) in + loop (param :: acc) return_mod_expr + | return_mod_expr -> (List.rev acc, return_mod_expr) in - loop [] modExpr + loop [] mod_expr -let rec collectPatternsFromListConstruct acc pattern = +let rec collect_patterns_from_list_construct acc pattern = let open Parsetree in match pattern.ppat_desc with | Ppat_construct ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) -> - collectPatternsFromListConstruct (pat :: acc) rest + collect_patterns_from_list_construct (pat :: acc) rest | _ -> (List.rev acc, pattern) -let hasTemplateLiteralAttr attrs = +let has_template_literal_attr attrs = List.exists (fun attr -> match attr with @@ -639,7 +646,7 @@ let hasTemplateLiteralAttr attrs = | _ -> false) attrs -let hasTaggedTemplateLiteralAttr attrs = +let has_tagged_template_literal_attr attrs = List.exists (fun attr -> match attr with @@ -647,24 +654,24 @@ let hasTaggedTemplateLiteralAttr attrs = | _ -> false) attrs -let isTemplateLiteral expr = +let is_template_literal expr = match expr.pexp_desc with | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, [(Nolabel, _); (Nolabel, _)] ) - when hasTemplateLiteralAttr expr.pexp_attributes -> + when has_template_literal_attr expr.pexp_attributes -> true | Pexp_constant (Pconst_string (_, Some "")) -> true - | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true + | Pexp_constant _ when has_template_literal_attr expr.pexp_attributes -> true | _ -> false -let isTaggedTemplateLiteral expr = +let is_tagged_template_literal expr = match expr with | {pexp_desc = Pexp_apply _; pexp_attributes = attrs} -> - hasTaggedTemplateLiteralAttr attrs + has_tagged_template_literal_attr attrs | _ -> false -let hasSpreadAttr attrs = +let has_spread_attr attrs = List.exists (fun attr -> match attr with @@ -672,7 +679,7 @@ let hasSpreadAttr attrs = | _ -> false) attrs -let isSpreadBeltListConcat expr = +let is_spread_belt_list_concat expr = match expr.pexp_desc with | Pexp_ident { @@ -680,10 +687,10 @@ let isSpreadBeltListConcat expr = Longident.Ldot (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany"); } -> - hasSpreadAttr expr.pexp_attributes + has_spread_attr expr.pexp_attributes | _ -> false -let isSpreadBeltArrayConcat expr = +let is_spread_belt_array_concat expr = match expr.pexp_desc with | Pexp_ident { @@ -691,11 +698,11 @@ let isSpreadBeltArrayConcat expr = Longident.Ldot (Longident.Ldot (Longident.Lident "Belt", "Array"), "concatMany"); } -> - hasSpreadAttr expr.pexp_attributes + has_spread_attr expr.pexp_attributes | _ -> false (* Blue | Red | Green -> [Blue; Red; Green] *) -let collectOrPatternChain pat = +let collect_or_pattern_chain pat = let rec loop pattern chain = match pattern.ppat_desc with | Ppat_or (left, right) -> loop left (right :: chain) @@ -703,7 +710,7 @@ let collectOrPatternChain pat = in loop pat [] -let isSinglePipeExpr expr = +let is_single_pipe_expr expr = (* handles: * x * ->Js.Dict.get("wm-property") @@ -716,7 +723,7 @@ let isSinglePipeExpr expr = * } * ) *) - let isPipeExpr expr = + let is_pipe_expr expr = match expr.pexp_desc with | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|.u" | "|>")}}, @@ -728,11 +735,11 @@ let isSinglePipeExpr expr = | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|.u" | "|>")}}, [(Nolabel, operand1); (Nolabel, _operand2)] ) - when not (isPipeExpr operand1) -> + when not (is_pipe_expr operand1) -> true | _ -> false -let isUnderscoreApplySugar expr = +let is_underscore_apply_sugar expr = match expr.pexp_desc with | Pexp_fun ( Nolabel, @@ -742,7 +749,7 @@ let isUnderscoreApplySugar expr = true | _ -> false -let isRewrittenUnderscoreApplySugar expr = +let is_rewritten_underscore_apply_sugar expr = match expr.pexp_desc with | Pexp_ident {txt = Longident.Lident "_"} -> true | _ -> false diff --git a/analysis/vendor/res_syntax/res_parsetree_viewer.mli b/analysis/vendor/res_syntax/res_parsetree_viewer.mli index 954638c06..d270e05e0 100644 --- a/analysis/vendor/res_syntax/res_parsetree_viewer.mli +++ b/analysis/vendor/res_syntax/res_parsetree_viewer.mli @@ -1,71 +1,72 @@ (* Restructures a nested tree of arrow types into its args & returnType * The parsetree contains: a => b => c => d, for printing purposes * we restructure the tree into (a, b, c) and its returnType d *) -val arrowType : +val arrow_type : ?arity:int -> Parsetree.core_type -> Parsetree.attributes * (Parsetree.attributes * Asttypes.arg_label * Parsetree.core_type) list * Parsetree.core_type -val functorType : +val functor_type : Parsetree.module_type -> (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list * Parsetree.module_type (* filters @bs out of the provided attributes *) -val processBsAttribute : Parsetree.attributes -> bool * Parsetree.attributes +val process_bs_attribute : Parsetree.attributes -> bool * Parsetree.attributes -val processUncurriedAppAttribute : +val process_uncurried_app_attribute : Parsetree.attributes -> bool * Parsetree.attributes -val processPartialAppAttribute : +val process_partial_app_attribute : Parsetree.attributes -> bool * Parsetree.attributes -type functionAttributesInfo = { +type function_attributes_info = { async: bool; bs: bool; attributes: Parsetree.attributes; } (* determines whether a function is async and/or uncurried based on the given attributes *) -val processFunctionAttributes : Parsetree.attributes -> functionAttributesInfo +val process_function_attributes : + Parsetree.attributes -> function_attributes_info -val hasAwaitAttribute : Parsetree.attributes -> bool +val has_await_attribute : Parsetree.attributes -> bool -type ifConditionKind = +type if_condition_kind = | If of Parsetree.expression | IfLet of Parsetree.pattern * Parsetree.expression (* if ... else if ... else ... is represented as nested expressions: if ... else { if ... } * The purpose of this function is to flatten nested ifs into one sequence. * Basically compute: ([if, else if, else if, else if], else) *) -val collectIfExpressions : +val collect_if_expressions : Parsetree.expression -> - (Location.t * ifConditionKind * Parsetree.expression) list + (Location.t * if_condition_kind * Parsetree.expression) list * Parsetree.expression option -val collectArrayExpressions : +val collect_array_expressions : Parsetree.expression -> Parsetree.expression list * Parsetree.expression option -val collectListExpressions : +val collect_list_expressions : Parsetree.expression -> Parsetree.expression list * Parsetree.expression option -type funParamKind = +type fun_param_kind = | Parameter of { attrs: Parsetree.attributes; lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; + default_expr: Parsetree.expression option; pat: Parsetree.pattern; } | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} -val funExpr : +val fun_expr : Parsetree.expression -> - bool * Parsetree.attributes * funParamKind list * Parsetree.expression + bool * Parsetree.attributes * fun_param_kind list * Parsetree.expression (* example: * `makeCoordinate({ @@ -73,53 +74,54 @@ val funExpr : * y: 2, * })` * Notice howe `({` and `})` "hug" or stick to each other *) -val isHuggableExpression : Parsetree.expression -> bool +val is_huggable_expression : Parsetree.expression -> bool -val isHuggablePattern : Parsetree.pattern -> bool +val is_huggable_pattern : Parsetree.pattern -> bool -val isHuggableRhs : Parsetree.expression -> bool +val is_huggable_rhs : Parsetree.expression -> bool -val operatorPrecedence : string -> int +val operator_precedence : string -> int -val isUnaryExpression : Parsetree.expression -> bool -val isBinaryOperator : string -> bool -val isBinaryExpression : Parsetree.expression -> bool -val isRhsBinaryOperator : string -> bool +val is_unary_expression : Parsetree.expression -> bool +val is_binary_operator : string -> bool +val is_binary_expression : Parsetree.expression -> bool +val is_rhs_binary_operator : string -> bool -val flattenableOperators : string -> string -> bool +val flattenable_operators : string -> string -> bool -val hasAttributes : Parsetree.attributes -> bool +val has_attributes : Parsetree.attributes -> bool -val isArrayAccess : Parsetree.expression -> bool -val isTernaryExpr : Parsetree.expression -> bool -val isIfLetExpr : Parsetree.expression -> bool +val is_array_access : Parsetree.expression -> bool +val is_ternary_expr : Parsetree.expression -> bool +val is_if_let_expr : Parsetree.expression -> bool -val collectTernaryParts : +val collect_ternary_parts : Parsetree.expression -> (Parsetree.expression * Parsetree.expression) list * Parsetree.expression -val parametersShouldHug : funParamKind list -> bool +val parameters_should_hug : fun_param_kind list -> bool -val filterTernaryAttributes : Parsetree.attributes -> Parsetree.attributes -val filterFragileMatchAttributes : Parsetree.attributes -> Parsetree.attributes +val filter_ternary_attributes : Parsetree.attributes -> Parsetree.attributes +val filter_fragile_match_attributes : + Parsetree.attributes -> Parsetree.attributes -val isJsxExpression : Parsetree.expression -> bool -val hasJsxAttribute : Parsetree.attributes -> bool -val hasOptionalAttribute : Parsetree.attributes -> bool +val is_jsx_expression : Parsetree.expression -> bool +val has_jsx_attribute : Parsetree.attributes -> bool +val has_optional_attribute : Parsetree.attributes -> bool -val shouldIndentBinaryExpr : Parsetree.expression -> bool -val shouldInlineRhsBinaryExpr : Parsetree.expression -> bool -val hasPrintableAttributes : Parsetree.attributes -> bool -val filterPrintableAttributes : Parsetree.attributes -> Parsetree.attributes -val partitionPrintableAttributes : +val should_indent_binary_expr : Parsetree.expression -> bool +val should_inline_rhs_binary_expr : Parsetree.expression -> bool +val has_printable_attributes : Parsetree.attributes -> bool +val filter_printable_attributes : Parsetree.attributes -> Parsetree.attributes +val partition_printable_attributes : Parsetree.attributes -> Parsetree.attributes * Parsetree.attributes -val requiresSpecialCallbackPrintingLastArg : +val requires_special_callback_printing_last_arg : (Asttypes.arg_label * Parsetree.expression) list -> bool -val requiresSpecialCallbackPrintingFirstArg : +val requires_special_callback_printing_first_arg : (Asttypes.arg_label * Parsetree.expression) list -> bool -val modExprApply : +val mod_expr_apply : Parsetree.module_expr -> Parsetree.module_expr list * Parsetree.module_expr (* Collection of utilities to view the ast in a more a convenient form, @@ -127,46 +129,46 @@ val modExprApply : * Example: given a ptyp_arrow type, what are its arguments and what is the * returnType? *) -val modExprFunctor : +val mod_expr_functor : Parsetree.module_expr -> (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list * Parsetree.module_expr -val collectPatternsFromListConstruct : +val collect_patterns_from_list_construct : Parsetree.pattern list -> Parsetree.pattern -> Parsetree.pattern list * Parsetree.pattern -val isBlockExpr : Parsetree.expression -> bool +val is_block_expr : Parsetree.expression -> bool -val isTemplateLiteral : Parsetree.expression -> bool -val isTaggedTemplateLiteral : Parsetree.expression -> bool -val hasTemplateLiteralAttr : Parsetree.attributes -> bool +val is_template_literal : Parsetree.expression -> bool +val is_tagged_template_literal : Parsetree.expression -> bool +val has_template_literal_attr : Parsetree.attributes -> bool -val isSpreadBeltListConcat : Parsetree.expression -> bool +val is_spread_belt_list_concat : Parsetree.expression -> bool -val isSpreadBeltArrayConcat : Parsetree.expression -> bool +val is_spread_belt_array_concat : Parsetree.expression -> bool -val collectOrPatternChain : Parsetree.pattern -> Parsetree.pattern list +val collect_or_pattern_chain : Parsetree.pattern -> Parsetree.pattern list -val processBracesAttr : +val process_braces_attr : Parsetree.expression -> Parsetree.attribute option * Parsetree.expression -val filterParsingAttrs : Parsetree.attributes -> Parsetree.attributes +val filter_parsing_attrs : Parsetree.attributes -> Parsetree.attributes -val isBracedExpr : Parsetree.expression -> bool +val is_braced_expr : Parsetree.expression -> bool -val isSinglePipeExpr : Parsetree.expression -> bool +val is_single_pipe_expr : Parsetree.expression -> bool (* (__x) => f(a, __x, c) -----> f(a, _, c) *) -val rewriteUnderscoreApply : Parsetree.expression -> Parsetree.expression +val rewrite_underscore_apply : Parsetree.expression -> Parsetree.expression (* (__x) => f(a, __x, c) -----> f(a, _, c) *) -val isUnderscoreApplySugar : Parsetree.expression -> bool +val is_underscore_apply_sugar : Parsetree.expression -> bool -val hasIfLetAttribute : Parsetree.attributes -> bool +val has_if_let_attribute : Parsetree.attributes -> bool -val isRewrittenUnderscoreApplySugar : Parsetree.expression -> bool +val is_rewritten_underscore_apply_sugar : Parsetree.expression -> bool -val isFunNewtype : Parsetree.expression -> bool +val is_fun_newtype : Parsetree.expression -> bool diff --git a/analysis/vendor/res_syntax/res_printer.ml b/analysis/vendor/res_syntax/res_printer.ml index 9c2ef4b66..f9d370af4 100644 --- a/analysis/vendor/res_syntax/res_printer.ml +++ b/analysis/vendor/res_syntax/res_printer.ml @@ -5,7 +5,7 @@ module Token = Res_token module Parens = Res_parens module ParsetreeViewer = Res_parsetree_viewer -type callbackStyle = +type callback_style = (* regular arrow function, example: `let f = x => x + 1` *) | NoCallback (* `Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument))` *) @@ -16,114 +16,71 @@ type callbackStyle = *) | ArgumentsFitOnOneLine -(* Since compiler version 8.3, the bs. prefix is no longer needed *) -(* Synced from - https://github.com/rescript-lang/rescript-compiler/blob/29174de1a5fde3b16cf05d10f5ac109cfac5c4ca/jscomp/frontend/ast_external_process.ml#L291-L367 *) -let convertBsExternalAttribute = function - | "bs.as" -> "as" - | "bs.deriving" -> "deriving" - | "bs.get" -> "get" - | "bs.get_index" -> "get_index" - | "bs.ignore" -> "ignore" - | "bs.inline" -> "inline" - | "bs.int" -> "int" - | "bs.meth" -> "meth" - | "bs.module" -> "module" - | "bs.new" -> "new" - | "bs.obj" -> "obj" - | "bs.optional" -> "optional" - | "bs.return" -> "return" - | "bs.send" -> "send" - | "bs.scope" -> "scope" - | "bs.set" -> "set" - | "bs.set_index" -> "set_index" - | "bs.splice" | "bs.variadic" -> "variadic" - | "bs.string" -> "string" - | "bs.this" -> "this" - | "bs.uncurry" -> "uncurry" - | "bs.unwrap" -> "unwrap" - | "bs.val" -> "val" - (* bs.send.pipe shouldn't be transformed *) - | txt -> txt - -(* These haven't been needed for a long time now *) -(* Synced from - https://github.com/rescript-lang/rescript-compiler/blob/29174de1a5fde3b16cf05d10f5ac109cfac5c4ca/jscomp/frontend/ast_exp_extension.ml *) -let convertBsExtension = function - | "bs.debugger" -> "debugger" - | "bs.external" -> "raw" - (* We should never see this one since we use the sugared object form, but still *) - | "bs.obj" -> "obj" - | "bs.raw" -> "raw" - | "bs.re" -> "re" - (* TODO: what about bs.time and bs.node? *) - | txt -> txt - -let addParens doc = +let add_parens doc = Doc.group (Doc.concat [ Doc.lparen; - Doc.indent (Doc.concat [Doc.softLine; doc]); - Doc.softLine; + Doc.indent (Doc.concat [Doc.soft_line; doc]); + Doc.soft_line; Doc.rparen; ]) -let addBraces doc = +let add_braces doc = Doc.group (Doc.concat [ Doc.lbrace; - Doc.indent (Doc.concat [Doc.softLine; doc]); - Doc.softLine; + Doc.indent (Doc.concat [Doc.soft_line; doc]); + Doc.soft_line; Doc.rbrace; ]) -let addAsync doc = Doc.concat [Doc.text "async "; doc] +let add_async doc = Doc.concat [Doc.text "async "; doc] -let getFirstLeadingComment tbl loc = +let get_first_leading_comment tbl loc = match Hashtbl.find tbl.CommentTable.leading loc with | comment :: _ -> Some comment | [] -> None | exception Not_found -> None (* Checks if `loc` has a leading line comment, i.e. `// comment above`*) -let hasLeadingLineComment tbl loc = - match getFirstLeadingComment tbl loc with - | Some comment -> Comment.isSingleLineComment comment +let has_leading_line_comment tbl loc = + match get_first_leading_comment tbl loc with + | Some comment -> Comment.is_single_line_comment comment | None -> false -let hasCommentBelow tbl loc = +let has_comment_below tbl loc = match Hashtbl.find tbl.CommentTable.trailing loc with | comment :: _ -> - let commentLoc = Comment.loc comment in - commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum + let comment_loc = Comment.loc comment in + comment_loc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum | [] -> false | exception Not_found -> false -let hasNestedJsxOrMoreThanOneChild expr = - let rec loop inRecursion expr = +let has_nested_jsx_or_more_than_one_child expr = + let rec loop in_recursion expr = match expr.Parsetree.pexp_desc with | Pexp_construct ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [hd; tail]}) -> - if inRecursion || ParsetreeViewer.isJsxExpression hd then true + if in_recursion || ParsetreeViewer.is_jsx_expression hd then true else loop true tail | _ -> false in loop false expr -let hasCommentsInside tbl loc = +let has_comments_inside tbl loc = match Hashtbl.find_opt tbl.CommentTable.inside loc with | None -> false | _ -> true -let hasTrailingComments tbl loc = +let has_trailing_comments tbl loc = match Hashtbl.find_opt tbl.CommentTable.trailing loc with | None -> false | _ -> true -let printMultilineCommentContent txt = +let print_multiline_comment_content txt = (* Turns * |* first line * * second line @@ -136,102 +93,103 @@ let printMultilineCommentContent txt = * What makes a comment suitable for this kind of indentation? * -> multiple lines + every line starts with a star *) - let rec indentStars lines acc = + let rec indent_stars lines acc = match lines with | [] -> Doc.nil - | [lastLine] -> - let line = String.trim lastLine in + | [last_line] -> + let line = String.trim last_line in let doc = Doc.text (" " ^ line) in - let trailingSpace = if line = "" then Doc.nil else Doc.space in - List.rev (trailingSpace :: doc :: acc) |> Doc.concat + let trailing_space = if line = "" then Doc.nil else Doc.space in + List.rev (trailing_space :: doc :: acc) |> Doc.concat | line :: lines -> let line = String.trim line in if line != "" && String.unsafe_get line 0 == '*' then let doc = Doc.text (" " ^ line) in - indentStars lines (Doc.hardLine :: doc :: acc) + indent_stars lines (Doc.hard_line :: doc :: acc) else - let trailingSpace = + let trailing_space = let len = String.length txt in if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space else Doc.nil in - let content = Comment.trimSpaces txt in - Doc.concat [Doc.text content; trailingSpace] + let content = Comment.trim_spaces txt in + Doc.concat [Doc.text content; trailing_space] in let lines = String.split_on_char '\n' txt in match lines with | [] -> Doc.text "/* */" | [line] -> Doc.concat - [Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */"] + [Doc.text "/* "; Doc.text (Comment.trim_spaces line); Doc.text " */"] | first :: rest -> - let firstLine = Comment.trimSpaces first in + let first_line = Comment.trim_spaces first in Doc.concat [ Doc.text "/*"; - (match firstLine with + (match first_line with | "" | "*" -> Doc.nil | _ -> Doc.space); - indentStars rest [Doc.hardLine; Doc.text firstLine]; + indent_stars rest [Doc.hard_line; Doc.text first_line]; Doc.text "*/"; ] -let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = - let singleLine = Comment.isSingleLineComment comment in +let print_trailing_comment (prev_loc : Location.t) (node_loc : Location.t) + comment = + let single_line = Comment.is_single_line_comment comment in let content = let txt = Comment.txt comment in - if singleLine then Doc.text ("//" ^ txt) - else printMultilineCommentContent txt + if single_line then Doc.text ("//" ^ txt) + else print_multiline_comment_content txt in let diff = - let cmtStart = (Comment.loc comment).loc_start in - cmtStart.pos_lnum - prevLoc.loc_end.pos_lnum + let cmt_start = (Comment.loc comment).loc_start in + cmt_start.pos_lnum - prev_loc.loc_end.pos_lnum in - let isBelow = - (Comment.loc comment).loc_start.pos_lnum > nodeLoc.loc_end.pos_lnum + let is_below = + (Comment.loc comment).loc_start.pos_lnum > node_loc.loc_end.pos_lnum in - if diff > 0 || isBelow then + if diff > 0 || is_below then Doc.concat [ - Doc.breakParent; - Doc.lineSuffix + Doc.break_parent; + Doc.line_suffix (Doc.concat [ - Doc.hardLine; - (if diff > 1 then Doc.hardLine else Doc.nil); + Doc.hard_line; + (if diff > 1 then Doc.hard_line else Doc.nil); content; ]); ] - else if not singleLine then Doc.concat [Doc.space; content] - else Doc.lineSuffix (Doc.concat [Doc.space; content]) + else if not single_line then Doc.concat [Doc.space; content] + else Doc.line_suffix (Doc.concat [Doc.space; content]) -let printLeadingComment ?nextComment comment = - let singleLine = Comment.isSingleLineComment comment in +let print_leading_comment ?next_comment comment = + let single_line = Comment.is_single_line_comment comment in let content = let txt = Comment.txt comment in - if singleLine then Doc.text ("//" ^ txt) - else printMultilineCommentContent txt + if single_line then Doc.text ("//" ^ txt) + else print_multiline_comment_content txt in let separator = Doc.concat [ - (if singleLine then Doc.concat [Doc.hardLine; Doc.breakParent] + (if single_line then Doc.concat [Doc.hard_line; Doc.break_parent] else Doc.nil); - (match nextComment with + (match next_comment with | Some next -> - let nextLoc = Comment.loc next in - let currLoc = Comment.loc comment in + let next_loc = Comment.loc next in + let curr_loc = Comment.loc comment in let diff = - nextLoc.Location.loc_start.pos_lnum - - currLoc.Location.loc_end.pos_lnum + next_loc.Location.loc_start.pos_lnum + - curr_loc.Location.loc_end.pos_lnum in - let nextSingleLine = Comment.isSingleLineComment next in - if singleLine && nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if singleLine && not nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else if diff == 1 then Doc.hardLine + let next_single_line = Comment.is_single_line_comment next in + if single_line && next_single_line then + if diff > 1 then Doc.hard_line else Doc.nil + else if single_line && not next_single_line then + if diff > 1 then Doc.hard_line else Doc.nil + else if diff > 1 then Doc.concat [Doc.hard_line; Doc.hard_line] + else if diff == 1 then Doc.hard_line else Doc.space | None -> Doc.nil); ] @@ -239,83 +197,84 @@ let printLeadingComment ?nextComment comment = Doc.concat [content; separator] (* This function is used for printing comments inside an empty block *) -let printCommentsInside cmtTbl loc = - let printComment comment = - let singleLine = Comment.isSingleLineComment comment in +let print_comments_inside cmt_tbl loc = + let print_comment comment = + let single_line = Comment.is_single_line_comment comment in let txt = Comment.txt comment in - if singleLine then Doc.text ("//" ^ txt) - else printMultilineCommentContent txt + if single_line then Doc.text ("//" ^ txt) + else print_multiline_comment_content txt in - let forceBreak = + let force_break = loc.Location.loc_start.pos_lnum <> loc.Location.loc_end.pos_lnum in let rec loop acc comments = match comments with | [] -> Doc.nil | [comment] -> - let cmtDoc = printComment comment in - let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in + let cmt_doc = print_comment comment in + let cmts_doc = Doc.concat (Doc.soft_line :: List.rev (cmt_doc :: acc)) in let doc = - Doc.breakableGroup ~forceBreak - (Doc.concat [Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine]) + Doc.breakable_group ~force_break + (Doc.concat + [Doc.if_breaks (Doc.indent cmts_doc) cmts_doc; Doc.soft_line]) in doc | comment :: rest -> - let cmtDoc = Doc.concat [printComment comment; Doc.line] in - loop (cmtDoc :: acc) rest + let cmt_doc = Doc.concat [print_comment comment; Doc.line] in + loop (cmt_doc :: acc) rest in - match Hashtbl.find cmtTbl.CommentTable.inside loc with + match Hashtbl.find cmt_tbl.CommentTable.inside loc with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside loc; + Hashtbl.remove cmt_tbl.inside loc; loop [] comments (* This function is used for printing comments inside an empty file *) -let printCommentsInsideFile cmtTbl = +let print_comments_inside_file cmt_tbl = let rec loop acc comments = match comments with | [] -> Doc.nil | [comment] -> - let cmtDoc = printLeadingComment comment in + let cmt_doc = print_leading_comment comment in let doc = - Doc.group (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc))]) + Doc.group (Doc.concat [Doc.concat (List.rev (cmt_doc :: acc))]) in doc - | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + | comment :: (next_comment :: _comments as rest) -> + let cmt_doc = print_leading_comment ~next_comment comment in + loop (cmt_doc :: acc) rest in - match Hashtbl.find cmtTbl.CommentTable.inside Location.none with + match Hashtbl.find cmt_tbl.CommentTable.inside Location.none with | exception Not_found -> Doc.nil | comments -> - Hashtbl.remove cmtTbl.inside Location.none; + Hashtbl.remove cmt_tbl.inside Location.none; Doc.group (loop [] comments) -let printLeadingComments node tbl loc = +let print_leading_comments node tbl loc = let rec loop acc comments = match comments with | [] -> node | [comment] -> - let cmtDoc = printLeadingComment comment in + let cmt_doc = print_leading_comment comment in let diff = loc.Location.loc_start.pos_lnum - (Comment.loc comment).Location.loc_end.pos_lnum in let separator = - if Comment.isSingleLineComment comment then - if diff > 1 then Doc.hardLine else Doc.nil + if Comment.is_single_line_comment comment then + if diff > 1 then Doc.hard_line else Doc.nil else if diff == 0 then Doc.space - else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.hardLine + else if diff > 1 then Doc.concat [Doc.hard_line; Doc.hard_line] + else Doc.hard_line in let doc = Doc.group - (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc)); separator; node]) + (Doc.concat [Doc.concat (List.rev (cmt_doc :: acc)); separator; node]) in doc - | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest + | comment :: (next_comment :: _comments as rest) -> + let cmt_doc = print_leading_comment ~next_comment comment in + loop (cmt_doc :: acc) rest in match Hashtbl.find tbl loc with | exception Not_found -> node @@ -325,13 +284,13 @@ let printLeadingComments node tbl loc = Hashtbl.remove tbl loc; loop [] comments -let printTrailingComments node tbl loc = +let print_trailing_comments node tbl loc = let rec loop prev acc comments = match comments with | [] -> Doc.concat (List.rev acc) | comment :: comments -> - let cmtDoc = printTrailingComment prev loc comment in - loop (Comment.loc comment) (cmtDoc :: acc) comments + let cmt_doc = print_trailing_comment prev loc comment in + loop (Comment.loc comment) (cmt_doc :: acc) comments in match Hashtbl.find tbl loc with | exception Not_found -> node @@ -340,109 +299,110 @@ let printTrailingComments node tbl loc = (* Remove comments from tbl: Some ast nodes have the same location. * We only want to print comments once *) Hashtbl.remove tbl loc; - let cmtsDoc = loop loc [] comments in - Doc.concat [node; cmtsDoc] + let cmts_doc = loop loc [] comments in + Doc.concat [node; cmts_doc] -let printComments doc (tbl : CommentTable.t) loc = - let docWithLeadingComments = printLeadingComments doc tbl.leading loc in - printTrailingComments docWithLeadingComments tbl.trailing loc +let print_comments doc (tbl : CommentTable.t) loc = + let doc_with_leading_comments = print_leading_comments doc tbl.leading loc in + print_trailing_comments doc_with_leading_comments tbl.trailing loc -let printList ~getLoc ~nodes ~print ?(forceBreak = false) t = - let rec loop (prevLoc : Location.t) acc nodes = +let print_list ~get_loc ~nodes ~print ?(force_break = false) t = + let rec loop (prev_loc : Location.t) acc nodes = match nodes with - | [] -> (prevLoc, Doc.concat (List.rev acc)) + | [] -> (prev_loc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with + let loc = get_loc node in + let start_pos = + match get_first_leading_comment t loc with | None -> loc.loc_start | Some comment -> (Comment.loc comment).loc_start in let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.hardLine + if start_pos.pos_lnum - prev_loc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hard_line; Doc.hard_line] + else Doc.hard_line in - let doc = printComments (print node t) t loc in + let doc = print_comments (print node t) t loc in loop loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t) t firstLoc in - let lastLoc, docs = loop firstLoc [doc] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + let first_loc = get_loc node in + let doc = print_comments (print node t) t first_loc in + let last_loc, docs = loop first_loc [doc] nodes in + let force_break = + force_break || first_loc.loc_start.pos_lnum != last_loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak docs + Doc.breakable_group ~force_break docs -let printListi ~getLoc ~nodes ~print ?(forceBreak = false) t = - let rec loop i (prevLoc : Location.t) acc nodes = +let print_listi ~get_loc ~nodes ~print ?(force_break = false) t = + let rec loop i (prev_loc : Location.t) acc nodes = match nodes with - | [] -> (prevLoc, Doc.concat (List.rev acc)) + | [] -> (prev_loc, Doc.concat (List.rev acc)) | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with + let loc = get_loc node in + let start_pos = + match get_first_leading_comment t loc with | None -> loc.loc_start | Some comment -> (Comment.loc comment).loc_start in let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] + if start_pos.pos_lnum - prev_loc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hard_line; Doc.hard_line] else Doc.line in - let doc = printComments (print node t i) t loc in + let doc = print_comments (print node t i) t loc in loop (i + 1) loc (doc :: sep :: acc) nodes in match nodes with | [] -> Doc.nil | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t 0) t firstLoc in - let lastLoc, docs = loop 1 firstLoc [doc] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + let first_loc = get_loc node in + let doc = print_comments (print node t 0) t first_loc in + let last_loc, docs = loop 1 first_loc [doc] nodes in + let force_break = + force_break || first_loc.loc_start.pos_lnum != last_loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak docs + Doc.breakable_group ~force_break docs -let rec printLongidentAux accu = function +let rec print_longident_aux accu = function | Longident.Lident s -> Doc.text s :: accu - | Ldot (lid, s) -> printLongidentAux (Doc.text s :: accu) lid + | Ldot (lid, s) -> print_longident_aux (Doc.text s :: accu) lid | Lapply (lid1, lid2) -> - let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in - let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in + let d1 = Doc.join ~sep:Doc.dot (print_longident_aux [] lid1) in + let d2 = Doc.join ~sep:Doc.dot (print_longident_aux [] lid2) in Doc.concat [d1; Doc.lparen; d2; Doc.rparen] :: accu -let printLongident = function +let print_longident = function | Longident.Lident txt -> Doc.text txt - | lid -> Doc.join ~sep:Doc.dot (printLongidentAux [] lid) + | lid -> Doc.join ~sep:Doc.dot (print_longident_aux [] lid) -type identifierStyle = ExoticIdent | NormalIdent +type identifier_style = ExoticIdent | NormalIdent -let classifyIdentContent ?(allowUident = false) ?(allowHyphen = false) txt = - if Token.isKeywordTxt txt then ExoticIdent +let classify_ident_content ?(allow_uident = false) ?(allow_hyphen = false) txt = + if Token.is_keyword_txt txt then ExoticIdent else let len = String.length txt in let rec loop i = if i == len then NormalIdent else if i == 0 then match String.unsafe_get txt i with - | 'A' .. 'Z' when allowUident -> loop (i + 1) + | 'A' .. 'Z' when allow_uident -> loop (i + 1) | 'a' .. 'z' | '_' -> loop (i + 1) - | '-' when allowHyphen -> loop (i + 1) + | '-' when allow_hyphen -> loop (i + 1) | _ -> ExoticIdent else match String.unsafe_get txt i with | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '\'' | '_' -> loop (i + 1) - | '-' when allowHyphen -> loop (i + 1) + | '-' when allow_hyphen -> loop (i + 1) | _ -> ExoticIdent in loop 0 -let printIdentLike ?allowUident ?allowHyphen txt = - match classifyIdentContent ?allowUident ?allowHyphen txt with +let print_ident_like ?allow_uident ?allow_hyphen txt = + let txt = Ext_ident.unwrap_uppercase_exotic txt in + match classify_ident_content ?allow_uident ?allow_hyphen txt with | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] | NormalIdent -> Doc.text txt @@ -456,7 +416,7 @@ let for_all_from s start p = unsafe_for_all_range s ~start ~finish:(len - 1) p (* See https://github.com/rescript-lang/rescript-compiler/blob/726cfa534314b586e5b5734471bc2023ad99ebd9/jscomp/ext/ext_string.ml#L510 *) -let isValidNumericPolyvarNumber (x : string) = +let is_valid_numeric_polyvar_number (x : string) = let len = String.length x in len > 0 && @@ -471,23 +431,24 @@ let isValidNumericPolyvarNumber (x : string) = else a >= 48 (* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) -let printPolyVarIdent txt = +let print_poly_var_ident txt = (* numeric poly-vars don't need quotes: #644 *) - if isValidNumericPolyvarNumber txt then Doc.text txt + if is_valid_numeric_polyvar_number txt then Doc.text txt else - match classifyIdentContent ~allowUident:true txt with + let txt = Ext_ident.unwrap_uppercase_exotic txt in + match classify_ident_content ~allow_uident:true txt with | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] | NormalIdent -> ( match txt with | "" -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] | _ -> Doc.text txt) -let polyVarIdentToString polyVarIdent = - Doc.concat [Doc.text "#"; printPolyVarIdent polyVarIdent] - |> Doc.toString ~width:80 +let polyvar_ident_to_string poly_var_ident = + Doc.concat [Doc.text "#"; print_poly_var_ident poly_var_ident] + |> Doc.to_string ~width:80 -let printLident l = - let flatLidOpt lid = +let print_lident l = + let flat_lid_opt lid = let rec flat accu = function | Longident.Lident s -> Some (s :: accu) | Ldot (lid, s) -> flat (s :: accu) lid @@ -496,64 +457,64 @@ let printLident l = flat [] lid in match l with - | Longident.Lident txt -> printIdentLike txt + | Longident.Lident txt -> print_ident_like txt | Longident.Ldot (path, txt) -> let doc = - match flatLidOpt path with + match flat_lid_opt path with | Some txts -> Doc.concat [ Doc.join ~sep:Doc.dot (List.map Doc.text txts); Doc.dot; - printIdentLike txt; + print_ident_like txt; ] | None -> Doc.text "printLident: Longident.Lapply is not supported" in doc | Lapply (_, _) -> Doc.text "printLident: Longident.Lapply is not supported" -let printLongidentLocation l cmtTbl = - let doc = printLongident l.Location.txt in - printComments doc cmtTbl l.loc +let print_longident_location l cmt_tbl = + let doc = print_longident l.Location.txt in + print_comments doc cmt_tbl l.loc (* Module.SubModule.x *) -let printLidentPath path cmtTbl = - let doc = printLident path.Location.txt in - printComments doc cmtTbl path.loc +let print_lident_path path cmt_tbl = + let doc = print_lident path.Location.txt in + print_comments doc cmt_tbl path.loc (* Module.SubModule.x or Module.SubModule.X *) -let printIdentPath path cmtTbl = - let doc = printLident path.Location.txt in - printComments doc cmtTbl path.loc +let print_ident_path path cmt_tbl = + let doc = print_lident path.Location.txt in + print_comments doc cmt_tbl path.loc -let printStringLoc sloc cmtTbl = - let doc = printIdentLike sloc.Location.txt in - printComments doc cmtTbl sloc.loc +let print_string_loc sloc cmt_tbl = + let doc = print_ident_like sloc.Location.txt in + print_comments doc cmt_tbl sloc.loc -let printStringContents txt = +let print_string_contents txt = let lines = String.split_on_char '\n' txt in - Doc.join ~sep:Doc.literalLine (List.map Doc.text lines) + Doc.join ~sep:Doc.literal_line (List.map Doc.text lines) -let printConstant ?(templateLiteral = false) c = +let print_constant ?(template_literal = false) c = match c with | Parsetree.Pconst_integer (s, suffix) -> ( match suffix with | Some c -> Doc.text (s ^ Char.escaped c) | None -> Doc.text s) | Pconst_string (txt, None) -> - Doc.concat [Doc.text "\""; printStringContents txt; Doc.text "\""] + Doc.concat [Doc.text "\""; print_string_contents txt; Doc.text "\""] | Pconst_string (txt, Some prefix) -> if prefix = "INTERNAL_RES_CHAR_CONTENTS" then Doc.concat [Doc.text "'"; Doc.text txt; Doc.text "'"] else let lquote, rquote = - if templateLiteral then ("`", "`") else ("\"", "\"") + if template_literal then ("`", "`") else ("\"", "\"") in Doc.concat [ (if prefix = "js" then Doc.nil else Doc.text prefix); Doc.text lquote; - printStringContents txt; + print_string_contents txt; Doc.text rquote; ] | Pconst_float (s, _) -> Doc.text s @@ -570,120 +531,122 @@ let printConstant ?(templateLiteral = false) c = let s = (Bytes.create [@doesNotRaise]) 1 in Bytes.unsafe_set s 0 c; Bytes.unsafe_to_string s - | _ -> Res_utf8.encodeCodePoint c + | _ -> Res_utf8.encode_code_point c in Doc.text ("'" ^ str ^ "'") -let printOptionalLabel attrs = - if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" +let print_optional_label attrs = + if Res_parsetree_viewer.has_optional_attribute attrs then Doc.text "?" else Doc.nil module State = struct - let customLayoutThreshold = 2 + let custom_layout_threshold = 2 - type t = {customLayout: int; mutable uncurried_config: Config.uncurried} + type t = {custom_layout: int; mutable uncurried_config: Config.uncurried} - let init () = {customLayout = 0; uncurried_config = !Config.uncurried} + let init () = {custom_layout = 0; uncurried_config = !Config.uncurried} - let nextCustomLayout t = {t with customLayout = t.customLayout + 1} + let next_custom_layout t = {t with custom_layout = t.custom_layout + 1} - let shouldBreakCallback t = t.customLayout > customLayoutThreshold + let should_break_callback t = t.custom_layout > custom_layout_threshold end -let rec printStructure ~state (s : Parsetree.structure) t = +let rec print_structure ~state (s : Parsetree.structure) t = match s with - | [] -> printCommentsInsideFile t + | [] -> print_comments_inside_file t | structure -> - printList - ~getLoc:(fun s -> s.Parsetree.pstr_loc) + print_list + ~get_loc:(fun s -> s.Parsetree.pstr_loc) ~nodes:structure - ~print:(printStructureItem ~state) + ~print:(print_structure_item ~state) t -and printStructureItem ~state (si : Parsetree.structure_item) cmtTbl = +and print_structure_item ~state (si : Parsetree.structure_item) cmt_tbl = match si.pstr_desc with - | Pstr_value (rec_flag, valueBindings) -> - let recFlag = + | Pstr_value (rec_flag, value_bindings) -> + let rec_flag = match rec_flag with | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - printValueBindings ~state ~recFlag valueBindings cmtTbl - | Pstr_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with + print_value_bindings ~state ~rec_flag value_bindings cmt_tbl + | Pstr_type (rec_flag, type_declarations) -> + let rec_flag = + match rec_flag with | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - printTypeDeclarations ~state ~recFlag typeDeclarations cmtTbl - | Pstr_primitive valueDescription -> - printValueDescription ~state valueDescription cmtTbl + print_type_declarations ~state ~rec_flag type_declarations cmt_tbl + | Pstr_primitive value_description -> + print_value_description ~state value_description cmt_tbl | Pstr_eval (expr, attrs) -> - let exprDoc = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.structureExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + let expr_doc = + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.structure_expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc in - Doc.concat [printAttributes ~state attrs cmtTbl; exprDoc] + Doc.concat [print_attributes ~state attrs cmt_tbl; expr_doc] | Pstr_attribute attr -> - fst (printAttribute ~state ~standalone:true attr cmtTbl) + fst (print_attribute ~state ~standalone:true attr cmt_tbl) | Pstr_extension (extension, attrs) -> Doc.concat [ - printAttributes ~state attrs cmtTbl; - Doc.concat [printExtension ~state ~atModuleLvl:true extension cmtTbl]; + print_attributes ~state attrs cmt_tbl; + Doc.concat + [print_extension ~state ~at_module_lvl:true extension cmt_tbl]; ] - | Pstr_include includeDeclaration -> - printIncludeDeclaration ~state includeDeclaration cmtTbl - | Pstr_open openDescription -> - printOpenDescription ~state openDescription cmtTbl - | Pstr_modtype modTypeDecl -> - printModuleTypeDeclaration ~state modTypeDecl cmtTbl - | Pstr_module moduleBinding -> - printModuleBinding ~state ~isRec:false moduleBinding cmtTbl 0 - | Pstr_recmodule moduleBindings -> - printListi - ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) - ~nodes:moduleBindings - ~print:(printModuleBinding ~state ~isRec:true) - cmtTbl - | Pstr_exception extensionConstructor -> - printExceptionDef ~state extensionConstructor cmtTbl - | Pstr_typext typeExtension -> printTypeExtension ~state typeExtension cmtTbl + | Pstr_include include_declaration -> + print_include_declaration ~state include_declaration cmt_tbl + | Pstr_open open_description -> + print_open_description ~state open_description cmt_tbl + | Pstr_modtype mod_type_decl -> + print_module_type_declaration ~state mod_type_decl cmt_tbl + | Pstr_module module_binding -> + print_module_binding ~state ~is_rec:false module_binding cmt_tbl 0 + | Pstr_recmodule module_bindings -> + print_listi + ~get_loc:(fun mb -> mb.Parsetree.pmb_loc) + ~nodes:module_bindings + ~print:(print_module_binding ~state ~is_rec:true) + cmt_tbl + | Pstr_exception extension_constructor -> + print_exception_def ~state extension_constructor cmt_tbl + | Pstr_typext type_extension -> + print_type_extension ~state type_extension cmt_tbl | Pstr_class _ | Pstr_class_type _ -> Doc.nil -and printTypeExtension ~state (te : Parsetree.type_extension) cmtTbl = +and print_type_extension ~state (te : Parsetree.type_extension) cmt_tbl = let prefix = Doc.text "type " in - let name = printLidentPath te.ptyext_path cmtTbl in - let typeParams = printTypeParams ~state te.ptyext_params cmtTbl in - let extensionConstructors = + let name = print_lident_path te.ptyext_path cmt_tbl in + let type_params = print_type_params ~state te.ptyext_params cmt_tbl in + let extension_constructors = let ecs = te.ptyext_constructors in - let forceBreak = + let force_break = match (ecs, List.rev ecs) with | first :: _, last :: _ -> first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum | _ -> false in - let privateFlag = + let private_flag = match te.ptyext_private with | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] | Public -> Doc.nil in let rows = - printListi - ~getLoc:(fun n -> n.Parsetree.pext_loc) - ~print:(printExtensionConstructor ~state) - ~nodes:ecs ~forceBreak cmtTbl + print_listi + ~get_loc:(fun n -> n.Parsetree.pext_loc) + ~print:(print_extension_constructor ~state) + ~nodes:ecs ~force_break cmt_tbl in - Doc.breakableGroup ~forceBreak + Doc.breakable_group ~force_break (Doc.indent (Doc.concat [ Doc.line; - privateFlag; + private_flag; rows; (* Doc.join ~sep:Doc.line ( *) (* List.mapi printExtensionConstructor ecs *) @@ -693,114 +656,119 @@ and printTypeExtension ~state (te : Parsetree.type_extension) cmtTbl = Doc.group (Doc.concat [ - printAttributes ~state ~loc:te.ptyext_path.loc te.ptyext_attributes - cmtTbl; + print_attributes ~state ~loc:te.ptyext_path.loc te.ptyext_attributes + cmt_tbl; prefix; name; - typeParams; + type_params; Doc.text " +="; - extensionConstructors; + extension_constructors; ]) -and printModuleBinding ~state ~isRec moduleBinding cmtTbl i = +and print_module_binding ~state ~is_rec module_binding cmt_tbl i = let prefix = if i = 0 then Doc.concat - [Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil)] + [Doc.text "module "; (if is_rec then Doc.text "rec " else Doc.nil)] else Doc.text "and " in - let modExprDoc, modConstraintDoc = - match moduleBinding.pmb_expr with - | {pmod_desc = Pmod_constraint (modExpr, modType)} + let mod_expr_doc, mod_constraint_doc = + match module_binding.pmb_expr with + | {pmod_desc = Pmod_constraint (mod_expr, mod_type)} when not - (ParsetreeViewer.hasAwaitAttribute - moduleBinding.pmb_expr.pmod_attributes) -> - ( printModExpr ~state modExpr cmtTbl, - Doc.concat [Doc.text ": "; printModType ~state modType cmtTbl] ) - | modExpr -> (printModExpr ~state modExpr cmtTbl, Doc.nil) + (ParsetreeViewer.has_await_attribute + module_binding.pmb_expr.pmod_attributes) -> + ( print_mod_expr ~state mod_expr cmt_tbl, + Doc.concat [Doc.text ": "; print_mod_type ~state mod_type cmt_tbl] ) + | mod_expr -> (print_mod_expr ~state mod_expr cmt_tbl, Doc.nil) in - let modName = - let doc = Doc.text moduleBinding.pmb_name.Location.txt in - printComments doc cmtTbl moduleBinding.pmb_name.loc + let mod_name = + let doc = Doc.text module_binding.pmb_name.Location.txt in + print_comments doc cmt_tbl module_binding.pmb_name.loc in let doc = Doc.concat [ - printAttributes ~state ~loc:moduleBinding.pmb_name.loc - moduleBinding.pmb_attributes cmtTbl; + print_attributes ~state ~loc:module_binding.pmb_name.loc + module_binding.pmb_attributes cmt_tbl; prefix; - modName; - modConstraintDoc; + mod_name; + mod_constraint_doc; Doc.text " = "; - modExprDoc; + mod_expr_doc; ] in - printComments doc cmtTbl moduleBinding.pmb_loc + print_comments doc cmt_tbl module_binding.pmb_loc -and printModuleTypeDeclaration ~state - (modTypeDecl : Parsetree.module_type_declaration) cmtTbl = - let modName = - let doc = Doc.text modTypeDecl.pmtd_name.txt in - printComments doc cmtTbl modTypeDecl.pmtd_name.loc +and print_module_type_declaration ~state + (mod_type_decl : Parsetree.module_type_declaration) cmt_tbl = + let mod_name = + let doc = Doc.text mod_type_decl.pmtd_name.txt in + print_comments doc cmt_tbl mod_type_decl.pmtd_name.loc in Doc.concat [ - printAttributes ~state modTypeDecl.pmtd_attributes cmtTbl; + print_attributes ~state mod_type_decl.pmtd_attributes cmt_tbl; Doc.text "module type "; - modName; - (match modTypeDecl.pmtd_type with + mod_name; + (match mod_type_decl.pmtd_type with | None -> Doc.nil - | Some modType -> - Doc.concat [Doc.text " = "; printModType ~state modType cmtTbl]); + | Some mod_type -> + Doc.concat [Doc.text " = "; print_mod_type ~state mod_type cmt_tbl]); ] -and printModType ~state modType cmtTbl = - let modTypeDoc = - match modType.pmty_desc with +and print_mod_type ~state mod_type cmt_tbl = + let mod_type_doc = + match mod_type.pmty_desc with | Parsetree.Pmty_ident longident -> Doc.concat [ - printAttributes ~state ~loc:longident.loc modType.pmty_attributes - cmtTbl; - printLongidentLocation longident cmtTbl; + print_attributes ~state ~loc:longident.loc mod_type.pmty_attributes + cmt_tbl; + print_longident_location longident cmt_tbl; ] | Pmty_signature [] -> - if hasCommentsInside cmtTbl modType.pmty_loc then - let doc = printCommentsInside cmtTbl modType.pmty_loc in + if has_comments_inside cmt_tbl mod_type.pmty_loc then + let doc = print_comments_inside cmt_tbl mod_type.pmty_loc in Doc.concat [Doc.lbrace; doc; Doc.rbrace] else - let shouldBreak = - modType.pmty_loc.loc_start.pos_lnum - < modType.pmty_loc.loc_end.pos_lnum + let should_break = + mod_type.pmty_loc.loc_start.pos_lnum + < mod_type.pmty_loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat [Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace]) + Doc.breakable_group ~force_break:should_break + (Doc.concat [Doc.lbrace; Doc.soft_line; Doc.soft_line; Doc.rbrace]) | Pmty_signature signature -> - let signatureDoc = - Doc.breakableGroup ~forceBreak:true + let signature_doc = + Doc.breakable_group ~force_break:true (Doc.concat [ Doc.lbrace; Doc.indent - (Doc.concat [Doc.line; printSignature ~state signature cmtTbl]); + (Doc.concat + [Doc.line; print_signature ~state signature cmt_tbl]); Doc.line; Doc.rbrace; ]) in Doc.concat - [printAttributes ~state modType.pmty_attributes cmtTbl; signatureDoc] + [ + print_attributes ~state mod_type.pmty_attributes cmt_tbl; signature_doc; + ] | Pmty_functor _ -> - let parameters, returnType = ParsetreeViewer.functorType modType in - let parametersDoc = + let parameters, return_type = ParsetreeViewer.functor_type mod_type in + let parameters_doc = match parameters with | [] -> Doc.nil - | [(attrs, {Location.txt = "_"; loc}, Some modType)] -> - let cmtLoc = - {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + | [(attrs, {Location.txt = "_"; loc}, Some mod_type)] -> + let cmt_loc = + {loc with loc_end = mod_type.Parsetree.pmty_loc.loc_end} in - let attrs = printAttributes ~state attrs cmtTbl in - let doc = Doc.concat [attrs; printModType ~state modType cmtTbl] in - printComments doc cmtTbl cmtLoc + let attrs = print_attributes ~state attrs cmt_tbl in + let doc = + Doc.concat [attrs; print_mod_type ~state mod_type cmt_tbl] + in + print_comments doc cmt_tbl cmt_loc | params -> Doc.group (Doc.concat @@ -809,76 +777,79 @@ and printModType ~state modType cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun (attrs, lbl, modType) -> - let cmtLoc = - match modType with + (fun (attrs, lbl, mod_type) -> + let cmt_loc = + match mod_type with | None -> lbl.Asttypes.loc - | Some modType -> + | Some mod_type -> { lbl.Asttypes.loc with loc_end = - modType.Parsetree.pmty_loc.loc_end; + mod_type.Parsetree.pmty_loc.loc_end; } in let attrs = - printAttributes ~state attrs cmtTbl + print_attributes ~state attrs cmt_tbl in - let lblDoc = + let lbl_doc = if lbl.Location.txt = "_" || lbl.txt = "*" then Doc.nil else let doc = Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc + print_comments doc cmt_tbl lbl.loc in let doc = Doc.concat [ attrs; - lblDoc; - (match modType with + lbl_doc; + (match mod_type with | None -> Doc.nil - | Some modType -> + | Some mod_type -> Doc.concat [ (if lbl.txt = "_" then Doc.nil else Doc.text ": "); - printModType ~state modType cmtTbl; + print_mod_type ~state mod_type + cmt_tbl; ]); ] in - printComments doc cmtTbl cmtLoc) + print_comments doc cmt_tbl cmt_loc) params); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ]) in - let returnDoc = - let doc = printModType ~state returnType cmtTbl in - if Parens.modTypeFunctorReturn returnType then addParens doc else doc + let return_doc = + let doc = print_mod_type ~state return_type cmt_tbl in + if Parens.mod_type_functor_return return_type then add_parens doc + else doc in Doc.group (Doc.concat [ - parametersDoc; - Doc.group (Doc.concat [Doc.text " =>"; Doc.line; returnDoc]); + parameters_doc; + Doc.group (Doc.concat [Doc.text " =>"; Doc.line; return_doc]); ]) - | Pmty_typeof modExpr -> + | Pmty_typeof mod_expr -> Doc.concat - [Doc.text "module type of "; printModExpr ~state modExpr cmtTbl] + [Doc.text "module type of "; print_mod_expr ~state mod_expr cmt_tbl] | Pmty_extension extension -> - printExtension ~state ~atModuleLvl:false extension cmtTbl + print_extension ~state ~at_module_lvl:false extension cmt_tbl | Pmty_alias longident -> - Doc.concat [Doc.text "module "; printLongidentLocation longident cmtTbl] - | Pmty_with (modType, withConstraints) -> + Doc.concat + [Doc.text "module "; print_longident_location longident cmt_tbl] + | Pmty_with (mod_type, with_constraints) -> let operand = - let doc = printModType ~state modType cmtTbl in - if Parens.modTypeWithOperand modType then addParens doc else doc + let doc = print_mod_type ~state mod_type cmt_tbl in + if Parens.mod_type_with_operand mod_type then add_parens doc else doc in Doc.group (Doc.concat @@ -886,228 +857,235 @@ and printModType ~state modType cmtTbl = operand; Doc.indent (Doc.concat - [Doc.line; printWithConstraints ~state withConstraints cmtTbl]); + [ + Doc.line; + print_with_constraints ~state with_constraints cmt_tbl; + ]); ]) in - let attrsAlreadyPrinted = - match modType.pmty_desc with + let attrs_already_printed = + match mod_type.pmty_desc with | Pmty_functor _ | Pmty_signature _ | Pmty_ident _ -> true | _ -> false in let doc = Doc.concat [ - (if attrsAlreadyPrinted then Doc.nil - else printAttributes ~state modType.pmty_attributes cmtTbl); - modTypeDoc; + (if attrs_already_printed then Doc.nil + else print_attributes ~state mod_type.pmty_attributes cmt_tbl); + mod_type_doc; ] in - printComments doc cmtTbl modType.pmty_loc + print_comments doc cmt_tbl mod_type.pmty_loc -and printWithConstraints ~state withConstraints cmtTbl = +and print_with_constraints ~state with_constraints cmt_tbl = let rows = List.mapi - (fun i withConstraint -> + (fun i with_constraint -> Doc.group (Doc.concat [ (if i == 0 then Doc.text "with " else Doc.text "and "); - printWithConstraint ~state withConstraint cmtTbl; + print_with_constraint ~state with_constraint cmt_tbl; ])) - withConstraints + with_constraints in Doc.join ~sep:Doc.line rows -and printWithConstraint ~state (withConstraint : Parsetree.with_constraint) - cmtTbl = - match withConstraint with +and print_with_constraint ~state (with_constraint : Parsetree.with_constraint) + cmt_tbl = + match with_constraint with (* with type X.t = ... *) - | Pwith_type (longident, typeDeclaration) -> + | Pwith_type (longident, type_declaration) -> Doc.group - (printTypeDeclaration ~state - ~name:(printLidentPath longident cmtTbl) - ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + (print_type_declaration ~state + ~name:(print_lident_path longident cmt_tbl) + ~equal_sign:"=" ~rec_flag:Doc.nil 0 type_declaration CommentTable.empty) (* with module X.Y = Z *) | Pwith_module ({txt = longident1}, {txt = longident2}) -> Doc.concat [ Doc.text "module "; - printLongident longident1; + print_longident longident1; Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printLongident longident2]); + Doc.indent (Doc.concat [Doc.line; print_longident longident2]); ] (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_typesubst (longident, typeDeclaration) -> + | Pwith_typesubst (longident, type_declaration) -> Doc.group - (printTypeDeclaration ~state - ~name:(printLidentPath longident cmtTbl) - ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) + (print_type_declaration ~state + ~name:(print_lident_path longident cmt_tbl) + ~equal_sign:":=" ~rec_flag:Doc.nil 0 type_declaration + CommentTable.empty) | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> Doc.concat [ Doc.text "module "; - printLongident longident1; + print_longident longident1; Doc.text " :="; - Doc.indent (Doc.concat [Doc.line; printLongident longident2]); + Doc.indent (Doc.concat [Doc.line; print_longident longident2]); ] -and printSignature ~state signature cmtTbl = +and print_signature ~state signature cmt_tbl = match signature with - | [] -> printCommentsInsideFile cmtTbl + | [] -> print_comments_inside_file cmt_tbl | signature -> - printList - ~getLoc:(fun s -> s.Parsetree.psig_loc) + print_list + ~get_loc:(fun s -> s.Parsetree.psig_loc) ~nodes:signature - ~print:(printSignatureItem ~state) - cmtTbl + ~print:(print_signature_item ~state) + cmt_tbl -and printSignatureItem ~state (si : Parsetree.signature_item) cmtTbl = +and print_signature_item ~state (si : Parsetree.signature_item) cmt_tbl = match si.psig_desc with - | Parsetree.Psig_value valueDescription -> - printValueDescription ~state valueDescription cmtTbl - | Psig_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with + | Parsetree.Psig_value value_description -> + print_value_description ~state value_description cmt_tbl + | Psig_type (rec_flag, type_declarations) -> + let rec_flag = + match rec_flag with | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - printTypeDeclarations ~state ~recFlag typeDeclarations cmtTbl - | Psig_typext typeExtension -> printTypeExtension ~state typeExtension cmtTbl - | Psig_exception extensionConstructor -> - printExceptionDef ~state extensionConstructor cmtTbl - | Psig_module moduleDeclaration -> - printModuleDeclaration ~state moduleDeclaration cmtTbl - | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations ~state moduleDeclarations cmtTbl - | Psig_modtype modTypeDecl -> - printModuleTypeDeclaration ~state modTypeDecl cmtTbl - | Psig_open openDescription -> - printOpenDescription ~state openDescription cmtTbl - | Psig_include includeDescription -> - printIncludeDescription ~state includeDescription cmtTbl + print_type_declarations ~state ~rec_flag type_declarations cmt_tbl + | Psig_typext type_extension -> + print_type_extension ~state type_extension cmt_tbl + | Psig_exception extension_constructor -> + print_exception_def ~state extension_constructor cmt_tbl + | Psig_module module_declaration -> + print_module_declaration ~state module_declaration cmt_tbl + | Psig_recmodule module_declarations -> + print_rec_module_declarations ~state module_declarations cmt_tbl + | Psig_modtype mod_type_decl -> + print_module_type_declaration ~state mod_type_decl cmt_tbl + | Psig_open open_description -> + print_open_description ~state open_description cmt_tbl + | Psig_include include_description -> + print_include_description ~state include_description cmt_tbl | Psig_attribute attr -> - fst (printAttribute ~state ~standalone:true attr cmtTbl) + fst (print_attribute ~state ~standalone:true attr cmt_tbl) | Psig_extension (extension, attrs) -> Doc.concat [ - printAttributes ~state attrs cmtTbl; - Doc.concat [printExtension ~state ~atModuleLvl:true extension cmtTbl]; + print_attributes ~state attrs cmt_tbl; + Doc.concat + [print_extension ~state ~at_module_lvl:true extension cmt_tbl]; ] | Psig_class _ | Psig_class_type _ -> Doc.nil -and printRecModuleDeclarations ~state moduleDeclarations cmtTbl = - printListi - ~getLoc:(fun n -> n.Parsetree.pmd_loc) - ~nodes:moduleDeclarations - ~print:(printRecModuleDeclaration ~state) - cmtTbl +and print_rec_module_declarations ~state module_declarations cmt_tbl = + print_listi + ~get_loc:(fun n -> n.Parsetree.pmd_loc) + ~nodes:module_declarations + ~print:(print_rec_module_declaration ~state) + cmt_tbl -and printRecModuleDeclaration ~state md cmtTbl i = +and print_rec_module_declaration ~state md cmt_tbl i = let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] + Doc.concat [Doc.text " = "; print_longident_location longident cmt_tbl] | _ -> - let needsParens = + let needs_parens = match md.pmd_type.pmty_desc with | Pmty_with _ -> true | _ -> false in - let modTypeDoc = - let doc = printModType ~state md.pmd_type cmtTbl in - if needsParens then addParens doc else doc + let mod_type_doc = + let doc = print_mod_type ~state md.pmd_type cmt_tbl in + if needs_parens then add_parens doc else doc in - Doc.concat [Doc.text ": "; modTypeDoc] + Doc.concat [Doc.text ": "; mod_type_doc] in let prefix = if i < 1 then "module rec " else "and " in Doc.concat [ - printAttributes ~state ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + print_attributes ~state ~loc:md.pmd_name.loc md.pmd_attributes cmt_tbl; Doc.text prefix; - printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; + print_comments (Doc.text md.pmd_name.txt) cmt_tbl md.pmd_name.loc; body; ] -and printModuleDeclaration ~state (md : Parsetree.module_declaration) cmtTbl = +and print_module_declaration ~state (md : Parsetree.module_declaration) cmt_tbl + = let body = match md.pmd_type.pmty_desc with | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] - | _ -> Doc.concat [Doc.text ": "; printModType ~state md.pmd_type cmtTbl] + Doc.concat [Doc.text " = "; print_longident_location longident cmt_tbl] + | _ -> Doc.concat [Doc.text ": "; print_mod_type ~state md.pmd_type cmt_tbl] in Doc.concat [ - printAttributes ~state ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + print_attributes ~state ~loc:md.pmd_name.loc md.pmd_attributes cmt_tbl; Doc.text "module "; - printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; + print_comments (Doc.text md.pmd_name.txt) cmt_tbl md.pmd_name.loc; body; ] -and printOpenDescription ~state (openDescription : Parsetree.open_description) - cmtTbl = +and print_open_description ~state + (open_description : Parsetree.open_description) cmt_tbl = Doc.concat [ - printAttributes ~state openDescription.popen_attributes cmtTbl; + print_attributes ~state open_description.popen_attributes cmt_tbl; Doc.text "open"; - (match openDescription.popen_override with + (match open_description.popen_override with | Asttypes.Fresh -> Doc.space | Asttypes.Override -> Doc.text "! "); - printLongidentLocation openDescription.popen_lid cmtTbl; + print_longident_location open_description.popen_lid cmt_tbl; ] -and printIncludeDescription ~state - (includeDescription : Parsetree.include_description) cmtTbl = +and print_include_description ~state + (include_description : Parsetree.include_description) cmt_tbl = Doc.concat [ - printAttributes ~state includeDescription.pincl_attributes cmtTbl; + print_attributes ~state include_description.pincl_attributes cmt_tbl; Doc.text "include "; - printModType ~state includeDescription.pincl_mod cmtTbl; + print_mod_type ~state include_description.pincl_mod cmt_tbl; ] -and printIncludeDeclaration ~state - (includeDeclaration : Parsetree.include_declaration) cmtTbl = +and print_include_declaration ~state + (include_declaration : Parsetree.include_declaration) cmt_tbl = Doc.concat [ - printAttributes ~state includeDeclaration.pincl_attributes cmtTbl; + print_attributes ~state include_declaration.pincl_attributes cmt_tbl; Doc.text "include "; - (let includeDoc = - printModExpr ~state includeDeclaration.pincl_mod cmtTbl + (let include_doc = + print_mod_expr ~state include_declaration.pincl_mod cmt_tbl in - if Parens.includeModExpr includeDeclaration.pincl_mod then - addParens includeDoc - else includeDoc); + if Parens.include_mod_expr include_declaration.pincl_mod then + add_parens include_doc + else include_doc); ] -and printValueBindings ~state ~recFlag (vbs : Parsetree.value_binding list) - cmtTbl = - printListi - ~getLoc:(fun vb -> vb.Parsetree.pvb_loc) +and print_value_bindings ~state ~rec_flag (vbs : Parsetree.value_binding list) + cmt_tbl = + print_listi + ~get_loc:(fun vb -> vb.Parsetree.pvb_loc) ~nodes:vbs - ~print:(printValueBinding ~state ~recFlag) - cmtTbl + ~print:(print_value_binding ~state ~rec_flag) + cmt_tbl -and printValueDescription ~state valueDescription cmtTbl = - let isExternal = - match valueDescription.pval_prim with +and print_value_description ~state value_description cmt_tbl = + let is_external = + match value_description.pval_prim with | [] -> false | _ -> true in let attrs = - printAttributes ~state ~loc:valueDescription.pval_name.loc - valueDescription.pval_attributes cmtTbl + print_attributes ~state ~loc:value_description.pval_name.loc + value_description.pval_attributes cmt_tbl in - let header = if isExternal then "external " else "let " in + let header = if is_external then "external " else "let " in Doc.group (Doc.concat [ attrs; Doc.text header; - printComments - (printIdentLike valueDescription.pval_name.txt) - cmtTbl valueDescription.pval_name.loc; + print_comments + (print_ident_like value_description.pval_name.txt) + cmt_tbl value_description.pval_name.loc; Doc.text ": "; - printTypExpr ~state valueDescription.pval_type cmtTbl; - (if isExternal then + print_typ_expr ~state value_description.pval_type cmt_tbl; + (if is_external then Doc.group (Doc.concat [ @@ -1121,18 +1099,18 @@ and printValueDescription ~state valueDescription cmtTbl = (fun s -> Doc.concat [Doc.text "\""; Doc.text s; Doc.text "\""]) - valueDescription.pval_prim); + value_description.pval_prim); ]); ]) else Doc.nil); ]) -and printTypeDeclarations ~state ~recFlag typeDeclarations cmtTbl = - printListi - ~getLoc:(fun n -> n.Parsetree.ptype_loc) - ~nodes:typeDeclarations - ~print:(printTypeDeclaration2 ~state ~recFlag) - cmtTbl +and print_type_declarations ~state ~rec_flag type_declarations cmt_tbl = + print_listi + ~get_loc:(fun n -> n.Parsetree.ptype_loc) + ~nodes:type_declarations + ~print:(print_type_declaration2 ~state ~rec_flag) + cmt_tbl (* * type_declaration = { @@ -1166,17 +1144,17 @@ and printTypeDeclarations ~state ~recFlag typeDeclarations cmtTbl = * (* Invariant: non-empty list *) * | Ptype_open *) -and printTypeDeclaration ~state ~name ~equalSign ~recFlag i - (td : Parsetree.type_declaration) cmtTbl = +and print_type_declaration ~state ~name ~equal_sign ~rec_flag i + (td : Parsetree.type_declaration) cmt_tbl = let attrs = - printAttributes ~state ~loc:td.ptype_loc td.ptype_attributes cmtTbl + print_attributes ~state ~loc:td.ptype_loc td.ptype_attributes cmt_tbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] + if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; rec_flag] in - let typeName = name in - let typeParams = printTypeParams ~state td.ptype_params cmtTbl in - let manifestAndKind = + let type_name = name in + let type_params = print_type_params ~state td.ptype_params cmt_tbl in + let manifest_and_kind = match td.ptype_kind with | Ptype_abstract -> ( match td.ptype_manifest with @@ -1184,15 +1162,15 @@ and printTypeDeclaration ~state ~name ~equalSign ~recFlag i | Some typ -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printTypExpr ~state typ cmtTbl; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; + print_typ_expr ~state typ cmt_tbl; ]) | Ptype_open -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; Doc.text ".."; ] | Ptype_record lds -> @@ -1202,16 +1180,16 @@ and printTypeDeclaration ~state ~name ~equalSign ~recFlag i | Some typ -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~state typ cmtTbl; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_typ_expr ~state typ cmt_tbl; ] in Doc.concat [ manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~state lds cmtTbl; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; + print_record_declaration ~state lds cmt_tbl; ] | Ptype_variant cds -> let manifest = @@ -1220,39 +1198,39 @@ and printTypeDeclaration ~state ~name ~equalSign ~recFlag i | Some typ -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~state typ cmtTbl; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_typ_expr ~state typ cmt_tbl; ] in Doc.concat [ manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~state ~privateFlag:td.ptype_private cds - cmtTbl; + Doc.concat [Doc.space; Doc.text equal_sign]; + print_constructor_declarations ~state ~private_flag:td.ptype_private + cds cmt_tbl; ] in - let constraints = printTypeDefinitionConstraints ~state td.ptype_cstrs in + let constraints = print_type_definition_constraints ~state td.ptype_cstrs in Doc.group (Doc.concat - [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) + [attrs; prefix; type_name; type_params; manifest_and_kind; constraints]) -and printTypeDeclaration2 ~state ~recFlag (td : Parsetree.type_declaration) - cmtTbl i = +and print_type_declaration2 ~state ~rec_flag (td : Parsetree.type_declaration) + cmt_tbl i = let name = - let doc = printIdentLike td.Parsetree.ptype_name.txt in - printComments doc cmtTbl td.ptype_name.loc + let doc = print_ident_like td.Parsetree.ptype_name.txt in + print_comments doc cmt_tbl td.ptype_name.loc in - let equalSign = "=" in + let equal_sign = "=" in let attrs = - printAttributes ~state ~loc:td.ptype_loc td.ptype_attributes cmtTbl + print_attributes ~state ~loc:td.ptype_loc td.ptype_attributes cmt_tbl in let prefix = - if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] + if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; rec_flag] in - let typeName = name in - let typeParams = printTypeParams ~state td.ptype_params cmtTbl in - let manifestAndKind = + let type_name = name in + let type_params = print_type_params ~state td.ptype_params cmt_tbl in + let manifest_and_kind = match td.ptype_kind with | Ptype_abstract -> ( match td.ptype_manifest with @@ -1260,15 +1238,15 @@ and printTypeDeclaration2 ~state ~recFlag (td : Parsetree.type_declaration) | Some typ -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printTypExpr ~state typ cmtTbl; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; + print_typ_expr ~state typ cmt_tbl; ]) | Ptype_open -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; Doc.text ".."; ] | Ptype_record lds -> @@ -1276,10 +1254,10 @@ and printTypeDeclaration2 ~state ~recFlag (td : Parsetree.type_declaration) Doc.concat [ Doc.space; - Doc.text equalSign; + Doc.text equal_sign; Doc.space; Doc.lbrace; - printCommentsInside cmtTbl td.ptype_loc; + print_comments_inside cmt_tbl td.ptype_loc; Doc.rbrace; ] else @@ -1289,16 +1267,16 @@ and printTypeDeclaration2 ~state ~recFlag (td : Parsetree.type_declaration) | Some typ -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~state typ cmtTbl; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_typ_expr ~state typ cmt_tbl; ] in Doc.concat [ manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~state lds cmtTbl; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; + print_record_declaration ~state lds cmt_tbl; ] | Ptype_variant cds -> let manifest = @@ -1307,24 +1285,24 @@ and printTypeDeclaration2 ~state ~recFlag (td : Parsetree.type_declaration) | Some typ -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~state typ cmtTbl; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_typ_expr ~state typ cmt_tbl; ] in Doc.concat [ manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~state ~privateFlag:td.ptype_private cds - cmtTbl; + Doc.concat [Doc.space; Doc.text equal_sign]; + print_constructor_declarations ~state ~private_flag:td.ptype_private + cds cmt_tbl; ] in - let constraints = printTypeDefinitionConstraints ~state td.ptype_cstrs in + let constraints = print_type_definition_constraints ~state td.ptype_cstrs in Doc.group (Doc.concat - [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) + [attrs; prefix; type_name; type_params; manifest_and_kind; constraints]) -and printTypeDefinitionConstraints ~state cstrs = +and print_type_definition_constraints ~state cstrs = match cstrs with | [] -> Doc.nil | cstrs -> @@ -1335,137 +1313,137 @@ and printTypeDefinitionConstraints ~state cstrs = Doc.line; Doc.group (Doc.join ~sep:Doc.line - (List.map (printTypeDefinitionConstraint ~state) cstrs)); + (List.map (print_type_definition_constraint ~state) cstrs)); ])) -and printTypeDefinitionConstraint ~state +and print_type_definition_constraint ~state ((typ1, typ2, _loc) : Parsetree.core_type * Parsetree.core_type * Location.t) = Doc.concat [ Doc.text "constraint "; - printTypExpr ~state typ1 CommentTable.empty; + print_typ_expr ~state typ1 CommentTable.empty; Doc.text " = "; - printTypExpr ~state typ2 CommentTable.empty; + print_typ_expr ~state typ2 CommentTable.empty; ] -and printPrivateFlag (flag : Asttypes.private_flag) = +and print_private_flag (flag : Asttypes.private_flag) = match flag with | Private -> Doc.text "private " | Public -> Doc.nil -and printTypeParams ~state typeParams cmtTbl = - match typeParams with +and print_type_params ~state type_params cmt_tbl = + match type_params with | [] -> Doc.nil - | typeParams -> + | type_params -> Doc.group (Doc.concat [ - Doc.lessThan; + Doc.less_than; Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun typeParam -> - let doc = printTypeParam ~state typeParam cmtTbl in - printComments doc cmtTbl - (fst typeParam).Parsetree.ptyp_loc) - typeParams); + (fun type_param -> + let doc = print_type_param ~state type_param cmt_tbl in + print_comments doc cmt_tbl + (fst type_param).Parsetree.ptyp_loc) + type_params); ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; + Doc.trailing_comma; + Doc.soft_line; + Doc.greater_than; ]) -and printTypeParam ~state (param : Parsetree.core_type * Asttypes.variance) - cmtTbl = +and print_type_param ~state (param : Parsetree.core_type * Asttypes.variance) + cmt_tbl = let typ, variance = param in - let printedVariance = + let printed_variance = match variance with | Covariant -> Doc.text "+" | Contravariant -> Doc.text "-" | Invariant -> Doc.nil in - Doc.concat [printedVariance; printTypExpr ~state typ cmtTbl] + Doc.concat [printed_variance; print_typ_expr ~state typ cmt_tbl] -and printRecordDeclaration ~state (lds : Parsetree.label_declaration list) - cmtTbl = - let forceBreak = +and print_record_declaration ~state (lds : Parsetree.label_declaration list) + cmt_tbl = + let force_break = match (lds, List.rev lds) with | first :: _, last :: _ -> first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum | _ -> false in - Doc.breakableGroup ~forceBreak + Doc.breakable_group ~force_break (Doc.concat [ Doc.lbrace; Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun ld -> - let doc = printLabelDeclaration ~state ld cmtTbl in - printComments doc cmtTbl ld.Parsetree.pld_loc) + let doc = print_label_declaration ~state ld cmt_tbl in + print_comments doc cmt_tbl ld.Parsetree.pld_loc) lds); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbrace; ]) -and printConstructorDeclarations ~state ~privateFlag - (cds : Parsetree.constructor_declaration list) cmtTbl = - let forceBreak = +and print_constructor_declarations ~state ~private_flag + (cds : Parsetree.constructor_declaration list) cmt_tbl = + let force_break = match (cds, List.rev cds) with | first :: _, last :: _ -> first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum | _ -> false in - let privateFlag = - match privateFlag with + let private_flag = + match private_flag with | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] | Public -> Doc.nil in let rows = - printListi - ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) + print_listi + ~get_loc:(fun cd -> cd.Parsetree.pcd_loc) ~nodes:cds - ~print:(fun cd cmtTbl i -> - let doc = printConstructorDeclaration2 ~state i cd cmtTbl in - printComments doc cmtTbl cd.Parsetree.pcd_loc) - ~forceBreak cmtTbl - in - Doc.breakableGroup ~forceBreak - (Doc.indent (Doc.concat [Doc.line; privateFlag; rows])) - -and printConstructorDeclaration2 ~state i - (cd : Parsetree.constructor_declaration) cmtTbl = - let attrs = printAttributes ~state cd.pcd_attributes cmtTbl in - let isDotDotDot = cd.pcd_name.txt = "..." in + ~print:(fun cd cmt_tbl i -> + let doc = print_constructor_declaration2 ~state i cd cmt_tbl in + print_comments doc cmt_tbl cd.Parsetree.pcd_loc) + ~force_break cmt_tbl + in + Doc.breakable_group ~force_break + (Doc.indent (Doc.concat [Doc.line; private_flag; rows])) + +and print_constructor_declaration2 ~state i + (cd : Parsetree.constructor_declaration) cmt_tbl = + let attrs = print_attributes ~state cd.pcd_attributes cmt_tbl in + let is_dot_dot_dot = cd.pcd_name.txt = "..." in let bar = - if i > 0 || cd.pcd_attributes <> [] || isDotDotDot then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil + if i > 0 || cd.pcd_attributes <> [] || is_dot_dot_dot then Doc.text "| " + else Doc.if_breaks (Doc.text "| ") Doc.nil in - let constrName = + let constr_name = let doc = Doc.text cd.pcd_name.txt in - printComments doc cmtTbl cd.pcd_name.loc + print_comments doc cmt_tbl cd.pcd_name.loc in - let constrArgs = - printConstructorArguments ~isDotDotDot ~state ~indent:true cd.pcd_args - cmtTbl + let constr_args = + print_constructor_arguments ~is_dot_dot_dot ~state ~indent:true cd.pcd_args + cmt_tbl in let gadt = match cd.pcd_res with | None -> Doc.nil | Some typ -> - Doc.indent (Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl]) + Doc.indent (Doc.concat [Doc.text ": "; print_typ_expr ~state typ cmt_tbl]) in Doc.concat [ @@ -1475,34 +1453,34 @@ and printConstructorDeclaration2 ~state i [ attrs; (* TODO: fix parsing of attributes, so when can print them above the bar? *) - constrName; - constrArgs; + constr_name; + constr_args; gadt; ]); ] -and printConstructorArguments ?(isDotDotDot = false) ~state ~indent - (cdArgs : Parsetree.constructor_arguments) cmtTbl = - match cdArgs with +and print_constructor_arguments ?(is_dot_dot_dot = false) ~state ~indent + (cd_args : Parsetree.constructor_arguments) cmt_tbl = + match cd_args with | Pcstr_tuple [] -> Doc.nil | Pcstr_tuple types -> let args = Doc.concat [ - (if isDotDotDot then Doc.nil else Doc.lparen); + (if is_dot_dot_dot then Doc.nil else Doc.lparen); Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun typexpr -> printTypExpr ~state typexpr cmtTbl) + (fun typexpr -> print_typ_expr ~state typexpr cmt_tbl) types); ]); - Doc.trailingComma; - Doc.softLine; - (if isDotDotDot then Doc.nil else Doc.rparen); + Doc.trailing_comma; + Doc.soft_line; + (if is_dot_dot_dot then Doc.nil else Doc.rparen); ] in Doc.group (if indent then Doc.indent args else args) @@ -1516,88 +1494,88 @@ and printConstructorArguments ?(isDotDotDot = false) ~state ~indent Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun ld -> - let doc = printLabelDeclaration ~state ld cmtTbl in - printComments doc cmtTbl ld.Parsetree.pld_loc) + let doc = print_label_declaration ~state ld cmt_tbl in + print_comments doc cmt_tbl ld.Parsetree.pld_loc) lds); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbrace; Doc.rparen; ] in if indent then Doc.indent args else args -and printLabelDeclaration ~state (ld : Parsetree.label_declaration) cmtTbl = +and print_label_declaration ~state (ld : Parsetree.label_declaration) cmt_tbl = let attrs = - printAttributes ~state ~loc:ld.pld_name.loc ld.pld_attributes cmtTbl + print_attributes ~state ~loc:ld.pld_name.loc ld.pld_attributes cmt_tbl in - let mutableFlag = + let mutable_flag = match ld.pld_mutable with | Mutable -> Doc.text "mutable " | Immutable -> Doc.nil in - let name, isDot = - let doc, isDot = + let name, is_dot = + let doc, is_dot = if ld.pld_name.txt = "..." then (Doc.text ld.pld_name.txt, true) - else (printIdentLike ld.pld_name.txt, false) + else (print_ident_like ld.pld_name.txt, false) in - (printComments doc cmtTbl ld.pld_name.loc, isDot) + (print_comments doc cmt_tbl ld.pld_name.loc, is_dot) in - let optional = printOptionalLabel ld.pld_attributes in + let optional = print_optional_label ld.pld_attributes in Doc.group (Doc.concat [ attrs; - mutableFlag; + mutable_flag; name; optional; - (if isDot then Doc.nil else Doc.text ": "); - printTypExpr ~state ld.pld_type cmtTbl; + (if is_dot then Doc.nil else Doc.text ": "); + print_typ_expr ~state ld.pld_type cmt_tbl; ]) -and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl = - let printArrow ~uncurried ?(arity = max_int) typExpr = - let attrsBefore, args, returnType = - ParsetreeViewer.arrowType ~arity typExpr +and print_typ_expr ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = + let print_arrow ~uncurried ?(arity = max_int) typ_expr = + let attrs_before, args, return_type = + ParsetreeViewer.arrow_type ~arity typ_expr in - let dotted, attrsBefore = + let dotted, attrs_before = let dotted = - state.uncurried_config |> Res_uncurried.getDotted ~uncurried + state.uncurried_config |> Res_uncurried.get_dotted ~uncurried in (* Converting .ml code to .res requires processing uncurried attributes *) - let hasBs, attrs = ParsetreeViewer.processBsAttribute attrsBefore in - (dotted || hasBs, attrs) + let has_bs, attrs = ParsetreeViewer.process_bs_attribute attrs_before in + (dotted || has_bs, attrs) in - let returnTypeNeedsParens = - match returnType.ptyp_desc with + let return_type_needs_parens = + match return_type.ptyp_desc with | Ptyp_alias _ -> true | _ -> false in - let returnDoc = - let doc = printTypExpr ~state returnType cmtTbl in - if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] + let return_doc = + let doc = print_typ_expr ~state return_type cmt_tbl in + if return_type_needs_parens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in match args with | [] -> Doc.nil | [([], Nolabel, n)] when not dotted -> - let hasAttrsBefore = not (attrsBefore = []) in + let has_attrs_before = not (attrs_before = []) in let attrs = - if hasAttrsBefore then - printAttributes ~state ~inline:true attrsBefore cmtTbl + if has_attrs_before then + print_attributes ~state ~inline:true attrs_before cmt_tbl else Doc.nil in - let typDoc = - let doc = printTypExpr ~state n cmtTbl in + let typ_doc = + let doc = print_typ_expr ~state n cmt_tbl in match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ when Ast_uncurried.coreTypeIsUncurriedFun n -> addParens doc + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> add_parens doc + | _ when Ast_uncurried.core_type_is_uncurried_fun n -> add_parens doc | _ -> doc in Doc.group @@ -1605,21 +1583,21 @@ and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl = [ Doc.group attrs; Doc.group - (if hasAttrsBefore then + (if has_attrs_before then Doc.concat [ Doc.lparen; Doc.indent (Doc.concat - [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); - Doc.softLine; + [Doc.soft_line; typ_doc; Doc.text " => "; return_doc]); + Doc.soft_line; Doc.rparen; ] - else Doc.concat [typDoc; Doc.text " => "; returnDoc]); + else Doc.concat [typ_doc; Doc.text " => "; return_doc]); ]) | args -> - let attrs = printAttributes ~state ~inline:true attrsBefore cmtTbl in - let renderedArgs = + let attrs = print_attributes ~state ~inline:true attrs_before cmt_tbl in + let rendered_args = Doc.concat [ attrs; @@ -1627,143 +1605,149 @@ and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; (if dotted then Doc.concat [Doc.dot; Doc.space] else Doc.nil); Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun tp -> printTypeParameter ~state tp cmtTbl) + (fun tp -> print_type_parameter ~state tp cmt_tbl) args); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.text ")"; ] in - Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc]) + Doc.group (Doc.concat [rendered_args; Doc.text " => "; return_doc]) in - let renderedType = - match typExpr.ptyp_desc with + let rendered_type = + match typ_expr.ptyp_desc with | Ptyp_any -> Doc.text "_" | Ptyp_var var -> - Doc.concat [Doc.text "'"; printIdentLike ~allowUident:true var] + Doc.concat [Doc.text "'"; print_ident_like ~allow_uident:true var] | Ptyp_extension extension -> - printExtension ~state ~atModuleLvl:false extension cmtTbl + print_extension ~state ~at_module_lvl:false extension cmt_tbl | Ptyp_alias (typ, alias) -> let typ = (* Technically type t = (string, float) => unit as 'x, doesn't require * parens around the arrow expression. This is very confusing though. * Is the "as" part of "unit" or "(string, float) => unit". By printing * parens we guide the user towards its meaning.*) - let needsParens = + let needs_parens = match typ.ptyp_desc with | Ptyp_arrow _ -> true - | _ when Ast_uncurried.coreTypeIsUncurriedFun typ -> true + | _ when Ast_uncurried.core_type_is_uncurried_fun typ -> true | _ -> false in - let doc = printTypExpr ~state typ cmtTbl in - if needsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc + let doc = print_typ_expr ~state typ cmt_tbl in + if needs_parens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in Doc.concat - [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] + [ + typ; Doc.text " as "; Doc.concat [Doc.text "'"; print_ident_like alias]; + ] (* object printings *) - | Ptyp_object (fields, openFlag) -> - printObject ~state ~inline:false fields openFlag cmtTbl - | Ptyp_arrow _ -> printArrow ~uncurried:false typExpr - | Ptyp_constr _ when Ast_uncurried.coreTypeIsUncurriedFun typExpr -> - let arity, tArg = Ast_uncurried.typeExtractUncurriedFun typExpr in - printArrow ~uncurried:true ~arity tArg - | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) - -> + | Ptyp_object (fields, open_flag) -> + print_object ~state ~inline:false fields open_flag cmt_tbl + | Ptyp_arrow _ -> print_arrow ~uncurried:false typ_expr + | Ptyp_constr _ when Ast_uncurried.core_type_is_uncurried_fun typ_expr -> + let arity, t_arg = + Ast_uncurried.core_type_extract_uncurried_fun typ_expr + in + print_arrow ~uncurried:true ~arity t_arg + | Ptyp_constr + (longident_loc, [{ptyp_desc = Ptyp_object (fields, open_flag)}]) -> (* for foo<{"a": b}>, when the object is long and needs a line break, we want the <{ and }> to stay hugged together *) - let constrName = printLidentPath longidentLoc cmtTbl in + let constr_name = print_lident_path longident_loc cmt_tbl in Doc.concat [ - constrName; - Doc.lessThan; - printObject ~state ~inline:true fields openFlag cmtTbl; - Doc.greaterThan; + constr_name; + Doc.less_than; + print_object ~state ~inline:true fields open_flag cmt_tbl; + Doc.greater_than; ] - | Ptyp_constr (longidentLoc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> - let constrName = printLidentPath longidentLoc cmtTbl in + | Ptyp_constr (longident_loc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> + let constr_name = print_lident_path longident_loc cmt_tbl in Doc.group (Doc.concat [ - constrName; - Doc.lessThan; - printTupleType ~state ~inline:true tuple cmtTbl; - Doc.greaterThan; + constr_name; + Doc.less_than; + print_tuple_type ~state ~inline:true tuple cmt_tbl; + Doc.greater_than; ]) - | Ptyp_constr (longidentLoc, constrArgs) -> ( - let constrName = printLidentPath longidentLoc cmtTbl in - match constrArgs with - | [] -> constrName + | Ptyp_constr (longident_loc, constr_args) -> ( + let constr_name = print_lident_path longident_loc cmt_tbl in + match constr_args with + | [] -> constr_name | _args -> Doc.group (Doc.concat [ - constrName; - Doc.lessThan; + constr_name; + Doc.less_than; Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun typexpr -> printTypExpr ~state typexpr cmtTbl) - constrArgs); + (fun typexpr -> + print_typ_expr ~state typexpr cmt_tbl) + constr_args); ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; + Doc.trailing_comma; + Doc.soft_line; + Doc.greater_than; ])) - | Ptyp_tuple types -> printTupleType ~state ~inline:false types cmtTbl - | Ptyp_poly ([], typ) -> printTypExpr ~state typ cmtTbl - | Ptyp_poly (stringLocs, typ) -> + | Ptyp_tuple types -> print_tuple_type ~state ~inline:false types cmt_tbl + | Ptyp_poly ([], typ) -> print_typ_expr ~state typ cmt_tbl + | Ptyp_poly (string_locs, typ) -> Doc.concat [ Doc.join ~sep:Doc.space (List.map (fun {Location.txt; loc} -> let doc = Doc.concat [Doc.text "'"; Doc.text txt] in - printComments doc cmtTbl loc) - stringLocs); + print_comments doc cmt_tbl loc) + string_locs); Doc.dot; Doc.space; - printTypExpr ~state typ cmtTbl; + print_typ_expr ~state typ cmt_tbl; ] - | Ptyp_package packageType -> - printPackageType ~state ~printModuleKeywordAndParens:true packageType - cmtTbl + | Ptyp_package package_type -> + print_package_type ~state ~print_module_keyword_and_parens:true + package_type cmt_tbl | Ptyp_class _ -> Doc.text "classes are not supported in types" - | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> - let forceBreak = - typExpr.ptyp_loc.Location.loc_start.pos_lnum - < typExpr.ptyp_loc.loc_end.pos_lnum + | Ptyp_variant (row_fields, closed_flag, labels_opt) -> + let force_break = + typ_expr.ptyp_loc.Location.loc_start.pos_lnum + < typ_expr.ptyp_loc.loc_end.pos_lnum in - let printRowField = function + let print_row_field = function | Parsetree.Rtag ({txt; loc}, attrs, true, []) -> let doc = Doc.group (Doc.concat [ - printAttributes ~state attrs cmtTbl; - Doc.concat [Doc.text "#"; printPolyVarIdent txt]; + print_attributes ~state attrs cmt_tbl; + Doc.concat [Doc.text "#"; print_poly_var_ident txt]; ]) in - printComments doc cmtTbl loc + print_comments doc cmt_tbl loc | Rtag ({txt}, attrs, truth, types) -> - let doType t = + let do_type t = match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> printTypExpr ~state t cmtTbl + | Ptyp_tuple _ -> print_typ_expr ~state t cmt_tbl | _ -> - Doc.concat [Doc.lparen; printTypExpr ~state t cmtTbl; Doc.rparen] + Doc.concat + [Doc.lparen; print_typ_expr ~state t cmt_tbl; Doc.rparen] in - let printedTypes = List.map doType types in + let printed_types = List.map do_type types in let cases = - Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes + Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printed_types in let cases = if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases @@ -1771,69 +1755,70 @@ and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl = Doc.group (Doc.concat [ - printAttributes ~state attrs cmtTbl; - Doc.concat [Doc.text "#"; printPolyVarIdent txt]; + print_attributes ~state attrs cmt_tbl; + Doc.concat [Doc.text "#"; print_poly_var_ident txt]; cases; ]) - | Rinherit coreType -> printTypExpr ~state coreType cmtTbl + | Rinherit core_type -> print_typ_expr ~state core_type cmt_tbl in - let docs = List.map printRowField rowFields in + let docs = List.map print_row_field row_fields in let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in let cases = if docs = [] then cases - else Doc.concat [Doc.ifBreaks (Doc.text "| ") Doc.nil; cases] + else Doc.concat [Doc.if_breaks (Doc.text "| ") Doc.nil; cases] in - let openingSymbol = - if closedFlag = Open then Doc.concat [Doc.greaterThan; Doc.line] - else if labelsOpt = None then Doc.softLine - else Doc.concat [Doc.lessThan; Doc.line] + let opening_symbol = + if closed_flag = Open then Doc.concat [Doc.greater_than; Doc.line] + else if labels_opt = None then Doc.soft_line + else Doc.concat [Doc.less_than; Doc.line] in let labels = - match labelsOpt with + match labels_opt with | None | Some [] -> Doc.nil | Some labels -> Doc.concat (List.map (fun label -> - Doc.concat [Doc.line; Doc.text "#"; printPolyVarIdent label]) + Doc.concat [Doc.line; Doc.text "#"; print_poly_var_ident label]) labels) in - let closingSymbol = - match labelsOpt with + let closing_symbol = + match labels_opt with | None | Some [] -> Doc.nil | _ -> Doc.text " >" in - Doc.breakableGroup ~forceBreak + Doc.breakable_group ~force_break (Doc.concat [ Doc.lbracket; Doc.indent - (Doc.concat [openingSymbol; cases; closingSymbol; labels]); - Doc.softLine; + (Doc.concat [opening_symbol; cases; closing_symbol; labels]); + Doc.soft_line; Doc.rbracket; ]) in - let shouldPrintItsOwnAttributes = - match typExpr.ptyp_desc with + let should_print_its_own_attributes = + match typ_expr.ptyp_desc with | Ptyp_arrow _ (* es6 arrow types print their own attributes *) -> true | _ -> false in let doc = - match typExpr.ptyp_attributes with - | _ :: _ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; renderedType]) - | _ -> renderedType + match typ_expr.ptyp_attributes with + | _ :: _ as attrs when not should_print_its_own_attributes -> + Doc.group + (Doc.concat [print_attributes ~state attrs cmt_tbl; rendered_type]) + | _ -> rendered_type in - printComments doc cmtTbl typExpr.ptyp_loc + print_comments doc cmt_tbl typ_expr.ptyp_loc -and printObject ~state ~inline fields openFlag cmtTbl = +and print_object ~state ~inline fields open_flag cmt_tbl = let doc = match fields with | [] -> Doc.concat [ Doc.lbrace; - (match openFlag with + (match open_flag with | Asttypes.Closed -> Doc.dot | Open -> Doc.dotdot); Doc.rbrace; @@ -1842,7 +1827,7 @@ and printObject ~state ~inline fields openFlag cmtTbl = Doc.concat [ Doc.lbrace; - (match openFlag with + (match open_flag with | Asttypes.Closed -> Doc.nil | Open -> ( match fields with @@ -1853,21 +1838,21 @@ and printObject ~state ~inline fields openFlag cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun field -> printObjectField ~state field cmtTbl) + (fun field -> print_object_field ~state field cmt_tbl) fields); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbrace; ] in if inline then doc else Doc.group doc -and printTupleType ~state ~inline (types : Parsetree.core_type list) cmtTbl = +and print_tuple_type ~state ~inline (types : Parsetree.core_type list) cmt_tbl = let tuple = Doc.concat [ @@ -1875,58 +1860,58 @@ and printTupleType ~state ~inline (types : Parsetree.core_type list) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun typexpr -> printTypExpr ~state typexpr cmtTbl) + (fun typexpr -> print_typ_expr ~state typexpr cmt_tbl) types); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ] in if inline == false then Doc.group tuple else tuple -and printObjectField ~state (field : Parsetree.object_field) cmtTbl = +and print_object_field ~state (field : Parsetree.object_field) cmt_tbl = match field with - | Otag (labelLoc, attrs, typ) -> + | Otag (label_loc, attrs, typ) -> let lbl = - let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in - printComments doc cmtTbl labelLoc.loc + let doc = Doc.text ("\"" ^ label_loc.txt ^ "\"") in + print_comments doc cmt_tbl label_loc.loc in let doc = Doc.concat [ - printAttributes ~state ~loc:labelLoc.loc attrs cmtTbl; + print_attributes ~state ~loc:label_loc.loc attrs cmt_tbl; lbl; Doc.text ": "; - printTypExpr ~state typ cmtTbl; + print_typ_expr ~state typ cmt_tbl; ] in - let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in - printComments doc cmtTbl cmtLoc + let cmt_loc = {label_loc.loc with loc_end = typ.ptyp_loc.loc_end} in + print_comments doc cmt_tbl cmt_loc | Oinherit typexpr -> - Doc.concat [Doc.dotdotdot; printTypExpr ~state typexpr cmtTbl] + Doc.concat [Doc.dotdotdot; print_typ_expr ~state typexpr cmt_tbl] (* es6 arrow type arg * type t = (~foo: string, ~bar: float=?, unit) => unit * i.e. ~foo: string, ~bar: float *) -and printTypeParameter ~state (attrs, lbl, typ) cmtTbl = +and print_type_parameter ~state (attrs, lbl, typ) cmt_tbl = (* Converting .ml code to .res requires processing uncurried attributes *) - let hasBs, attrs = ParsetreeViewer.processBsAttribute attrs in - let dotted = if hasBs then Doc.concat [Doc.dot; Doc.space] else Doc.nil in - let attrs = printAttributes ~state attrs cmtTbl in + let has_bs, attrs = ParsetreeViewer.process_bs_attribute attrs in + let dotted = if has_bs then Doc.concat [Doc.dot; Doc.space] else Doc.nil in + let attrs = print_attributes ~state attrs cmt_tbl in let label = match lbl with | Asttypes.Nolabel -> Doc.nil | Labelled lbl -> - Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] + Doc.concat [Doc.text "~"; print_ident_like lbl; Doc.text ": "] | Optional lbl -> - Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] + Doc.concat [Doc.text "~"; print_ident_like lbl; Doc.text ": "] in - let optionalIndicator = + let optional_indicator = match lbl with | Asttypes.Nolabel | Labelled _ -> Doc.nil | Optional _lbl -> Doc.text "=?" @@ -1945,32 +1930,33 @@ and printTypeParameter ~state (attrs, lbl, typ) cmtTbl = dotted; attrs; label; - printTypExpr ~state typ cmtTbl; - optionalIndicator; + print_typ_expr ~state typ cmt_tbl; + optional_indicator; ]) in - printComments doc cmtTbl loc + print_comments doc cmt_tbl loc -and printValueBinding ~state ~recFlag (vb : Parsetree.value_binding) cmtTbl i = +and print_value_binding ~state ~rec_flag (vb : Parsetree.value_binding) cmt_tbl + i = let attrs = - printAttributes ~state ~loc:vb.pvb_pat.ppat_loc vb.pvb_attributes cmtTbl + print_attributes ~state ~loc:vb.pvb_pat.ppat_loc vb.pvb_attributes cmt_tbl in let header = - if i == 0 then Doc.concat [Doc.text "let "; recFlag] else Doc.text "and " + if i == 0 then Doc.concat [Doc.text "let "; rec_flag] else Doc.text "and " in match vb with | { pvb_pat = { ppat_desc = - Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as patTyp)); + Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as pat_typ)); }; pvb_expr = {pexp_desc = Pexp_newtype _} as expr; } -> ( - let _uncurried, _attrs, parameters, returnExpr = - ParsetreeViewer.funExpr expr + let _uncurried, _attrs, parameters, return_expr = + ParsetreeViewer.fun_expr expr in - let abstractType = + let abstract_type = match parameters with | [NewTypes {locs = vars}] -> Doc.concat @@ -1982,25 +1968,28 @@ and printValueBinding ~state ~recFlag (vb : Parsetree.value_binding) cmtTbl i = ] | _ -> Doc.nil in - match returnExpr.pexp_desc with + match return_expr.pexp_desc with | Pexp_constraint (expr, typ) -> Doc.group (Doc.concat [ attrs; header; - printPattern ~state pattern cmtTbl; + print_pattern ~state pattern cmt_tbl; Doc.text ":"; Doc.indent (Doc.concat [ Doc.line; - abstractType; + abstract_type; Doc.space; - printTypExpr ~state typ cmtTbl; + print_typ_expr ~state typ cmt_tbl; Doc.text " ="; Doc.concat - [Doc.line; printExpressionWithComments ~state expr cmtTbl]; + [ + Doc.line; + print_expression_with_comments ~state expr cmt_tbl; + ]; ]); ]) | _ -> @@ -2013,30 +2002,33 @@ and printValueBinding ~state ~recFlag (vb : Parsetree.value_binding) cmtTbl i = [ attrs; header; - printPattern ~state pattern cmtTbl; + print_pattern ~state pattern cmt_tbl; Doc.text ":"; Doc.indent (Doc.concat [ Doc.line; - abstractType; + abstract_type; Doc.space; - printTypExpr ~state patTyp cmtTbl; + print_typ_expr ~state pat_typ cmt_tbl; Doc.text " ="; Doc.concat - [Doc.line; printExpressionWithComments ~state expr cmtTbl]; + [ + Doc.line; + print_expression_with_comments ~state expr cmt_tbl; + ]; ]); ])) | _ -> - let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in - let printedExpr = - let doc = printExpressionWithComments ~state vb.pvb_expr cmtTbl in + let opt_braces, expr = ParsetreeViewer.process_braces_attr vb.pvb_expr in + let printed_expr = + let doc = print_expression_with_comments ~state vb.pvb_expr cmt_tbl in match Parens.expr vb.pvb_expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc in - let patternDoc = printPattern ~state vb.pvb_pat cmtTbl in + let pattern_doc = print_pattern ~state vb.pvb_pat cmt_tbl in (* * we want to optimize the layout of one pipe: * let tbl = data->Js.Array2.reduce((map, curr) => { @@ -2049,77 +2041,82 @@ and printValueBinding ~state ~recFlag (vb : Parsetree.value_binding) cmtTbl i = * ->Belt.Array.map(...) * Multiple pipes chained together lend themselves more towards the last layout. *) - if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then - Doc.customLayout + if ParsetreeViewer.is_single_pipe_expr vb.pvb_expr then + Doc.custom_layout [ Doc.group (Doc.concat [ - attrs; header; patternDoc; Doc.text " ="; Doc.space; printedExpr; + attrs; + header; + pattern_doc; + Doc.text " ="; + Doc.space; + printed_expr; ]); Doc.group (Doc.concat [ attrs; header; - patternDoc; + pattern_doc; Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printedExpr]); + Doc.indent (Doc.concat [Doc.line; printed_expr]); ]); ] else - let shouldIndent = - match optBraces with + let should_indent = + match opt_braces with | Some _ -> false | _ -> ( - ParsetreeViewer.isBinaryExpression expr + ParsetreeViewer.is_binary_expression expr || match vb.pvb_expr with | { pexp_attributes = [({Location.txt = "res.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + pexp_desc = Pexp_ifthenelse (if_expr, _, _); } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + ParsetreeViewer.is_binary_expression if_expr + || ParsetreeViewer.has_attributes if_expr.pexp_attributes | {pexp_desc = Pexp_newtype _} -> false | {pexp_attributes = [({Location.txt = "res.taggedTemplate"}, _)]} -> false | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e) + ParsetreeViewer.has_attributes e.pexp_attributes + || ParsetreeViewer.is_array_access e) in Doc.group (Doc.concat [ attrs; header; - patternDoc; + pattern_doc; Doc.text " ="; - (if shouldIndent then - Doc.indent (Doc.concat [Doc.line; printedExpr]) - else Doc.concat [Doc.space; printedExpr]); + (if should_indent then + Doc.indent (Doc.concat [Doc.line; printed_expr]) + else Doc.concat [Doc.space; printed_expr]); ]) -and printPackageType ~state ~printModuleKeywordAndParens - (packageType : Parsetree.package_type) cmtTbl = +and print_package_type ~state ~print_module_keyword_and_parens + (package_type : Parsetree.package_type) cmt_tbl = let doc = - match packageType with - | longidentLoc, [] -> - Doc.group (Doc.concat [printLongidentLocation longidentLoc cmtTbl]) - | longidentLoc, packageConstraints -> + match package_type with + | longident_loc, [] -> + Doc.group (Doc.concat [print_longident_location longident_loc cmt_tbl]) + | longident_loc, package_constraints -> Doc.group (Doc.concat [ - printLongidentLocation longidentLoc cmtTbl; - printPackageConstraints ~state packageConstraints cmtTbl; - Doc.softLine; + print_longident_location longident_loc cmt_tbl; + print_package_constraints ~state package_constraints cmt_tbl; + Doc.soft_line; ]) in - if printModuleKeywordAndParens then + if print_module_keyword_and_parens then Doc.concat [Doc.text "module("; doc; Doc.rparen] else doc -and printPackageConstraints ~state packageConstraints cmtTbl = +and print_package_constraints ~state package_constraints cmt_tbl = Doc.concat [ Doc.text " with"; @@ -2131,53 +2128,53 @@ and printPackageConstraints ~state packageConstraints cmtTbl = (List.mapi (fun i pc -> let longident, typexpr = pc in - let cmtLoc = + let cmt_loc = { longident.Asttypes.loc with loc_end = typexpr.Parsetree.ptyp_loc.loc_end; } in - let doc = printPackageConstraint ~state i cmtTbl pc in - printComments doc cmtTbl cmtLoc) - packageConstraints); + let doc = print_package_constraint ~state i cmt_tbl pc in + print_comments doc cmt_tbl cmt_loc) + package_constraints); ]); ] -and printPackageConstraint ~state i cmtTbl (longidentLoc, typ) = +and print_package_constraint ~state i cmt_tbl (longident_loc, typ) = let prefix = if i == 0 then Doc.text "type " else Doc.text "and type " in Doc.concat [ prefix; - printLongidentLocation longidentLoc cmtTbl; + print_longident_location longident_loc cmt_tbl; Doc.text " = "; - printTypExpr ~state typ cmtTbl; + print_typ_expr ~state typ cmt_tbl; ] -and printExtension ~state ~atModuleLvl (stringLoc, payload) cmtTbl = - let txt = convertBsExtension stringLoc.Location.txt in - let extName = +and print_extension ~state ~at_module_lvl (string_loc, payload) cmt_tbl = + let txt = string_loc.Location.txt in + let ext_name = let doc = Doc.concat [ Doc.text "%"; - (if atModuleLvl then Doc.text "%" else Doc.nil); + (if at_module_lvl then Doc.text "%" else Doc.nil); Doc.text txt; ] in - printComments doc cmtTbl stringLoc.Location.loc + print_comments doc cmt_tbl string_loc.Location.loc in - Doc.group (Doc.concat [extName; printPayload ~state payload cmtTbl]) + Doc.group (Doc.concat [ext_name; print_payload ~state payload cmt_tbl]) -and printPattern ~state (p : Parsetree.pattern) cmtTbl = - let patternWithoutAttributes = +and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = + let pattern_without_attributes = match p.ppat_desc with | Ppat_any -> Doc.text "_" - | Ppat_var var -> printIdentLike var.txt + | Ppat_var var -> print_ident_like var.txt | Ppat_constant c -> - let templateLiteral = - ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes + let template_literal = + ParsetreeViewer.has_template_literal_attr p.ppat_attributes in - printConstant ~templateLiteral c + print_constant ~template_literal c | Ppat_tuple patterns -> Doc.group (Doc.concat @@ -2186,20 +2183,20 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun pat -> printPattern ~state pat cmtTbl) + (fun pat -> print_pattern ~state pat cmt_tbl) patterns); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ]) | Ppat_array [] -> Doc.concat - [Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket] + [Doc.lbracket; print_comments_inside cmt_tbl p.ppat_loc; Doc.rbracket] | Ppat_array patterns -> Doc.group (Doc.concat @@ -2208,47 +2205,48 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun pat -> printPattern ~state pat cmtTbl) + (fun pat -> print_pattern ~state pat cmt_tbl) patterns); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.text "]"; ]) | Ppat_construct ({txt = Longident.Lident "()"}, _) -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen] + Doc.concat + [Doc.lparen; print_comments_inside cmt_tbl p.ppat_loc; Doc.rparen] | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.concat - [Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace] + [Doc.text "list{"; print_comments_inside cmt_tbl p.ppat_loc; Doc.rbrace] | Ppat_construct ({txt = Longident.Lident "::"}, _) -> let patterns, tail = - ParsetreeViewer.collectPatternsFromListConstruct [] p + ParsetreeViewer.collect_patterns_from_list_construct [] p in - let shouldHug = + let should_hug = match (patterns, tail) with | [pat], {ppat_desc = Ppat_construct ({txt = Longident.Lident "[]"}, _)} - when ParsetreeViewer.isHuggablePattern pat -> + when ParsetreeViewer.is_huggable_pattern pat -> true | _ -> false in let children = Doc.concat [ - (if shouldHug then Doc.nil else Doc.softLine); + (if should_hug then Doc.nil else Doc.soft_line); Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun pat -> printPattern ~state pat cmtTbl) patterns); + (List.map (fun pat -> print_pattern ~state pat cmt_tbl) patterns); (match tail.Parsetree.ppat_desc with | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.nil | _ -> let doc = - Doc.concat [Doc.text "..."; printPattern ~state tail cmtTbl] + Doc.concat [Doc.text "..."; print_pattern ~state tail cmt_tbl] in - let tail = printComments doc cmtTbl tail.ppat_loc in + let tail = print_comments doc cmt_tbl tail.ppat_loc in Doc.concat [Doc.text ","; Doc.line; tail]); ] in @@ -2256,20 +2254,20 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl = (Doc.concat [ Doc.text "list{"; - (if shouldHug then children + (if should_hug then children else Doc.concat [ Doc.indent children; - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; + Doc.if_breaks (Doc.text ",") Doc.nil; + Doc.soft_line; ]); Doc.rbrace; ]) - | Ppat_construct (constrName, constructorArgs) -> - let constrName = printLongidentLocation constrName cmtTbl in - let argsDoc = - match constructorArgs with + | Ppat_construct (constr_name, constructor_args) -> + let constr_name = print_longident_location constr_name cmt_tbl in + let args_doc = + match constructor_args with | None -> Doc.nil | Some { @@ -2277,12 +2275,12 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl = ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); } -> Doc.concat - [Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen] + [Doc.lparen; print_comments_inside cmt_tbl ppat_loc; Doc.rparen] | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] + Doc.concat [Doc.lparen; print_comments_inside cmt_tbl loc; Doc.rparen] (* Some((1, 2) *) | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat [Doc.lparen; printPattern ~state arg cmtTbl; Doc.rparen] + Doc.concat [Doc.lparen; print_pattern ~state arg cmt_tbl; Doc.rparen] | Some {ppat_desc = Ppat_tuple patterns} -> Doc.concat [ @@ -2290,50 +2288,52 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun pat -> printPattern ~state pat cmtTbl) + (fun pat -> print_pattern ~state pat cmt_tbl) patterns); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ] | Some arg -> - let argDoc = printPattern ~state arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in + let arg_doc = print_pattern ~state arg cmt_tbl in + let should_hug = ParsetreeViewer.is_huggable_pattern arg in Doc.concat [ Doc.lparen; - (if shouldHug then argDoc + (if should_hug then arg_doc else Doc.concat [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; + Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); + Doc.trailing_comma; + Doc.soft_line; ]); Doc.rparen; ] in - Doc.group (Doc.concat [constrName; argsDoc]) + Doc.group (Doc.concat [constr_name; args_doc]) | Ppat_variant (label, None) -> - Doc.concat [Doc.text "#"; printPolyVarIdent label] - | Ppat_variant (label, variantArgs) -> - let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in - let argsDoc = - match variantArgs with + Doc.concat [Doc.text "#"; print_poly_var_ident label] + | Ppat_variant (label, variant_args) -> + let variant_name = + Doc.concat [Doc.text "#"; print_poly_var_ident label] + in + let args_doc = + match variant_args with | None -> Doc.nil | Some {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)} -> Doc.text "()" | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] + Doc.concat [Doc.lparen; print_comments_inside cmt_tbl loc; Doc.rparen] (* Some((1, 2) *) | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat [Doc.lparen; printPattern ~state arg cmtTbl; Doc.rparen] + Doc.concat [Doc.lparen; print_pattern ~state arg cmt_tbl; Doc.rparen] | Some {ppat_desc = Ppat_tuple patterns} -> Doc.concat [ @@ -2341,38 +2341,38 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun pat -> printPattern ~state pat cmtTbl) + (fun pat -> print_pattern ~state pat cmt_tbl) patterns); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ] | Some arg -> - let argDoc = printPattern ~state arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in + let arg_doc = print_pattern ~state arg cmt_tbl in + let should_hug = ParsetreeViewer.is_huggable_pattern arg in Doc.concat [ Doc.lparen; - (if shouldHug then argDoc + (if should_hug then arg_doc else Doc.concat [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; + Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); + Doc.trailing_comma; + Doc.soft_line; ]); Doc.rparen; ] in - Doc.group (Doc.concat [variantName; argsDoc]) + Doc.group (Doc.concat [variant_name; args_doc]) | Ppat_type ident -> - Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl] - | Ppat_record (rows, openFlag) -> + Doc.concat [Doc.text "#..."; print_ident_path ident cmt_tbl] + | Ppat_record (rows, open_flag) -> Doc.group (Doc.concat [ @@ -2380,126 +2380,129 @@ and printPattern ~state (p : Parsetree.pattern) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun row -> printPatternRecordRow ~state row cmtTbl) + (fun row -> + print_pattern_record_row ~state row cmt_tbl) rows); - (match openFlag with + (match open_flag with | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] | Closed -> Doc.nil); ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; + Doc.if_breaks (Doc.text ",") Doc.nil; + Doc.soft_line; Doc.rbrace; ]) | Ppat_exception p -> - let needsParens = + let needs_parens = match p.ppat_desc with | Ppat_or (_, _) | Ppat_alias (_, _) -> true | _ -> false in let pat = - let p = printPattern ~state p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + let p = print_pattern ~state p cmt_tbl in + if needs_parens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p in Doc.group (Doc.concat [Doc.text "exception"; Doc.line; pat]) | Ppat_or _ -> (* Blue | Red | Green -> [Blue; Red; Green] *) - let orChain = ParsetreeViewer.collectOrPatternChain p in + let or_chain = ParsetreeViewer.collect_or_pattern_chain p in let docs = List.mapi (fun i pat -> - let patternDoc = printPattern ~state pat cmtTbl in + let pattern_doc = print_pattern ~state pat cmt_tbl in Doc.concat [ (if i == 0 then Doc.nil else Doc.concat [Doc.line; Doc.text "| "]); (match pat.ppat_desc with (* (Blue | Red) | (Green | Black) | White *) - | Ppat_or _ -> addParens patternDoc - | _ -> patternDoc); + | Ppat_or _ -> add_parens pattern_doc + | _ -> pattern_doc); ]) - orChain + or_chain in - let isSpreadOverMultipleLines = - match (orChain, List.rev orChain) with + let is_spread_over_multiple_lines = + match (or_chain, List.rev or_chain) with | first :: _, last :: _ -> first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum | _ -> false in - Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) - | Ppat_extension ext -> printExtension ~state ~atModuleLvl:false ext cmtTbl + Doc.breakable_group ~force_break:is_spread_over_multiple_lines + (Doc.concat docs) + | Ppat_extension ext -> + print_extension ~state ~at_module_lvl:false ext cmt_tbl | Ppat_lazy p -> - let needsParens = + let needs_parens = match p.ppat_desc with | Ppat_or (_, _) | Ppat_alias (_, _) -> true | _ -> false in let pat = - let p = printPattern ~state p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + let p = print_pattern ~state p cmt_tbl in + if needs_parens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p in Doc.concat [Doc.text "lazy "; pat] - | Ppat_alias (p, aliasLoc) -> - let needsParens = + | Ppat_alias (p, alias_loc) -> + let needs_parens = match p.ppat_desc with | Ppat_or (_, _) | Ppat_alias (_, _) -> true | _ -> false in - let renderedPattern = - let p = printPattern ~state p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + let rendered_pattern = + let p = print_pattern ~state p cmt_tbl in + if needs_parens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p in Doc.concat - [renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl] + [rendered_pattern; Doc.text " as "; print_string_loc alias_loc cmt_tbl] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_constraint - ( {ppat_desc = Ppat_unpack stringLoc}, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> + ( {ppat_desc = Ppat_unpack string_loc}, + {ptyp_desc = Ptyp_package package_type; ptyp_loc} ) -> Doc.concat [ Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + print_comments (Doc.text string_loc.txt) cmt_tbl string_loc.loc; Doc.text ": "; - printComments - (printPackageType ~state ~printModuleKeywordAndParens:false - packageType cmtTbl) - cmtTbl ptyp_loc; + print_comments + (print_package_type ~state ~print_module_keyword_and_parens:false + package_type cmt_tbl) + cmt_tbl ptyp_loc; Doc.rparen; ] | Ppat_constraint (pattern, typ) -> Doc.concat [ - printPattern ~state pattern cmtTbl; + print_pattern ~state pattern cmt_tbl; Doc.text ": "; - printTypExpr ~state typ cmtTbl; + print_typ_expr ~state typ cmt_tbl; ] (* Note: module(P : S) is represented as *) (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) - | Ppat_unpack stringLoc -> + | Ppat_unpack string_loc -> Doc.concat [ Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + print_comments (Doc.text string_loc.txt) cmt_tbl string_loc.loc; Doc.rparen; ] | Ppat_interval (a, b) -> - Doc.concat [printConstant a; Doc.text " .. "; printConstant b] + Doc.concat [print_constant a; Doc.text " .. "; print_constant b] | Ppat_open _ -> Doc.nil in let doc = match p.ppat_attributes with - | [] -> patternWithoutAttributes + | [] -> pattern_without_attributes | attrs -> Doc.group (Doc.concat - [printAttributes ~state attrs cmtTbl; patternWithoutAttributes]) + [print_attributes ~state attrs cmt_tbl; pattern_without_attributes]) in - printComments doc cmtTbl p.ppat_loc + print_comments doc cmt_tbl p.ppat_loc -and printPatternRecordRow ~state row cmtTbl = +and print_pattern_record_row ~state row cmt_tbl = match row with (* punned {x}*) | ( ({Location.txt = Longident.Lident ident} as longident), @@ -2507,139 +2510,142 @@ and printPatternRecordRow ~state row cmtTbl = when ident = txt -> Doc.concat [ - printOptionalLabel ppat_attributes; - printAttributes ~state ppat_attributes cmtTbl; - printLidentPath longident cmtTbl; + print_optional_label ppat_attributes; + print_attributes ~state ppat_attributes cmt_tbl; + print_lident_path longident cmt_tbl; ] | longident, pattern -> - let locForComments = + let loc_for_comments = {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} in - let rhsDoc = - let doc = printPattern ~state pattern cmtTbl in + let rhs_doc = + let doc = print_pattern ~state pattern cmt_tbl in let doc = - if Parens.patternRecordRowRhs pattern then addParens doc else doc + if Parens.pattern_record_row_rhs pattern then add_parens doc else doc in - Doc.concat [printOptionalLabel pattern.ppat_attributes; doc] + Doc.concat [print_optional_label pattern.ppat_attributes; doc] in let doc = Doc.group (Doc.concat [ - printLidentPath longident cmtTbl; + print_lident_path longident cmt_tbl; Doc.text ":"; - (if ParsetreeViewer.isHuggablePattern pattern then - Doc.concat [Doc.space; rhsDoc] - else Doc.indent (Doc.concat [Doc.line; rhsDoc])); + (if ParsetreeViewer.is_huggable_pattern pattern then + Doc.concat [Doc.space; rhs_doc] + else Doc.indent (Doc.concat [Doc.line; rhs_doc])); ]) in - printComments doc cmtTbl locForComments + print_comments doc cmt_tbl loc_for_comments -and printExpressionWithComments ~state expr cmtTbl : Doc.t = - let doc = printExpression ~state expr cmtTbl in - printComments doc cmtTbl expr.Parsetree.pexp_loc +and print_expression_with_comments ~state expr cmt_tbl : Doc.t = + let doc = print_expression ~state expr cmt_tbl in + print_comments doc cmt_tbl expr.Parsetree.pexp_loc -and printIfChain ~state pexp_attributes ifs elseExpr cmtTbl = - let ifDocs = +and print_if_chain ~state pexp_attributes ifs else_expr cmt_tbl = + let if_docs = Doc.join ~sep:Doc.space (List.mapi - (fun i (outerLoc, ifExpr, thenExpr) -> - let ifTxt = if i > 0 then Doc.text "else if " else Doc.text "if " in + (fun i (outer_loc, if_expr, then_expr) -> + let if_txt = if i > 0 then Doc.text "else if " else Doc.text "if " in let doc = - match ifExpr with - | ParsetreeViewer.If ifExpr -> + match if_expr with + | ParsetreeViewer.If if_expr -> let condition = - if ParsetreeViewer.isBlockExpr ifExpr then - printExpressionBlock ~state ~braces:true ifExpr cmtTbl + if ParsetreeViewer.is_block_expr if_expr then + print_expression_block ~state ~braces:true if_expr cmt_tbl else - let doc = printExpressionWithComments ~state ifExpr cmtTbl in - match Parens.expr ifExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc ifExpr braces - | Nothing -> Doc.ifBreaks (addParens doc) doc + let doc = + print_expression_with_comments ~state if_expr cmt_tbl + in + match Parens.expr if_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc if_expr braces + | Nothing -> Doc.if_breaks (add_parens doc) doc in Doc.concat [ - ifTxt; + if_txt; Doc.group condition; Doc.space; - (let thenExpr = - match ParsetreeViewer.processBracesAttr thenExpr with + (let then_expr = + match ParsetreeViewer.process_braces_attr then_expr with (* This case only happens when coming from Reason, we strip braces *) | Some _, expr -> expr - | _ -> thenExpr + | _ -> then_expr in - printExpressionBlock ~state ~braces:true thenExpr cmtTbl); + print_expression_block ~state ~braces:true then_expr cmt_tbl); ] - | IfLet (pattern, conditionExpr) -> - let conditionDoc = + | IfLet (pattern, condition_expr) -> + let condition_doc = let doc = - printExpressionWithComments ~state conditionExpr cmtTbl + print_expression_with_comments ~state condition_expr cmt_tbl in - match Parens.expr conditionExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc conditionExpr braces + match Parens.expr condition_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc condition_expr braces | Nothing -> doc in Doc.concat [ - ifTxt; + if_txt; Doc.text "let "; - printPattern ~state pattern cmtTbl; + print_pattern ~state pattern cmt_tbl; Doc.text " = "; - conditionDoc; + condition_doc; Doc.space; - printExpressionBlock ~state ~braces:true thenExpr cmtTbl; + print_expression_block ~state ~braces:true then_expr cmt_tbl; ] in - printLeadingComments doc cmtTbl.leading outerLoc) + print_leading_comments doc cmt_tbl.leading outer_loc) ifs) in - let elseDoc = - match elseExpr with + let else_doc = + match else_expr with | None -> Doc.nil | Some expr -> Doc.concat [ - Doc.text " else "; printExpressionBlock ~state ~braces:true expr cmtTbl; + Doc.text " else "; + print_expression_block ~state ~braces:true expr cmt_tbl; ] in - let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in - Doc.concat [printAttributes ~state attrs cmtTbl; ifDocs; elseDoc] + let attrs = ParsetreeViewer.filter_fragile_match_attributes pexp_attributes in + Doc.concat [print_attributes ~state attrs cmt_tbl; if_docs; else_doc] -and printExpression ~state (e : Parsetree.expression) cmtTbl = - let printArrow e = - let uncurried, attrsOnArrow, parameters, returnExpr = - ParsetreeViewer.funExpr e +and print_expression ~state (e : Parsetree.expression) cmt_tbl = + let print_arrow e = + let uncurried, attrs_on_arrow, parameters, return_expr = + ParsetreeViewer.fun_expr e in let ParsetreeViewer.{async; bs; attributes = attrs} = - ParsetreeViewer.processFunctionAttributes attrsOnArrow + ParsetreeViewer.process_function_attributes attrs_on_arrow in let uncurried = uncurried || bs in - let returnExpr, typConstraint = - match returnExpr.pexp_desc with + let return_expr, typ_constraint = + match return_expr.pexp_desc with | Pexp_constraint (expr, typ) -> ( { expr with pexp_attributes = - List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; + List.concat [expr.pexp_attributes; return_expr.pexp_attributes]; }, Some typ ) - | _ -> (returnExpr, None) + | _ -> (return_expr, None) in - let hasConstraint = - match typConstraint with + let has_constraint = + match typ_constraint with | Some _ -> true | None -> false in - let parametersDoc = - printExprFunParameters ~state ~inCallback:NoCallback ~uncurried ~async - ~hasConstraint parameters cmtTbl + let parameters_doc = + print_expr_fun_parameters ~state ~in_callback:NoCallback ~uncurried ~async + ~has_constraint parameters cmt_tbl in - let returnExprDoc = - let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = - match (returnExpr.pexp_desc, optBraces) with + let return_expr_doc = + let opt_braces, _ = ParsetreeViewer.process_braces_attr return_expr in + let should_inline = + match (return_expr.pexp_desc, opt_braces) with | _, Some _ -> true | ( ( Pexp_array _ | Pexp_tuple _ | Pexp_construct (_, Some _) @@ -2648,46 +2654,52 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = true | _ -> false in - let shouldIndent = - match returnExpr.pexp_desc with + let should_indent = + match return_expr.pexp_desc with | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> false | _ -> true in - let returnDoc = - let doc = printExpressionWithComments ~state returnExpr cmtTbl in - match Parens.expr returnExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces + let return_doc = + let doc = print_expression_with_comments ~state return_expr cmt_tbl in + match Parens.expr return_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc return_expr braces | Nothing -> doc in - if shouldInline then Doc.concat [Doc.space; returnDoc] + if should_inline then Doc.concat [Doc.space; return_doc] else Doc.group - (if shouldIndent then Doc.indent (Doc.concat [Doc.line; returnDoc]) - else Doc.concat [Doc.space; returnDoc]) + (if should_indent then Doc.indent (Doc.concat [Doc.line; return_doc]) + else Doc.concat [Doc.space; return_doc]) in - let typConstraintDoc = - match typConstraint with + let typ_constraint_doc = + match typ_constraint with | Some typ -> - let typDoc = - let doc = printTypExpr ~state typ cmtTbl in - if Parens.arrowReturnTypExpr typ then addParens doc else doc + let typ_doc = + let doc = print_typ_expr ~state typ cmt_tbl in + if Parens.arrow_return_typ_expr typ then add_parens doc else doc in - Doc.concat [Doc.text ": "; typDoc] + Doc.concat [Doc.text ": "; typ_doc] | _ -> Doc.nil in - let attrs = printAttributes ~state attrs cmtTbl in + let attrs = print_attributes ~state attrs cmt_tbl in Doc.group (Doc.concat - [attrs; parametersDoc; typConstraintDoc; Doc.text " =>"; returnExprDoc]) + [ + attrs; + parameters_doc; + typ_constraint_doc; + Doc.text " =>"; + return_expr_doc; + ]) in - let uncurried = Ast_uncurried.exprIsUncurriedFun e in + let uncurried = Ast_uncurried.expr_is_uncurried_fun e in let e_fun = - if uncurried then Ast_uncurried.exprExtractUncurriedFun e else e + if uncurried then Ast_uncurried.expr_extract_uncurried_fun e else e in - let printedExpression = + let printed_expression = match e_fun.pexp_desc with | Pexp_fun ( Nolabel, @@ -2706,21 +2718,22 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = {pexp_desc = Pexp_apply _} ); } ) -> (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - printExpressionWithComments ~state - (ParsetreeViewer.rewriteUnderscoreApply e_fun) - cmtTbl - | Pexp_fun _ | Pexp_newtype _ -> printArrow e + print_expression_with_comments ~state + (ParsetreeViewer.rewrite_underscore_apply e_fun) + cmt_tbl + | Pexp_fun _ | Pexp_newtype _ -> print_arrow e | Parsetree.Pexp_constant c -> - printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c - | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment ~state e cmtTbl + print_constant ~template_literal:(ParsetreeViewer.is_template_literal e) c + | Pexp_construct _ when ParsetreeViewer.has_jsx_attribute e.pexp_attributes + -> + print_jsx_fragment ~state e cmt_tbl | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> Doc.concat - [Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] + [Doc.text "list{"; print_comments_inside cmt_tbl e.pexp_loc; Doc.rbrace] | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let expressions, spread = ParsetreeViewer.collectListExpressions e in - let spreadDoc = + let expressions, spread = ParsetreeViewer.collect_list_expressions e in + let spread_doc = match spread with | Some expr -> Doc.concat @@ -2728,10 +2741,10 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = Doc.text ","; Doc.line; Doc.dotdotdot; - (let doc = printExpressionWithComments ~state expr cmtTbl in + (let doc = print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc); ] | None -> Doc.nil @@ -2743,27 +2756,27 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun expr -> let doc = - printExpressionWithComments ~state expr cmtTbl + print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc) expressions); - spreadDoc; + spread_doc; ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbrace; ]) - | Pexp_construct (longidentLoc, args) -> - let constr = printLongidentLocation longidentLoc cmtTbl in + | Pexp_construct (longident_loc, args) -> + let constr = print_longident_location longident_loc cmt_tbl in let args = match args with | None -> Doc.nil @@ -2775,10 +2788,10 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = Doc.concat [ Doc.lparen; - (let doc = printExpressionWithComments ~state arg cmtTbl in + (let doc = print_expression_with_comments ~state arg cmt_tbl in match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc arg braces | Nothing -> doc); Doc.rparen; ] @@ -2789,49 +2802,49 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun expr -> let doc = - printExpressionWithComments ~state expr cmtTbl + print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc) args); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ] | Some arg -> - let argDoc = - let doc = printExpressionWithComments ~state arg cmtTbl in + let arg_doc = + let doc = print_expression_with_comments ~state arg cmt_tbl in match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc arg braces | Nothing -> doc in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in + let should_hug = ParsetreeViewer.is_huggable_expression arg in Doc.concat [ Doc.lparen; - (if shouldHug then argDoc + (if should_hug then arg_doc else Doc.concat [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; + Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); + Doc.trailing_comma; + Doc.soft_line; ]); Doc.rparen; ] in Doc.group (Doc.concat [constr; args]) - | Pexp_ident path -> printLidentPath path cmtTbl + | Pexp_ident path -> print_lident_path path cmt_tbl | Pexp_tuple exprs -> Doc.group (Doc.concat @@ -2840,27 +2853,27 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun expr -> let doc = - printExpressionWithComments ~state expr cmtTbl + print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc) exprs); ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; + Doc.if_breaks (Doc.text ",") Doc.nil; + Doc.soft_line; Doc.rparen; ]) | Pexp_array [] -> Doc.concat - [Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket] + [Doc.lbracket; print_comments_inside cmt_tbl e.pexp_loc; Doc.rbracket] | Pexp_array exprs -> Doc.group (Doc.concat @@ -2869,26 +2882,28 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun expr -> let doc = - printExpressionWithComments ~state expr cmtTbl + print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc) exprs); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbracket; ]) | Pexp_variant (label, args) -> - let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in + let variant_name = + Doc.concat [Doc.text "#"; print_poly_var_ident label] + in let args = match args with | None -> Doc.nil @@ -2900,10 +2915,10 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = Doc.concat [ Doc.lparen; - (let doc = printExpressionWithComments ~state arg cmtTbl in + (let doc = print_expression_with_comments ~state arg cmt_tbl in match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc arg braces | Nothing -> doc); Doc.rparen; ] @@ -2914,65 +2929,75 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun expr -> let doc = - printExpressionWithComments ~state expr cmtTbl + print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc) args); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ] | Some arg -> - let argDoc = - let doc = printExpressionWithComments ~state arg cmtTbl in + let arg_doc = + let doc = print_expression_with_comments ~state arg cmt_tbl in match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc arg braces | Nothing -> doc in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in + let should_hug = ParsetreeViewer.is_huggable_expression arg in Doc.concat [ Doc.lparen; - (if shouldHug then argDoc + (if should_hug then arg_doc else Doc.concat [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; + Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); + Doc.trailing_comma; + Doc.soft_line; ]); Doc.rparen; ] in - Doc.group (Doc.concat [variantName; args]) - | Pexp_record (rows, spreadExpr) -> + Doc.group (Doc.concat [variant_name; args]) + | Pexp_record (rows, spread_expr) -> if rows = [] then Doc.concat - [Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] + [Doc.lbrace; print_comments_inside cmt_tbl e.pexp_loc; Doc.rbrace] else let spread = - match spreadExpr with + match spread_expr with | None -> Doc.nil - | Some expr -> + | Some ({pexp_desc} as expr) -> + let doc = + match pexp_desc with + | Pexp_ident {txt = expr} -> print_lident expr + | _ -> print_expression ~state expr cmt_tbl + in + let doc_with_spread = + Doc.concat + [ + Doc.dotdotdot; + (match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc); + ] + in Doc.concat [ - Doc.dotdotdot; - (let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); + print_comments doc_with_spread cmt_tbl expr.Parsetree.pexp_loc; Doc.comma; Doc.line; ] @@ -2983,38 +3008,38 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = * a: 1, * b: 2, * }` -> record is written on multiple lines, break the group *) - let forceBreak = + let force_break = e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum in - let punningAllowed = - match (spreadExpr, rows) with + let punning_allowed = + match (spread_expr, rows) with | None, [_] -> false (* disallow punning for single-element records *) | _ -> true in - Doc.breakableGroup ~forceBreak + Doc.breakable_group ~force_break (Doc.concat [ Doc.lbrace; Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; spread; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun row -> - printExpressionRecordRow ~state row cmtTbl - punningAllowed) + print_expression_record_row ~state row cmt_tbl + punning_allowed) rows); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbrace; ]) | Pexp_extension extension -> ( match extension with - | ( {txt = "bs.obj" | "obj"}, + | ( {txt = "obj"}, PStr [ { @@ -3028,65 +3053,66 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = * "a": 1, * "b": 2, * }` -> object is written on multiple lines, break the group *) - let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak + let force_break = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in + Doc.breakable_group ~force_break (Doc.concat [ Doc.lbrace; Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun row -> printBsObjectRow ~state row cmtTbl) + (fun row -> print_bs_object_row ~state row cmt_tbl) rows); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbrace; ]) - | extension -> printExtension ~state ~atModuleLvl:false extension cmtTbl) - | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) - when ParsetreeViewer.isSpreadBeltArrayConcat e -> - printBeltArrayConcatApply ~state subLists cmtTbl - | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) - when ParsetreeViewer.isSpreadBeltListConcat e -> - printBeltListConcatApply ~state subLists cmtTbl - | Pexp_apply (callExpr, args) -> - if ParsetreeViewer.isUnaryExpression e then - printUnaryExpression ~state e cmtTbl - else if ParsetreeViewer.isTemplateLiteral e then - printTemplateLiteral ~state e cmtTbl - else if ParsetreeViewer.isTaggedTemplateLiteral e then - printTaggedTemplateLiteral ~state callExpr args cmtTbl - else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression ~state e cmtTbl - else printPexpApply ~state e cmtTbl + | extension -> + print_extension ~state ~at_module_lvl:false extension cmt_tbl) + | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array sub_lists})]) + when ParsetreeViewer.is_spread_belt_array_concat e -> + print_belt_array_concat_apply ~state sub_lists cmt_tbl + | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array sub_lists})]) + when ParsetreeViewer.is_spread_belt_list_concat e -> + print_belt_list_concat_apply ~state sub_lists cmt_tbl + | Pexp_apply (call_expr, args) -> + if ParsetreeViewer.is_unary_expression e then + print_unary_expression ~state e cmt_tbl + else if ParsetreeViewer.is_template_literal e then + print_template_literal ~state e cmt_tbl + else if ParsetreeViewer.is_tagged_template_literal e then + print_tagged_template_literal ~state call_expr args cmt_tbl + else if ParsetreeViewer.is_binary_expression e then + print_binary_expression ~state e cmt_tbl + else print_pexp_apply ~state e cmt_tbl | Pexp_unreachable -> Doc.dot - | Pexp_field (expr, longidentLoc) -> + | Pexp_field (expr, longident_loc) -> let lhs = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.fieldExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.field_expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc in - Doc.concat [lhs; Doc.dot; printLidentPath longidentLoc cmtTbl] - | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr ~state e.pexp_attributes expr1 longidentLoc expr2 - e.pexp_loc cmtTbl + Doc.concat [lhs; Doc.dot; print_lident_path longident_loc cmt_tbl] + | Pexp_setfield (expr1, longident_loc, expr2) -> + print_set_field_expr ~state e.pexp_attributes expr1 longident_loc expr2 + e.pexp_loc cmt_tbl | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) - when ParsetreeViewer.isTernaryExpr e -> - let parts, alternate = ParsetreeViewer.collectTernaryParts e in - let ternaryDoc = + when ParsetreeViewer.is_ternary_expr e -> + let parts, alternate = ParsetreeViewer.collect_ternary_parts e in + let ternary_doc = match parts with | (condition1, consequent1) :: rest -> Doc.group (Doc.concat [ - printTernaryOperand ~state condition1 cmtTbl; + print_ternary_operand ~state condition1 cmt_tbl; Doc.indent (Doc.concat [ @@ -3095,7 +3121,7 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = (Doc.concat [ Doc.text "? "; - printTernaryOperand ~state consequent1 cmtTbl; + print_ternary_operand ~state consequent1 cmt_tbl; ]); Doc.concat (List.map @@ -3104,74 +3130,79 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = [ Doc.line; Doc.text ": "; - printTernaryOperand ~state condition cmtTbl; + print_ternary_operand ~state condition + cmt_tbl; Doc.line; Doc.text "? "; - printTernaryOperand ~state consequent cmtTbl; + print_ternary_operand ~state consequent + cmt_tbl; ]) rest); Doc.line; Doc.text ": "; - Doc.indent (printTernaryOperand ~state alternate cmtTbl); + Doc.indent + (print_ternary_operand ~state alternate cmt_tbl); ]); ]) | _ -> Doc.nil in - let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in - let needsParens = - match ParsetreeViewer.filterParsingAttrs attrs with + let attrs = ParsetreeViewer.filter_ternary_attributes e.pexp_attributes in + let needs_parens = + match ParsetreeViewer.filter_parsing_attrs attrs with | [] -> false | _ -> true in Doc.concat [ - printAttributes ~state attrs cmtTbl; - (if needsParens then addParens ternaryDoc else ternaryDoc); + print_attributes ~state attrs cmt_tbl; + (if needs_parens then add_parens ternary_doc else ternary_doc); ] | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~state e.pexp_attributes ifs elseExpr cmtTbl + let ifs, else_expr = ParsetreeViewer.collect_if_expressions e in + print_if_chain ~state e.pexp_attributes ifs else_expr cmt_tbl | Pexp_while (expr1, expr2) -> let condition = - let doc = printExpressionWithComments ~state expr1 cmtTbl in + let doc = print_expression_with_comments ~state expr1 cmt_tbl in match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr1 braces | Nothing -> doc in - Doc.breakableGroup ~forceBreak:true + Doc.breakable_group ~force_break:true (Doc.concat [ Doc.text "while "; - (if ParsetreeViewer.isBlockExpr expr1 then condition - else Doc.group (Doc.ifBreaks (addParens condition) condition)); + (if ParsetreeViewer.is_block_expr expr1 then condition + else Doc.group (Doc.if_breaks (add_parens condition) condition)); Doc.space; - printExpressionBlock ~state ~braces:true expr2 cmtTbl; + print_expression_block ~state ~braces:true expr2 cmt_tbl; ]) - | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> - Doc.breakableGroup ~forceBreak:true + | Pexp_for (pattern, from_expr, to_expr, direction_flag, body) -> + Doc.breakable_group ~force_break:true (Doc.concat [ Doc.text "for "; - printPattern ~state pattern cmtTbl; + print_pattern ~state pattern cmt_tbl; Doc.text " in "; - (let doc = printExpressionWithComments ~state fromExpr cmtTbl in - match Parens.expr fromExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc fromExpr braces + (let doc = + print_expression_with_comments ~state from_expr cmt_tbl + in + match Parens.expr from_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc from_expr braces | Nothing -> doc); - printDirectionFlag directionFlag; - (let doc = printExpressionWithComments ~state toExpr cmtTbl in - match Parens.expr toExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc toExpr braces + print_direction_flag direction_flag; + (let doc = print_expression_with_comments ~state to_expr cmt_tbl in + match Parens.expr to_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc to_expr braces | Nothing -> doc); Doc.space; - printExpressionBlock ~state ~braces:true body cmtTbl; + print_expression_block ~state ~braces:true body cmt_tbl; ]) | Pexp_constraint - ( {pexp_desc = Pexp_pack modExpr}, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> + ( {pexp_desc = Pexp_pack mod_expr}, + {ptyp_desc = Ptyp_package package_type; ptyp_loc} ) -> Doc.group (Doc.concat [ @@ -3179,121 +3210,130 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; - printModExpr ~state modExpr cmtTbl; + Doc.soft_line; + print_mod_expr ~state mod_expr cmt_tbl; Doc.text ": "; - printComments - (printPackageType ~state - ~printModuleKeywordAndParens:false packageType cmtTbl) - cmtTbl ptyp_loc; + print_comments + (print_package_type ~state + ~print_module_keyword_and_parens:false package_type + cmt_tbl) + cmt_tbl ptyp_loc; ]); - Doc.softLine; + Doc.soft_line; Doc.rparen; ]) | Pexp_constraint (expr, typ) -> - let exprDoc = - let doc = printExpressionWithComments ~state expr cmtTbl in + let expr_doc = + let doc = print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc in - Doc.concat [exprDoc; Doc.text ": "; printTypExpr ~state typ cmtTbl] + Doc.concat [expr_doc; Doc.text ": "; print_typ_expr ~state typ cmt_tbl] | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> - printExpressionBlock ~state ~braces:true e cmtTbl + print_expression_block ~state ~braces:true e cmt_tbl | Pexp_letexception (_extensionConstructor, _expr) -> - printExpressionBlock ~state ~braces:true e cmtTbl + print_expression_block ~state ~braces:true e cmt_tbl | Pexp_assert expr -> - let expr = printExpressionWithComments ~state expr cmtTbl in + let expr = print_expression_with_comments ~state expr cmt_tbl in Doc.concat [Doc.text "assert("; expr; Doc.text ")"] | Pexp_lazy expr -> let rhs = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.lazy_or_assert_or_await_expr_rhs expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc in Doc.group (Doc.concat [Doc.text "lazy "; rhs]) | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> - printExpressionBlock ~state ~braces:true e cmtTbl - | Pexp_pack modExpr -> + print_expression_block ~state ~braces:true e cmt_tbl + | Pexp_pack mod_expr -> Doc.group (Doc.concat [ Doc.text "module("; Doc.indent - (Doc.concat [Doc.softLine; printModExpr ~state modExpr cmtTbl]); - Doc.softLine; + (Doc.concat + [Doc.soft_line; print_mod_expr ~state mod_expr cmt_tbl]); + Doc.soft_line; Doc.rparen; ]) - | Pexp_sequence _ -> printExpressionBlock ~state ~braces:true e cmtTbl - | Pexp_let _ -> printExpressionBlock ~state ~braces:true e cmtTbl + | Pexp_sequence _ -> print_expression_block ~state ~braces:true e cmt_tbl + | Pexp_let _ -> print_expression_block ~state ~braces:true e cmt_tbl | Pexp_try (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~state expr cmtTbl in + let expr_doc = + let doc = print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc in Doc.concat [ Doc.text "try "; - exprDoc; + expr_doc; Doc.text " catch "; - printCases ~state cases cmtTbl; + print_cases ~state cases cmt_tbl; ] - | Pexp_match (_, [_; _]) when ParsetreeViewer.isIfLetExpr e -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~state e.pexp_attributes ifs elseExpr cmtTbl + | Pexp_match (_, [_; _]) when ParsetreeViewer.is_if_let_expr e -> + let ifs, else_expr = ParsetreeViewer.collect_if_expressions e in + print_if_chain ~state e.pexp_attributes ifs else_expr cmt_tbl | Pexp_match (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~state expr cmtTbl in + let expr_doc = + let doc = print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc in Doc.concat - [Doc.text "switch "; exprDoc; Doc.space; printCases ~state cases cmtTbl] + [ + Doc.text "switch "; + expr_doc; + Doc.space; + print_cases ~state cases cmt_tbl; + ] | Pexp_function cases -> - Doc.concat [Doc.text "x => switch x "; printCases ~state cases cmtTbl] - | Pexp_coerce (expr, typOpt, typ) -> - let docExpr = printExpressionWithComments ~state expr cmtTbl in - let docTyp = printTypExpr ~state typ cmtTbl in - let ofType = - match typOpt with + Doc.concat [Doc.text "x => switch x "; print_cases ~state cases cmt_tbl] + | Pexp_coerce (expr, typ_opt, typ) -> + let doc_expr = print_expression_with_comments ~state expr cmt_tbl in + let doc_typ = print_typ_expr ~state typ cmt_tbl in + let of_type = + match typ_opt with | None -> Doc.nil | Some typ1 -> - Doc.concat [Doc.text ": "; printTypExpr ~state typ1 cmtTbl] + Doc.concat [Doc.text ": "; print_typ_expr ~state typ1 cmt_tbl] in Doc.concat - [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] - | Pexp_send (parentExpr, label) -> - let parentDoc = - let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces + [Doc.lparen; doc_expr; of_type; Doc.text " :> "; doc_typ; Doc.rparen] + | Pexp_send (parent_expr, label) -> + let parent_doc = + let doc = print_expression_with_comments ~state parent_expr cmt_tbl in + match Parens.unary_expr_operand parent_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc parent_expr braces | Nothing -> doc in let member = - let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + let member_doc = + print_comments (Doc.text label.txt) cmt_tbl label.loc + in + Doc.concat [Doc.text "\""; member_doc; Doc.text "\""] in - Doc.group (Doc.concat [parentDoc; Doc.lbracket; member; Doc.rbracket]) + Doc.group (Doc.concat [parent_doc; Doc.lbracket; member; Doc.rbracket]) | Pexp_new _ -> Doc.text "Pexp_new not implemented in printer" | Pexp_setinstvar _ -> Doc.text "Pexp_setinstvar not implemented in printer" | Pexp_override _ -> Doc.text "Pexp_override not implemented in printer" | Pexp_poly _ -> Doc.text "Pexp_poly not implemented in printer" | Pexp_object _ -> Doc.text "Pexp_object not implemented in printer" in - let exprWithAwait = - if ParsetreeViewer.hasAwaitAttribute e.pexp_attributes then + let expr_with_await = + if ParsetreeViewer.has_await_attribute e.pexp_attributes then let rhs = match - Parens.lazyOrAssertOrAwaitExprRhs ~inAwait:true + Parens.lazy_or_assert_or_await_expr_rhs ~in_await:true { e with pexp_attributes = @@ -3304,67 +3344,69 @@ and printExpression ~state (e : Parsetree.expression) cmtTbl = e.pexp_attributes; } with - | Parens.Parenthesized -> addParens printedExpression - | Braced braces -> printBraces printedExpression e braces - | Nothing -> printedExpression + | Parens.Parenthesized -> add_parens printed_expression + | Braced braces -> print_braces printed_expression e braces + | Nothing -> printed_expression in Doc.concat [Doc.text "await "; rhs] - else printedExpression + else printed_expression in - let shouldPrintItsOwnAttributes = + let should_print_its_own_attributes = match e.pexp_desc with | Pexp_apply _ | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_ifthenelse _ -> true - | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true - | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> + | Pexp_match _ when ParsetreeViewer.is_if_let_expr e -> true + | Pexp_construct _ when ParsetreeViewer.has_jsx_attribute e.pexp_attributes + -> true | _ -> false in match e.pexp_attributes with - | [] -> exprWithAwait - | attrs when not shouldPrintItsOwnAttributes -> - Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; exprWithAwait]) - | _ -> exprWithAwait + | [] -> expr_with_await + | attrs when not should_print_its_own_attributes -> + Doc.group + (Doc.concat [print_attributes ~state attrs cmt_tbl; expr_with_await]) + | _ -> expr_with_await -and printPexpFun ~state ~inCallback e cmtTbl = - let uncurried, attrsOnArrow, parameters, returnExpr = - ParsetreeViewer.funExpr e +and print_pexp_fun ~state ~in_callback e cmt_tbl = + let uncurried, attrs_on_arrow, parameters, return_expr = + ParsetreeViewer.fun_expr e in let ParsetreeViewer.{async; bs; attributes = attrs} = - ParsetreeViewer.processFunctionAttributes attrsOnArrow + ParsetreeViewer.process_function_attributes attrs_on_arrow in let uncurried = bs || uncurried in - let returnExpr, typConstraint = - match returnExpr.pexp_desc with + let return_expr, typ_constraint = + match return_expr.pexp_desc with | Pexp_constraint (expr, typ) -> ( { expr with pexp_attributes = - List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; + List.concat [expr.pexp_attributes; return_expr.pexp_attributes]; }, Some typ ) - | _ -> (returnExpr, None) + | _ -> (return_expr, None) in - let parametersDoc = - printExprFunParameters ~state ~inCallback ~async ~uncurried - ~hasConstraint: - (match typConstraint with + let parameters_doc = + print_expr_fun_parameters ~state ~in_callback ~async ~uncurried + ~has_constraint: + (match typ_constraint with | Some _ -> true | None -> false) - parameters cmtTbl + parameters cmt_tbl in - let returnShouldIndent = - match returnExpr.pexp_desc with + let return_should_indent = + match return_expr.pexp_desc with | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> false | _ -> true in - let returnExprDoc = - let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = - match (returnExpr.pexp_desc, optBraces) with + let return_expr_doc = + let opt_braces, _ = ParsetreeViewer.process_braces_attr return_expr in + let should_inline = + match (return_expr.pexp_desc, opt_braces) with | _, Some _ -> true | ( ( Pexp_array _ | Pexp_tuple _ | Pexp_construct (_, Some _) @@ -3373,108 +3415,109 @@ and printPexpFun ~state ~inCallback e cmtTbl = true | _ -> false in - let returnDoc = - let doc = printExpressionWithComments ~state returnExpr cmtTbl in - match Parens.expr returnExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces + let return_doc = + let doc = print_expression_with_comments ~state return_expr cmt_tbl in + match Parens.expr return_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc return_expr braces | Nothing -> doc in - if shouldInline then Doc.concat [Doc.space; returnDoc] + if should_inline then Doc.concat [Doc.space; return_doc] else Doc.group - (if returnShouldIndent then + (if return_should_indent then Doc.concat [ - Doc.indent (Doc.concat [Doc.line; returnDoc]); - (match inCallback with - | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine + Doc.indent (Doc.concat [Doc.line; return_doc]); + (match in_callback with + | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.soft_line | _ -> Doc.nil); ] - else Doc.concat [Doc.space; returnDoc]) + else Doc.concat [Doc.space; return_doc]) in - let typConstraintDoc = - match typConstraint with - | Some typ -> Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl] + let typ_constraint_doc = + match typ_constraint with + | Some typ -> Doc.concat [Doc.text ": "; print_typ_expr ~state typ cmt_tbl] | _ -> Doc.nil in Doc.concat [ - printAttributes ~state attrs cmtTbl; - parametersDoc; - typConstraintDoc; + print_attributes ~state attrs cmt_tbl; + parameters_doc; + typ_constraint_doc; Doc.text " =>"; - returnExprDoc; + return_expr_doc; ] -and printTernaryOperand ~state expr cmtTbl = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.ternaryOperand expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces +and print_ternary_operand ~state expr cmt_tbl = + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.ternary_operand expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc -and printSetFieldExpr ~state attrs lhs longidentLoc rhs loc cmtTbl = - let rhsDoc = - let doc = printExpressionWithComments ~state rhs cmtTbl in - match Parens.setFieldExprRhs rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces +and print_set_field_expr ~state attrs lhs longident_loc rhs loc cmt_tbl = + let rhs_doc = + let doc = print_expression_with_comments ~state rhs cmt_tbl in + match Parens.set_field_expr_rhs rhs with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc rhs braces | Nothing -> doc in - let lhsDoc = - let doc = printExpressionWithComments ~state lhs cmtTbl in - match Parens.fieldExpr lhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc lhs braces + let lhs_doc = + let doc = print_expression_with_comments ~state lhs cmt_tbl in + match Parens.field_expr lhs with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc lhs braces | Nothing -> doc in - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let should_indent = ParsetreeViewer.is_binary_expression rhs in let doc = Doc.group (Doc.concat [ - lhsDoc; + lhs_doc; Doc.dot; - printLidentPath longidentLoc cmtTbl; + print_lident_path longident_loc cmt_tbl; Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + (if should_indent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhs_doc])) + else Doc.concat [Doc.space; rhs_doc]); ]) in let doc = match attrs with | [] -> doc - | attrs -> Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; doc]) + | attrs -> + Doc.group (Doc.concat [print_attributes ~state attrs cmt_tbl; doc]) in - printComments doc cmtTbl loc + print_comments doc cmt_tbl loc -and printTemplateLiteral ~state expr cmtTbl = +and print_template_literal ~state expr cmt_tbl = let tag = ref "js" in - let rec walkExpr expr = + let rec walk_expr expr = let open Parsetree in match expr.pexp_desc with | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, [(Nolabel, arg1); (Nolabel, arg2)] ) -> - let lhs = walkExpr arg1 in - let rhs = walkExpr arg2 in + let lhs = walk_expr arg1 in + let rhs = walk_expr arg2 in Doc.concat [lhs; rhs] | Pexp_constant (Pconst_string (txt, Some prefix)) -> tag := prefix; - printStringContents txt + print_string_contents txt | _ -> - let doc = printExpressionWithComments ~state expr cmtTbl in + let doc = print_expression_with_comments ~state expr cmt_tbl in let doc = match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc in Doc.group (Doc.concat [Doc.text "${"; Doc.indent doc; Doc.rbrace]) in - let content = walkExpr expr in + let content = walk_expr expr in Doc.concat [ (if !tag = "js" then Doc.nil else Doc.text !tag); @@ -3483,8 +3526,8 @@ and printTemplateLiteral ~state expr cmtTbl = Doc.text "`"; ] -and printTaggedTemplateLiteral ~state callExpr args cmtTbl = - let stringsList, valuesList = +and print_tagged_template_literal ~state call_expr args cmt_tbl = + let strings_list, values_list = match args with | [ (_, {Parsetree.pexp_desc = Pexp_array strings}); @@ -3499,9 +3542,9 @@ and printTaggedTemplateLiteral ~state callExpr args cmtTbl = (fun x -> match x with | {Parsetree.pexp_desc = Pexp_constant (Pconst_string (txt, _))} -> - printStringContents txt + print_string_contents txt | _ -> assert false) - stringsList + strings_list in let values = @@ -3510,10 +3553,10 @@ and printTaggedTemplateLiteral ~state callExpr args cmtTbl = Doc.concat [ Doc.text "${"; - printExpressionWithComments ~state x cmtTbl; + print_expression_with_comments ~state x cmt_tbl; Doc.text "}"; ]) - valuesList + values_list in let process strings values = @@ -3527,11 +3570,11 @@ and printTaggedTemplateLiteral ~state callExpr args cmtTbl = let content : Doc.t = process strings values in - let tag = printExpressionWithComments ~state callExpr cmtTbl in + let tag = print_expression_with_comments ~state call_expr cmt_tbl in Doc.concat [tag; Doc.text "`"; content; Doc.text "`"] -and printUnaryExpression ~state expr cmtTbl = - let printUnaryOperator op = +and print_unary_expression ~state expr cmt_tbl = + let print_unary_operator op = Doc.text (match op with | "~+" -> "+" @@ -3545,20 +3588,20 @@ and printUnaryExpression ~state expr cmtTbl = | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, [(Nolabel, operand)] ) -> - let printedOperand = - let doc = printExpressionWithComments ~state operand cmtTbl in - match Parens.unaryExprOperand operand with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc operand braces + let printed_operand = + let doc = print_expression_with_comments ~state operand cmt_tbl in + match Parens.unary_expr_operand operand with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc operand braces | Nothing -> doc in - let doc = Doc.concat [printUnaryOperator operator; printedOperand] in - printComments doc cmtTbl expr.pexp_loc + let doc = Doc.concat [print_unary_operator operator; printed_operand] in + print_comments doc cmt_tbl expr.pexp_loc | _ -> assert false -and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = - let printBinaryOperator ~inlineRhs operator = - let operatorTxt = +and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = + let print_binary_operator ~inline_rhs operator = + let operator_txt = match operator with | "|." | "|.u" -> "->" | "^" -> "++" @@ -3568,23 +3611,23 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = | "!=" -> "!==" | txt -> txt in - let spacingBeforeOperator = - if operator = "|." || operator = "|.u" then Doc.softLine + let spacing_before_operator = + if operator = "|." || operator = "|.u" then Doc.soft_line else if operator = "|>" then Doc.line else Doc.space in - let spacingAfterOperator = + let spacing_after_operator = if operator = "|." || operator = "|.u" then Doc.nil else if operator = "|>" then Doc.space - else if inlineRhs then Doc.space + else if inline_rhs then Doc.space else Doc.line in Doc.concat - [spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator] + [spacing_before_operator; Doc.text operator_txt; spacing_after_operator] in - let printOperand ~isLhs ~isMultiline expr parentOperator = - let rec flatten ~isLhs ~isMultiline expr parentOperator = - if ParsetreeViewer.isBinaryExpression expr then + let print_operand ~is_lhs ~is_multiline expr parent_operator = + let rec flatten ~is_lhs ~is_multiline expr parent_operator = + if ParsetreeViewer.is_binary_expression expr then match expr with | { pexp_desc = @@ -3593,100 +3636,103 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = [(_, left); (_, right)] ); } -> if - ParsetreeViewer.flattenableOperators parentOperator operator - && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) + ParsetreeViewer.flattenable_operators parent_operator operator + && not (ParsetreeViewer.has_attributes expr.pexp_attributes) then - let leftPrinted = flatten ~isLhs:true ~isMultiline left operator in - let rightPrinted = - let rightPrinteableAttrs, rightInternalAttrs = - ParsetreeViewer.partitionPrintableAttributes + let left_printed = + flatten ~is_lhs:true ~is_multiline left operator + in + let right_printed = + let right_printeable_attrs, right_internal_attrs = + ParsetreeViewer.partition_printable_attributes right.pexp_attributes in let doc = - printExpressionWithComments ~state - {right with pexp_attributes = rightInternalAttrs} - cmtTbl + print_expression_with_comments ~state + {right with pexp_attributes = right_internal_attrs} + cmt_tbl in let doc = - if Parens.flattenOperandRhs parentOperator right then + if Parens.flatten_operand_rhs parent_operator right then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in let doc = Doc.concat - [printAttributes ~state rightPrinteableAttrs cmtTbl; doc] + [print_attributes ~state right_printeable_attrs cmt_tbl; doc] in - match rightPrinteableAttrs with + match right_printeable_attrs with | [] -> doc - | _ -> addParens doc + | _ -> add_parens doc in - let isAwait = - ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes + let is_await = + ParsetreeViewer.has_await_attribute expr.pexp_attributes in let doc = - if isAwait then + if is_await then let parens = - Res_parens.binaryOperatorInsideAwaitNeedsParens operator + Res_parens.binary_operator_inside_await_needs_parens operator in Doc.concat [ Doc.lparen; Doc.text "await "; (if parens then Doc.lparen else Doc.nil); - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; + left_printed; + print_binary_operator ~inline_rhs:false operator; + right_printed; (if parens then Doc.rparen else Doc.nil); Doc.rparen; ] else match operator with - | ("|." | "|.u") when isMultiline -> + | ("|." | "|.u") when is_multiline -> (* If the pipe-chain is written over multiple lines, break automatically * `let x = a->b->c -> same line, break when line-width exceeded * `let x = a-> * b->c` -> pipe-chain is written on multiple lines, break the group *) - Doc.breakableGroup ~forceBreak:true + Doc.breakable_group ~force_break:true (Doc.concat [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; + left_printed; + print_binary_operator ~inline_rhs:false operator; + right_printed; ]) | _ -> Doc.concat [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; + left_printed; + print_binary_operator ~inline_rhs:false operator; + right_printed; ] in let doc = - if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then - Doc.concat [Doc.lparen; doc; Doc.rparen] + if (not is_lhs) && Parens.rhs_binary_expr_operand operator expr + then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in - printComments doc cmtTbl expr.pexp_loc + print_comments doc cmt_tbl expr.pexp_loc else - let printeableAttrs, internalAttrs = - ParsetreeViewer.partitionPrintableAttributes expr.pexp_attributes + let printeable_attrs, internal_attrs = + ParsetreeViewer.partition_printable_attributes + expr.pexp_attributes in let doc = - printExpressionWithComments ~state - {expr with pexp_attributes = internalAttrs} - cmtTbl + print_expression_with_comments ~state + {expr with pexp_attributes = internal_attrs} + cmt_tbl in let doc = if - Parens.subBinaryExprOperand parentOperator operator - || printeableAttrs <> [] - && (ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isTernaryExpr expr) + Parens.sub_binary_expr_operand parent_operator operator + || printeable_attrs <> [] + && (ParsetreeViewer.is_binary_expression expr + || ParsetreeViewer.is_ternary_expr expr) then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc in - Doc.concat [printAttributes ~state printeableAttrs cmtTbl; doc] + Doc.concat [print_attributes ~state printeable_attrs cmt_tbl; doc] | _ -> assert false else match expr.pexp_desc with @@ -3694,47 +3740,48 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, [(Nolabel, _); (Nolabel, _)] ) when loc.loc_ghost -> - let doc = printTemplateLiteral ~state expr cmtTbl in - printComments doc cmtTbl expr.Parsetree.pexp_loc + let doc = print_template_literal ~state expr cmt_tbl in + print_comments doc cmt_tbl expr.Parsetree.pexp_loc | Pexp_setfield (lhs, field, rhs) -> let doc = - printSetFieldExpr ~state expr.pexp_attributes lhs field rhs - expr.pexp_loc cmtTbl + print_set_field_expr ~state expr.pexp_attributes lhs field rhs + expr.pexp_loc cmt_tbl in - if isLhs then addParens doc else doc + if is_lhs then add_parens doc else doc | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, [(Nolabel, lhs); (Nolabel, rhs)] ) -> - let rhsDoc = printExpressionWithComments ~state rhs cmtTbl in - let lhsDoc = printExpressionWithComments ~state lhs cmtTbl in + let rhs_doc = print_expression_with_comments ~state rhs cmt_tbl in + let lhs_doc = print_expression_with_comments ~state lhs cmt_tbl in (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let should_indent = ParsetreeViewer.is_binary_expression rhs in let doc = Doc.group (Doc.concat [ - lhsDoc; + lhs_doc; Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + (if should_indent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhs_doc])) + else Doc.concat [Doc.space; rhs_doc]); ]) in let doc = match expr.pexp_attributes with | [] -> doc | attrs -> - Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; doc]) + Doc.group + (Doc.concat [print_attributes ~state attrs cmt_tbl; doc]) in - if isLhs then addParens doc else doc + if is_lhs then add_parens doc else doc | _ -> ( - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.binaryExprOperand ~isLhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.binary_expr_operand ~is_lhs expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc) in - flatten ~isLhs ~isMultiline expr parentOperator + flatten ~is_lhs ~is_multiline expr parent_operator in match expr.pexp_desc with | Pexp_apply @@ -3744,115 +3791,116 @@ and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = }, [(Nolabel, lhs); (Nolabel, rhs)] ) when not - (ParsetreeViewer.isBinaryExpression lhs - || ParsetreeViewer.isBinaryExpression rhs - || printAttributes ~state expr.pexp_attributes cmtTbl <> Doc.nil) -> - let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in - let lhsDoc = printOperand ~isLhs:true ~isMultiline:false lhs op in - let rhsDoc = printOperand ~isLhs:false ~isMultiline:false rhs op in + (ParsetreeViewer.is_binary_expression lhs + || ParsetreeViewer.is_binary_expression rhs + || print_attributes ~state expr.pexp_attributes cmt_tbl <> Doc.nil) + -> + let lhs_has_comment_below = has_comment_below cmt_tbl lhs.pexp_loc in + let lhs_doc = print_operand ~is_lhs:true ~is_multiline:false lhs op in + let rhs_doc = print_operand ~is_lhs:false ~is_multiline:false rhs op in Doc.group (Doc.concat [ - printAttributes ~state expr.pexp_attributes cmtTbl; - lhsDoc; - (match (lhsHasCommentBelow, op) with - | true, ("|." | "|.u") -> Doc.concat [Doc.softLine; Doc.text "->"] + print_attributes ~state expr.pexp_attributes cmt_tbl; + lhs_doc; + (match (lhs_has_comment_below, op) with + | true, ("|." | "|.u") -> Doc.concat [Doc.soft_line; Doc.text "->"] | false, ("|." | "|.u") -> Doc.text "->" | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "] | false, "|>" -> Doc.text " |> " | _ -> Doc.nil); - rhsDoc; + rhs_doc; ]) | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, [(Nolabel, lhs); (Nolabel, rhs)] ) -> - let isMultiline = + let is_multiline = lhs.pexp_loc.loc_start.pos_lnum < rhs.pexp_loc.loc_start.pos_lnum in let right = - let operatorWithRhs = - let rhsDoc = - printOperand - ~isLhs:(ParsetreeViewer.isRhsBinaryOperator operator) - ~isMultiline rhs operator + let operator_with_rhs = + let rhs_doc = + print_operand + ~is_lhs:(ParsetreeViewer.is_rhs_binary_operator operator) + ~is_multiline rhs operator in Doc.concat [ - printBinaryOperator - ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) + print_binary_operator + ~inline_rhs:(ParsetreeViewer.should_inline_rhs_binary_expr rhs) operator; - rhsDoc; + rhs_doc; ] in - if ParsetreeViewer.shouldIndentBinaryExpr expr then - Doc.group (Doc.indent operatorWithRhs) - else operatorWithRhs + if ParsetreeViewer.should_indent_binary_expr expr then + Doc.group (Doc.indent operator_with_rhs) + else operator_with_rhs in let doc = Doc.group (Doc.concat [ - printOperand - ~isLhs:(not @@ ParsetreeViewer.isRhsBinaryOperator operator) - ~isMultiline lhs operator; + print_operand + ~is_lhs:(not @@ ParsetreeViewer.is_rhs_binary_operator operator) + ~is_multiline lhs operator; right; ]) in Doc.group (Doc.concat [ - printAttributes ~state expr.pexp_attributes cmtTbl; + print_attributes ~state expr.pexp_attributes cmt_tbl; (match - Parens.binaryExpr + Parens.binary_expr { expr with pexp_attributes = - ParsetreeViewer.filterPrintableAttributes + ParsetreeViewer.filter_printable_attributes expr.pexp_attributes; } with - | Braced bracesLoc -> printBraces doc expr bracesLoc - | Parenthesized -> addParens doc + | Braced braces_loc -> print_braces doc expr braces_loc + | Parenthesized -> add_parens doc | Nothing -> doc); ]) | _ -> Doc.nil -and printBeltArrayConcatApply ~state subLists cmtTbl = - let makeSpreadDoc commaBeforeSpread = function +and print_belt_array_concat_apply ~state sub_lists cmt_tbl = + let make_spread_doc comma_before_spread = function | Some expr -> Doc.concat [ - commaBeforeSpread; + comma_before_spread; Doc.dotdotdot; - (let doc = printExpressionWithComments ~state expr cmtTbl in + (let doc = print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc); ] | None -> Doc.nil in - let makeSubListDoc (expressions, spread) = - let commaBeforeSpread = + let make_sub_list_doc (expressions, spread) = + let comma_before_spread = match expressions with | [] -> Doc.nil | _ -> Doc.concat [Doc.text ","; Doc.line] in - let spreadDoc = makeSpreadDoc commaBeforeSpread spread in + let spread_doc = make_spread_doc comma_before_spread spread in Doc.concat [ Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun expr -> - let doc = printExpressionWithComments ~state expr cmtTbl in + let doc = print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc) expressions); - spreadDoc; + spread_doc; ] in Doc.group @@ -3862,52 +3910,53 @@ and printBeltArrayConcatApply ~state subLists cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map makeSubListDoc - (List.map ParsetreeViewer.collectArrayExpressions subLists)); + (List.map make_sub_list_doc + (List.map ParsetreeViewer.collect_array_expressions + sub_lists)); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbracket; ]) -and printBeltListConcatApply ~state subLists cmtTbl = - let makeSpreadDoc commaBeforeSpread = function +and print_belt_list_concat_apply ~state sub_lists cmt_tbl = + let make_spread_doc comma_before_spread = function | Some expr -> Doc.concat [ - commaBeforeSpread; + comma_before_spread; Doc.dotdotdot; - (let doc = printExpressionWithComments ~state expr cmtTbl in + (let doc = print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc); ] | None -> Doc.nil in - let makeSubListDoc (expressions, spread) = - let commaBeforeSpread = + let make_sub_list_doc (expressions, spread) = + let comma_before_spread = match expressions with | [] -> Doc.nil | _ -> Doc.concat [Doc.text ","; Doc.line] in - let spreadDoc = makeSpreadDoc commaBeforeSpread spread in + let spread_doc = make_spread_doc comma_before_spread spread in Doc.concat [ Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map (fun expr -> - let doc = printExpressionWithComments ~state expr cmtTbl in + let doc = print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc) expressions); - spreadDoc; + spread_doc; ] in Doc.group @@ -3917,44 +3966,47 @@ and printBeltListConcatApply ~state subLists cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map makeSubListDoc - (List.map ParsetreeViewer.collectListExpressions subLists)); + (List.map make_sub_list_doc + (List.map ParsetreeViewer.collect_list_expressions + sub_lists)); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rbrace; ]) (* callExpr(arg1, arg2) *) -and printPexpApply ~state expr cmtTbl = +and print_pexp_apply ~state expr cmt_tbl = match expr.pexp_desc with | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> - let parentDoc = - let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces + [(Nolabel, parent_expr); (Nolabel, member_expr)] ) -> + let parent_doc = + let doc = print_expression_with_comments ~state parent_expr cmt_tbl in + match Parens.unary_expr_operand parent_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc parent_expr braces | Nothing -> doc in let member = - let memberDoc = - match memberExpr.pexp_desc with + let member_doc = + match member_expr.pexp_desc with | Pexp_ident lident -> - printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc - | _ -> printExpressionWithComments ~state memberExpr cmtTbl + print_comments + (print_longident lident.txt) + cmt_tbl member_expr.pexp_loc + | _ -> print_expression_with_comments ~state member_expr cmt_tbl in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + Doc.concat [Doc.text "\""; member_doc; Doc.text "\""] in Doc.group (Doc.concat [ - printAttributes ~state expr.pexp_attributes cmtTbl; - parentDoc; + print_attributes ~state expr.pexp_attributes cmt_tbl; + parent_doc; Doc.lbracket; member; Doc.rbracket; @@ -3962,174 +4014,181 @@ and printPexpApply ~state expr cmtTbl = | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, [(Nolabel, lhs); (Nolabel, rhs)] ) -> ( - let rhsDoc = - let doc = printExpressionWithComments ~state rhs cmtTbl in + let rhs_doc = + let doc = print_expression_with_comments ~state rhs cmt_tbl in match Parens.expr rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc rhs braces | Nothing -> doc in (* TODO: unify indentation of "=" *) - let shouldIndent = - (not (ParsetreeViewer.isBracedExpr rhs)) - && ParsetreeViewer.isBinaryExpression rhs + let should_indent = + (not (ParsetreeViewer.is_braced_expr rhs)) + && ParsetreeViewer.is_binary_expression rhs in let doc = Doc.group (Doc.concat [ - printExpressionWithComments ~state lhs cmtTbl; + print_expression_with_comments ~state lhs cmt_tbl; Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); + (if should_indent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhs_doc])) + else Doc.concat [Doc.space; rhs_doc]); ]) in match expr.pexp_attributes with | [] -> doc - | attrs -> Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; doc]) - ) + | attrs -> + Doc.group (Doc.concat [print_attributes ~state attrs cmt_tbl; doc])) | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) - when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> + [(Nolabel, parent_expr); (Nolabel, member_expr)] ) + when not (ParsetreeViewer.is_rewritten_underscore_apply_sugar parent_expr) + -> (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) let member = - let memberDoc = - let doc = printExpressionWithComments ~state memberExpr cmtTbl in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces + let member_doc = + let doc = print_expression_with_comments ~state member_expr cmt_tbl in + match Parens.expr member_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc member_expr braces | Nothing -> doc in - let shouldInline = - match memberExpr.pexp_desc with + let should_inline = + match member_expr.pexp_desc with | Pexp_constant _ | Pexp_ident _ -> true | _ -> false in - if shouldInline then memberDoc + if should_inline then member_doc else Doc.concat - [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] + [Doc.indent (Doc.concat [Doc.soft_line; member_doc]); Doc.soft_line] in - let parentDoc = - let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces + let parent_doc = + let doc = print_expression_with_comments ~state parent_expr cmt_tbl in + match Parens.unary_expr_operand parent_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc parent_expr braces | Nothing -> doc in Doc.group (Doc.concat [ - printAttributes ~state expr.pexp_attributes cmtTbl; - parentDoc; + print_attributes ~state expr.pexp_attributes cmt_tbl; + parent_doc; Doc.lbracket; member; Doc.rbracket; ]) | Pexp_apply ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr)] ) - -> + [(Nolabel, parent_expr); (Nolabel, member_expr); (Nolabel, target_expr)] + ) -> let member = - let memberDoc = - let doc = printExpressionWithComments ~state memberExpr cmtTbl in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces + let member_doc = + let doc = print_expression_with_comments ~state member_expr cmt_tbl in + match Parens.expr member_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc member_expr braces | Nothing -> doc in - let shouldInline = - match memberExpr.pexp_desc with + let should_inline = + match member_expr.pexp_desc with | Pexp_constant _ | Pexp_ident _ -> true | _ -> false in - if shouldInline then memberDoc + if should_inline then member_doc else Doc.concat - [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] + [Doc.indent (Doc.concat [Doc.soft_line; member_doc]); Doc.soft_line] in - let shouldIndentTargetExpr = - if ParsetreeViewer.isBracedExpr targetExpr then false + let should_indent_target_expr = + if ParsetreeViewer.is_braced_expr target_expr then false else - ParsetreeViewer.isBinaryExpression targetExpr + ParsetreeViewer.is_binary_expression target_expr || - match targetExpr with + match target_expr with | { pexp_attributes = [({Location.txt = "res.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); + pexp_desc = Pexp_ifthenelse (if_expr, _, _); } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + ParsetreeViewer.is_binary_expression if_expr + || ParsetreeViewer.has_attributes if_expr.pexp_attributes | {pexp_desc = Pexp_newtype _} -> false | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e + ParsetreeViewer.has_attributes e.pexp_attributes + || ParsetreeViewer.is_array_access e in - let targetExpr = - let doc = printExpressionWithComments ~state targetExpr cmtTbl in - match Parens.expr targetExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc targetExpr braces + let target_expr = + let doc = print_expression_with_comments ~state target_expr cmt_tbl in + match Parens.expr target_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc target_expr braces | Nothing -> doc in - let parentDoc = - let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces + let parent_doc = + let doc = print_expression_with_comments ~state parent_expr cmt_tbl in + match Parens.unary_expr_operand parent_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc parent_expr braces | Nothing -> doc in Doc.group (Doc.concat [ - printAttributes ~state expr.pexp_attributes cmtTbl; - parentDoc; + print_attributes ~state expr.pexp_attributes cmt_tbl; + parent_doc; Doc.lbracket; member; Doc.rbracket; Doc.text " ="; - (if shouldIndentTargetExpr then - Doc.indent (Doc.concat [Doc.line; targetExpr]) - else Doc.concat [Doc.space; targetExpr]); + (if should_indent_target_expr then + Doc.indent (Doc.concat [Doc.line; target_expr]) + else Doc.concat [Doc.space; target_expr]); ]) (* TODO: cleanup, are those branches even remotely performant? *) | Pexp_apply ({pexp_desc = Pexp_ident lident}, args) - when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression ~state lident args cmtTbl - | Pexp_apply (callExpr, args) -> + when ParsetreeViewer.is_jsx_expression expr -> + print_jsx_expression ~state lident args cmt_tbl + | Pexp_apply (call_expr, args) -> let args = List.map - (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) + (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewrite_underscore_apply arg)) args in let uncurried, attrs = - ParsetreeViewer.processUncurriedAppAttribute expr.pexp_attributes + ParsetreeViewer.process_uncurried_app_attribute expr.pexp_attributes in - let partial, attrs = ParsetreeViewer.processPartialAppAttribute attrs in + let partial, attrs = ParsetreeViewer.process_partial_app_attribute attrs in let args = if partial then let dummy = Ast_helper.Exp.constant (Ast_helper.Const.int 0) in args @ [(Asttypes.Labelled "...", dummy)] else args in - let dotted = state.uncurried_config |> Res_uncurried.getDotted ~uncurried in - let callExprDoc = - let doc = printExpressionWithComments ~state callExpr cmtTbl in - match Parens.callExpr callExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc callExpr braces + let dotted = + state.uncurried_config |> Res_uncurried.get_dotted ~uncurried + in + let call_expr_doc = + let doc = print_expression_with_comments ~state call_expr cmt_tbl in + match Parens.call_expr call_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc call_expr braces | Nothing -> doc in - if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then - let argsDoc = - printArgumentsWithCallbackInFirstPosition ~dotted ~state args cmtTbl + if ParsetreeViewer.requires_special_callback_printing_first_arg args then + let args_doc = + print_arguments_with_callback_in_first_position ~dotted ~state args + cmt_tbl in - Doc.concat [printAttributes ~state attrs cmtTbl; callExprDoc; argsDoc] - else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then - let argsDoc = - printArgumentsWithCallbackInLastPosition ~state ~dotted args cmtTbl + Doc.concat + [print_attributes ~state attrs cmt_tbl; call_expr_doc; args_doc] + else if ParsetreeViewer.requires_special_callback_printing_last_arg args + then + let args_doc = + print_arguments_with_callback_in_last_position ~state ~dotted args + cmt_tbl in (* * Fixes the following layout (the `[` and `]` should break): @@ -4145,26 +4204,27 @@ and printPexpApply ~state expr cmtTbl = * https://github.com/rescript-lang/syntax/issues/111 * https://github.com/rescript-lang/syntax/issues/166 *) - let maybeBreakParent = - if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil + let maybe_break_parent = + if Doc.will_break args_doc then Doc.break_parent else Doc.nil in Doc.concat [ - maybeBreakParent; - printAttributes ~state attrs cmtTbl; - callExprDoc; - argsDoc; + maybe_break_parent; + print_attributes ~state attrs cmt_tbl; + call_expr_doc; + args_doc; ] else - let argsDoc = printArguments ~state ~dotted ~partial args cmtTbl in - Doc.concat [printAttributes ~state attrs cmtTbl; callExprDoc; argsDoc] + let args_doc = print_arguments ~state ~dotted ~partial args cmt_tbl in + Doc.concat + [print_attributes ~state attrs cmt_tbl; call_expr_doc; args_doc] | _ -> assert false -and printJsxExpression ~state lident args cmtTbl = - let name = printJsxName lident in - let formattedProps, children = printJsxProps ~state args cmtTbl in +and print_jsx_expression ~state lident args cmt_tbl = + let name = print_jsx_name lident in + let formatted_props, children = print_jsx_props ~state args cmt_tbl in (*
*) - let hasChildren = + let has_children = match children with | Some { @@ -4175,7 +4235,7 @@ and printJsxExpression ~state lident args cmtTbl = | None -> false | _ -> true in - let isSelfClosing = + let is_self_closing = match children with | Some { @@ -4183,14 +4243,15 @@ and printJsxExpression ~state lident args cmtTbl = Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (has_comments_inside cmt_tbl loc) | _ -> false in - let printChildren children = - let lineSep = + let print_children children = + let line_sep = match children with | Some expr -> - if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + if has_nested_jsx_or_more_than_one_child expr then Doc.hard_line + else Doc.line | None -> Doc.line in Doc.concat @@ -4200,11 +4261,12 @@ and printJsxExpression ~state lident args cmtTbl = [ Doc.line; (match children with - | Some childrenExpression -> - printJsxChildren ~state childrenExpression ~sep:lineSep cmtTbl + | Some children_expression -> + print_jsx_children ~state children_expression ~sep:line_sep + cmt_tbl | None -> Doc.nil); ]); - lineSep; + line_sep; ] in Doc.group @@ -4213,17 +4275,17 @@ and printJsxExpression ~state lident args cmtTbl = Doc.group (Doc.concat [ - printComments - (Doc.concat [Doc.lessThan; name]) - cmtTbl lident.Asttypes.loc; - formattedProps; + print_comments + (Doc.concat [Doc.less_than; name]) + cmt_tbl lident.Asttypes.loc; + formatted_props; (match children with | Some { Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); } - when isSelfClosing -> + when is_self_closing -> Doc.text "/>" | _ -> (* if tag A has trailing comments then put > on the next line @@ -4232,15 +4294,15 @@ and printJsxExpression ~state lident args cmtTbl = > *) - if hasTrailingComments cmtTbl lident.Asttypes.loc then - Doc.concat [Doc.softLine; Doc.greaterThan] - else Doc.greaterThan); + if has_trailing_comments cmt_tbl lident.Asttypes.loc then + Doc.concat [Doc.soft_line; Doc.greater_than] + else Doc.greater_than); ]); - (if isSelfClosing then Doc.nil + (if is_self_closing then Doc.nil else Doc.concat [ - (if hasChildren then printChildren children + (if has_children then print_children children else match children with | Some @@ -4249,19 +4311,20 @@ and printJsxExpression ~state lident args cmtTbl = Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - printCommentsInside cmtTbl loc + print_comments_inside cmt_tbl loc | _ -> Doc.nil); Doc.text "" in let closing = Doc.text "" in - let lineSep = - if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + let line_sep = + if has_nested_jsx_or_more_than_one_child expr then Doc.hard_line + else Doc.line in Doc.group (Doc.concat @@ -4272,57 +4335,65 @@ and printJsxFragment ~state expr cmtTbl = | _ -> Doc.indent (Doc.concat - [Doc.line; printJsxChildren ~state expr ~sep:lineSep cmtTbl])); - lineSep; + [Doc.line; print_jsx_children ~state expr ~sep:line_sep cmt_tbl])); + line_sep; closing; ]) -and printJsxChildren ~state (childrenExpr : Parsetree.expression) ~sep cmtTbl = - match childrenExpr.pexp_desc with +and print_jsx_children ~state (children_expr : Parsetree.expression) ~sep + cmt_tbl = + match children_expr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in + let children, _ = ParsetreeViewer.collect_list_expressions children_expr in Doc.group (Doc.join ~sep (List.map (fun (expr : Parsetree.expression) -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc + let leading_line_comment_present = + has_leading_line_comment cmt_tbl expr.pexp_loc + in + let expr_doc = + print_expression_with_comments ~state expr cmt_tbl in - let exprDoc = printExpressionWithComments ~state expr cmtTbl in - let addParensOrBraces exprDoc = + let add_parens_or_braces expr_doc = (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = - if Parens.bracedExpr expr then addParens exprDoc else exprDoc + let inner_doc = + if Parens.braced_expr expr then add_parens expr_doc + else expr_doc in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + if leading_line_comment_present then add_braces inner_doc + else Doc.concat [Doc.lbrace; inner_doc; Doc.rbrace] in - match Parens.jsxChildExpr expr with - | Nothing -> exprDoc - | Parenthesized -> addParensOrBraces exprDoc - | Braced bracesLoc -> - printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) + match Parens.jsx_child_expr expr with + | Nothing -> expr_doc + | Parenthesized -> add_parens_or_braces expr_doc + | Braced braces_loc -> + print_comments + (add_parens_or_braces expr_doc) + cmt_tbl braces_loc) children)) | _ -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl childrenExpr.pexp_loc + let leading_line_comment_present = + has_leading_line_comment cmt_tbl children_expr.pexp_loc + in + let expr_doc = + print_expression_with_comments ~state children_expr cmt_tbl in - let exprDoc = printExpressionWithComments ~state childrenExpr cmtTbl in Doc.concat [ Doc.dotdotdot; - (match Parens.jsxChildExpr childrenExpr with + (match Parens.jsx_child_expr children_expr with | Parenthesized | Braced _ -> - let innerDoc = - if Parens.bracedExpr childrenExpr then addParens exprDoc - else exprDoc + let inner_doc = + if Parens.braced_expr children_expr then add_parens expr_doc + else expr_doc in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - | Nothing -> exprDoc); + if leading_line_comment_present then add_braces inner_doc + else Doc.concat [Doc.lbrace; inner_doc; Doc.rbrace] + | Nothing -> expr_doc); ] -and printJsxProps ~state args cmtTbl : Doc.t * Parsetree.expression option = +and print_jsx_props ~state args cmt_tbl : Doc.t * Parsetree.expression option = (* This function was introduced because we have different formatting behavior for self-closing tags and other tags we always put /> on a new line for self-closing tag when it breaks we should remove this function once the format is unified *) - let isSelfClosing children = + let is_self_closing children = match children with | { Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); pexp_loc = loc; } -> - not (hasCommentsInside cmtTbl loc) + not (has_comments_inside cmt_tbl loc) | _ -> false in let rec loop props args = @@ -4355,9 +4426,9 @@ and printJsxProps ~state args cmtTbl : Doc.t * Parsetree.expression option = Pexp_construct ({txt = Longident.Lident "()"}, None); } ); ] -> - let doc = if isSelfClosing children then Doc.line else Doc.nil in + let doc = if is_self_closing children then Doc.line else Doc.nil in (doc, Some children) - | ((_, expr) as lastProp) + | ((_, expr) as last_prop) :: [ (Asttypes.Labelled "children", children); ( Asttypes.Nolabel, @@ -4372,9 +4443,9 @@ and printJsxProps ~state args cmtTbl : Doc.t * Parsetree.expression option = {loc with loc_end = expr.pexp_loc.loc_end} | _ -> expr.pexp_loc in - let trailingCommentsPresent = hasTrailingComments cmtTbl loc in - let propDoc = printJsxProp ~state lastProp cmtTbl in - let formattedProps = + let trailing_comments_present = has_trailing_comments cmt_tbl loc in + let prop_doc = print_jsx_prop ~state last_prop cmt_tbl in + let formatted_props = Doc.concat [ Doc.indent @@ -4382,131 +4453,137 @@ and printJsxProps ~state args cmtTbl : Doc.t * Parsetree.expression option = [ Doc.line; Doc.group - (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); + (Doc.join ~sep:Doc.line (prop_doc :: props |> List.rev)); ]); (* print > on new line if the last prop has trailing comments *) - (match (isSelfClosing children, trailingCommentsPresent) with + (match (is_self_closing children, trailing_comments_present) with (* we always put /> on a new line when a self-closing tag breaks *) | true, _ -> Doc.line - | false, true -> Doc.softLine + | false, true -> Doc.soft_line | false, false -> Doc.nil); ] in - (formattedProps, Some children) + (formatted_props, Some children) | arg :: args -> - let propDoc = printJsxProp ~state arg cmtTbl in - loop (propDoc :: props) args + let prop_doc = print_jsx_prop ~state arg cmt_tbl in + loop (prop_doc :: props) args in loop [] args -and printJsxProp ~state arg cmtTbl = +and print_jsx_prop ~state arg cmt_tbl = match arg with - | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), + | ( ((Asttypes.Labelled lbl_txt | Optional lbl_txt) as lbl), { Parsetree.pexp_attributes = - [({Location.txt = "res.namedArgLoc"; loc = argLoc}, _)]; + [({Location.txt = "res.namedArgLoc"; loc = arg_loc}, _)]; pexp_desc = Pexp_ident {txt = Longident.Lident ident}; } ) - when lblTxt = ident (* jsx punning *) -> ( + when lbl_txt = ident (* jsx punning *) -> ( match lbl with | Nolabel -> Doc.nil - | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc + | Labelled _lbl -> print_comments (print_ident_like ident) cmt_tbl arg_loc | Optional _lbl -> - let doc = Doc.concat [Doc.question; printIdentLike ident] in - printComments doc cmtTbl argLoc) - | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), + let doc = Doc.concat [Doc.question; print_ident_like ident] in + print_comments doc cmt_tbl arg_loc) + | ( ((Asttypes.Labelled lbl_txt | Optional lbl_txt) as lbl), { Parsetree.pexp_attributes = []; pexp_desc = Pexp_ident {txt = Longident.Lident ident}; } ) - when lblTxt = ident (* jsx punning when printing from Reason *) -> ( + when lbl_txt = ident (* jsx punning when printing from Reason *) -> ( match lbl with | Nolabel -> Doc.nil - | Labelled _lbl -> printIdentLike ident - | Optional _lbl -> Doc.concat [Doc.question; printIdentLike ident]) + | Labelled _lbl -> print_ident_like ident + | Optional _lbl -> Doc.concat [Doc.question; print_ident_like ident]) | Asttypes.Labelled "_spreadProps", expr -> - let doc = printExpressionWithComments ~state expr cmtTbl in + let doc = print_expression_with_comments ~state expr cmt_tbl in Doc.concat [Doc.lbrace; Doc.dotdotdot; doc; Doc.rbrace] | lbl, expr -> - let argLoc, expr = + let arg_loc, expr = match expr.pexp_attributes with | ({Location.txt = "res.namedArgLoc"; loc}, _) :: attrs -> (loc, {expr with pexp_attributes = attrs}) | _ -> (Location.none, expr) in - let lblDoc = + let lbl_doc = match lbl with | Asttypes.Labelled lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + let lbl = print_comments (print_ident_like lbl) cmt_tbl arg_loc in Doc.concat [lbl; Doc.equal] | Asttypes.Optional lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + let lbl = print_comments (print_ident_like lbl) cmt_tbl arg_loc in Doc.concat [lbl; Doc.equal; Doc.question] | Nolabel -> Doc.nil in - let exprDoc = - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc + let expr_doc = + let leading_line_comment_present = + has_leading_line_comment cmt_tbl expr.pexp_loc in - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.jsxPropExpr expr with + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.jsx_prop_expr expr with | Parenthesized | Braced _ -> (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = if Parens.bracedExpr expr then addParens doc else doc in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + let inner_doc = + if Parens.braced_expr expr then add_parens doc else doc + in + if leading_line_comment_present then add_braces inner_doc + else Doc.concat [Doc.lbrace; inner_doc; Doc.rbrace] | _ -> doc in - let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in - printComments (Doc.concat [lblDoc; exprDoc]) cmtTbl fullLoc + let full_loc = {arg_loc with loc_end = expr.pexp_loc.loc_end} in + print_comments (Doc.concat [lbl_doc; expr_doc]) cmt_tbl full_loc (* div -> div. * Navabar.createElement -> Navbar * Staff.Users.createElement -> Staff.Users *) -and printJsxName {txt = lident} = - let printIdent = printIdentLike ~allowUident:true ~allowHyphen:true in +and print_jsx_name {txt = lident} = + let print_ident = print_ident_like ~allow_uident:true ~allow_hyphen:true in let rec flatten acc lident = match lident with - | Longident.Lident txt -> printIdent txt :: acc + | Longident.Lident txt -> print_ident txt :: acc | Ldot (lident, "createElement") -> flatten acc lident - | Ldot (lident, txt) -> flatten (printIdent txt :: acc) lident + | Ldot (lident, txt) -> flatten (print_ident txt :: acc) lident | _ -> acc in match lident with - | Longident.Lident txt -> printIdent txt + | Longident.Lident txt -> print_ident txt | _ as lident -> let segments = flatten [] lident in Doc.join ~sep:Doc.dot segments -and printArgumentsWithCallbackInFirstPosition ~dotted ~state args cmtTbl = +and print_arguments_with_callback_in_first_position ~dotted ~state args cmt_tbl + = (* Because the same subtree gets printed twice, we need to copy the cmtTbl. * consumed comments need to be marked not-consumed and reprinted… * Cheng's different comment algorithm will solve this. *) - let state = State.nextCustomLayout state in - let cmtTblCopy = CommentTable.copy cmtTbl in - let callback, printedArgs = + let state = State.next_custom_layout state in + let cmt_tbl_copy = CommentTable.copy cmt_tbl in + let callback, printed_args = match args with | (lbl, expr) :: args -> - let lblDoc = + let lbl_doc = match lbl with | Asttypes.Nolabel -> Doc.nil | Asttypes.Labelled txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] + Doc.concat [Doc.tilde; print_ident_like txt; Doc.equal] | Asttypes.Optional txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] + Doc.concat [Doc.tilde; print_ident_like txt; Doc.equal; Doc.question] in let callback = Doc.concat - [lblDoc; printPexpFun ~state ~inCallback:FitsOnOneLine expr cmtTbl] + [ + lbl_doc; + print_pexp_fun ~state ~in_callback:FitsOnOneLine expr cmt_tbl; + ] in - let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in - let printedArgs = + let callback = lazy (print_comments callback cmt_tbl expr.pexp_loc) in + let printed_args = lazy (Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun arg -> printArgument ~state arg cmtTbl) args)) + (List.map (fun arg -> print_argument ~state arg cmt_tbl) args)) in - (callback, printedArgs) + (callback, printed_args) | _ -> assert false in @@ -4515,7 +4592,7 @@ and printArgumentsWithCallbackInFirstPosition ~dotted ~state args cmtTbl = * MyModuleBlah.toList(argument) * }, longArgumet, veryLooooongArgument) *) - let fitsOnOneLine = + let fits_on_one_line = lazy (Doc.concat [ @@ -4523,7 +4600,7 @@ and printArgumentsWithCallbackInFirstPosition ~dotted ~state args cmtTbl = Lazy.force callback; Doc.comma; Doc.line; - Lazy.force printedArgs; + Lazy.force printed_args; Doc.rparen; ]) in @@ -4535,7 +4612,9 @@ and printArgumentsWithCallbackInFirstPosition ~dotted ~state args cmtTbl = * arg3, * ) *) - let breakAllArgs = lazy (printArguments ~state ~dotted args cmtTblCopy) in + let break_all_args = + lazy (print_arguments ~state ~dotted args cmt_tbl_copy) + in (* Sometimes one of the non-callback arguments will break. * There might be a single line comment in there, or a multiline string etc. @@ -4552,62 +4631,64 @@ and printArgumentsWithCallbackInFirstPosition ~dotted ~state args cmtTbl = * In this case, we always want the arguments broken over multiple lines, * like a normal function call. *) - if state |> State.shouldBreakCallback then Lazy.force breakAllArgs - else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs - else Doc.customLayout [Lazy.force fitsOnOneLine; Lazy.force breakAllArgs] + if state |> State.should_break_callback then Lazy.force break_all_args + else if Doc.will_break (Lazy.force printed_args) then + Lazy.force break_all_args + else + Doc.custom_layout [Lazy.force fits_on_one_line; Lazy.force break_all_args] -and printArgumentsWithCallbackInLastPosition ~state ~dotted args cmtTbl = +and print_arguments_with_callback_in_last_position ~state ~dotted args cmt_tbl = (* Because the same subtree gets printed twice, we need to copy the cmtTbl. * consumed comments need to be marked not-consumed and reprinted… * Cheng's different comment algorithm will solve this. *) - let state = state |> State.nextCustomLayout in - let cmtTblCopy = CommentTable.copy cmtTbl in - let cmtTblCopy2 = CommentTable.copy cmtTbl in + let state = state |> State.next_custom_layout in + let cmt_tbl_copy = CommentTable.copy cmt_tbl in + let cmt_tbl_copy2 = CommentTable.copy cmt_tbl in let rec loop acc args = match args with | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil) | [(lbl, expr)] -> - let lblDoc = + let lbl_doc = match lbl with | Asttypes.Nolabel -> Doc.nil | Asttypes.Labelled txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] + Doc.concat [Doc.tilde; print_ident_like txt; Doc.equal] | Asttypes.Optional txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] + Doc.concat [Doc.tilde; print_ident_like txt; Doc.equal; Doc.question] in - let callbackFitsOnOneLine = + let callback_fits_on_one_line = lazy - (let pexpFunDoc = - printPexpFun ~state ~inCallback:FitsOnOneLine expr cmtTbl + (let pexp_fun_doc = + print_pexp_fun ~state ~in_callback:FitsOnOneLine expr cmt_tbl in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTbl expr.pexp_loc) + let doc = Doc.concat [lbl_doc; pexp_fun_doc] in + print_comments doc cmt_tbl expr.pexp_loc) in - let callbackArgumentsFitsOnOneLine = + let callback_arguments_fits_on_one_line = lazy - (let pexpFunDoc = - printPexpFun ~state ~inCallback:ArgumentsFitOnOneLine expr - cmtTblCopy + (let pexp_fun_doc = + print_pexp_fun ~state ~in_callback:ArgumentsFitOnOneLine expr + cmt_tbl_copy in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTblCopy expr.pexp_loc) + let doc = Doc.concat [lbl_doc; pexp_fun_doc] in + print_comments doc cmt_tbl_copy expr.pexp_loc) in ( lazy (Doc.concat (List.rev acc)), - callbackFitsOnOneLine, - callbackArgumentsFitsOnOneLine ) + callback_fits_on_one_line, + callback_arguments_fits_on_one_line ) | arg :: args -> - let argDoc = printArgument ~state arg cmtTbl in - loop (Doc.line :: Doc.comma :: argDoc :: acc) args + let arg_doc = print_argument ~state arg cmt_tbl in + loop (Doc.line :: Doc.comma :: arg_doc :: acc) args in - let printedArgs, callback, callback2 = loop [] args in + let printed_args, callback, callback2 = loop [] args in (* Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument)) *) - let fitsOnOneLine = + let fits_on_one_line = lazy (Doc.concat [ (if dotted then Doc.text "(." else Doc.lparen); - Lazy.force printedArgs; + Lazy.force printed_args; Lazy.force callback; Doc.rparen; ]) @@ -4617,13 +4698,13 @@ and printArgumentsWithCallbackInLastPosition ~state ~dotted args cmtTbl = * MyModuleBlah.toList(argument) * ) *) - let arugmentsFitOnOneLine = + let arugments_fit_on_one_line = lazy (Doc.concat [ (if dotted then Doc.text "(." else Doc.lparen); - Lazy.force printedArgs; - Doc.breakableGroup ~forceBreak:true (Lazy.force callback2); + Lazy.force printed_args; + Doc.breakable_group ~force_break:true (Lazy.force callback2); Doc.rparen; ]) in @@ -4635,7 +4716,9 @@ and printArgumentsWithCallbackInLastPosition ~state ~dotted args cmtTbl = * (param1, parm2) => doStuff(param1, parm2) * ) *) - let breakAllArgs = lazy (printArguments ~state ~dotted args cmtTblCopy2) in + let break_all_args = + lazy (print_arguments ~state ~dotted args cmt_tbl_copy2) + in (* Sometimes one of the non-callback arguments will break. * There might be a single line comment in there, or a multiline string etc. @@ -4652,18 +4735,19 @@ and printArgumentsWithCallbackInLastPosition ~state ~dotted args cmtTbl = * In this case, we always want the arguments broken over multiple lines, * like a normal function call. *) - if state |> State.shouldBreakCallback then Lazy.force breakAllArgs - else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs + if state |> State.should_break_callback then Lazy.force break_all_args + else if Doc.will_break (Lazy.force printed_args) then + Lazy.force break_all_args else - Doc.customLayout + Doc.custom_layout [ - Lazy.force fitsOnOneLine; - Lazy.force arugmentsFitOnOneLine; - Lazy.force breakAllArgs; + Lazy.force fits_on_one_line; + Lazy.force arugments_fit_on_one_line; + Lazy.force break_all_args; ] -and printArguments ~state ~dotted ?(partial = false) - (args : (Asttypes.arg_label * Parsetree.expression) list) cmtTbl = +and print_arguments ~state ~dotted ?(partial = false) + (args : (Asttypes.arg_label * Parsetree.expression) list) cmt_tbl = match args with | [ ( Nolabel, @@ -4679,16 +4763,16 @@ and printArguments ~state ~dotted ?(partial = false) | true, true -> Doc.text "(.)" (* arity zero *) | true, false -> Doc.text "(. ())" (* arity one *) | _ -> Doc.text "()") - | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> - let argDoc = - let doc = printExpressionWithComments ~state arg cmtTbl in + | [(Nolabel, arg)] when ParsetreeViewer.is_huggable_expression arg -> + let arg_doc = + let doc = print_expression_with_comments ~state arg cmt_tbl in match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc arg braces | Nothing -> doc in Doc.concat - [(if dotted then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen] + [(if dotted then Doc.text "(. " else Doc.lparen); arg_doc; Doc.rparen] | args -> Doc.group (Doc.concat @@ -4697,13 +4781,15 @@ and printArguments ~state ~dotted ?(partial = false) Doc.indent (Doc.concat [ - (if dotted then Doc.line else Doc.softLine); + (if dotted then Doc.line else Doc.soft_line); Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun arg -> printArgument ~state arg cmtTbl) args); + (List.map + (fun arg -> print_argument ~state arg cmt_tbl) + args); ]); - (if partial then Doc.nil else Doc.trailingComma); - Doc.softLine; + (if partial then Doc.nil else Doc.trailing_comma); + Doc.soft_line; Doc.rparen; ]) @@ -4721,34 +4807,34 @@ and printArguments ~state ~dotted ?(partial = false) * | ~ label-name = ? expr * | ~ label-name = ? _ (* syntax sugar *) * | ~ label-name = ? expr : type *) -and printArgument ~state (argLbl, arg) cmtTbl = - match (argLbl, arg) with +and print_argument ~state (arg_lbl, arg) cmt_tbl = + match (arg_lbl, arg) with (* ~a (punned)*) | ( Labelled lbl, ({ pexp_desc = Pexp_ident {txt = Longident.Lident name}; pexp_attributes = [] | [({Location.txt = "res.namedArgLoc"}, _)]; - } as argExpr) ) - when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> + } as arg_expr) ) + when lbl = name && not (ParsetreeViewer.is_braced_expr arg_expr) -> let loc = match arg.pexp_attributes with | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> loc | _ -> arg.pexp_loc in - let doc = Doc.concat [Doc.tilde; printIdentLike lbl] in - printComments doc cmtTbl loc + let doc = Doc.concat [Doc.tilde; print_ident_like lbl] in + print_comments doc cmt_tbl loc (* ~a: int (punned)*) | ( Labelled lbl, { pexp_desc = Pexp_constraint - ( ({pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr), + ( ({pexp_desc = Pexp_ident {txt = Longident.Lident name}} as arg_expr), typ ); pexp_loc; pexp_attributes = ([] | [({Location.txt = "res.namedArgLoc"}, _)]) as attrs; } ) - when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> + when lbl = name && not (ParsetreeViewer.is_braced_expr arg_expr) -> let loc = match attrs with | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> @@ -4759,12 +4845,12 @@ and printArgument ~state (argLbl, arg) cmtTbl = Doc.concat [ Doc.tilde; - printIdentLike lbl; + print_ident_like lbl; Doc.text ": "; - printTypExpr ~state typ cmtTbl; + print_typ_expr ~state typ cmt_tbl; ] in - printComments doc cmtTbl loc + print_comments doc cmt_tbl loc (* ~a? (optional lbl punned)*) | ( Optional lbl, { @@ -4777,78 +4863,78 @@ and printArgument ~state (argLbl, arg) cmtTbl = | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> loc | _ -> arg.pexp_loc in - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.question] in - printComments doc cmtTbl loc + let doc = Doc.concat [Doc.tilde; print_ident_like lbl; Doc.question] in + print_comments doc cmt_tbl loc | _lbl, expr -> - let argLoc, expr = + let arg_loc, expr = match expr.pexp_attributes with | ({Location.txt = "res.namedArgLoc"; loc}, _) :: attrs -> (loc, {expr with pexp_attributes = attrs}) | _ -> (expr.pexp_loc, expr) in - let printedLbl, dotdotdot = - match argLbl with + let printed_lbl, dotdotdot = + match arg_lbl with | Nolabel -> (Doc.nil, false) | Labelled "..." -> let doc = Doc.text "..." in - (printComments doc cmtTbl argLoc, true) + (print_comments doc cmt_tbl arg_loc, true) | Labelled lbl -> - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in - (printComments doc cmtTbl argLoc, false) + let doc = Doc.concat [Doc.tilde; print_ident_like lbl; Doc.equal] in + (print_comments doc cmt_tbl arg_loc, false) | Optional lbl -> let doc = - Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] + Doc.concat [Doc.tilde; print_ident_like lbl; Doc.equal; Doc.question] in - (printComments doc cmtTbl argLoc, false) + (print_comments doc cmt_tbl arg_loc, false) in - let printedExpr = - let doc = printExpressionWithComments ~state expr cmtTbl in + let printed_expr = + let doc = print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc in - let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in + let loc = {arg_loc with loc_end = expr.pexp_loc.loc_end} in let doc = - if dotdotdot then printedLbl else Doc.concat [printedLbl; printedExpr] + if dotdotdot then printed_lbl else Doc.concat [printed_lbl; printed_expr] in - printComments doc cmtTbl loc + print_comments doc cmt_tbl loc -and printCases ~state (cases : Parsetree.case list) cmtTbl = - Doc.breakableGroup ~forceBreak:true +and print_cases ~state (cases : Parsetree.case list) cmt_tbl = + Doc.breakable_group ~force_break:true (Doc.concat [ Doc.lbrace; Doc.concat [ Doc.line; - printList - ~getLoc:(fun n -> + print_list + ~get_loc:(fun n -> { n.Parsetree.pc_lhs.ppat_loc with loc_end = - (match ParsetreeViewer.processBracesAttr n.pc_rhs with + (match ParsetreeViewer.process_braces_attr n.pc_rhs with | None, _ -> n.pc_rhs.pexp_loc.loc_end | Some ({loc}, _), _ -> loc.Location.loc_end); }) - ~print:(printCase ~state) ~nodes:cases cmtTbl; + ~print:(print_case ~state) ~nodes:cases cmt_tbl; ]; Doc.line; Doc.rbrace; ]) -and printCase ~state (case : Parsetree.case) cmtTbl = +and print_case ~state (case : Parsetree.case) cmt_tbl = let rhs = match case.pc_rhs.pexp_desc with | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ -> - printExpressionBlock ~state - ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) - case.pc_rhs cmtTbl + print_expression_block ~state + ~braces:(ParsetreeViewer.is_braced_expr case.pc_rhs) + case.pc_rhs cmt_tbl | _ -> ( - let doc = printExpressionWithComments ~state case.pc_rhs cmtTbl in + let doc = print_expression_with_comments ~state case.pc_rhs cmt_tbl in match Parens.expr case.pc_rhs with - | Parenthesized -> addParens doc + | Parenthesized -> add_parens doc | _ -> doc) in @@ -4861,43 +4947,44 @@ and printCase ~state (case : Parsetree.case) cmtTbl = [ Doc.line; Doc.text "if "; - printExpressionWithComments ~state expr cmtTbl; + print_expression_with_comments ~state expr cmt_tbl; ]) in - let shouldInlineRhs = + let should_inline_rhs = match case.pc_rhs.pexp_desc with | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) | Pexp_constant _ | Pexp_ident _ -> true - | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true + | _ when ParsetreeViewer.is_huggable_rhs case.pc_rhs -> true | _ -> false in - let shouldIndentPattern = + let should_indent_pattern = match case.pc_lhs.ppat_desc with | Ppat_or _ -> false | _ -> true in - let patternDoc = - let doc = printPattern ~state case.pc_lhs cmtTbl in + let pattern_doc = + let doc = print_pattern ~state case.pc_lhs cmt_tbl in match case.pc_lhs.ppat_desc with - | Ppat_constraint _ -> addParens doc + | Ppat_constraint _ -> add_parens doc | _ -> doc in let content = Doc.concat [ - (if shouldIndentPattern then Doc.indent patternDoc else patternDoc); + (if should_indent_pattern then Doc.indent pattern_doc else pattern_doc); Doc.indent guard; Doc.text " =>"; Doc.indent - (Doc.concat [(if shouldInlineRhs then Doc.space else Doc.line); rhs]); + (Doc.concat + [(if should_inline_rhs then Doc.space else Doc.line); rhs]); ] in Doc.group (Doc.concat [Doc.text "| "; content]) -and printExprFunParameters ~state ~inCallback ~async ~uncurried ~hasConstraint - parameters cmtTbl = - let dotted = state.uncurried_config |> Res_uncurried.getDotted ~uncurried in +and print_expr_fun_parameters ~state ~in_callback ~async ~uncurried + ~has_constraint parameters cmt_tbl = + let dotted = state.uncurried_config |> Res_uncurried.get_dotted ~uncurried in match parameters with (* let f = _ => () *) | [ @@ -4905,137 +4992,141 @@ and printExprFunParameters ~state ~inCallback ~async ~uncurried ~hasConstraint { attrs = []; lbl = Asttypes.Nolabel; - defaultExpr = None; + default_expr = None; pat = {Parsetree.ppat_desc = Ppat_any; ppat_loc}; }; ] when not dotted -> let any = - let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in - printComments doc cmtTbl ppat_loc + let doc = if has_constraint then Doc.text "(_)" else Doc.text "_" in + print_comments doc cmt_tbl ppat_loc in - if async then addAsync any else any + if async then add_async any else any (* let f = a => () *) | [ ParsetreeViewer.Parameter { attrs = []; lbl = Asttypes.Nolabel; - defaultExpr = None; + default_expr = None; pat = { - Parsetree.ppat_desc = Ppat_var stringLoc; + Parsetree.ppat_desc = Ppat_var string_loc; Parsetree.ppat_attributes = attrs; }; }; ] when not dotted -> - let txtDoc = - let var = printIdentLike stringLoc.txt in + let txt_doc = + let var = print_ident_like string_loc.txt in let var = match attrs with - | [] -> if hasConstraint then addParens var else var + | [] -> if has_constraint then add_parens var else var | attrs -> - let attrs = printAttributes ~state attrs cmtTbl in - addParens (Doc.concat [attrs; var]) + let attrs = print_attributes ~state attrs cmt_tbl in + add_parens (Doc.concat [attrs; var]) in - if async then addAsync var else var + if async then add_async var else var in - printComments txtDoc cmtTbl stringLoc.loc + print_comments txt_doc cmt_tbl string_loc.loc (* let f = () => () *) | [ ParsetreeViewer.Parameter { attrs = []; lbl = Asttypes.Nolabel; - defaultExpr = None; + default_expr = None; pat = {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, None)}; }; ] when not dotted -> let doc = - let lparenRparen = Doc.text "()" in - if async then addAsync lparenRparen else lparenRparen + let lparen_rparen = Doc.text "()" in + if async then add_async lparen_rparen else lparen_rparen in - printComments doc cmtTbl loc + print_comments doc cmt_tbl loc (* let f = (~greeting, ~from as hometown, ~x=?) => () *) | parameters -> - let inCallback = - match inCallback with + let in_callback = + match in_callback with | FitsOnOneLine -> true | _ -> false in - let maybeAsyncLparen = + let maybe_async_lparen = let lparen = if dotted then Doc.text "(. " else Doc.lparen in - if async then addAsync lparen else lparen + if async then add_async lparen else lparen in - let shouldHug = ParsetreeViewer.parametersShouldHug parameters in - let printedParamaters = + let should_hug = ParsetreeViewer.parameters_should_hug parameters in + let printed_paramaters = Doc.concat [ - (if shouldHug || inCallback then Doc.nil else Doc.softLine); + (if should_hug || in_callback then Doc.nil else Doc.soft_line); Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun p -> printExpFunParameter ~state p cmtTbl) + (fun p -> print_exp_fun_parameter ~state p cmt_tbl) parameters); ] in Doc.group (Doc.concat [ - maybeAsyncLparen; - (if shouldHug || inCallback then printedParamaters + maybe_async_lparen; + (if should_hug || in_callback then printed_paramaters else Doc.concat - [Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine]); + [ + Doc.indent printed_paramaters; + Doc.trailing_comma; + Doc.soft_line; + ]); Doc.rparen; ]) -and printExpFunParameter ~state parameter cmtTbl = +and print_exp_fun_parameter ~state parameter cmt_tbl = match parameter with | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> Doc.group (Doc.concat [ - printAttributes ~state attrs cmtTbl; + print_attributes ~state attrs cmt_tbl; Doc.text "type "; (* XX *) Doc.join ~sep:Doc.space (List.map (fun lbl -> - printComments - (printIdentLike lbl.Asttypes.txt) - cmtTbl lbl.Asttypes.loc) + print_comments + (print_ident_like lbl.Asttypes.txt) + cmt_tbl lbl.Asttypes.loc) lbls); ]) - | Parameter {attrs; lbl; defaultExpr; pat = pattern} -> - let hasBs, attrs = ParsetreeViewer.processBsAttribute attrs in - let dotted = if hasBs then Doc.concat [Doc.dot; Doc.space] else Doc.nil in - let attrs = printAttributes ~state attrs cmtTbl in + | Parameter {attrs; lbl; default_expr; pat = pattern} -> + let has_bs, attrs = ParsetreeViewer.process_bs_attribute attrs in + let dotted = if has_bs then Doc.concat [Doc.dot; Doc.space] else Doc.nil in + let attrs = print_attributes ~state attrs cmt_tbl in (* =defaultValue *) - let defaultExprDoc = - match defaultExpr with + let default_expr_doc = + match default_expr with | Some expr -> Doc.concat - [Doc.text "="; printExpressionWithComments ~state expr cmtTbl] + [Doc.text "="; print_expression_with_comments ~state expr cmt_tbl] | None -> Doc.nil in (* ~from as hometown * ~from -> punning *) - let labelWithPattern = + let label_with_pattern = match (lbl, pattern) with - | Asttypes.Nolabel, pattern -> printPattern ~state pattern cmtTbl + | Asttypes.Nolabel, pattern -> print_pattern ~state pattern cmt_tbl | ( (Asttypes.Labelled lbl | Optional lbl), - {ppat_desc = Ppat_var stringLoc; ppat_attributes} ) - when lbl = stringLoc.txt -> + {ppat_desc = Ppat_var string_loc; ppat_attributes} ) + when lbl = string_loc.txt -> (* ~d *) Doc.concat [ - printAttributes ~state ppat_attributes cmtTbl; + print_attributes ~state ppat_attributes cmt_tbl; Doc.text "~"; - printIdentLike lbl; + print_ident_like lbl; ] | ( (Asttypes.Labelled lbl | Optional lbl), { @@ -5046,24 +5137,24 @@ and printExpFunParameter ~state parameter cmtTbl = (* ~d: e *) Doc.concat [ - printAttributes ~state ppat_attributes cmtTbl; + print_attributes ~state ppat_attributes cmt_tbl; Doc.text "~"; - printIdentLike lbl; + print_ident_like lbl; Doc.text ": "; - printTypExpr ~state typ cmtTbl; + print_typ_expr ~state typ cmt_tbl; ] | (Asttypes.Labelled lbl | Optional lbl), pattern -> (* ~b as c *) Doc.concat [ Doc.text "~"; - printIdentLike lbl; + print_ident_like lbl; Doc.text " as "; - printPattern ~state pattern cmtTbl; + print_pattern ~state pattern cmt_tbl; ] in - let optionalLabelSuffix = - match (lbl, defaultExpr) with + let optional_label_suffix = + match (lbl, default_expr) with | Asttypes.Optional _, None -> Doc.text "=?" | _ -> Doc.nil in @@ -5071,117 +5162,125 @@ and printExpFunParameter ~state parameter cmtTbl = Doc.group (Doc.concat [ - dotted; attrs; labelWithPattern; defaultExprDoc; optionalLabelSuffix; + dotted; + attrs; + label_with_pattern; + default_expr_doc; + optional_label_suffix; ]) in - let cmtLoc = - match defaultExpr with + let cmt_loc = + match default_expr with | None -> ( match pattern.ppat_attributes with | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> {loc with loc_end = pattern.ppat_loc.loc_end} | _ -> pattern.ppat_loc) | Some expr -> - let startPos = + let start_pos = match pattern.ppat_attributes with | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> loc.loc_start | _ -> pattern.ppat_loc.loc_start in { pattern.ppat_loc with - loc_start = startPos; + loc_start = start_pos; loc_end = expr.pexp_loc.loc_end; } in - printComments doc cmtTbl cmtLoc + print_comments doc cmt_tbl cmt_loc -and printExpressionBlock ~state ~braces expr cmtTbl = - let rec collectRows acc expr = +and print_expression_block ~state ~braces expr cmt_tbl = + let rec collect_rows acc expr = match expr.Parsetree.pexp_desc with - | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> + | Parsetree.Pexp_letmodule (mod_name, mod_expr, expr2) -> let name = - let doc = Doc.text modName.txt in - printComments doc cmtTbl modName.loc + let doc = Doc.text mod_name.txt in + print_comments doc cmt_tbl mod_name.loc in - let name, modExpr = - match modExpr.pmod_desc with - | Pmod_constraint (modExpr2, modType) - when not (ParsetreeViewer.hasAwaitAttribute modExpr.pmod_attributes) + let name, mod_expr = + match mod_expr.pmod_desc with + | Pmod_constraint (mod_expr2, mod_type) + when not + (ParsetreeViewer.has_await_attribute mod_expr.pmod_attributes) -> let name = - Doc.concat [name; Doc.text ": "; printModType ~state modType cmtTbl] + Doc.concat + [name; Doc.text ": "; print_mod_type ~state mod_type cmt_tbl] in - (name, modExpr2) - | _ -> (name, modExpr) + (name, mod_expr2) + | _ -> (name, mod_expr) in - let letModuleDoc = + let let_module_doc = Doc.concat [ Doc.text "module "; name; Doc.text " = "; - printModExpr ~state modExpr cmtTbl; + print_mod_expr ~state mod_expr cmt_tbl; ] in - let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in - collectRows ((loc, letModuleDoc) :: acc) expr2 - | Pexp_letexception (extensionConstructor, expr2) -> + let loc = {expr.pexp_loc with loc_end = mod_expr.pmod_loc.loc_end} in + collect_rows ((loc, let_module_doc) :: acc) expr2 + | Pexp_letexception (extension_constructor, expr2) -> let loc = let loc = - {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} + {expr.pexp_loc with loc_end = extension_constructor.pext_loc.loc_end} in - match getFirstLeadingComment cmtTbl loc with + match get_first_leading_comment cmt_tbl loc with | None -> loc | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} + let cmt_loc = Comment.loc comment in + {cmt_loc with loc_end = loc.loc_end} in - let letExceptionDoc = - printExceptionDef ~state extensionConstructor cmtTbl + let let_exception_doc = + print_exception_def ~state extension_constructor cmt_tbl in - collectRows ((loc, letExceptionDoc) :: acc) expr2 - | Pexp_open (overrideFlag, longidentLoc, expr2) -> - let openDoc = + collect_rows ((loc, let_exception_doc) :: acc) expr2 + | Pexp_open (override_flag, longident_loc, expr2) -> + let open_doc = Doc.concat [ Doc.text "open"; - printOverrideFlag overrideFlag; + print_override_flag override_flag; Doc.space; - printLongidentLocation longidentLoc cmtTbl; + print_longident_location longident_loc cmt_tbl; ] in - let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in - collectRows ((loc, openDoc) :: acc) expr2 + let loc = {expr.pexp_loc with loc_end = longident_loc.loc.loc_end} in + collect_rows ((loc, open_doc) :: acc) expr2 | Pexp_sequence (expr1, expr2) -> - let exprDoc = - let doc = printExpression ~state expr1 cmtTbl in + let expr_doc = + let doc = print_expression ~state expr1 cmt_tbl in match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr1 braces | Nothing -> doc in let loc = expr1.pexp_loc in - collectRows ((loc, exprDoc) :: acc) expr2 - | Pexp_let (recFlag, valueBindings, expr2) -> ( + collect_rows ((loc, expr_doc) :: acc) expr2 + | Pexp_let (rec_flag, value_bindings, expr2) -> ( let loc = let loc = - match (valueBindings, List.rev valueBindings) with - | vb :: _, lastVb :: _ -> - {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end} + match (value_bindings, List.rev value_bindings) with + | vb :: _, last_vb :: _ -> + {vb.pvb_loc with loc_end = last_vb.pvb_loc.loc_end} | _ -> Location.none in - match getFirstLeadingComment cmtTbl loc with + match get_first_leading_comment cmt_tbl loc with | None -> loc | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} + let cmt_loc = Comment.loc comment in + {cmt_loc with loc_end = loc.loc_end} in - let recFlag = - match recFlag with + let rec_flag = + match rec_flag with | Asttypes.Nonrecursive -> Doc.nil | Asttypes.Recursive -> Doc.text "rec " in - let letDoc = printValueBindings ~state ~recFlag valueBindings cmtTbl in + let let_doc = + print_value_bindings ~state ~rec_flag value_bindings cmt_tbl + in (* let () = { * let () = foo() * () @@ -5190,25 +5289,25 @@ and printExpressionBlock ~state ~braces expr cmtTbl = *) match expr2.pexp_desc with | Pexp_construct ({txt = Longident.Lident "()"}, _) -> - List.rev ((loc, letDoc) :: acc) - | _ -> collectRows ((loc, letDoc) :: acc) expr2) + List.rev ((loc, let_doc) :: acc) + | _ -> collect_rows ((loc, let_doc) :: acc) expr2) | _ -> - let exprDoc = - let doc = printExpression ~state expr cmtTbl in + let expr_doc = + let doc = print_expression ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc in - List.rev ((expr.pexp_loc, exprDoc) :: acc) + List.rev ((expr.pexp_loc, expr_doc) :: acc) in - let rows = collectRows [] expr in + let rows = collect_rows [] expr in let block = - printList ~getLoc:fst ~nodes:rows + print_list ~get_loc:fst ~nodes:rows ~print:(fun (_, doc) _ -> doc) - ~forceBreak:true cmtTbl + ~force_break:true cmt_tbl in - Doc.breakableGroup ~forceBreak:true + Doc.breakable_group ~force_break:true (if braces then Doc.concat [ @@ -5236,10 +5335,10 @@ and printExpressionBlock ~state ~braces expr cmtTbl = * a + b * } *) -and printBraces doc expr bracesLoc = - let overMultipleLines = +and print_braces doc expr braces_loc = + let over_multiple_lines = let open Location in - bracesLoc.loc_end.pos_lnum > bracesLoc.loc_start.pos_lnum + braces_loc.loc_end.pos_lnum > braces_loc.loc_start.pos_lnum in match expr.Parsetree.pexp_desc with | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ @@ -5247,80 +5346,80 @@ and printBraces doc expr bracesLoc = (* already has braces *) doc | _ -> - Doc.breakableGroup ~forceBreak:overMultipleLines + Doc.breakable_group ~force_break:over_multiple_lines (Doc.concat [ Doc.lbrace; Doc.indent (Doc.concat [ - Doc.softLine; - (if Parens.bracedExpr expr then addParens doc else doc); + Doc.soft_line; + (if Parens.braced_expr expr then add_parens doc else doc); ]); - Doc.softLine; + Doc.soft_line; Doc.rbrace; ]) -and printOverrideFlag overrideFlag = - match overrideFlag with +and print_override_flag override_flag = + match override_flag with | Asttypes.Override -> Doc.text "!" | Fresh -> Doc.nil -and printDirectionFlag flag = +and print_direction_flag flag = match flag with | Asttypes.Downto -> Doc.text " downto " | Asttypes.Upto -> Doc.text " to " -and printExpressionRecordRow ~state (lbl, expr) cmtTbl punningAllowed = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in +and print_expression_record_row ~state (lbl, expr) cmt_tbl punning_allowed = + let cmt_loc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let doc = Doc.group (match expr.pexp_desc with | Pexp_ident {txt = Lident key; loc = _keyLoc} - when punningAllowed && Longident.last lbl.txt = key -> + when punning_allowed && Longident.last lbl.txt = key -> (* print punned field *) Doc.concat [ - printAttributes ~state expr.pexp_attributes cmtTbl; - printOptionalLabel expr.pexp_attributes; - printLidentPath lbl cmtTbl; + print_attributes ~state expr.pexp_attributes cmt_tbl; + print_optional_label expr.pexp_attributes; + print_lident_path lbl cmt_tbl; ] | _ -> Doc.concat [ - printLidentPath lbl cmtTbl; + print_lident_path lbl cmt_tbl; Doc.text ": "; - printOptionalLabel expr.pexp_attributes; - (let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.exprRecordRowRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + print_optional_label expr.pexp_attributes; + (let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr_record_row_rhs expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc); ]) in - printComments doc cmtTbl cmtLoc + print_comments doc cmt_tbl cmt_loc -and printBsObjectRow ~state (lbl, expr) cmtTbl = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in - let lblDoc = +and print_bs_object_row ~state (lbl, expr) cmt_tbl = + let cmt_loc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let lbl_doc = let doc = - Doc.concat [Doc.text "\""; printLongident lbl.txt; Doc.text "\""] + Doc.concat [Doc.text "\""; print_longident lbl.txt; Doc.text "\""] in - printComments doc cmtTbl lbl.loc + print_comments doc cmt_tbl lbl.loc in let doc = Doc.concat [ - lblDoc; + lbl_doc; Doc.text ": "; - (let doc = printExpressionWithComments ~state expr cmtTbl in + (let doc = print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces | Nothing -> doc); ] in - printComments doc cmtTbl cmtLoc + print_comments doc cmt_tbl cmt_loc (* The optional loc indicates whether we need to print the attributes in * relation to some location. In practise this means the following: @@ -5328,46 +5427,46 @@ and printBsObjectRow ~state (lbl, expr) cmtTbl = * `@attr * type t = string` -> attr is on prev line, print the attributes * with a line break between, we respect the users' original layout *) -and printAttributes ?loc ?(inline = false) ~state (attrs : Parsetree.attributes) - cmtTbl = - match ParsetreeViewer.filterParsingAttrs attrs with +and print_attributes ?loc ?(inline = false) ~state + (attrs : Parsetree.attributes) cmt_tbl = + match ParsetreeViewer.filter_parsing_attrs attrs with | [] -> Doc.nil | attrs -> - let lineBreak = + let line_break = match loc with | None -> Doc.line | Some loc -> ( match List.rev attrs with - | ({loc = firstLoc}, _) :: _ - when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> - Doc.hardLine + | ({loc = first_loc}, _) :: _ + when loc.loc_start.pos_lnum > first_loc.loc_end.pos_lnum -> + Doc.hard_line | _ -> Doc.line) in Doc.concat [ Doc.group - (Doc.joinWithSep - (List.map (fun attr -> printAttribute ~state attr cmtTbl) attrs)); - (if inline then Doc.space else lineBreak); + (Doc.join_with_sep + (List.map (fun attr -> print_attribute ~state attr cmt_tbl) attrs)); + (if inline then Doc.space else line_break); ] -and printPayload ~state (payload : Parsetree.payload) cmtTbl = +and print_payload ~state (payload : Parsetree.payload) cmt_tbl = match payload with | PStr [] -> Doc.nil | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpressionWithComments ~state expr cmtTbl in - let needsParens = + let expr_doc = print_expression_with_comments ~state expr cmt_tbl in + let needs_parens = match attrs with | [] -> false | _ -> true in - let shouldHug = ParsetreeViewer.isHuggableExpression expr in - if shouldHug then + let should_hug = ParsetreeViewer.is_huggable_expression expr in + if should_hug then Doc.concat [ Doc.lparen; - printAttributes ~state attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); + print_attributes ~state attrs cmt_tbl; + (if needs_parens then add_parens expr_doc else expr_doc); Doc.rparen; ] else @@ -5377,34 +5476,34 @@ and printPayload ~state (payload : Parsetree.payload) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; - printAttributes ~state attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); + Doc.soft_line; + print_attributes ~state attrs cmt_tbl; + (if needs_parens then add_parens expr_doc else expr_doc); ]); - Doc.softLine; + Doc.soft_line; Doc.rparen; ] | PStr [({pstr_desc = Pstr_value (_recFlag, _bindings)} as si)] -> - addParens (printStructureItem ~state si cmtTbl) - | PStr structure -> addParens (printStructure ~state structure cmtTbl) + add_parens (print_structure_item ~state si cmt_tbl) + | PStr structure -> add_parens (print_structure ~state structure cmt_tbl) | PTyp typ -> Doc.concat [ Doc.lparen; Doc.text ":"; - Doc.indent (Doc.concat [Doc.line; printTypExpr ~state typ cmtTbl]); - Doc.softLine; + Doc.indent (Doc.concat [Doc.line; print_typ_expr ~state typ cmt_tbl]); + Doc.soft_line; Doc.rparen; ] - | PPat (pat, optExpr) -> - let whenDoc = - match optExpr with + | PPat (pat, opt_expr) -> + let when_doc = + match opt_expr with | Some expr -> Doc.concat [ Doc.line; Doc.text "if "; - printExpressionWithComments ~state expr cmtTbl; + print_expression_with_comments ~state expr cmt_tbl; ] | None -> Doc.nil in @@ -5414,12 +5513,12 @@ and printPayload ~state (payload : Parsetree.payload) cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.text "? "; - printPattern ~state pat cmtTbl; - whenDoc; + print_pattern ~state pat cmt_tbl; + when_doc; ]); - Doc.softLine; + Doc.soft_line; Doc.rparen; ] | PSig signature -> @@ -5428,13 +5527,13 @@ and printPayload ~state (payload : Parsetree.payload) cmtTbl = Doc.lparen; Doc.text ":"; Doc.indent - (Doc.concat [Doc.line; printSignature ~state signature cmtTbl]); - Doc.softLine; + (Doc.concat [Doc.line; print_signature ~state signature cmt_tbl]); + Doc.soft_line; Doc.rparen; ] -and printAttribute ?(standalone = false) ~state - ((id, payload) : Parsetree.attribute) cmtTbl = +and print_attribute ?(standalone = false) ~state + ((id, payload) : Parsetree.attribute) cmt_tbl = match (id, payload) with | ( {txt = "res.doc"}, PStr @@ -5450,7 +5549,7 @@ and printAttribute ?(standalone = false) ~state Doc.text txt; Doc.text "*/"; ], - Doc.hardLine ) + Doc.hard_line ) | _ -> let id = match id.txt with @@ -5466,35 +5565,40 @@ and printAttribute ?(standalone = false) ~state (Doc.concat [ Doc.text (if standalone then "@@" else "@"); - Doc.text (convertBsExternalAttribute id.txt); - printPayload ~state payload cmtTbl; + Doc.text id.txt; + print_payload ~state payload cmt_tbl; ]), Doc.line ) -and printModExpr ~state modExpr cmtTbl = +and print_mod_expr ~state mod_expr cmt_tbl = let doc = - match modExpr.pmod_desc with - | Pmod_ident longidentLoc -> printLongidentLocation longidentLoc cmtTbl + match mod_expr.pmod_desc with + | Pmod_ident longident_loc -> print_longident_location longident_loc cmt_tbl | Pmod_structure [] -> - let shouldBreak = - modExpr.pmod_loc.loc_start.pos_lnum < modExpr.pmod_loc.loc_end.pos_lnum + let should_break = + mod_expr.pmod_loc.loc_start.pos_lnum + < mod_expr.pmod_loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak:shouldBreak + Doc.breakable_group ~force_break:should_break (Doc.concat - [Doc.lbrace; printCommentsInside cmtTbl modExpr.pmod_loc; Doc.rbrace]) + [ + Doc.lbrace; + print_comments_inside cmt_tbl mod_expr.pmod_loc; + Doc.rbrace; + ]) | Pmod_structure structure -> - Doc.breakableGroup ~forceBreak:true + Doc.breakable_group ~force_break:true (Doc.concat [ Doc.lbrace; Doc.indent (Doc.concat - [Doc.softLine; printStructure ~state structure cmtTbl]); - Doc.softLine; + [Doc.soft_line; print_structure ~state structure cmt_tbl]); + Doc.soft_line; Doc.rbrace; ]) | Pmod_unpack expr -> - let shouldHug = + let should_hug = match expr.pexp_desc with | Pexp_let _ -> true | Pexp_constraint @@ -5503,53 +5607,56 @@ and printModExpr ~state modExpr cmtTbl = true | _ -> false in - let expr, moduleConstraint = + let expr, module_constraint = match expr.pexp_desc with | Pexp_constraint - (expr, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> - let packageDoc = + (expr, {ptyp_desc = Ptyp_package package_type; ptyp_loc}) -> + let package_doc = let doc = - printPackageType ~state ~printModuleKeywordAndParens:false - packageType cmtTbl + print_package_type ~state ~print_module_keyword_and_parens:false + package_type cmt_tbl in - printComments doc cmtTbl ptyp_loc + print_comments doc cmt_tbl ptyp_loc in - let typeDoc = + let type_doc = Doc.group (Doc.concat - [Doc.text ":"; Doc.indent (Doc.concat [Doc.line; packageDoc])]) + [Doc.text ":"; Doc.indent (Doc.concat [Doc.line; package_doc])]) in - (expr, typeDoc) + (expr, type_doc) | _ -> (expr, Doc.nil) in - let unpackDoc = + let unpack_doc = Doc.group (Doc.concat - [printExpressionWithComments ~state expr cmtTbl; moduleConstraint]) + [ + print_expression_with_comments ~state expr cmt_tbl; + module_constraint; + ]) in Doc.group (Doc.concat [ Doc.text "unpack("; - (if shouldHug then unpackDoc + (if should_hug then unpack_doc else Doc.concat [ - Doc.indent (Doc.concat [Doc.softLine; unpackDoc]); - Doc.softLine; + Doc.indent (Doc.concat [Doc.soft_line; unpack_doc]); + Doc.soft_line; ]); Doc.rparen; ]) | Pmod_extension extension -> - printExtension ~state ~atModuleLvl:false extension cmtTbl + print_extension ~state ~at_module_lvl:false extension cmt_tbl | Pmod_apply _ -> - let args, callExpr = ParsetreeViewer.modExprApply modExpr in - let isUnitSugar = + let args, call_expr = ParsetreeViewer.mod_expr_apply mod_expr in + let is_unit_sugar = match args with | [{pmod_desc = Pmod_structure []}] -> true | _ -> false in - let shouldHug = + let should_hug = match args with | [{pmod_desc = Pmod_structure _}] -> true | _ -> false @@ -5557,77 +5664,80 @@ and printModExpr ~state modExpr cmtTbl = Doc.group (Doc.concat [ - printModExpr ~state callExpr cmtTbl; - (if isUnitSugar then - printModApplyArg ~state (List.hd args [@doesNotRaise]) cmtTbl + print_mod_expr ~state call_expr cmt_tbl; + (if is_unit_sugar then + print_mod_apply_arg ~state + (List.hd args [@doesNotRaise]) + cmt_tbl else Doc.concat [ Doc.lparen; - (if shouldHug then - printModApplyArg ~state + (if should_hug then + print_mod_apply_arg ~state (List.hd args [@doesNotRaise]) - cmtTbl + cmt_tbl else Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun modArg -> - printModApplyArg ~state modArg cmtTbl) + (fun mod_arg -> + print_mod_apply_arg ~state mod_arg cmt_tbl) args); ])); - (if not shouldHug then - Doc.concat [Doc.trailingComma; Doc.softLine] + (if not should_hug then + Doc.concat [Doc.trailing_comma; Doc.soft_line] else Doc.nil); Doc.rparen; ]); ]) - | Pmod_constraint (modExpr, modType) -> + | Pmod_constraint (mod_expr, mod_type) -> Doc.concat [ - printModExpr ~state modExpr cmtTbl; + print_mod_expr ~state mod_expr cmt_tbl; Doc.text ": "; - printModType ~state modType cmtTbl; + print_mod_type ~state mod_type cmt_tbl; ] - | Pmod_functor _ -> printModFunctor ~state modExpr cmtTbl + | Pmod_functor _ -> print_mod_functor ~state mod_expr cmt_tbl in let doc = - if ParsetreeViewer.hasAwaitAttribute modExpr.pmod_attributes then - match modExpr.pmod_desc with + if ParsetreeViewer.has_await_attribute mod_expr.pmod_attributes then + match mod_expr.pmod_desc with | Pmod_constraint _ -> Doc.concat [Doc.text "await "; Doc.lparen; doc; Doc.rparen] | _ -> Doc.concat [Doc.text "await "; doc] else doc in - printComments doc cmtTbl modExpr.pmod_loc + print_comments doc cmt_tbl mod_expr.pmod_loc -and printModFunctor ~state modExpr cmtTbl = - let parameters, returnModExpr = ParsetreeViewer.modExprFunctor modExpr in +and print_mod_functor ~state mod_expr cmt_tbl = + let parameters, return_mod_expr = ParsetreeViewer.mod_expr_functor mod_expr in (* let shouldInline = match returnModExpr.pmod_desc with *) (* | Pmod_structure _ | Pmod_ident _ -> true *) (* | Pmod_constraint ({pmod_desc = Pmod_structure _}, _) -> true *) (* | _ -> false *) (* in *) - let returnConstraint, returnModExpr = - match returnModExpr.pmod_desc with - | Pmod_constraint (modExpr, modType) -> - let constraintDoc = - let doc = printModType ~state modType cmtTbl in - if Parens.modExprFunctorConstraint modType then addParens doc else doc + let return_constraint, return_mod_expr = + match return_mod_expr.pmod_desc with + | Pmod_constraint (mod_expr, mod_type) -> + let constraint_doc = + let doc = print_mod_type ~state mod_type cmt_tbl in + if Parens.mod_expr_functor_constraint mod_type then add_parens doc + else doc in - let modConstraint = Doc.concat [Doc.text ": "; constraintDoc] in - (modConstraint, printModExpr ~state modExpr cmtTbl) - | _ -> (Doc.nil, printModExpr ~state returnModExpr cmtTbl) + let mod_constraint = Doc.concat [Doc.text ": "; constraint_doc] in + (mod_constraint, print_mod_expr ~state mod_expr cmt_tbl) + | _ -> (Doc.nil, print_mod_expr ~state return_mod_expr cmt_tbl) in - let parametersDoc = + let parameters_doc = match parameters with | [(attrs, {txt = "*"}, None)] -> Doc.group - (Doc.concat [printAttributes ~state attrs cmtTbl; Doc.text "()"]) + (Doc.concat [print_attributes ~state attrs cmt_tbl; Doc.text "()"]) | [([], {txt = lbl}, None)] -> Doc.text lbl | parameters -> Doc.group @@ -5637,128 +5747,136 @@ and printModFunctor ~state modExpr cmtTbl = Doc.indent (Doc.concat [ - Doc.softLine; + Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun param -> printModFunctorParam ~state param cmtTbl) + (fun param -> + print_mod_functor_param ~state param cmt_tbl) parameters); ]); - Doc.trailingComma; - Doc.softLine; + Doc.trailing_comma; + Doc.soft_line; Doc.rparen; ]) in Doc.group (Doc.concat - [parametersDoc; returnConstraint; Doc.text " => "; returnModExpr]) + [parameters_doc; return_constraint; Doc.text " => "; return_mod_expr]) -and printModFunctorParam ~state (attrs, lbl, optModType) cmtTbl = - let cmtLoc = - match optModType with +and print_mod_functor_param ~state (attrs, lbl, opt_mod_type) cmt_tbl = + let cmt_loc = + match opt_mod_type with | None -> lbl.Asttypes.loc - | Some modType -> - {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + | Some mod_type -> + {lbl.loc with loc_end = mod_type.Parsetree.pmty_loc.loc_end} in - let attrs = printAttributes ~state attrs cmtTbl in - let lblDoc = + let attrs = print_attributes ~state attrs cmt_tbl in + let lbl_doc = let doc = if lbl.txt = "*" then Doc.text "()" else Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc + print_comments doc cmt_tbl lbl.loc in let doc = Doc.group (Doc.concat [ attrs; - lblDoc; - (match optModType with + lbl_doc; + (match opt_mod_type with | None -> Doc.nil - | Some modType -> - Doc.concat [Doc.text ": "; printModType ~state modType cmtTbl]); + | Some mod_type -> + Doc.concat [Doc.text ": "; print_mod_type ~state mod_type cmt_tbl]); ]) in - printComments doc cmtTbl cmtLoc + print_comments doc cmt_tbl cmt_loc -and printModApplyArg ~state modExpr cmtTbl = - match modExpr.pmod_desc with +and print_mod_apply_arg ~state mod_expr cmt_tbl = + match mod_expr.pmod_desc with | Pmod_structure [] -> Doc.text "()" - | _ -> printModExpr ~state modExpr cmtTbl + | _ -> print_mod_expr ~state mod_expr cmt_tbl -and printExceptionDef ~state (constr : Parsetree.extension_constructor) cmtTbl = +and print_exception_def ~state (constr : Parsetree.extension_constructor) + cmt_tbl = let kind = match constr.pext_kind with | Pext_rebind longident -> Doc.indent (Doc.concat - [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) + [Doc.text " ="; Doc.line; print_longident_location longident cmt_tbl]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = + let gadt_doc = match gadt with - | Some typ -> Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl] + | Some typ -> + Doc.concat [Doc.text ": "; print_typ_expr ~state typ cmt_tbl] | None -> Doc.nil in Doc.concat - [printConstructorArguments ~state ~indent:false args cmtTbl; gadtDoc] + [ + print_constructor_arguments ~state ~indent:false args cmt_tbl; gadt_doc; + ] in let name = - printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc + print_comments (Doc.text constr.pext_name.txt) cmt_tbl constr.pext_name.loc in let doc = Doc.group (Doc.concat [ - printAttributes ~state constr.pext_attributes cmtTbl; + print_attributes ~state constr.pext_attributes cmt_tbl; Doc.text "exception "; name; kind; ]) in - printComments doc cmtTbl constr.pext_loc + print_comments doc cmt_tbl constr.pext_loc -and printExtensionConstructor ~state (constr : Parsetree.extension_constructor) - cmtTbl i = - let attrs = printAttributes ~state constr.pext_attributes cmtTbl in +and print_extension_constructor ~state + (constr : Parsetree.extension_constructor) cmt_tbl i = + let attrs = print_attributes ~state constr.pext_attributes cmt_tbl in let bar = - if i > 0 then Doc.text "| " else Doc.ifBreaks (Doc.text "| ") Doc.nil + if i > 0 then Doc.text "| " else Doc.if_breaks (Doc.text "| ") Doc.nil in let kind = match constr.pext_kind with | Pext_rebind longident -> Doc.indent (Doc.concat - [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) + [Doc.text " ="; Doc.line; print_longident_location longident cmt_tbl]) | Pext_decl (Pcstr_tuple [], None) -> Doc.nil | Pext_decl (args, gadt) -> - let gadtDoc = + let gadt_doc = match gadt with - | Some typ -> Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl] + | Some typ -> + Doc.concat [Doc.text ": "; print_typ_expr ~state typ cmt_tbl] | None -> Doc.nil in Doc.concat - [printConstructorArguments ~state ~indent:false args cmtTbl; gadtDoc] + [ + print_constructor_arguments ~state ~indent:false args cmt_tbl; gadt_doc; + ] in let name = - printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc + print_comments (Doc.text constr.pext_name.txt) cmt_tbl constr.pext_name.loc in Doc.concat [bar; Doc.group (Doc.concat [attrs; name; kind])] -let printTypeParams params = printTypeParams ~state:(State.init ()) params -let printTypExpr t = printTypExpr ~state:(State.init ()) t -let printExpression e = printExpression ~state:(State.init ()) e -let printPattern p = printPattern ~state:(State.init ()) p +let print_type_params params = print_type_params ~state:(State.init ()) params +let print_typ_expr t = print_typ_expr ~state:(State.init ()) t +let print_expression e = print_expression ~state:(State.init ()) e +let print_pattern p = print_pattern ~state:(State.init ()) p -let printImplementation ~width (s : Parsetree.structure) ~comments = - let cmtTbl = CommentTable.make () in - CommentTable.walkStructure s cmtTbl comments; +let print_implementation ~width (s : Parsetree.structure) ~comments = + let cmt_tbl = CommentTable.make () in + CommentTable.walk_structure s cmt_tbl comments; (* CommentTable.log cmtTbl; *) - let doc = printStructure ~state:(State.init ()) s cmtTbl in + let doc = print_structure ~state:(State.init ()) s cmt_tbl in (* Doc.debug doc; *) - Doc.toString ~width doc ^ "\n" + Doc.to_string ~width doc ^ "\n" -let printInterface ~width (s : Parsetree.signature) ~comments = - let cmtTbl = CommentTable.make () in - CommentTable.walkSignature s cmtTbl comments; - Doc.toString ~width (printSignature ~state:(State.init ()) s cmtTbl) ^ "\n" +let print_interface ~width (s : Parsetree.signature) ~comments = + let cmt_tbl = CommentTable.make () in + CommentTable.walk_signature s cmt_tbl comments; + Doc.to_string ~width (print_signature ~state:(State.init ()) s cmt_tbl) ^ "\n" -let printStructure = printStructure ~state:(State.init ()) +let print_structure = print_structure ~state:(State.init ()) diff --git a/analysis/vendor/res_syntax/res_printer.mli b/analysis/vendor/res_syntax/res_printer.mli index 3647dc379..c3b95b8e2 100644 --- a/analysis/vendor/res_syntax/res_printer.mli +++ b/analysis/vendor/res_syntax/res_printer.mli @@ -1,28 +1,30 @@ -val convertBsExternalAttribute : string -> string -val convertBsExtension : string -> string - -val printTypeParams : +val print_type_params : (Parsetree.core_type * Asttypes.variance) list -> Res_comments_table.t -> Res_doc.t -val printLongident : Longident.t -> Res_doc.t +val print_longident : Longident.t -> Res_doc.t -val printTypExpr : Parsetree.core_type -> Res_comments_table.t -> Res_doc.t +val print_typ_expr : Parsetree.core_type -> Res_comments_table.t -> Res_doc.t -val addParens : Res_doc.t -> Res_doc.t +val add_parens : Res_doc.t -> Res_doc.t -val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t +val print_expression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t -val printPattern : Parsetree.pattern -> Res_comments_table.t -> Res_doc.t +val print_pattern : Parsetree.pattern -> Res_comments_table.t -> Res_doc.t [@@live] -val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t +val print_structure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t [@@live] -val printImplementation : +val print_implementation : width:int -> Parsetree.structure -> comments:Res_comment.t list -> string -val printInterface : +val print_interface : width:int -> Parsetree.signature -> comments:Res_comment.t list -> string -val polyVarIdentToString : string -> string [@@live] +val print_ident_like : + ?allow_uident:bool -> ?allow_hyphen:bool -> string -> Res_doc.t + +val print_poly_var_ident : string -> Res_doc.t + +val polyvar_ident_to_string : string -> string [@@live] diff --git a/analysis/vendor/res_syntax/res_reporting.ml b/analysis/vendor/res_syntax/res_reporting.ml index 77d370af0..53a3eedce 100644 --- a/analysis/vendor/res_syntax/res_reporting.ml +++ b/analysis/vendor/res_syntax/res_reporting.ml @@ -13,4 +13,4 @@ type problem = | Lident [@live] | Unbalanced of Token.t [@live] -type parseError = Lexing.position * problem +type parse_error = Lexing.position * problem diff --git a/analysis/vendor/res_syntax/res_scanner.ml b/analysis/vendor/res_syntax/res_scanner.ml index b16904103..5d823a737 100644 --- a/analysis/vendor/res_syntax/res_scanner.ml +++ b/analysis/vendor/res_syntax/res_scanner.ml @@ -7,41 +7,41 @@ type mode = Jsx | Diamond (* We hide the implementation detail of the scanner reading character. Our char will also contain the special -1 value to indicate end-of-file. This isn't ideal; we should clean this up *) -let hackyEOFChar = Char.unsafe_chr (-1) -type charEncoding = Char.t +let hacky_eof_char = Char.unsafe_chr (-1) +type char_encoding = Char.t type t = { filename: string; src: string; mutable err: - startPos:Lexing.position -> - endPos:Lexing.position -> + start_pos:Lexing.position -> + end_pos:Lexing.position -> Diagnostics.category -> unit; - mutable ch: charEncoding; (* current character *) + mutable ch: char_encoding; (* current character *) mutable offset: int; (* current byte offset *) mutable offset16: int; (* current number of utf16 code units since line start *) - mutable lineOffset: int; (* current line offset *) + mutable line_offset: int; (* current line offset *) mutable lnum: int; (* current line number *) mutable mode: mode list; } -let setDiamondMode scanner = scanner.mode <- Diamond :: scanner.mode +let set_diamond_mode scanner = scanner.mode <- Diamond :: scanner.mode -let setJsxMode scanner = scanner.mode <- Jsx :: scanner.mode +let set_jsx_mode scanner = scanner.mode <- Jsx :: scanner.mode -let popMode scanner mode = +let pop_mode scanner mode = match scanner.mode with | m :: ms when m = mode -> scanner.mode <- ms | _ -> () -let inDiamondMode scanner = +let in_diamond_mode scanner = match scanner.mode with | Diamond :: _ -> true | _ -> false -let inJsxMode scanner = +let in_jsx_mode scanner = match scanner.mode with | Jsx :: _ -> true | _ -> false @@ -55,9 +55,9 @@ let position scanner = (* offset of the beginning of the line (number of bytes between the beginning of the scanner and the beginning of the line) *) - pos_bol = scanner.lineOffset; + pos_bol = scanner.line_offset; (* [pos_cnum - pos_bol] is the number of utf16 code units since line start *) - pos_cnum = scanner.lineOffset + scanner.offset16; + pos_cnum = scanner.line_offset + scanner.offset16; } (* Small debugging util @@ -74,28 +74,28 @@ let position scanner = ^ eof 18-18 let msg = "hello" *) -let _printDebug ~startPos ~endPos scanner token = +let _printDebug ~start_pos ~end_pos scanner token = let open Lexing in print_string scanner.src; - print_string ((String.make [@doesNotRaise]) startPos.pos_cnum ' '); + print_string ((String.make [@doesNotRaise]) start_pos.pos_cnum ' '); print_char '^'; - (match endPos.pos_cnum - startPos.pos_cnum with + (match end_pos.pos_cnum - start_pos.pos_cnum with | 0 -> if token = Token.Eof then () else assert false | 1 -> () | n -> print_string ((String.make [@doesNotRaise]) (n - 2) '-'); print_char '^'); print_char ' '; - print_string (Res_token.toString token); + print_string (Res_token.to_string token); print_char ' '; - print_int startPos.pos_cnum; + print_int start_pos.pos_cnum; print_char '-'; - print_int endPos.pos_cnum; + print_int end_pos.pos_cnum; print_endline "" [@@live] let next scanner = - let nextOffset = scanner.offset + 1 in + let next_offset = scanner.offset + 1 in let utf16len = match Ext_utf8.classify scanner.ch with | Single _ | Invalid -> 1 @@ -109,17 +109,17 @@ let next scanner = -> we can just bump the line count on \n *) in if newline then ( - scanner.lineOffset <- nextOffset; + scanner.line_offset <- next_offset; scanner.offset16 <- 0; scanner.lnum <- scanner.lnum + 1) else scanner.offset16 <- scanner.offset16 + utf16len; - if nextOffset < String.length scanner.src then ( - scanner.offset <- nextOffset; - scanner.ch <- String.unsafe_get scanner.src nextOffset) + if next_offset < String.length scanner.src then ( + scanner.offset <- next_offset; + scanner.ch <- String.unsafe_get scanner.src next_offset) else ( scanner.offset <- String.length scanner.src; - scanner.offset16 <- scanner.offset - scanner.lineOffset; - scanner.ch <- hackyEOFChar) + scanner.offset16 <- scanner.offset - scanner.line_offset; + scanner.ch <- hacky_eof_char) let next2 scanner = next scanner; @@ -133,44 +133,44 @@ let next3 scanner = let peek scanner = if scanner.offset + 1 < String.length scanner.src then String.unsafe_get scanner.src (scanner.offset + 1) - else hackyEOFChar + else hacky_eof_char let peek2 scanner = if scanner.offset + 2 < String.length scanner.src then String.unsafe_get scanner.src (scanner.offset + 2) - else hackyEOFChar + else hacky_eof_char let peek3 scanner = if scanner.offset + 3 < String.length scanner.src then String.unsafe_get scanner.src (scanner.offset + 3) - else hackyEOFChar + else hacky_eof_char let make ~filename src = { filename; src; - err = (fun ~startPos:_ ~endPos:_ _ -> ()); - ch = (if src = "" then hackyEOFChar else String.unsafe_get src 0); + err = (fun ~start_pos:_ ~end_pos:_ _ -> ()); + ch = (if src = "" then hacky_eof_char else String.unsafe_get src 0); offset = 0; offset16 = 0; - lineOffset = 0; + line_offset = 0; lnum = 1; mode = []; } (* generic helpers *) -let isWhitespace ch = +let is_whitespace ch = match ch with | ' ' | '\t' | '\n' | '\r' -> true | _ -> false -let rec skipWhitespace scanner = - if isWhitespace scanner.ch then ( +let rec skip_whitespace scanner = + if is_whitespace scanner.ch then ( next scanner; - skipWhitespace scanner) + skip_whitespace scanner) -let digitValue ch = +let digit_value ch = match ch with | '0' .. '9' -> Char.code ch - 48 | 'a' .. 'f' -> Char.code ch - Char.code 'a' + 10 @@ -179,29 +179,30 @@ let digitValue ch = (* scanning helpers *) -let scanIdentifier scanner = - let startOff = scanner.offset in - let rec skipGoodChars scanner = - match (scanner.ch, inJsxMode scanner) with +let scan_identifier scanner = + let start_off = scanner.offset in + let rec skip_good_chars scanner = + match (scanner.ch, in_jsx_mode scanner) with | ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\''), false -> next scanner; - skipGoodChars scanner + skip_good_chars scanner | ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\'' | '-'), true -> next scanner; - skipGoodChars scanner + skip_good_chars scanner | _ -> () in - skipGoodChars scanner; + skip_good_chars scanner; let str = - (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) + (String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - start_off) in if '{' == scanner.ch && str = "list" then ( next scanner; (* TODO: this isn't great *) - Token.lookupKeyword "list{") - else Token.lookupKeyword str + Token.lookup_keyword "list{") + else Token.lookup_keyword str -let scanDigits scanner ~base = +let scan_digits scanner ~base = if base <= 10 then let rec loop scanner = match scanner.ch with @@ -223,8 +224,8 @@ let scanDigits scanner ~base = loop scanner (* float: (0…9) { 0…9∣ _ } [. { 0…9∣ _ }] [(e∣ E) [+∣ -] (0…9) { 0…9∣ _ }] *) -let scanNumber scanner = - let startOff = scanner.offset in +let scan_number scanner = + let start_off = scanner.offset in (* integer part *) let base = @@ -245,92 +246,96 @@ let scanNumber scanner = 8) | _ -> 10 in - scanDigits scanner ~base; + scan_digits scanner ~base; (* *) - let isFloat = + let is_float = if '.' == scanner.ch then ( next scanner; - scanDigits scanner ~base; + scan_digits scanner ~base; true) else false in (* exponent part *) - let isFloat = + let is_float = match scanner.ch with | 'e' | 'E' | 'p' | 'P' -> (match peek scanner with | '+' | '-' -> next2 scanner | _ -> next scanner); - scanDigits scanner ~base; + scan_digits scanner ~base; true - | _ -> isFloat + | _ -> is_float in let literal = - (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) + (String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - start_off) in (* suffix *) let suffix = match scanner.ch with - | 'n' -> - let msg = - "Unsupported number type (nativeint). Did you mean `" ^ literal ^ "`?" - in - let pos = position scanner in - scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); - next scanner; - Some 'n' | ('g' .. 'z' | 'G' .. 'Z') as ch -> next scanner; Some ch | _ -> None in - if isFloat then Token.Float {f = literal; suffix} + if is_float then Token.Float {f = literal; suffix} else Token.Int {i = literal; suffix} -let scanExoticIdentifier scanner = - (* TODO: are we disregarding the current char...? Should be a quote *) - next scanner; - let buffer = Buffer.create 20 in - let startPos = position scanner in +let scan_exotic_identifier scanner = + let start_pos = position scanner in + let start_off = scanner.offset in + + next2 scanner; let rec scan () = match scanner.ch with | '"' -> next scanner | '\n' | '\r' -> (* line break *) - let endPos = position scanner in - scanner.err ~startPos ~endPos + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos (Diagnostics.message "A quoted identifier can't contain line breaks."); next scanner - | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos + | ch when ch == hacky_eof_char -> + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos (Diagnostics.message "Did you forget a \" here?") - | ch -> - Buffer.add_char buffer ch; + | _ -> next scanner; scan () in scan (); - (* TODO: do we really need to create a new buffer instead of substring once? *) - Token.Lident (Buffer.contents buffer) -let scanStringEscapeSequence ~startPos scanner = + let ident = + (String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - start_off) + in + let name = Ext_ident.unwrap_uppercase_exotic ident in + if name = String.empty then ( + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos + (Diagnostics.message "A quoted identifier can't be empty string."); + Token.Lident ident) + else if Ext_ident.is_uident name then Token.Lident ident + (* Exotic ident with uppercase letter should be encoded to avoid confusing in OCaml parsetree *) + else Token.Lident name + +let scan_string_escape_sequence ~start_pos scanner = let scan ~n ~base ~max = let rec loop n x = if n == 0 then x else - let d = digitValue scanner.ch in + let d = digit_value scanner.ch in if d >= base then ( let pos = position scanner in let msg = - if scanner.ch == hackyEOFChar then "unclosed escape sequence" + if scanner.ch == hacky_eof_char then "unclosed escape sequence" else "unknown escape sequence" in - scanner.err ~startPos ~endPos:pos (Diagnostics.message msg); + scanner.err ~start_pos ~end_pos:pos (Diagnostics.message msg); -1) else let () = next scanner in @@ -340,7 +345,7 @@ let scanStringEscapeSequence ~startPos scanner = if x > max || (0xD800 <= x && x < 0xE000) then let pos = position scanner in let msg = "escape sequence is invalid unicode code point" in - scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) + scanner.err ~start_pos ~end_pos:pos (Diagnostics.message msg) in match scanner.ch with (* \ already consumed *) @@ -367,7 +372,7 @@ let scanStringEscapeSequence ~startPos scanner = | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false do - x := (!x * 16) + digitValue scanner.ch; + x := (!x * 16) + digit_value scanner.ch; next scanner done; (* consume '}' in '\u{7A}' *) @@ -388,95 +393,96 @@ let scanStringEscapeSequence ~startPos scanner = *) () -let scanString scanner = +let scan_string scanner = (* assumption: we've just matched a quote *) - let startPosWithQuote = position scanner in + let start_pos_with_quote = position scanner in next scanner; (* If the text needs changing, a buffer is used *) let buf = Buffer.create 0 in - let firstCharOffset = scanner.offset in - let lastOffsetInBuf = ref firstCharOffset in + let first_char_offset = scanner.offset in + let last_offset_in_buf = ref first_char_offset in - let bringBufUpToDate ~startOffset = - let strUpToNow = - (String.sub scanner.src !lastOffsetInBuf - (startOffset - !lastOffsetInBuf) [@doesNotRaise]) + let bring_buf_up_to_date ~start_offset = + let str_up_to_now = + (String.sub scanner.src !last_offset_in_buf + (start_offset - !last_offset_in_buf) [@doesNotRaise]) in - Buffer.add_string buf strUpToNow; - lastOffsetInBuf := startOffset + Buffer.add_string buf str_up_to_now; + last_offset_in_buf := start_offset in - let result ~firstCharOffset ~lastCharOffset = + let result ~first_char_offset ~last_char_offset = if Buffer.length buf = 0 then - (String.sub [@doesNotRaise]) scanner.src firstCharOffset - (lastCharOffset - firstCharOffset) + (String.sub [@doesNotRaise]) scanner.src first_char_offset + (last_char_offset - first_char_offset) else ( - bringBufUpToDate ~startOffset:lastCharOffset; + bring_buf_up_to_date ~start_offset:last_char_offset; Buffer.contents buf) in let rec scan () = match scanner.ch with | '"' -> - let lastCharOffset = scanner.offset in + let last_char_offset = scanner.offset in next scanner; - result ~firstCharOffset ~lastCharOffset + result ~first_char_offset ~last_char_offset | '\\' -> - let startPos = position scanner in - let startOffset = scanner.offset + 1 in - next scanner; - scanStringEscapeSequence ~startPos scanner; - let endOffset = scanner.offset in - convertOctalToHex ~startOffset ~endOffset - | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString; - let lastCharOffset = scanner.offset in - result ~firstCharOffset ~lastCharOffset + let start_pos = position scanner in + let start_offset = scanner.offset + 1 in + next scanner; + scan_string_escape_sequence ~start_pos scanner; + let end_offset = scanner.offset in + convert_octal_to_hex ~start_offset ~end_offset + | ch when ch == hacky_eof_char -> + let end_pos = position scanner in + scanner.err ~start_pos:start_pos_with_quote ~end_pos + Diagnostics.unclosed_string; + let last_char_offset = scanner.offset in + result ~first_char_offset ~last_char_offset | _ -> next scanner; scan () - and convertOctalToHex ~startOffset ~endOffset = - let len = endOffset - startOffset in - let isDigit = function + and convert_octal_to_hex ~start_offset ~end_offset = + let len = end_offset - start_offset in + let is_digit = function | '0' .. '9' -> true | _ -> false in let txt = scanner.src in - let isNumericEscape = + let is_numeric_escape = len = 3 - && (isDigit txt.[startOffset] [@doesNotRaise]) - && (isDigit txt.[startOffset + 1] [@doesNotRaise]) - && (isDigit txt.[startOffset + 2] [@doesNotRaise]) + && (is_digit txt.[start_offset] [@doesNotRaise]) + && (is_digit txt.[start_offset + 1] [@doesNotRaise]) + && (is_digit txt.[start_offset + 2] [@doesNotRaise]) in - if isNumericEscape then ( - let strDecimal = (String.sub txt startOffset 3 [@doesNotRaise]) in - bringBufUpToDate ~startOffset; - let strHex = Res_string.convertDecimalToHex ~strDecimal in - lastOffsetInBuf := startOffset + 3; - Buffer.add_string buf strHex; + if is_numeric_escape then ( + let str_decimal = (String.sub txt start_offset 3 [@doesNotRaise]) in + bring_buf_up_to_date ~start_offset; + let str_hex = Res_string.convert_decimal_to_hex ~str_decimal in + last_offset_in_buf := start_offset + 3; + Buffer.add_string buf str_hex; scan ()) else scan () in Token.String (scan ()) -let scanEscape scanner = +let scan_escape scanner = (* '\' consumed *) let offset = scanner.offset - 1 in - let convertNumber scanner ~n ~base = + let convert_number scanner ~n ~base = let x = ref 0 in for _ = n downto 1 do - let d = digitValue scanner.ch in + let d = digit_value scanner.ch in x := (!x * base) + d; next scanner done; let c = !x in - if Res_utf8.isValidCodePoint c then c else Res_utf8.repl + if Res_utf8.is_valid_code_point c then c else Res_utf8.repl in let codepoint = match scanner.ch with - | '0' .. '9' -> convertNumber scanner ~n:3 ~base:10 + | '0' .. '9' -> convert_number scanner ~n:3 ~base:10 | 'b' -> next scanner; 8 @@ -491,10 +497,10 @@ let scanEscape scanner = 009 | 'x' -> next scanner; - convertNumber scanner ~n:2 ~base:16 + convert_number scanner ~n:2 ~base:16 | 'o' -> next scanner; - convertNumber scanner ~n:3 ~base:8 + convert_number scanner ~n:3 ~base:8 | 'u' -> ( next scanner; match scanner.ch with @@ -507,7 +513,7 @@ let scanEscape scanner = | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false do - x := (!x * 16) + digitValue scanner.ch; + x := (!x * 16) + digit_value scanner.ch; next scanner done; (* consume '}' in '\u{7A}' *) @@ -515,10 +521,10 @@ let scanEscape scanner = | '}' -> next scanner | _ -> ()); let c = !x in - if Res_utf8.isValidCodePoint c then c else Res_utf8.repl + if Res_utf8.is_valid_code_point c then c else Res_utf8.repl | _ -> (* unicode escape sequence: '\u007A', exactly 4 hex digits *) - convertNumber scanner ~n:4 ~base:16) + convert_number scanner ~n:4 ~base:16) | ch -> next scanner; Char.code ch @@ -531,33 +537,34 @@ let scanEscape scanner = (* TODO: do we know it's \' ? *) Token.Codepoint {c = codepoint; original = contents} -let scanSingleLineComment scanner = - let startOff = scanner.offset in - let startPos = position scanner in +let scan_single_line_comment scanner = + let start_off = scanner.offset in + let start_pos = position scanner in let rec skip scanner = match scanner.ch with | '\n' | '\r' -> () - | ch when ch == hackyEOFChar -> () + | ch when ch == hacky_eof_char -> () | _ -> next scanner; skip scanner in skip scanner; - let endPos = position scanner in + let end_pos = position scanner in Token.Comment - (Comment.makeSingleLineComment - ~loc:Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false} - ((String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - startOff))) + (Comment.make_single_line_comment + ~loc: + Location.{loc_start = start_pos; loc_end = end_pos; loc_ghost = false} + ((String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - start_off))) -let scanMultiLineComment scanner = +let scan_multi_line_comment scanner = (* assumption: we're only ever using this helper in `scan` after detecting a comment *) - let docComment = peek2 scanner = '*' && peek3 scanner <> '/' (* no /**/ *) in - let standalone = docComment && peek3 scanner = '*' (* /*** *) in - let contentStartOff = - scanner.offset + if docComment then if standalone then 4 else 3 else 2 + let doc_comment = peek2 scanner = '*' && peek3 scanner <> '/' (* no /**/ *) in + let standalone = doc_comment && peek3 scanner = '*' (* /*** *) in + let content_start_off = + scanner.offset + if doc_comment then if standalone then 4 else 3 else 2 in - let startPos = position scanner in + let start_pos = position scanner in let rec scan ~depth = (* invariant: depth > 0 right after this match. See assumption *) match (scanner.ch, peek scanner) with @@ -567,50 +574,54 @@ let scanMultiLineComment scanner = | '*', '/' -> next2 scanner; if depth > 1 then scan ~depth:(depth - 1) - | ch, _ when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedComment + | ch, _ when ch == hacky_eof_char -> + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos Diagnostics.unclosed_comment | _ -> next scanner; scan ~depth in scan ~depth:0; - let length = scanner.offset - 2 - contentStartOff in + let length = scanner.offset - 2 - content_start_off in let length = if length < 0 (* in case of EOF *) then 0 else length in Token.Comment - (Comment.makeMultiLineComment ~docComment ~standalone + (Comment.make_multi_line_comment ~doc_comment ~standalone ~loc: Location. - {loc_start = startPos; loc_end = position scanner; loc_ghost = false} - ((String.sub [@doesNotRaise]) scanner.src contentStartOff length)) + { + loc_start = start_pos; + loc_end = position scanner; + loc_ghost = false; + } + ((String.sub [@doesNotRaise]) scanner.src content_start_off length)) -let scanTemplateLiteralToken scanner = - let startOff = scanner.offset in +let scan_template_literal_token scanner = + let start_off = scanner.offset in (* if starting } here, consume it *) if scanner.ch == '}' then next scanner; - let startPos = position scanner in + let start_pos = position scanner in let rec scan () = - let lastPos = position scanner in + let last_pos = position scanner in match scanner.ch with | '`' -> next scanner; let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 1 - startOff) + (String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - 1 - start_off) in - Token.TemplateTail (contents, lastPos) + Token.TemplateTail (contents, last_pos) | '$' -> ( match peek scanner with | '{' -> next2 scanner; let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 2 - startOff) + (String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - 2 - start_off) in - Token.TemplatePart (contents, lastPos) + Token.TemplatePart (contents, last_pos) | _ -> next scanner; scan ()) @@ -623,31 +634,31 @@ let scanTemplateLiteralToken scanner = | _ -> next scanner; scan ()) - | ch when ch = hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; + | ch when ch = hacky_eof_char -> + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos Diagnostics.unclosed_template; let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (max (scanner.offset - 1 - startOff) 0) + (String.sub [@doesNotRaise]) scanner.src start_off + (max (scanner.offset - 1 - start_off) 0) in - Token.TemplateTail (contents, lastPos) + Token.TemplateTail (contents, last_pos) | _ -> next scanner; scan () in let token = scan () in - let endPos = position scanner in - (startPos, endPos, token) + let end_pos = position scanner in + (start_pos, end_pos, token) let rec scan scanner = - skipWhitespace scanner; - let startPos = position scanner in + skip_whitespace scanner; + let start_pos = position scanner in let token = match scanner.ch with (* peeking 0 char *) - | 'A' .. 'Z' | 'a' .. 'z' -> scanIdentifier scanner - | '0' .. '9' -> scanNumber scanner + | 'A' .. 'Z' | 'a' .. 'z' -> scan_identifier scanner + | '0' .. '9' -> scan_number scanner | '`' -> next scanner; Token.Backtick @@ -681,11 +692,11 @@ let rec scan scanner = | ',' -> next scanner; Token.Comma - | '"' -> scanString scanner + | '"' -> scan_string scanner (* peeking 1 char *) | '_' -> ( match peek scanner with - | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scanIdentifier scanner + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scan_identifier scanner | _ -> next scanner; Token.Underscore) @@ -754,15 +765,13 @@ let rec scan scanner = | _ -> next scanner; Token.Colon) - | '\\' -> - next scanner; - scanExoticIdentifier scanner + | '\\' -> scan_exotic_identifier scanner | '/' -> ( match peek scanner with | '/' -> next2 scanner; - scanSingleLineComment scanner - | '*' -> scanMultiLineComment scanner + scan_single_line_comment scanner + | '*' -> scan_multi_line_comment scanner | '.' -> next2 scanner; Token.ForwardslashDot @@ -796,13 +805,13 @@ let rec scan scanner = Token.Plus) | '>' -> ( match peek scanner with - | '=' when not (inDiamondMode scanner) -> + | '=' when not (in_diamond_mode scanner) -> next2 scanner; Token.GreaterEqual | _ -> next scanner; Token.GreaterThan) - | '<' when not (inJsxMode scanner) -> ( + | '<' when not (in_jsx_mode scanner) -> ( match peek scanner with | '=' -> next2 scanner; @@ -820,7 +829,7 @@ let rec scan scanner = * This signals a closing element. To simulate the two-token lookahead, * the next scanner; @@ -850,7 +859,7 @@ let rec scan scanner = SingleQuote | '\\', _ -> next2 scanner; - scanEscape scanner + scan_escape scanner | ch, '\'' -> let offset = scanner.offset + 1 in next3 scanner; @@ -864,7 +873,7 @@ let rec scan scanner = let offset = scanner.offset in let offset16 = scanner.offset16 in let codepoint, length = - Res_utf8.decodeCodePoint scanner.offset scanner.src + Res_utf8.decode_code_point scanner.offset scanner.src (String.length scanner.src) in for _ = 0 to length - 1 do @@ -907,21 +916,21 @@ let rec scan scanner = next scanner; Token.Equal) (* special cases *) - | ch when ch == hackyEOFChar -> + | ch when ch == hacky_eof_char -> next scanner; Token.Eof | ch -> (* if we arrive here, we're dealing with an unknown character, * report the error and continue scanning… *) next scanner; - let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos (Diagnostics.unknown_uchar ch); let _, _, token = scan scanner in token in - let endPos = position scanner in + let end_pos = position scanner in (* _printDebug ~startPos ~endPos scanner token; *) - (startPos, endPos, token) + (start_pos, end_pos, token) (* misc helpers used elsewhere *) @@ -930,9 +939,9 @@ let rec scan scanner = * or is it the start of a closing tag?
* reconsiderLessThan peeks at the next token and * determines the correct token to disambiguate *) -let reconsiderLessThan scanner = +let reconsider_less_than scanner = (* < consumed *) - skipWhitespace scanner; + skip_whitespace scanner; if scanner.ch == '/' then let () = next scanner in Token.LessThanSlash @@ -940,17 +949,17 @@ let reconsiderLessThan scanner = (* If an operator has whitespace around both sides, it's a binary operator *) (* TODO: this helper seems out of place *) -let isBinaryOp src startCnum endCnum = - if startCnum == 0 then false +let is_binary_op src start_cnum end_cnum = + if start_cnum == 0 then false else ( (* we're gonna put some assertions and invariant checks here because this is used outside of the scanner's normal invariant assumptions *) - assert (endCnum >= 0); - assert (startCnum > 0 && startCnum < String.length src); - let leftOk = isWhitespace (String.unsafe_get src (startCnum - 1)) in + assert (end_cnum >= 0); + assert (start_cnum > 0 && start_cnum < String.length src); + let left_ok = is_whitespace (String.unsafe_get src (start_cnum - 1)) in (* we need some stronger confidence that endCnum is ok *) - let rightOk = - endCnum >= String.length src - || isWhitespace (String.unsafe_get src endCnum) + let right_ok = + end_cnum >= String.length src + || is_whitespace (String.unsafe_get src end_cnum) in - leftOk && rightOk) + left_ok && right_ok) diff --git a/analysis/vendor/res_syntax/res_scanner.mli b/analysis/vendor/res_syntax/res_scanner.mli index cc002699f..5ae40e812 100644 --- a/analysis/vendor/res_syntax/res_scanner.mli +++ b/analysis/vendor/res_syntax/res_scanner.mli @@ -1,20 +1,20 @@ type mode = Jsx | Diamond -type charEncoding +type char_encoding type t = { filename: string; src: string; mutable err: - startPos:Lexing.position -> - endPos:Lexing.position -> + start_pos:Lexing.position -> + end_pos:Lexing.position -> Res_diagnostics.category -> unit; - mutable ch: charEncoding; (* current character *) + mutable ch: char_encoding; (* current character *) mutable offset: int; (* current byte offset *) mutable offset16: int; (* current number of utf16 code units since line start *) - mutable lineOffset: int; (* current line offset *) + mutable line_offset: int; (* current line offset *) mutable lnum: int; (* current line number *) mutable mode: mode list; } @@ -24,13 +24,13 @@ val make : filename:string -> string -> t (* TODO: make this a record *) val scan : t -> Lexing.position * Lexing.position * Res_token.t -val isBinaryOp : string -> int -> int -> bool +val is_binary_op : string -> int -> int -> bool -val setJsxMode : t -> unit -val setDiamondMode : t -> unit -val popMode : t -> mode -> unit +val set_jsx_mode : t -> unit +val set_diamond_mode : t -> unit +val pop_mode : t -> mode -> unit -val reconsiderLessThan : t -> Res_token.t +val reconsider_less_than : t -> Res_token.t -val scanTemplateLiteralToken : +val scan_template_literal_token : t -> Lexing.position * Lexing.position * Res_token.t diff --git a/analysis/vendor/res_syntax/res_string.ml b/analysis/vendor/res_syntax/res_string.ml index a4ecba11d..6ef33a29e 100644 --- a/analysis/vendor/res_syntax/res_string.ml +++ b/analysis/vendor/res_syntax/res_string.ml @@ -1,11 +1,11 @@ -let hexTable = +let hex_table = [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; |] [@ocamlformat "disable"] -let convertDecimalToHex ~strDecimal = +let convert_decimal_to_hex ~str_decimal = try - let intNum = int_of_string strDecimal in - let c1 = Array.get hexTable (intNum lsr 4) in - let c2 = Array.get hexTable (intNum land 15) in + let int_num = int_of_string str_decimal in + let c1 = Array.get hex_table (int_num lsr 4) in + let c2 = Array.get hex_table (int_num land 15) in "x" ^ String.concat "" [String.make 1 c1; String.make 1 c2] - with Invalid_argument _ | Failure _ -> strDecimal + with Invalid_argument _ | Failure _ -> str_decimal diff --git a/analysis/vendor/res_syntax/res_token.ml b/analysis/vendor/res_syntax/res_token.ml index 5d12e0f14..16c88e55c 100644 --- a/analysis/vendor/res_syntax/res_token.ml +++ b/analysis/vendor/res_syntax/res_token.ml @@ -55,7 +55,6 @@ type t = | Hash | HashEqual | Assert - | Lazy | Tilde | Question | If @@ -111,7 +110,7 @@ let precedence = function | Dot -> 9 | _ -> 0 -let toString = function +let to_string = function | Await -> "await" | Open -> "open" | True -> "true" @@ -166,7 +165,6 @@ let toString = function | AsteriskDot -> "*." | Exponentiation -> "**" | Assert -> "assert" - | Lazy -> "lazy" | Tilde -> "tilde" | Question -> "?" | If -> "if" @@ -198,7 +196,7 @@ let toString = function | AtAt -> "@@" | Percent -> "%" | PercentPercent -> "%%" - | Comment c -> "Comment" ^ Comment.toString c + | Comment c -> "Comment" ^ Comment.to_string c | List -> "list{" | TemplatePart (text, _) -> text ^ "${" | TemplateTail (text, _) -> "TemplateTail(" ^ text ^ ")" @@ -208,7 +206,7 @@ let toString = function | DocComment (_loc, s) -> "DocComment " ^ s | ModuleComment (_loc, s) -> "ModuleComment " ^ s -let keywordTable = function +let keyword_table = function | "and" -> And | "as" -> As | "assert" -> Assert @@ -222,7 +220,6 @@ let keywordTable = function | "if" -> If | "in" -> In | "include" -> Include - | "lazy" -> Lazy | "let" -> Let | "list{" -> List | "module" -> Module @@ -240,23 +237,23 @@ let keywordTable = function | _ -> raise Not_found [@@raises Not_found] -let isKeyword = function +let is_keyword = function | Await | And | As | Assert | Constraint | Else | Exception | External | False - | For | If | In | Include | Land | Lazy | Let | List | Lor | Module | Mutable - | Of | Open | Private | Rec | Switch | True | Try | Typ | When | While -> + | For | If | In | Include | Land | Let | List | Lor | Module | Mutable | Of + | Open | Private | Rec | Switch | True | Try | Typ | When | While -> true | _ -> false -let lookupKeyword str = - try keywordTable str +let lookup_keyword str = + try keyword_table str with Not_found -> ( match str.[0] [@doesNotRaise] with | 'A' .. 'Z' -> Uident str | _ -> Lident str) -let isKeywordTxt str = +let is_keyword_txt str = try - let _ = keywordTable str in + let _ = keyword_table str in true with Not_found -> false diff --git a/analysis/vendor/res_syntax/res_uncurried.ml b/analysis/vendor/res_syntax/res_uncurried.ml index 1a777e159..b5d3706c6 100644 --- a/analysis/vendor/res_syntax/res_uncurried.ml +++ b/analysis/vendor/res_syntax/res_uncurried.ml @@ -1,11 +1,11 @@ (* For parsing *) -let fromDotted ~dotted = function +let from_dotted ~dotted = function | Config.Legacy -> dotted | Swap -> not dotted | Uncurried -> true (* For printing *) -let getDotted ~uncurried = function +let get_dotted ~uncurried = function | Config.Legacy -> uncurried | Swap -> not uncurried | Uncurried -> false diff --git a/analysis/vendor/res_syntax/res_utf8.ml b/analysis/vendor/res_syntax/res_utf8.ml index 69c7d234f..c41621761 100644 --- a/analysis/vendor/res_syntax/res_utf8.ml +++ b/analysis/vendor/res_syntax/res_utf8.ml @@ -6,8 +6,8 @@ let repl = 0xFFFD (* let min = 0x0000 *) let max = 0x10FFFF -let surrogateMin = 0xD800 -let surrogateMax = 0xDFFF +let surrogate_min = 0xD800 +let surrogate_max = 0xDFFF (* * Char. number range | UTF-8 octet sequence @@ -29,7 +29,7 @@ type category = {low: int; high: int; size: int} let locb = 0b1000_0000 let hicb = 0b1011_1111 -let categoryTable = [| +let category_table = [| (* 0 *) {low = -1; high= -1; size= 1}; (* invalid *) (* 1 *) {low = 1; high= -1; size= 1}; (* ascii *) (* 2 *) {low = locb; high= hicb; size= 2}; @@ -62,7 +62,7 @@ let categories = [| 6; 7; 7 ;7; 8; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; |] [@@ocamlformat "disable"] -let decodeCodePoint i s len = +let decode_code_point i s len = if len < 1 then (repl, 1) else let first = int_of_char (String.unsafe_get s i) in @@ -71,7 +71,7 @@ let decodeCodePoint i s len = let index = Array.unsafe_get categories first in if index = 0 then (repl, 1) else - let cat = Array.unsafe_get categoryTable index in + let cat = Array.unsafe_get category_table index in if len < i + cat.size then (repl, 1) else if cat.size == 2 then let c1 = int_of_char (String.unsafe_get s (i + 1)) in @@ -108,7 +108,7 @@ let decodeCodePoint i s len = let uc = i0 lor i3 lor i2 lor i1 in (uc, 4) -let encodeCodePoint c = +let encode_code_point c = if c <= 127 then ( let bytes = (Bytes.create [@doesNotRaise]) 1 in Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); @@ -139,5 +139,5 @@ let encodeCodePoint c = (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); Bytes.unsafe_to_string bytes -let isValidCodePoint c = - (0 <= c && c < surrogateMin) || (surrogateMax < c && c <= max) +let is_valid_code_point c = + (0 <= c && c < surrogate_min) || (surrogate_max < c && c <= max) diff --git a/analysis/vendor/res_syntax/res_utf8.mli b/analysis/vendor/res_syntax/res_utf8.mli index 7dcb342d6..fc80c8be9 100644 --- a/analysis/vendor/res_syntax/res_utf8.mli +++ b/analysis/vendor/res_syntax/res_utf8.mli @@ -2,8 +2,8 @@ val repl : int val max : int -val decodeCodePoint : int -> string -> int -> int * int +val decode_code_point : int -> string -> int -> int * int -val encodeCodePoint : int -> string +val encode_code_point : int -> string -val isValidCodePoint : int -> bool +val is_valid_code_point : int -> bool diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 1a3421993..b2f71afdf 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -446,7 +446,7 @@ let extractDocs ~entryPointFile ~debug = let extractEmbedded ~extensionPoints ~filename = let {Res_driver.parsetree = structure} = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false ~filename + Res_driver.parsing_engine.parse_implementation ~for_printer:false ~filename in let content = ref [] in let append item = content := item :: !content in From 01d979bee08b3acef5c96489c73aad0fc3589a93 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 30 May 2024 20:43:53 +0200 Subject: [PATCH 2/3] comment out --- .../not_compiled/expected/Diagnostics.res.txt | 48 +- .../not_compiled/expected/DocTemplate.res.txt | 20 - .../expected/DocTemplate.resi.txt | 20 - analysis/tests/src/expected/Auto.res.txt | 4 - .../src/expected/BrokenParserCases.res.txt | 13 - analysis/tests/src/expected/CodeLens.res.txt | 11 - analysis/tests/src/expected/Codemod.res.txt | 9 - .../src/expected/CompletableComponent.res.txt | 15 - .../src/expected/CompletePrioritize1.res.txt | 7 - .../src/expected/CompletePrioritize2.res.txt | 14 - .../tests/src/expected/Completion.res.txt | 468 ------------------ .../src/expected/CompletionAttributes.res.txt | 39 -- .../src/expected/CompletionDicts.res.txt | 16 - .../expected/CompletionExpressions.res.txt | 364 -------------- .../CompletionFunctionArguments.res.txt | 125 ----- .../expected/CompletionInferValues.res.txt | 169 ------- .../tests/src/expected/CompletionJsx.res.txt | 91 ---- .../src/expected/CompletionJsxProps.res.txt | 46 -- .../src/expected/CompletionPattern.res.txt | 232 --------- .../src/expected/CompletionPipeChain.res.txt | 105 ---- .../expected/CompletionPipeSubmodules.res.txt | 45 -- .../src/expected/CompletionResolve.res.txt | 4 - .../src/expected/CompletionSupport.res.txt | 42 -- .../src/expected/CompletionSupport2.res.txt | 17 - .../expected/CompletionTypeAnnotation.res.txt | 57 --- .../src/expected/CompletionTypeT.res.txt | 9 - analysis/tests/src/expected/Component.res.txt | 2 - .../tests/src/expected/Component.resi.txt | 2 - .../src/expected/CreateInterface.res.txt | 145 ------ analysis/tests/src/expected/Cross.res.txt | 41 -- analysis/tests/src/expected/Dce.res.txt | 4 - analysis/tests/src/expected/Debug.res.txt | 17 - .../tests/src/expected/Definition.res.txt | 28 -- .../expected/DefinitionWithInterface.res.txt | 12 - .../expected/DefinitionWithInterface.resi.txt | 9 - .../tests/src/expected/Destructuring.res.txt | 34 -- analysis/tests/src/expected/Div.res.txt | 5 - .../tests/src/expected/DocComments.res.txt | 49 -- .../tests/src/expected/DocumentSymbol.res.txt | 34 -- .../tests/src/expected/EnvCompletion.res.txt | 63 --- .../expected/EnvCompletionOtherFile.res.txt | 13 - .../src/expected/ExhaustiveSwitch.res.txt | 43 -- analysis/tests/src/expected/Fragment.res.txt | 16 - analysis/tests/src/expected/Highlight.res.txt | 140 ------ analysis/tests/src/expected/Hover.res.txt | 267 ---------- analysis/tests/src/expected/InlayHint.res.txt | 35 -- analysis/tests/src/expected/Jsx2.res.txt | 183 ------- analysis/tests/src/expected/Jsx2.resi.txt | 12 - analysis/tests/src/expected/JsxV4.res.txt | 58 --- .../tests/src/expected/LongIdentTest.res.txt | 7 - .../tests/src/expected/ModuleStuff.res.txt | 5 - analysis/tests/src/expected/Objects.res.txt | 11 - analysis/tests/src/expected/Patterns.res.txt | 29 +- analysis/tests/src/expected/PolyRec.res.txt | 14 - analysis/tests/src/expected/QueryFile.res.txt | 6 - .../tests/src/expected/RecModules.res.txt | 22 - .../src/expected/RecordCompletion.res.txt | 24 - .../tests/src/expected/RecoveryOnProp.res.txt | 12 - .../tests/src/expected/References.res.txt | 25 - .../expected/ReferencesWithInterface.res.txt | 2 - .../expected/ReferencesWithInterface.resi.txt | 2 - analysis/tests/src/expected/Rename.res.txt | 11 - .../src/expected/RenameWithInterface.res.txt | 2 - .../src/expected/RenameWithInterface.resi.txt | 2 - analysis/tests/src/expected/Reprod.res.txt | 56 --- .../tests/src/expected/SchemaAssets.res.txt | 6 - .../tests/src/expected/ShadowedBelt.res.txt | 3 - .../tests/src/expected/SignatureHelp.res.txt | 163 ------ .../src/expected/TypeAtPosCompletion.res.txt | 25 - .../tests/src/expected/TypeDefinition.res.txt | 25 - analysis/tests/src/expected/Xform.res.txt | 145 ------ analysis/vendor/res_syntax/res_cli.ml | 4 +- 72 files changed, 28 insertions(+), 3775 deletions(-) diff --git a/analysis/tests/not_compiled/expected/Diagnostics.res.txt b/analysis/tests/not_compiled/expected/Diagnostics.res.txt index f9e063a84..a5df33b71 100644 --- a/analysis/tests/not_compiled/expected/Diagnostics.res.txt +++ b/analysis/tests/not_compiled/expected/Diagnostics.res.txt @@ -1,33 +1,17 @@ - - Syntax error! - not_compiled/Diagnostics.res:1:5 - - 1 │ let = 1 + 1.0 - 2 │ let add = =2 - 3 │ lett a = 2 - - I was expecting a name for this let-binding. Example: `let message = "hello"` - - - Syntax error! - not_compiled/Diagnostics.res:2:10-11 - - 1 │ let = 1 + 1.0 - 2 │ let add = =2 - 3 │ lett a = 2 - 4 │ - - This let-binding misses an expression - - - Syntax error! - not_compiled/Diagnostics.res:3:5-6 - - 1 │ let = 1 + 1.0 - 2 │ let add = =2 - 3 │ lett a = 2 - 4 │ - 5 │ //^dia - - consecutive statements on a line must be separated by ';' or a newline +[{ + "range": {"start": {"line": 2, "character": 4}, "end": {"line": 2, "character": 6}}, + "message": "consecutive statements on a line must be separated by ';' or a newline", + "severity": 1, + "source": "ReScript" +}, { + "range": {"start": {"line": 1, "character": 9}, "end": {"line": 1, "character": 11}}, + "message": "This let-binding misses an expression", + "severity": 1, + "source": "ReScript" +}, { + "range": {"start": {"line": 0, "character": 4}, "end": {"line": 0, "character": 5}}, + "message": "I was expecting a name for this let-binding. Example: `let message = \"hello\"`", + "severity": 1, + "source": "ReScript" +}] diff --git a/analysis/tests/not_compiled/expected/DocTemplate.res.txt b/analysis/tests/not_compiled/expected/DocTemplate.res.txt index a26747100..ce8487127 100644 --- a/analysis/tests/not_compiled/expected/DocTemplate.res.txt +++ b/analysis/tests/not_compiled/expected/DocTemplate.res.txt @@ -1,23 +1,3 @@ -type a = {a: int} -// ^xfm - -type rec t = A | B -// ^xfm -and e = C -@unboxed type name = Name(string) -// ^xfm -let a = 1 -// ^xfm -let inc = x => x + 1 -// ^xfm -module T = { - // ^xfm - let b = 1 - // ^xfm -} -@module("path") -external dirname: string => string = "dirname" -//^xfm Xform not_compiled/DocTemplate.res 3:3 can't find module DocTemplate Hit: Add Documentation template diff --git a/analysis/tests/not_compiled/expected/DocTemplate.resi.txt b/analysis/tests/not_compiled/expected/DocTemplate.resi.txt index a6e2b1d6d..ef4987a7c 100644 --- a/analysis/tests/not_compiled/expected/DocTemplate.resi.txt +++ b/analysis/tests/not_compiled/expected/DocTemplate.resi.txt @@ -1,23 +1,3 @@ -type a = {a: int} -// ^xfm - -type rec t = A | B -// ^xfm -and e = C -@unboxed type name = Name(string) -// ^xfm -let a: int -// ^xfm -let inc: int => int -// ^xfm -module T: { - // ^xfm - let b: int - // ^xfm -} -@module("path") -external dirname: string => string = "dirname" -//^xfm Xform not_compiled/DocTemplate.resi 3:3 Hit: Add Documentation template diff --git a/analysis/tests/src/expected/Auto.res.txt b/analysis/tests/src/expected/Auto.res.txt index 55e440c05..78ec26d7f 100644 --- a/analysis/tests/src/expected/Auto.res.txt +++ b/analysis/tests/src/expected/Auto.res.txt @@ -1,7 +1,3 @@ -open! ShadowedBelt - -let m = List.map -// ^hov Hover src/Auto.res 2:13 {"contents": {"kind": "markdown", "value": "```rescript\n(list<'a>, 'a => 'b) => list<'b>\n```"}} diff --git a/analysis/tests/src/expected/BrokenParserCases.res.txt b/analysis/tests/src/expected/BrokenParserCases.res.txt index 9cf22529c..8a4494a65 100644 --- a/analysis/tests/src/expected/BrokenParserCases.res.txt +++ b/analysis/tests/src/expected/BrokenParserCases.res.txt @@ -1,16 +1,3 @@ -// --- BROKEN PARSER CASES --- -// This below demonstrates an issue when what you're completing is the _last_ labelled argument, and there's a unit application after it. The parser wrongly merges the unit argument as the expression of the labelled argument assignment, where is should really let the trailing unit argument be, and set a %rescript.exprhole as the expression of the assignment, just like it normally does. -// let _ = someFn(~isOff=, ()) -// ^com - -// This should parse as a single item tuple when in a pattern? -// switch s { | (t) } -// ^com - -// Here the parser eats the arrow and considers the None in the expression part of the pattern. -// let _ = switch x { | None | => None } -// ^com - Complete src/BrokenParserCases.res 2:24 posCursor:[2:24] posNoWhite:[2:23] Found expr:[2:11->2:30] Pexp_apply ...[2:11->2:17] (~isOff2:19->2:24=...[2:27->2:29]) diff --git a/analysis/tests/src/expected/CodeLens.res.txt b/analysis/tests/src/expected/CodeLens.res.txt index 0d527f00c..06472d5e4 100644 --- a/analysis/tests/src/expected/CodeLens.res.txt +++ b/analysis/tests/src/expected/CodeLens.res.txt @@ -1,14 +1,3 @@ -let add = (x, y) => x + y - -let foo = (~age, ~name) => name ++ string_of_int(age) - -let ff = (~opt1=0, ~a, ~b, (), ~opt2=0, (), ~c) => a + b + c + opt1 + opt2 - -let compFF = Completion.ff - -@react.component -let make = (~name) => React.string(name) -//^cle Code Lens src/CodeLens.res [{ "range": {"start": {"line": 9, "character": 4}, "end": {"line": 9, "character": 8}}, diff --git a/analysis/tests/src/expected/Codemod.res.txt b/analysis/tests/src/expected/Codemod.res.txt index 12e02f4e4..5e4783d5d 100644 --- a/analysis/tests/src/expected/Codemod.res.txt +++ b/analysis/tests/src/expected/Codemod.res.txt @@ -1,12 +1,3 @@ -type someTyp = [#valid | #invalid] - -let ff = (v1: someTyp, v2: someTyp) => { - let x = switch (v1, v2) { - // ^c-a (#valid, #valid) | (#invalid, _) - | (#valid, #invalid) => () - } - x -} Codemod AddMissingCasessrc/Codemod.res 3:10 switch (v1, v2) { // ^c-a (#valid, #valid) | (#invalid, _) diff --git a/analysis/tests/src/expected/CompletableComponent.res.txt b/analysis/tests/src/expected/CompletableComponent.res.txt index 50522a3d5..e69de29bb 100644 --- a/analysis/tests/src/expected/CompletableComponent.res.txt +++ b/analysis/tests/src/expected/CompletableComponent.res.txt @@ -1,15 +0,0 @@ -type status = On | Off - -@@jsxConfig({version: 4, mode: "automatic"}) -type props<'status, 'name> = {status: 'status, name: 'name} - -let make = ({status, name, _}: props) => { - ignore(status) - ignore(name) - React.null -} -let make = { - let \"CompletableComponent" = (props: props<_>) => make(props) - - \"CompletableComponent" -} diff --git a/analysis/tests/src/expected/CompletePrioritize1.res.txt b/analysis/tests/src/expected/CompletePrioritize1.res.txt index df38c76f7..b520a84a2 100644 --- a/analysis/tests/src/expected/CompletePrioritize1.res.txt +++ b/analysis/tests/src/expected/CompletePrioritize1.res.txt @@ -1,10 +1,3 @@ -module Test = { - type t = {name: int} - let add = (a: float) => a +. 1.0 -} -let a: Test.t = {name: 4} -// a-> -// ^com Complete src/CompletePrioritize1.res 5:6 posCursor:[5:6] posNoWhite:[5:5] Found expr:[5:3->0:-1] Completable: Cpath Value[a]-> diff --git a/analysis/tests/src/expected/CompletePrioritize2.res.txt b/analysis/tests/src/expected/CompletePrioritize2.res.txt index 5115ae72b..b6bea71f9 100644 --- a/analysis/tests/src/expected/CompletePrioritize2.res.txt +++ b/analysis/tests/src/expected/CompletePrioritize2.res.txt @@ -1,17 +1,3 @@ -let ax = 4 -let _ = ax -let ax = "" -let _ = ax -module Test = { - type t = {name: int} - let add = (ax: t) => ax.name + 1 -} -let ax: Test.t = {name: 4} -// ax-> -// ^com - -// ax -// ^com Complete src/CompletePrioritize2.res 9:7 posCursor:[9:7] posNoWhite:[9:6] Found expr:[9:3->0:-1] Completable: Cpath Value[ax]-> diff --git a/analysis/tests/src/expected/Completion.res.txt b/analysis/tests/src/expected/Completion.res.txt index d155e1f76..ccadf462f 100644 --- a/analysis/tests/src/expected/Completion.res.txt +++ b/analysis/tests/src/expected/Completion.res.txt @@ -1,471 +1,3 @@ -module MyList = Belt.List -// MyList.m -// ^com -// Array. -// ^com -// Array.m -// ^com - -module Dep: { - @ocaml.doc("Some doc comment") @deprecated("Use customDouble instead") - let customDouble: int => int -} = { - let customDouble = foo => foo * 2 -} - -// let cc = Dep.c -// ^com - -module Lib = { - let foo = (~age, ~name) => name ++ string_of_int(age) - let next = (~number=0, ~year) => number + year -} - -// let x = Lib.foo(~ -// ^com - -// [1,2,3]->m -// ^com - -// "abc"->toU -// ^com - -let op = Some(3) - -// op->e -// ^com - -module ForAuto = { - type t = int - let abc = (x: t, _y: int) => x - let abd = (x: t, _y: int) => x -} - -let fa: ForAuto.t = 34 -// fa-> -// ^com - -// "hello"->Js.Dict.u -// ^com - -module O = { - module Comp = { - @react.component - let make = (~first="", ~zoo=3, ~second) => React.string(first ++ second ++ string_of_int(zoo)) - } -} - -let zzz = 11 - -// let comp = x + y - -@react.component -let make = () => { - // my - // ^com - <> -} - -// Objects.object[" -// ^com - -let foo = { - let x = { - 3 - } - let y = 4 - let add = (a, b) => - switch a { - | 3 => a + b - | _ => 42 - } - let z = assert(false) - let _ = z - module Inner = { - type z = int - let v = 44 - } - exception MyException(int, string, float, array) - let _ = raise(MyException(2, "", 1.0, [])) - add((x: Inner.z), Inner.v + y) -} - -exception MyOtherException - -// children -} -// } - let forAutoRecord: forAutoRecord = assert(false) -} - -module FAO = { - let forAutoObject = {"forAutoLabel": FAR.forAutoRecord, "age": 32} -} - -// FAO.forAutoObject[" -// ^com - -// FAO.forAutoObject["forAutoLabel"]. -// ^com - -// FAO.forAutoObject["forAutoLabel"].forAuto-> -// ^com - -// FAO.forAutoObject["forAutoLabel"].forAuto->ForAuto.a -// ^com - -let name = "abc" -// let template = `My name is ${na}` -// ^com - -let notHere = " " -// ^com - -let someR = Some(r) -let _ = switch someR { -| Some(_z) => 1 -// + _z. -// ^com -| _ => 3 -} - -module SomeLocalModule = { - let aa = 10 - let bb = 20 - type zz = int -} - -// let _ = SomeLo -// ^com -// type zz = SomeLocalModule. -// ^com - -type record = { - someProp: string, - // otherProp: SomeLocalModule. - // ^com - thirdProp: string, -} - -type someLocalVariant = SomeLocalVariantItem - -// type t = SomeLocal -// ^com - -// let _ : SomeLocal -// ^com - -let _foo = _world => { - // let _ = _w - // ^com - 3 -} - -type someType = {hello: string} -// type t = SomeType(s) -// ^com - -type funRecord = { - someFun: (~name: string) => unit, - stuff: string, -} - -let funRecord: funRecord = assert(false) - -// let _ = funRecord.someFun(~ ) -// ^com - -let retAA = () => {x: 3, name: ""} - -// retAA(). -// ^com - -let ff = (~opt1=0, ~a, ~b, (), ~opt2=0, (), ~c) => a + b + c + opt1 + opt2 - -// ff(~c=1)(~ -// ^com - -// ff(~c=1)()(~ -// ^com - -// ff(~c=1, ())(~ -// ^com - -// ff(~c=1, (), ())(~ -// ^com - -// ff(~c=1, (), ~b=1)(~ -// ^com - -// ff(~opt2=1)(~ -// ^com - -type callback = (~a: int) => int - -let withCallback: (~b: int) => callback = (~b) => { - () - (~a) => a + b -} - -// withCallback(~ -// ^com - -// withCallback(~a)(~ -// ^com - -// withCallback(~b)(~ -// ^com - -let _ = -
{ - () - // let _: Res - // ^com - }} - name="abc"> - {React.string(name)} -
- -//let _ = switch Some(3) { | Some(thisIsNotSaved) -> this -// ^com - -let _ =
-// ^hov - -// let _ = FAO.forAutoObject["age"] -// ^hov - -// let _ = ff(~opt1=3) -// ^hov - -// (let _ = ff(~opt1=3)) -// ^com - -type v = This | That - -let _ = x => - switch x { - // | T - // ^com - | _ => 4 - } - -module AndThatOther = { - type v = And | ThatOther -} - -let _ = x => - switch x { - // | AndThatOther.T - // ^com - | _ => 4 - } - -// let _ = ` ${ForAuto.}` -// ^com - -// let _ = `abc ${FAO.forAutoObject[""}` -// ^com - -// let _ = `${funRecord.}` -// ^com - -let _ = _ => { - open Js - // []->ma - // ^com - () -} - -let red = "#ff0000" - -let header1 = ` - color: ${red}; ` -// ^com - -let header2 = ` - color: ${red}; - background-color: ${red}; ` -// ^com - -// let _ = `color: ${r -// ^com - -let onClick = evt => { - // SomeLocalModule. - // ^com - evt->ReactEvent.Synthetic.preventDefault - // SomeLocalModule. - // ^com - Js.log("Hello") -} - -// let _ = 123->t -// ^com - -// let _ = 123.0->t -// ^com - -let ok = Ok(true) - -// ok->g -// ^com - -type someRecordWithDeprecatedField = { - name: string, - @deprecated - someInt: int, - @deprecated("Use 'someInt'.") - someFloat: float, -} - -let rWithDepr: someRecordWithDeprecatedField = { - name: "hej", - someInt: 12, - someFloat: 12., -} - -// Should show deprecated status -// rWithDepr.so -// ^com - -type someVariantWithDeprecated = - | @deprecated DoNotUseMe | UseMeInstead | @deprecated("Use 'UseMeInstead'") AndNotMe - -// Should show deprecated status -// let v: someVariantWithDeprecated = -// ^com - -let uncurried = (. num) => num + 2 - -// let _ = uncurried(. 1)->toS -// ^com - -type withUncurried = {fn: (. int) => unit} - -// let f: withUncurried = {fn: } -// ^com - -// let someRecord = { FAR. } -// ^com Complete src/Completion.res 1:11 posCursor:[1:11] posNoWhite:[1:10] Found expr:[1:3->1:11] Pexp_ident MyList.m:[1:3->1:11] diff --git a/analysis/tests/src/expected/CompletionAttributes.res.txt b/analysis/tests/src/expected/CompletionAttributes.res.txt index ae0cbabce..3fa299ef7 100644 --- a/analysis/tests/src/expected/CompletionAttributes.res.txt +++ b/analysis/tests/src/expected/CompletionAttributes.res.txt @@ -1,42 +1,3 @@ -// @modu -// ^com - -// @module("") external doStuff: t = "test" -// ^com - -// @@js -// ^com - -// @@jsxConfig({}) -// ^com - -// @@jsxConfig({m}) -// ^com - -// @@jsxConfig({module_: }) -// ^com - -// @@jsxConfig({module_: "", }) -// ^com - -// @module({}) external doStuff: t = "default" -// ^com - -// @module({with: }) external doStuff: t = "default" -// ^com - -// @module({with: {}}) external doStuff: t = "default" -// ^com - -// @module({from: "" }) external doStuff: t = "default" -// ^com - -// @module({from: }) external doStuff: t = "default" -// ^com - -// let dd = %t -// ^com - Complete src/CompletionAttributes.res 0:8 Attribute id:modu:[0:3->0:8] label:modu Completable: Cdecorator(modu) diff --git a/analysis/tests/src/expected/CompletionDicts.res.txt b/analysis/tests/src/expected/CompletionDicts.res.txt index 0755fdb8e..c3a423d50 100644 --- a/analysis/tests/src/expected/CompletionDicts.res.txt +++ b/analysis/tests/src/expected/CompletionDicts.res.txt @@ -1,19 +1,3 @@ -// let dict = Js.Dict.fromArray([]) -// ^com - -// let dict = Js.Dict.fromArray([()]) -// ^com - -// let dict = Js.Dict.fromArray([("key", )]) -// ^com - -// ^in+ -let dict = Js.Dict.fromArray([ - ("key", true), - // ("key2", ) - // ^com -]) -// ^in- Complete src/CompletionDicts.res 0:33 posCursor:[0:33] posNoWhite:[0:32] Found expr:[0:14->0:35] Pexp_apply ...[0:14->0:31] (...[0:32->0:34]) diff --git a/analysis/tests/src/expected/CompletionExpressions.res.txt b/analysis/tests/src/expected/CompletionExpressions.res.txt index 343473fa3..1cddba3b7 100644 --- a/analysis/tests/src/expected/CompletionExpressions.res.txt +++ b/analysis/tests/src/expected/CompletionExpressions.res.txt @@ -1,367 +1,3 @@ -let s = true -let f = Some([false]) - -// switch (s, f) { | } -// ^com - -type otherRecord = { - someField: int, - otherField: string, -} - -type rec someRecord = { - age: int, - offline: bool, - online: option, - variant: someVariant, - polyvariant: somePolyVariant, - nested: option, -} -and someVariant = One | Two | Three(int, string) -and somePolyVariant = [#one | #two(bool) | #three(someRecord, bool)] - -let fnTakingRecord = (r: someRecord) => { - ignore(r) -} - -// let _ = fnTakingRecord({}) -// ^com - -// let _ = fnTakingRecord({n}) -// ^com - -// let _ = fnTakingRecord({offline: }) -// ^com - -// let _ = fnTakingRecord({age: 123, }) -// ^com - -// let _ = fnTakingRecord({age: 123, offline: true}) -// ^com - -// let _ = fnTakingRecord({age: 123, nested: }) -// ^com - -// let _ = fnTakingRecord({age: 123, nested: {}}) -// ^com - -// let _ = fnTakingRecord({age: 123, nested: Some({})}) -// ^com - -// let _ = fnTakingRecord({age: 123, variant: }) -// ^com - -// let _ = fnTakingRecord({age: 123, variant: O }) -// ^com - -// let _ = fnTakingRecord({age: 123, polyvariant: #three() }) -// ^com - -// let _ = fnTakingRecord({age: 123, polyvariant: #three({}, ) }) -// ^com - -// let _ = fnTakingRecord({age: 123, polyvariant: #three({}, t) }) -// ^com - -let fnTakingArray = (arr: array>) => { - ignore(arr) -} - -// let _ = fnTakingArray() -// ^com - -// let _ = fnTakingArray([]) -// ^com - -// let _ = fnTakingArray(s) -// ^com - -// let _ = fnTakingArray([Some()]) -// ^com - -// let _ = fnTakingArray([None, ]) -// ^com - -// let _ = fnTakingArray([None, , None]) -// ^com - -let someBoolVar = true - -// let _ = fnTakingRecord({offline: so }) -// ^com - -let fnTakingOtherRecord = (r: otherRecord) => { - ignore(r) -} - -// let _ = fnTakingOtherRecord({otherField: }) -// ^com - -type recordWithOptionalField = { - someField: int, - someOptField?: bool, -} - -let fnTakingRecordWithOptionalField = (r: recordWithOptionalField) => { - ignore(r) -} - -// let _ = fnTakingRecordWithOptionalField({someOptField: }) -// ^com -type recordWithOptVariant = {someVariant: option} - -let fnTakingRecordWithOptVariant = (r: recordWithOptVariant) => { - ignore(r) -} - -// let _ = fnTakingRecordWithOptVariant({someVariant: }) -// ^com - -type variantWithInlineRecord = - WithInlineRecord({someBoolField: bool, otherField: option, nestedRecord: otherRecord}) - -let fnTakingInlineRecord = (r: variantWithInlineRecord) => { - ignore(r) -} - -// let _ = fnTakingInlineRecord(WithInlineRecord()) -// ^com - -// let _ = fnTakingInlineRecord(WithInlineRecord({})) -// ^com - -// let _ = fnTakingInlineRecord(WithInlineRecord({s})) -// ^com - -// let _ = fnTakingInlineRecord(WithInlineRecord({nestedRecord: })) -// ^com - -// let _ = fnTakingInlineRecord(WithInlineRecord({nestedRecord: {} })) -// ^com - -type variant = First | Second(bool) - -let fnTakingCallback = ( - cb: unit => unit, - cb2: bool => unit, - cb3: ReactEvent.Mouse.t => unit, - cb4: (~on: bool, ~off: bool=?, variant) => int, - cb5: (bool, option, bool) => unit, - cb6: (~on: bool=?, ~off: bool=?, unit) => int, -) => { - let _ = cb - let _ = cb2 - let _ = cb3 - let _ = cb4 - let _ = cb5 - let _ = cb6 -} - -// fnTakingCallback() -// ^com - -// fnTakingCallback(a) -// ^com - -// fnTakingCallback(a, ) -// ^com - -// fnTakingCallback(a, b, ) -// ^com - -// fnTakingCallback(a, b, c, ) -// ^com - -// fnTakingCallback(a, b, c, d, ) -// ^com - -// fnTakingCallback(a, b, c, d, e, ) -// ^com - -let something = { - let second = true - let second2 = 1 - ignore(second) - ignore(second2) - Js.log(s) - // ^com -} - -let fff: recordWithOptionalField = { - someField: 123, - someOptField: true, -} - -ignore(fff) - -// fff.someOpt -// ^com - -type someTyp = {test: bool} - -let takesCb = cb => { - cb({test: true}) -} - -// takesCb() -// ^com - -module Environment = { - type t = {hello: bool} -} - -let takesCb2 = cb => { - cb({Environment.hello: true}) -} - -// takesCb2() -// ^com - -type apiCallResult = {hi: bool} - -let takesCb3 = cb => { - cb({hi: true}) -} - -// takesCb3() -// ^com - -let takesCb4 = cb => { - cb(Some({hi: true})) -} - -// takesCb4() -// ^com - -let takesCb5 = cb => { - cb([Some({hi: true})]) -} - -// takesCb5() -// ^com - -module RecordSourceSelectorProxy = { - type t -} - -@val -external commitLocalUpdate: (~updater: RecordSourceSelectorProxy.t => unit) => unit = - "commitLocalUpdate" - -// commitLocalUpdate(~updater=) -// ^com - -let fnTakingAsyncCallback = (cb: unit => promise) => { - let _ = cb -} - -// fnTakingAsyncCallback() -// ^com - -let arr = ["hello"] - -// arr->Belt.Array.map() -// ^com - -type exoticPolyvariant = [#"some exotic"] - -let takesExotic = (e: exoticPolyvariant) => { - ignore(e) -} - -// takesExotic() -// ^com - -let fnTakingPolyVariant = (a: somePolyVariant) => { - ignore(a) -} - -// fnTakingPolyVariant() -// ^com - -// fnTakingPolyVariant(#) -// ^com - -// fnTakingPolyVariant(#o) -// ^com - -// fnTakingPolyVariant(o) -// ^com - -module SuperInt: { - type t - let increment: (t, int) => t - let decrement: (t, int => int) => t - let make: int => t - let toInt: t => int -} = { - type t = int - let increment = (t, num) => t + num - let decrement = (t, decrementer) => decrementer(t) - let make = t => t - let toInt = t => t -} - -type withIntLocal = {superInt: SuperInt.t} - -// let withInt: withIntLocal = {superInt: } -// ^com - -// CompletionSupport.makeTestHidden() -// ^com - -open CompletionSupport -// CompletionSupport.makeTestHidden() -// ^com - -let mkStuff = (r: Js.Re.t) => { - ignore(r) - "hello" -} - -// mkStuff() -// ^com - -module Money: { - type t - - let zero: t - - let nonTType: string - - let make: unit => t - - let fromInt: int => t - - let plus: (t, t) => t -} = { - type t = string - - let zero: t = "0" - - let nonTType = "0" - - let make = (): t => zero - - let fromInt = (int): t => int->Js.Int.toString - - let plus = (m1, _) => m1 -} - -let tArgCompletionTestFn = (_tVal: Money.t) => () - -// tArgCompletionTestFn() -// ^com - -let labeledTArgCompletionTestFn = (~tVal as _: Money.t) => () - -// labeledTArgCompletionTestFn(~tVal=) -// ^com - -let someTyp: someTyp = {test: true} - -// switch someTyp. { | _ => () } -// ^com Complete src/CompletionExpressions.res 3:20 XXX Not found! Completable: Cpattern CTuple(Value[s], Value[f]) diff --git a/analysis/tests/src/expected/CompletionFunctionArguments.res.txt b/analysis/tests/src/expected/CompletionFunctionArguments.res.txt index 98dd8dc1d..b84d25a27 100644 --- a/analysis/tests/src/expected/CompletionFunctionArguments.res.txt +++ b/analysis/tests/src/expected/CompletionFunctionArguments.res.txt @@ -1,128 +1,3 @@ -let someFn = (~isOn, ~isOff=false, ()) => { - if isOn && !isOff { - "on" - } else { - "off" - } -} - -let tLocalVar = false - -// let _ = someFn(~isOn=) -// ^com - -// let _ = someFn(~isOn=t) -// ^com - -// let _ = someFn(~isOff=) -// ^com - -let _ = - someFn( - ~isOn={ - // switch someFn(~isOn=) - // ^com - true - }, - ... - ) - -let someOtherFn = (includeName, age, includeAge) => { - "Hello" ++ - (includeName ? " Some Name" : "") ++ - ", you are age " ++ - Belt.Int.toString(includeAge ? age : 0) -} - -// let _ = someOtherFn(f) -// ^com - -module OIncludeMeInCompletions = {} - -type someVariant = One | Two | Three(int, string) - -let someFnTakingVariant = ( - configOpt: option, - ~configOpt2=One, - ~config: someVariant, -) => { - ignore(config) - ignore(configOpt) - ignore(configOpt2) -} - -// let _ = someFnTakingVariant(~config=) -// ^com - -// let _ = someFnTakingVariant(~config=O) -// ^com - -// let _ = someFnTakingVariant(So) -// ^com - -// let _ = someFnTakingVariant(~configOpt2=O) -// ^com - -// let _ = someOtherFn() -// ^com - -// let _ = someOtherFn(1, 2, ) -// ^com - -// let _ = 1->someOtherFn(1, t) -// ^com - -let fnTakingTuple = (arg: (int, int, float)) => { - ignore(arg) -} - -// let _ = fnTakingTuple() -// ^com - -type someRecord = { - age: int, - offline: bool, - online: option, -} - -let fnTakingRecord = (r: someRecord) => { - ignore(r) -} - -// let _ = fnTakingRecord({}) -// ^com - -module FineModule = { - type t = { - online: bool, - somethingElse: string, - } - - let setToFalse = (t: t) => { - ...t, - online: false, - } -} - -let _ = -
{ - let reassignedWorks = thisGetsBrokenLoc - ignore(reassignedWorks) - // thisGetsBrokenLoc->a - // ^com - // reassignedWorks->a - // ^com - }} - /> - -let fineModuleVal = { - FineModule.online: true, - somethingElse: "", -} - -// makeItem(~changefreq=Monthly, ~lastmod=fineModuleVal->, ~priority=Low) -// ^com Complete src/CompletionFunctionArguments.res 10:24 posCursor:[10:24] posNoWhite:[10:23] Found expr:[10:11->10:25] Pexp_apply ...[10:11->10:17] (~isOn10:19->10:23=...__ghost__[0:-1->0:-1]) diff --git a/analysis/tests/src/expected/CompletionInferValues.res.txt b/analysis/tests/src/expected/CompletionInferValues.res.txt index 493c6b217..356a23819 100644 --- a/analysis/tests/src/expected/CompletionInferValues.res.txt +++ b/analysis/tests/src/expected/CompletionInferValues.res.txt @@ -1,172 +1,3 @@ -let getBool = () => true -let getInt = () => 123 - -type someRecord = {name: string, age: int} - -let someFnWithCallback = (cb: (~num: int, ~someRecord: someRecord, ~isOn: bool) => unit) => { - let _ = cb -} - -let reactEventFn = (cb: ReactEvent.Mouse.t => unit) => { - let _ = cb -} - -@val external getSomeRecord: unit => someRecord = "getSomeRecord" - -// let x = 123; let aliased = x; aliased->f -// ^com - -// let x = getSomeRecord(); x. -// ^com - -// let x = getSomeRecord(); let aliased = x; aliased. -// ^com - -// someFnWithCallback((~someRecord, ~num, ~isOn) => someRecord.) -// ^com - -// let aliasedFn = someFnWithCallback; aliasedFn((~num, ~someRecord, ~isOn) => someRecord.) -// ^com - -// reactEventFn(event => { event->pr }); -// ^com - -module Div = { - @react.component - let make = (~onMouseEnter: option unit>=?) => { - let _ = onMouseEnter - React.null - } -} - -// let _ =
{ event->pr }} /> -// ^com - -// let _ =
{ event->pr }} /> -// ^com - -// let _ =
{ let btn = event->JsxEvent.Mouse.button; btn->t }} /> -// ^com - -// let _ =
{ let btn = event->JsxEvent.Mouse.button->Belt.Int.toString; btn->spl }} /> -// ^com - -// let _ =
{ let btn = event->JsxEvent.Mouse.button->Belt.Int.toString->Js.String2.split("/"); btn->ma }} /> -// ^com - -// let x: someRecord = {name: "Hello", age: 123}; x. -// ^com - -type someVariant = One | Two | Three(int, string) -type somePolyVariant = [#one | #two | #three(int, string)] -type someNestedRecord = {someRecord: someRecord} - -type someRecordWithNestedStuff = { - things: string, - someInt: int, - srecord: someRecord, - nested: someNestedRecord, - someStuff: bool, -} - -type otherNestedRecord = { - someRecord: someRecord, - someTuple: (someVariant, int, somePolyVariant), - optRecord: option, -} - -// Destructure record -// let x: someRecordWithNestedStuff = Obj.magic(); let {srecord} = x; srecord. -// ^com - -// Follow aliased -// let x: someRecordWithNestedStuff = Obj.magic(); let {nested: aliased} = x; aliased. -// ^com - -// Follow nested record -// let x: someRecordWithNestedStuff = Obj.magic(); let {srecord, nested: {someRecord}} = x; someRecord. -// ^com - -// Destructure string -// let x: someRecordWithNestedStuff = Obj.magic(); let {things} = x; things->slic -// ^com - -// Destructure int -// let x: someRecordWithNestedStuff = Obj.magic(); let {someInt} = x; someInt->toS -// ^com - -// Follow tuples -// let x: otherNestedRecord = Obj.magic(); let {someTuple} = x; let (_, someInt, _) = someTuple; someInt->toS -// ^com - -// Same as above, but follow in switch case -// let x: otherNestedRecord; switch x { | {someTuple} => let (_, someInt, _) = someTuple; someInt->toS } -// ^com - -// Follow variant payloads -// let x: otherNestedRecord; switch x { | {someTuple:(Three(_, str), _, _)} => str->slic } -// ^com - -// Follow polyvariant payloads -// let x: otherNestedRecord; switch x { | {someTuple:(_, _, #three(_, str))} => str->slic } -// ^com - -// Follow options -// let x: otherNestedRecord; switch x { | {optRecord:Some({name})} => name->slic } -// ^com - -// Follow arrays -// let x: array; switch x { | [inner] => inner.s } -// ^com - -// Infer top level return -// let x = 123; switch x { | 123 => () | v => v->toSt } -// ^com - -let fnWithRecordCallback = (cb: someRecord => unit) => { - let _ = cb -} - -// Complete pattern of function parameter -// fnWithRecordCallback(({}) => {()}) -// ^com - -let fn2 = (~cb: CompletionSupport.Nested.config => unit) => { - let _ = cb -} - -// fn2(~cb=({root}) => {root-> }) -// ^com - -type sameFileRecord = {root: CompletionSupport.Test.t, test: int} - -let fn3 = (~cb: sameFileRecord => unit) => { - let _ = cb -} - -// fn3(~cb=({root}) => {root-> }) -// ^com - -// Handles pipe chains as input for switch -// let x = 123; switch x->Belt.Int.toString { | } -// ^com - -// Handles pipe chains as input for switch -// let x = 123; switch x->Belt.Int.toString->Js.String2.split("/") { | } -// ^com - -// Regular completion works -// let renderer = CompletionSupport2.makeRenderer(~prepare=() => "hello",~render=({support}) => {support.},()) -// ^com - -// But pipe completion gets the wrong completion path. Should be `ReactDOM.Client.Root.t`, but ends up being `CompletionSupport2.ReactDOM.Client.Root.t`. -// let renderer = CompletionSupport2.makeRenderer(~prepare=() => "hello",~render=({support:{root}}) => {root->},()) -// ^com - -// Handles reusing the same name already in scope for bindings -let res = 1 -// switch res { | res => res } -// ^hov Complete src/CompletionInferValues.res 15:43 posCursor:[15:43] posNoWhite:[15:42] Found expr:[15:33->15:43] Completable: Cpath Value[aliased]->f diff --git a/analysis/tests/src/expected/CompletionJsx.res.txt b/analysis/tests/src/expected/CompletionJsx.res.txt index f6da05726..65c5e9e89 100644 --- a/analysis/tests/src/expected/CompletionJsx.res.txt +++ b/analysis/tests/src/expected/CompletionJsx.res.txt @@ -1,94 +1,3 @@ -let someString = "hello" -ignore(someString) - -// someString->st -// ^com - -module SomeComponent = { - @react.component - let make = (~someProp) => { - let someInt = 12 - let someArr = [React.null] - ignore(someInt) - ignore(someArr) - // someString->st - // ^com -
- {React.string(someProp)} -
{React.null}
- // {someString->st} - // ^com - // {"Some string"->st} - // ^com - // {"Some string"->Js.String2.trim->st} - // ^com - // {someInt->} - // ^com - // {12->} - // ^com - // {someArr->a} - // ^com - // - } -} - -module CompWithoutJsxPpx = { - type props = {name: string} - - let make = ({name}) => { - ignore(name) - React.null - } -} - -// -// ^com - -//

Jsx.element = "createElement" -} - -// { - ignore(time) - name ++ age - } -} - -// { - React.string((_type :> string)) - } -} - -// -// ^com Complete src/CompletionJsx.res 3:17 posCursor:[3:17] posNoWhite:[3:16] Found expr:[3:3->3:17] Completable: Cpath Value[someString]->st diff --git a/analysis/tests/src/expected/CompletionJsxProps.res.txt b/analysis/tests/src/expected/CompletionJsxProps.res.txt index 69d6ba6e0..7175c70e4 100644 --- a/analysis/tests/src/expected/CompletionJsxProps.res.txt +++ b/analysis/tests/src/expected/CompletionJsxProps.res.txt @@ -1,49 +1,3 @@ -// let _ = -// ^com - -// let _ =
-// ^com - -// Should wrap in {} -// let _ = Js.import(CompletableComponent.make) - let make = React.lazy_(loadComponent) -} - -// let _ = 0:47] JSX 0:43] on[0:44->0:46]=...__ghost__[0:-1->0:-1]> _children:None diff --git a/analysis/tests/src/expected/CompletionPattern.res.txt b/analysis/tests/src/expected/CompletionPattern.res.txt index 2c61e7dc4..99b8b188d 100644 --- a/analysis/tests/src/expected/CompletionPattern.res.txt +++ b/analysis/tests/src/expected/CompletionPattern.res.txt @@ -1,235 +1,3 @@ -let v = (true, Some(false), (true, true)) - -let _ = switch v { -| (true, _, _) => 1 -| _ => 2 -} - -// switch v { -// ^com - -// switch v { | } -// ^com - -// switch v { | (t, _) } -// ^com - -// switch v { | (_, _, (f, _)) } -// ^com - -let x = true - -// switch x { | -// ^com - -// switch x { | t -// ^com - -type nestedRecord = {nested: bool} - -type rec someRecord = { - first: int, - second: (bool, option), - optThird: option<[#first | #second(someRecord)]>, - nest: nestedRecord, -} - -let f: someRecord = { - first: 123, - second: (true, None), - optThird: None, - nest: {nested: true}, -} - -let z = (f, true) -ignore(z) - -// switch f { | } -// ^com - -// switch f { | {}} -// ^com - -// switch f { | {first, , second }} -// ^com - -// switch f { | {fi}} -// ^com - -// switch z { | ({o}, _)} -// ^com - -// switch f { | {nest: }} -// ^com - -// switch f { | {nest: {}}} -// ^com - -let _ = switch f { -| {first: 123, nest} => - () - // switch nest { | {}} - // ^com - nest.nested -| _ => false -} - -// let {} = f -// ^com - -// let {nest: {n}}} = f -// ^com - -type someVariant = One | Two(bool) | Three(someRecord, bool) - -let z = Two(true) -ignore(z) - -// switch z { | Two()} -// ^com - -// switch z { | Two(t)} -// ^com - -// switch z { | Three({})} -// ^com - -// switch z { | Three({}, t)} -// ^com - -type somePolyVariant = [#one | #two(bool) | #three(someRecord, bool)] -let b: somePolyVariant = #two(true) -ignore(b) - -// switch b { | #two()} -// ^com - -// switch b { | #two(t)} -// ^com - -// switch b { | #three({})} -// ^com - -// switch b { | #three({}, t)} -// ^com - -let c: array = [] -ignore(c) - -// switch c { | } -// ^com - -// switch c { | [] } -// ^com - -let o = Some(true) -ignore(o) - -// switch o { | Some() } -// ^com - -type multiPayloadVariant = Test(int, bool, option, array) - -let p = Test(1, true, Some(false), []) - -// switch p { | Test(1, )} -// ^com - -// switch p { | Test(1, true, )} -// ^com - -// switch p { | Test(1, , None)} -// ^com - -// switch p { | Test(1, true, None, )} -// ^com - -type multiPayloadPolyVariant = [#test(int, bool, option, array)] - -let v: multiPayloadPolyVariant = #test(1, true, Some(false), []) - -// switch v { | #test(1, )} -// ^com - -// switch v { | #test(1, true, )} -// ^com - -// switch v { | #test(1, , None)} -// ^com - -// switch v { | #test(1, true, None, )} -// ^com - -let s = (true, Some(true), [false]) - -// switch s { | () } -// ^com - -// switch s { | (true, ) } -// ^com - -// switch s { | (true, , []) } -// ^com - -// switch s { | (true, []) => () | } -// ^com - -// switch s { | (true, []) => () | (true, , []) } -// ^com - -// switch z { | One | } -// ^com - -// switch z { | One | Two(true | ) } -// ^com - -// switch z { | One | Three({test: true}, true | ) } -// ^com - -// switch b { | #one | #two(true | ) } -// ^com - -// switch b { | #one | #three({test: true}, true | ) } -// ^com - -// switch s { | (true, _, []) } -// ^com - -type recordWithFn = {someFn: unit => unit} - -let ff: recordWithFn = {someFn: () => ()} - -// switch ff { | {someFn: }} -// ^com - -let xn: exn = Obj.magic() - -// switch xn { | } -// ^com - -let getThing = async () => One - -// switch await getThing() { | } -// ^com - -let res: result = Ok(One) - -// switch res { | Ok() } -// ^com - -// switch res { | Error() } -// ^com - -@react.component -let make = (~thing: result) => { - switch thing { - | Ok(Three(r, _)) => - let _x = r - // switch r { | {first, }} - // ^com - | _ => () - } -} Complete src/CompletionPattern.res 7:13 posCursor:[7:13] posNoWhite:[7:12] Found expr:[7:3->7:13] [] diff --git a/analysis/tests/src/expected/CompletionPipeChain.res.txt b/analysis/tests/src/expected/CompletionPipeChain.res.txt index bf583c6e0..91f6ca0e1 100644 --- a/analysis/tests/src/expected/CompletionPipeChain.res.txt +++ b/analysis/tests/src/expected/CompletionPipeChain.res.txt @@ -1,108 +1,3 @@ -module Integer: { - type t - let increment: (t, int) => t - let decrement: (t, int => int) => t - let make: int => t - let toInt: t => int -} = { - type t = int - let increment = (t, num) => t + num - let decrement = (t, decrementer) => decrementer(t) - let make = t => t - let toInt = t => t -} - -module SuperFloat: { - type t - let fromInteger: Integer.t => t - let toInteger: t => Integer.t -} = { - type t = float - let fromInteger = t => t->Integer.toInt->Belt.Float.fromInt - let toInteger = t => t->Belt.Float.toInt->Integer.make -} - -let toFlt = i => i->SuperFloat.fromInteger -let int = Integer.make(1) -let f = int->Integer.increment(2) -// let _ = int-> -// ^com - -// let _ = int->toFlt-> -// ^com - -// let _ = int->Integer.increment(2)-> -// ^com - -// let _ = Integer.increment(int, 2)-> -// ^com - -// let _ = int->Integer.decrement(t => t - 1)-> -// ^com - -// let _ = int->Integer.increment(2)->Integer.decrement(t => t - 1)-> -// ^com - -// let _ = int->Integer.increment(2)->SuperFloat.fromInteger-> -// ^com - -// let _ = int->Integer.increment(2)->SuperFloat.fromInteger->t -// ^com - -// let _ = int->Integer.increment(2)->Integer.toInt->CompletionSupport.Test.make-> -// ^com - -// let _ = CompletionSupport.Test.make(1)->CompletionSupport.Test.addSelf(2)-> -// ^com - -let _ = [123]->Js.Array2.forEach(v => Js.log(v)) -// -> -// ^com - -let _ = [123]->Belt.Array.reduce(0, (acc, curr) => acc + curr) -// ->t -// ^com - -type aliasedType = CompletionSupport.Test.t - -let aliased: aliasedType = {name: 123} -let notAliased: CompletionSupport.Test.t = {name: 123} - -// aliased-> -// ^com - -// notAliased-> -// ^com - -let renderer = CompletionSupport2.makeRenderer( - ~prepare=() => "hello", - ~render=props => { - ignore(props) - - // Doesn't work when tried through this chain. Presumably because it now goes through multiple different files. - // props.support.root->ren - // ^com - let root = props.support.root - ignore(root) - - // Works here though when it's lifted out. Probably because it only goes through one file...? - // root->ren - // ^com - React.null - }, - (), -) - -// Console.log(int->) -// ^com - -// Console.log(int->t) -// ^com - -let r = %re("/t/g") - -// r->la -// ^com Complete src/CompletionPipeChain.res 27:16 posCursor:[27:16] posNoWhite:[27:15] Found expr:[27:11->0:-1] Completable: Cpath Value[int]-> diff --git a/analysis/tests/src/expected/CompletionPipeSubmodules.res.txt b/analysis/tests/src/expected/CompletionPipeSubmodules.res.txt index 98f964fe1..73f9ab4a5 100644 --- a/analysis/tests/src/expected/CompletionPipeSubmodules.res.txt +++ b/analysis/tests/src/expected/CompletionPipeSubmodules.res.txt @@ -1,48 +1,3 @@ -module A = { - module B1 = { - type b1 = B1 - let xx = B1 - } - module B2 = { - let yy = 20 - } - type t = {v: B1.b1} - let x = {v: B1.B1} -} - -// let _ = A.B1.xx-> -// ^com -// b1 seen from B1 is A.B1.b1 - -// let _ = A.x.v-> -// ^com -// B1.b1 seen from A is A.B1.b1 - -module C = { - type t = C -} - -module D = { - module C2 = { - type t2 = C2 - } - - type d = {v: C.t, v2: C2.t2} - let d = {v: C.C, v2: C2.C2} -} - -module E = { - type e = {v: D.d} - let e = {v: D.d} -} - -// let _ = E.e.v.v-> -// ^com -// C.t seen from D is C.t - -// let _ = E.e.v.v2-> -// ^com -// C2.t2 seen from D is D.C2.t2 Complete src/CompletionPipeSubmodules.res 12:20 posCursor:[12:20] posNoWhite:[12:19] Found expr:[12:11->20:8] Completable: Cpath Value[A, B1, xx]-> diff --git a/analysis/tests/src/expected/CompletionResolve.res.txt b/analysis/tests/src/expected/CompletionResolve.res.txt index b242f0f81..d0492d217 100644 --- a/analysis/tests/src/expected/CompletionResolve.res.txt +++ b/analysis/tests/src/expected/CompletionResolve.res.txt @@ -1,7 +1,3 @@ -// ^cre Belt_Array - -// ^cre ModuleStuff - Completion resolve: Belt_Array "\nUtilities for `Array` functions.\n\n### Note about index syntax\n\nCode like `arr[0]` does *not* compile to JavaScript `arr[0]`. Reason transforms\nthe `[]` index syntax into a function: `Array.get(arr, 0)`. By default, this\nuses the default standard library's `Array.get` function, which may raise an\nexception if the index isn't found. If you `open Belt`, it will use the\n`Belt.Array.get` function which returns options instead of raising exceptions. \n[See this for more information](../belt.mdx#array-access-runtime-safety).\n" diff --git a/analysis/tests/src/expected/CompletionSupport.res.txt b/analysis/tests/src/expected/CompletionSupport.res.txt index 3c15a0a97..e69de29bb 100644 --- a/analysis/tests/src/expected/CompletionSupport.res.txt +++ b/analysis/tests/src/expected/CompletionSupport.res.txt @@ -1,42 +0,0 @@ -module Test = { - type t = {name: int} - let add = (ax: t) => ax.name + 1 - let addSelf = (ax: t) => {name: ax.name + 1} - let make = (name: int): t => {name: name} -} - -module TestHidden: { - type t - let make: int => t - let self: t => t -} = { - type t = {name: int} - let make = (name: int): t => {name: name} - let self = t => t -} - -type testVariant = One | Two | Three(int) - -module TestComponent = { - @react.component - let make = ( - ~on: bool, - ~test: testVariant, - ~testArr: array, - ~polyArg: option<[#one | #two | #two2 | #three(int, bool)]>=?, - ) => { - ignore(on) - ignore(test) - ignore(testArr) - ignore(polyArg) - React.null - } -} - -module Nested = { - type config = {root: ReactDOM.Client.Root.t} -} - -type options = {test: TestHidden.t} - -let makeTestHidden = t => TestHidden.self(t) diff --git a/analysis/tests/src/expected/CompletionSupport2.res.txt b/analysis/tests/src/expected/CompletionSupport2.res.txt index 925fc5d57..e69de29bb 100644 --- a/analysis/tests/src/expected/CompletionSupport2.res.txt +++ b/analysis/tests/src/expected/CompletionSupport2.res.txt @@ -1,17 +0,0 @@ -module Internal = { - type prepareProps<'prepared> = { - someName: string, - support: CompletionSupport.Nested.config, - prepared: 'prepared, - } -} - -let makeRenderer = ( - ~prepare: unit => 'prepared, - ~render: Internal.prepareProps<'prepared> => React.element, - (), -) => { - let _ = prepare - let _ = render - "123" -} diff --git a/analysis/tests/src/expected/CompletionTypeAnnotation.res.txt b/analysis/tests/src/expected/CompletionTypeAnnotation.res.txt index 84bbce9f7..b00084e7f 100644 --- a/analysis/tests/src/expected/CompletionTypeAnnotation.res.txt +++ b/analysis/tests/src/expected/CompletionTypeAnnotation.res.txt @@ -1,60 +1,3 @@ -type someRecord = { - age: int, - name: string, -} - -type someVariant = One | Two(bool) - -type somePolyVariant = [#one | #two(bool)] - -// let x: someRecord = -// ^com - -// let x: someRecord = {} -// ^com - -// let x: someVariant = -// ^com - -// let x: someVariant = O -// ^com - -// let x: somePolyVariant = -// ^com - -// let x: somePolyVariant = #o -// ^com - -type someFunc = (int, string) => bool - -// let x: someFunc = -// ^com - -type someTuple = (bool, option) - -// let x: someTuple = -// ^com - -// let x: someTuple = (true, ) -// ^com - -// let x: option = -// ^com - -// let x: option = Some() -// ^com - -// let x: array = -// ^com - -// let x: array = [] -// ^com - -// let x: array> = -// ^com - -// let x: option> = Some([]) -// ^com Complete src/CompletionTypeAnnotation.res 9:22 XXX Not found! Completable: Cexpression Type[someRecord] diff --git a/analysis/tests/src/expected/CompletionTypeT.res.txt b/analysis/tests/src/expected/CompletionTypeT.res.txt index 8c7160939..30c972299 100644 --- a/analysis/tests/src/expected/CompletionTypeT.res.txt +++ b/analysis/tests/src/expected/CompletionTypeT.res.txt @@ -1,12 +1,3 @@ -let date = Some(Js.Date.make()) - -type withDate = {date: Js.Date.t} - -// let x = switch date { | } -// ^com - -// let x: withDate = {date: } -// ^com Complete src/CompletionTypeT.res 4:26 XXX Not found! Completable: Cpattern Value[date] diff --git a/analysis/tests/src/expected/Component.res.txt b/analysis/tests/src/expected/Component.res.txt index aa3f50cb0..e69de29bb 100644 --- a/analysis/tests/src/expected/Component.res.txt +++ b/analysis/tests/src/expected/Component.res.txt @@ -1,2 +0,0 @@ -@react.component -let make = () => React.null diff --git a/analysis/tests/src/expected/Component.resi.txt b/analysis/tests/src/expected/Component.resi.txt index 1ca44ce26..e69de29bb 100644 --- a/analysis/tests/src/expected/Component.resi.txt +++ b/analysis/tests/src/expected/Component.resi.txt @@ -1,2 +0,0 @@ -@react.component -let make: unit => React.element diff --git a/analysis/tests/src/expected/CreateInterface.res.txt b/analysis/tests/src/expected/CreateInterface.res.txt index b7ae7894b..4e1212948 100644 --- a/analysis/tests/src/expected/CreateInterface.res.txt +++ b/analysis/tests/src/expected/CreateInterface.res.txt @@ -1,148 +1,3 @@ -// ^int - -type r = {name: string, age: int} - -let add = (~x, ~y) => x + y - -@react.component -let make = (~name) => React.string(name) - -module Other = { - @react.component - let otherComponentName = (~name) => React.string(name) -} - -module Mod = { - @react.component - let make = (~name) => React.string(name) -} - -module type ModTyp = { - @react.component - let make: (~name: string) => React.element -} - -@module("path") external dirname: string => string = "dirname" - -@module("path") @variadic -external join: array => string = "join" - -@val -external padLeft: ( - string, - @unwrap - [ - | #Str(string) - | #Int(int) - ], -) => string = "padLeft" - -@inline -let f1 = 10 - -@inline let f2 = "some string" - -@genType @inline -let f3 = 10 - -@genType @inline -let f4 = "some string" - -@genType @inline let f5 = 5.5 - -module RFS = { - @module("fs") - external readFileSync: ( - ~name: string, - @string - [ - | #utf8 - | @as("ascii") #useAscii - ], - ) => string = "readFileSync" -} - -module Functor = () => { - @react.component - let make = () => React.null -} - -module type FT = { - module Functor: ( - X: { - let a: int - @react.component - let make: (~name: string) => React.element - let b: int - }, - Y: ModTyp, - ) => - { - @react.component - let make: (~name: string) => React.element - } -} - -module NormaList = List -open Belt -module BeltList = List - -module type MT2 = ModTyp - -module rec RM: ModTyp = D -and D: ModTyp = Mod - -module type OptT = { - @react.component - let withOpt1: (~x: int=?, ~y: int) => int - - module type Opt2 = { - @react.component - let withOpt2: (~x: int=?, ~y: int) => int - } - - module type Opt3 = { - @react.component - let withOpt3: (~x: option, ~y: int) => int - } -} - -module Opt = { - @react.component - let withOpt1 = (~x=3, ~y) => x + y - - module Opt2 = { - @react.component - let withOpt2 = (~x: option=?, ~y: int) => - switch x { - | None => 0 - | Some(x) => x - } + - y - } - module type Opt2 = module type of Opt2 - - module Opt3 = { - @react.component - let withOpt3 = (~x: option, ~y: int) => - switch x { - | None => 0 - | Some(x) => x - } + - y - } - module type Opt3 = module type of Opt3 -} - -module Opt2: OptT = Opt -module Opt3 = Opt - -module Memo = { - @react.component - let make = (~name) => React.string(name) - - let make = React.memo(make) -} Create Interface src/CreateInterface.res type r = {name: string, age: int} let add: (~x: int, ~y: int) => int diff --git a/analysis/tests/src/expected/Cross.res.txt b/analysis/tests/src/expected/Cross.res.txt index ee0e6d11c..6f5ad3e43 100644 --- a/analysis/tests/src/expected/Cross.res.txt +++ b/analysis/tests/src/expected/Cross.res.txt @@ -1,44 +1,3 @@ -let crossRef = References.x -// ^ref - -let crossRef2 = References.x - -module Ref = References - -let crossRef3 = References.x - -let crossRefWithInterface = ReferencesWithInterface.x -// ^ref - -let crossRefWithInterface2 = ReferencesWithInterface.x - -module RefWithInterface = ReferencesWithInterface - -let crossRefWithInterface3 = ReferencesWithInterface.x - -let _ = RenameWithInterface.x -// ^ren RenameWithInterfacePrime - -let _ = RenameWithInterface.x -// ^ren xPrime - -let typeDef = {TypeDefinition.item: "foobar"} -// ^typ - -let _ = DefinitionWithInterface.y -// ^def - -type defT = DefinitionWithInterface.t -// ^def - -type defT2 = DefinitionWithInterface.t -// ^typ - -// DefinitionWithInterface.a -// ^com - -let yy = DefinitionWithInterface.Inner.y -// ^def References src/Cross.res 0:17 [ {"uri": "Cross.res", "range": {"start": {"line": 0, "character": 15}, "end": {"line": 0, "character": 25}}}, diff --git a/analysis/tests/src/expected/Dce.res.txt b/analysis/tests/src/expected/Dce.res.txt index 9ccb29cb4..58c835d7a 100644 --- a/analysis/tests/src/expected/Dce.res.txt +++ b/analysis/tests/src/expected/Dce.res.txt @@ -1,7 +1,3 @@ -// Note: in test mode this only reports on src/dce - -// ^dce - DCE src/Dce.res issues:1 diff --git a/analysis/tests/src/expected/Debug.res.txt b/analysis/tests/src/expected/Debug.res.txt index 0e79eb379..2f684865b 100644 --- a/analysis/tests/src/expected/Debug.res.txt +++ b/analysis/tests/src/expected/Debug.res.txt @@ -1,20 +1,3 @@ -// turn on by adding this comment // ^db+ - -let _ = ShadowedBelt.List.map -// ^def - -open Js -module Before = { - open Belt - let _ = Id.getCmpInternal -} -module Inner = { - // eqN - // ^com - open List - let _ = map -} -// ^db- Definition src/Debug.res 2:27 {"uri": "ShadowedBelt.res", "range": {"start": {"line": 1, "character": 6}, "end": {"line": 1, "character": 9}}} diff --git a/analysis/tests/src/expected/Definition.res.txt b/analysis/tests/src/expected/Definition.res.txt index 05eba14f8..69f87b41e 100644 --- a/analysis/tests/src/expected/Definition.res.txt +++ b/analysis/tests/src/expected/Definition.res.txt @@ -1,31 +1,3 @@ -let xx = 10 - -let y = xx -// ^def - -module Inner = { - type tInner = int - let vInner = 34 -} - -type typeInner = Inner.tInner -// ^def - -// open Belt -let m1 = List.map -// ^hov - -open ShadowedBelt -let m2 = List.map -// ^hov - -let uncurried = (. x, y) => x + y - -uncurried(. 3, 12)->ignore -// ^hov - -uncurried(. 3, 12)->ignore -// ^def Definition src/Definition.res 2:8 {"uri": "Definition.res", "range": {"start": {"line": 0, "character": 4}, "end": {"line": 0, "character": 6}}} diff --git a/analysis/tests/src/expected/DefinitionWithInterface.res.txt b/analysis/tests/src/expected/DefinitionWithInterface.res.txt index 4a288ca1d..f8d85032d 100644 --- a/analysis/tests/src/expected/DefinitionWithInterface.res.txt +++ b/analysis/tests/src/expected/DefinitionWithInterface.res.txt @@ -1,15 +1,3 @@ -let y = 4 -// ^def - -type t = int - -let aabbcc = 3 -let _ = aabbcc - -module Inner = { - let y = 100 - // ^def -} Definition src/DefinitionWithInterface.res 0:4 {"uri": "DefinitionWithInterface.resi", "range": {"start": {"line": 0, "character": 4}, "end": {"line": 0, "character": 5}}} diff --git a/analysis/tests/src/expected/DefinitionWithInterface.resi.txt b/analysis/tests/src/expected/DefinitionWithInterface.resi.txt index c37da22b3..10bc34339 100644 --- a/analysis/tests/src/expected/DefinitionWithInterface.resi.txt +++ b/analysis/tests/src/expected/DefinitionWithInterface.resi.txt @@ -1,12 +1,3 @@ -let y: int -// ^def - -type t - -module Inner: { - let y: int - // ^def -} Definition src/DefinitionWithInterface.resi 0:4 {"uri": "DefinitionWithInterface.res", "range": {"start": {"line": 0, "character": 4}, "end": {"line": 0, "character": 5}}} diff --git a/analysis/tests/src/expected/Destructuring.res.txt b/analysis/tests/src/expected/Destructuring.res.txt index 76d78f933..86b03c313 100644 --- a/analysis/tests/src/expected/Destructuring.res.txt +++ b/analysis/tests/src/expected/Destructuring.res.txt @@ -1,37 +1,3 @@ -type x = {name: string, age: int} - -let x = {name: "123", age: 12} - -let {name} = x -// ^com - -// let {} = x -// ^com - -let f = (x: x) => { - let {name} = x - - // ^com - name -} - -let f2 = (x: x) => { - // let {} = x - // ^com - ignore(x) -} - -type recordWithOptField = { - someField: int, - someOptField?: bool, -} - -let x: recordWithOptField = { - someField: 123, -} - -// let {} = x -// ^com Complete src/Destructuring.res 4:11 posCursor:[4:11] posNoWhite:[4:9] Found pattern:[4:4->4:12] Completable: Cpattern Value[x]->recordBody diff --git a/analysis/tests/src/expected/Div.res.txt b/analysis/tests/src/expected/Div.res.txt index f1f30190d..b5af0d5f6 100644 --- a/analysis/tests/src/expected/Div.res.txt +++ b/analysis/tests/src/expected/Div.res.txt @@ -1,8 +1,3 @@ -let q =
-// ^hov - -//
{"contents": {"kind": "markdown", "value": "```rescript\n(\n string,\n ~props: ReactDOM_V3.domProps=?,\n array,\n) => React.element\n```\n\n---\n\n```\n \n```\n```rescript\ntype ReactDOM_V3.domProps = Props.domProps\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22ReactDOM_V3.res%22%2C57%2C2%5D)\n\n\n---\n\n```\n \n```\n```rescript\ntype React.element = Jsx.element\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22React.res%22%2C0%2C0%5D)\n"}} diff --git a/analysis/tests/src/expected/DocComments.res.txt b/analysis/tests/src/expected/DocComments.res.txt index 68943d50e..1f8ab304d 100644 --- a/analysis/tests/src/expected/DocComments.res.txt +++ b/analysis/tests/src/expected/DocComments.res.txt @@ -1,52 +1,3 @@ -@ns.doc(" Doc comment with a triple-backquote example - - ```res example - let a = 10 - /* - * stuff - */ - ``` -") -let docComment1 = 12 -// ^hov - -/** - Doc comment with a triple-backquote example - - ```res example - let a = 10 - /* - * stuff - */ - ``` -*/ -let docComment2 = 12 -// ^hov - -@ns.doc(" Doc comment with a triple-backquote example - - ```res example - let a = 10 - let b = 20 - ``` -") -let docCommentNoNested1 = 12 -// ^hov - -/** - Doc comment with a triple-backquote example - - ```res example - let a = 10 - let b = 20 - ``` -*/ -let docCommentNoNested2 = 12 -// ^hov - -/**New doc comment format*/ -let newDoc = 10 -// ^hov Hover src/DocComments.res 9:9 {"contents": {"kind": "markdown", "value": "```rescript\nint\n```\n---\n Doc comment with a triple-backquote example\\n \\n ```res example\\n let a = 10\\n /*\\n * stuff\\n */\\n ```\\n"}} diff --git a/analysis/tests/src/expected/DocumentSymbol.res.txt b/analysis/tests/src/expected/DocumentSymbol.res.txt index b09cb65ac..dc99a99d4 100644 --- a/analysis/tests/src/expected/DocumentSymbol.res.txt +++ b/analysis/tests/src/expected/DocumentSymbol.res.txt @@ -1,37 +1,3 @@ -module MyList = Belt.List - -module Dep: { - @ocaml.doc("Some doc comment") @deprecated("Use customDouble instead") - let customDouble: int => int -} = { - let customDouble = foo => foo * 2 -} - -module Lib = { - let foo = (~age, ~name) => name ++ string_of_int(age) - let next = (~number=0, ~year) => number + year -} - -let op = Some(3) - -module ForAuto = { - type t = int - let abc = (x: t, _y: int) => x - let abd = (x: t, _y: int) => x -} - -let fa: ForAuto.t = 34 - -module O = { - module Comp = { - @react.component - let make = (~first="", ~zoo=3, ~second) => React.string(first ++ second ++ string_of_int(zoo)) - } -} - -let zzz = 11 - -//^doc DocumentSymbol src/DocumentSymbol.res [ { diff --git a/analysis/tests/src/expected/EnvCompletion.res.txt b/analysis/tests/src/expected/EnvCompletion.res.txt index f03c50dda..0c8ebef34 100644 --- a/analysis/tests/src/expected/EnvCompletion.res.txt +++ b/analysis/tests/src/expected/EnvCompletion.res.txt @@ -1,66 +1,3 @@ -type things = One | Two -type things2 = Four | Five - -let res: EnvCompletionOtherFile.someResult = Okay(One) - -let use = (): EnvCompletionOtherFile.response => { - stuff: First, - res: Failure(""), -} - -// switch res { | } -// ^com - -// switch res { | Okay() } -// ^com - -// switch res { | Failure() } -// ^com - -// switch use() { | } -// ^com - -// switch use() { | {} } -// ^com - -// switch use() { | {stuff: } } -// ^com - -// switch use() { | {stuff: Second() } } -// ^com - -// switch use() { | {stuff: Second({}) } } -// ^com - -// switch use() { | {res: } } -// ^com - -// switch use() { | {res: Okay() } } -// ^com - -// switch use() { | {res: Okay(Second()) } } -// ^com - -// switch use() { | {res: Okay(Second({})) } } -// ^com - -let res2: EnvCompletionOtherFile.someRecord = { - name: "string", - theThing: Four, - theVariant: First, -} - -// switch res2 { | } -// ^com - -// switch res2 { | {} } -// ^com - -// switch res2 { | {theThing: } } -// ^com - -// switch res2 { | {theVariant: } } -// ^com Complete src/EnvCompletion.res 10:17 XXX Not found! Completable: Cpattern Value[res] diff --git a/analysis/tests/src/expected/EnvCompletionOtherFile.res.txt b/analysis/tests/src/expected/EnvCompletionOtherFile.res.txt index 1218b0010..e69de29bb 100644 --- a/analysis/tests/src/expected/EnvCompletionOtherFile.res.txt +++ b/analysis/tests/src/expected/EnvCompletionOtherFile.res.txt @@ -1,13 +0,0 @@ -type someResult<'a, 'b> = Okay('a) | Failure('b) - -type r1 = {age: int} - -type theVariant = First | Second(r1) - -type someRecord<'thing> = { - name: string, - theThing: 'thing, - theVariant: theVariant, -} - -type response = {stuff: theVariant, res: someResult} diff --git a/analysis/tests/src/expected/ExhaustiveSwitch.res.txt b/analysis/tests/src/expected/ExhaustiveSwitch.res.txt index 4e17fc809..bf1cc8447 100644 --- a/analysis/tests/src/expected/ExhaustiveSwitch.res.txt +++ b/analysis/tests/src/expected/ExhaustiveSwitch.res.txt @@ -1,46 +1,3 @@ -type someVariant = One | Two | Three(option) -type somePolyVariant = [#one | #two | #three(option) | #"exotic ident" | #"switch"] - -let withSomeVariant = One -let withSomePoly: somePolyVariant = #one -let someBool = true -let someOpt = Some(true) - -// switch withSomeVarian -// ^com - -// switch withSomePol -// ^com - -// switch someBoo -// ^com - -// switch someOp -// ^com - -type rcrd = {someVariant: someVariant} - -let getV = r => r.someVariant - -let x: rcrd = { - someVariant: One, -} - -let vvv = Some(x->getV) - -// switch x->getV -// ^xfm - -// x->getV -// ^xfm ^ - -// vvv -// ^xfm - -// ^ve+ 11.1 -// switch withSomeVarian -// ^com -// ^ve- Complete src/ExhaustiveSwitch.res 8:24 XXX Not found! Completable: CexhaustiveSwitch Value[withSomeVarian] diff --git a/analysis/tests/src/expected/Fragment.res.txt b/analysis/tests/src/expected/Fragment.res.txt index fcf639615..ae23ede19 100644 --- a/analysis/tests/src/expected/Fragment.res.txt +++ b/analysis/tests/src/expected/Fragment.res.txt @@ -1,19 +1,3 @@ -module SectionHeader = { - @react.component - let make = (~children) => children -} - -let z1 = - <> - {React.string("abc")} - -// ^hov - -let z2 = - <> - {React.string("abc")} - -// ^hov Hover src/Fragment.res 6:19 getLocItem #4: heuristic for within fragments: take make as makeProps does not work the type is not great but jump to definition works diff --git a/analysis/tests/src/expected/Highlight.res.txt b/analysis/tests/src/expected/Highlight.res.txt index d8cb8b146..a4ab8e142 100644 --- a/analysis/tests/src/expected/Highlight.res.txt +++ b/analysis/tests/src/expected/Highlight.res.txt @@ -1,143 +1,3 @@ -module M = { - module C = Component -} - -let _c = - -let _mc = - -let _d =
- -let _d2 = -
- {React.string("abc")} -
{React.string("abc")}
- {React.string("abc")} - {React.string("abc")} -
- -type pair<'x, 'y> = ('x, 'y) - -type looooooooooooooooooooooooooooooooooooooong_int = int - -type looooooooooooooooooooooooooooooooooooooong_string = string - -type pairIntString = list< - pair< - looooooooooooooooooooooooooooooooooooooong_int, - looooooooooooooooooooooooooooooooooooooong_string, - >, -> - -let _ = !(3 < 4) || 3 > 4 - -module type MT = { - module DDF: { - - } -} - -module DDF: MT = { - module DDF = {} -} - -module XX = { - module YY = { - type t = int - } -} - -open XX.YY - -type tt = t - -// ^hig - -module T = { - type someRecord<'typeParameter> = { - someField: int, - someOtherField: string, - theParam: 'typeParameter, - } - - type someEnum = A | B | C -} - -let foo = x => x.T.someField - -let add = (~hello as x, ~world) => x + world - -let _ = add(~hello=3, ...) - -let _ = -
-
-
- -module SomeComponent = { - module Nested = { - @react.component - let make = (~children) => { - <> {children} - } - } -} - -let _ = - -
- - -// true/false -let _ = true || false - -// to/downto as label -let toAs = (~to as x) => x -let _toEquals = toAs(~to=10) - -let to = 1 -for _ in to + to to to + to { - () -} - -module ToAsProp = { - @react.component - let make = (~to) => { - <> {React.int(to)} - } -} -let _ = - -// quoted identifiers -let \"true" = 4 -let _ = \"true" - -let enumInModule = T.A - -type typeInModule = XX.YY.t - -module QQ = { - type somePolyEnumType = [ - | #someMember - | #AnotherMember - | #SomeMemberWithPayload(list) - | #"fourth Member" - ] -} - -let _ = x => - switch x { - | #stuff => 3 - | #...QQ.somePolyEnumType => 4 - } - -let _ = 3 == 3 || 3 === 3 - -let _ = (~_type_ as _) => () - -let _ = {"abc": 34} - -let _ = {"Key": 2} Highlight src/Highlight.res structure items:39 diagnostics:0 Lident: M 0:7 Namespace diff --git a/analysis/tests/src/expected/Hover.res.txt b/analysis/tests/src/expected/Hover.res.txt index f6b65e68e..725c5a93a 100644 --- a/analysis/tests/src/expected/Hover.res.txt +++ b/analysis/tests/src/expected/Hover.res.txt @@ -1,270 +1,3 @@ -let abc = 22 + 34 -// ^hov - -type t = (int, float) -// ^hov - -module Id = { - // ^hov - type x = int -} - -@ocaml.doc("This module is commented") -module Dep: { - @ocaml.doc("Some doc comment") - let customDouble: int => int -} = { - let customDouble = foo => foo * 2 -} - -module D = Dep -// ^hov - -let cd = D.customDouble -// ^hov - -module HoverInsideModuleWithComponent = { - let x = 2 // check that hover on x works - // ^hov - @react.component - let make = () => React.null -} - -@ocaml.doc("Doc comment for functionWithTypeAnnotation") -let functionWithTypeAnnotation: unit => int = () => 1 -// ^hov - -@react.component -let make = (~name) => React.string(name) -// ^hov - -module C2 = { - @react.component - let make2 = (~name: string) => React.string(name) - // ^hov -} - -let num = 34 -// ^hov - -module type Logger = { - // ^hov - let log: string => unit -} - -module JsLogger: Logger = { - // ^hov - let log = (msg: string) => Js.log(msg) - let _oneMore = 3 -} - -module JJ = JsLogger -// ^def - -module IdDefinedTwice = { - // ^hov - let _x = 10 - let y = 20 - let _x = 10 -} - -module A = { - let x = 13 -} - -module B = A -// ^hov - -module C = B -// ^hov - -module Comp = { - @react.component - let make = (~children: React.element) => children -} - -module Comp1 = Comp - -let _ = - -
-
- -// ^hov - -let _ = - -
-
- -// ^hov - -type r<'a> = {i: 'a, f: float} - -let _get = r => r.f +. r.i -// ^hov - -let withAs = (~xx as yyy) => yyy + 1 -// ^hov - -module AA = { - type cond<'a> = [< #str(string)] as 'a - let fnnxx = (b: cond<_>) => true ? b : b -} - -let funAlias = AA.fnnxx - -let typeOk = funAlias -// ^hov - -let typeDuplicate = AA.fnnxx -// ^hov - -@live let dd = 34 -// ^hov - -let arity0a = (. ()) => { - //^hov - let f = () => 3 - f -} - -let arity0b = (. ()) => (. ()) => 3 -// ^hov - -let arity0c = (. (), ()) => 3 -// ^hov - -let arity0d = (. ()) => { - // ^hov - let f = () => 3 - f -} - -/**doc comment 1*/ -let docComment1 = 12 -// ^hov - -/** doc comment 2 */ -let docComment2 = 12 -// ^hov - -module ModWithDocComment = { - /*** module level doc comment 1 */ - - /** doc comment for x */ - let x = 44 - - /*** module level doc comment 2 */ -} - -module TypeSubstitutionRecords = { - type foo<'a> = {content: 'a, zzz: string} - type bar = {age: int} - type foobar = foo - - let x1: foo = {content: {age: 42}, zzz: ""} - // ^hov - let x2: foobar = {content: {age: 42}, zzz: ""} - // ^hov - - // x1.content. - // ^com - - // x2.content. - // ^com - - type foo2<'b> = foo<'b> - type foobar2 = foo2 - - let y1: foo2 = {content: {age: 42}, zzz: ""} - let y2: foobar2 = {content: {age: 42}, zzz: ""} - - // y1.content. - // ^com - - // y2.content. - // ^com -} - -module CompV4 = { - type props<'n, 's> = {n?: 'n, s: 's} - let make = props => { - let _ = props.n == Some(10) - React.string(props.s) - } -} - -let mk = CompV4.make -// ^hov - -type useR = {x: int, y: list>>} - -let testUseR = (v: useR) => v -// ^hov - -let usr: useR = { - x: 123, - y: list{}, -} - -// let f = usr -// ^hov - -module NotShadowed = { - /** Stuff */ - let xx_ = 10 - - /** More Stuff */ - let xx = xx_ -} - -module Shadowed = { - /** Stuff */ - let xx = 10 - - /** More Stuff */ - let xx = xx -} - -let _ = NotShadowed.xx -// ^hov - -let _ = Shadowed.xx -// ^hov - -type recordWithDocstringField = { - /** Mighty fine field here. */ - someField: bool, -} - -let x: recordWithDocstringField = { - someField: true, -} - -// x.someField -// ^hov - -let someField = x.someField -// ^hov - -type variant = | /** Cool variant! */ CoolVariant | /** Other cool variant */ OtherCoolVariant - -let coolVariant = CoolVariant -// ^hov - -// Hover on unsaved -// let fff = "hello"; fff -// ^hov - -// switch x { | {someField} => someField } -// ^hov - -module Arr = Belt.Array -// ^hov - -type aliased = variant -// ^hov Hover src/Hover.res 0:4 {"contents": {"kind": "markdown", "value": "```rescript\nint\n```"}} diff --git a/analysis/tests/src/expected/InlayHint.res.txt b/analysis/tests/src/expected/InlayHint.res.txt index 9ef5802c3..db88d23bb 100644 --- a/analysis/tests/src/expected/InlayHint.res.txt +++ b/analysis/tests/src/expected/InlayHint.res.txt @@ -1,38 +1,3 @@ -let not_include = "Not Include" -let string = "ReScript" -let number = 1 -let float = 1.1 -let char = 'c' - -let add = (x, y) => x + y - -let my_sum = 3->add(1)->add(1)->add(1)->add(8) - -let withAs = (~xx as yyy) => yyy + 1 - -@react.component -let make = (~name) => React.string(name) - -let tuple = ("ReScript", "lol") - -let (lang, _) = tuple - -type foo = { - name: string, - age: int, -} - -let bar = () => ({name: "ReScript", age: 2}, tuple) -let ({name: _, age: _}, t) = bar() - -let alice = { - name: "Alice", - age: 42, -} - -let {name, age} = alice - -//^hin Inlay Hint src/InlayHint.res 1:34 [{ "position": {"line": 33, "character": 14}, diff --git a/analysis/tests/src/expected/Jsx2.res.txt b/analysis/tests/src/expected/Jsx2.res.txt index a8d18a3fd..d566a3bdd 100644 --- a/analysis/tests/src/expected/Jsx2.res.txt +++ b/analysis/tests/src/expected/Jsx2.res.txt @@ -1,186 +1,3 @@ -module M = { - @react.component - let make = (~first, ~fun="", ~second="") => React.string(first ++ fun ++ second) -} - -let _ = -// ^def - -// React.string(first) - -let y = 44 - -// k -// ^com - -// -// ^def - -module Ext = { - @react.component @module("@material-ui/core") - external make: (~align: string=?) => React.element = "Typography" -} - -let _ = Ext.make - -// -// ^com - -module WithChildren = { - @react.component - let make = (~name as _: string, ~children) => children -} - -let _ = - -
- -// x.DefineSomeFields.thisField + DefineSomeFields.thisValue - -module Outer = { - module Inner = { - let hello = 3 - } -} -let _ = Outer.Inner.hello - -let _ = -
- -let _ = -
- -let _ = -
- -module Nested = { - module Comp = { - @react.component - let make = (~name) => React.string(name) - } -} - -let _ = - -// let _ = -// ^com - -// let _ = -// ^com - -module Comp = { - @react.component - let make = (~age) => React.int(age) -} - -let _ = { - <> - - - // ^hov -} - -let _ = { - <> - {<> - - } - - // ^hov -} - -module type ExtT = module type of Ext - -let _ = module(Ext: ExtT) Definition src/Jsx2.res 5:9 getLocItem #4: heuristic for within fragments: take make as makeProps does not work the type is not great but jump to definition works diff --git a/analysis/tests/src/expected/Jsx2.resi.txt b/analysis/tests/src/expected/Jsx2.resi.txt index dd568ee3d..5c2c276de 100644 --- a/analysis/tests/src/expected/Jsx2.resi.txt +++ b/analysis/tests/src/expected/Jsx2.resi.txt @@ -1,15 +1,3 @@ -@react.component -let make: (~first: string) => React.element -// ^hov - -let y: int -// ^hov - -// type t = React.e -// ^com - -// let x : React.e -// ^com Hover src/Jsx2.resi 1:4 getLocItem #1: heuristic for makeProps in interface files n1:componentLike n2:unit n3:string diff --git a/analysis/tests/src/expected/JsxV4.res.txt b/analysis/tests/src/expected/JsxV4.res.txt index 1eb3211c1..339562bda 100644 --- a/analysis/tests/src/expected/JsxV4.res.txt +++ b/analysis/tests/src/expected/JsxV4.res.txt @@ -1,61 +1,3 @@ -@@jsxConfig({version: 4}) - -module M4 = { - type props<'first, 'fun, 'second> = {first: 'first, fun?: 'fun, second?: 'second} - - /** Doc Comment For M4 */ - let make = ({first, fun: ?__fun, second: ?__second, _}: props<_, _, _>) => { - let fun = switch __fun { - | Some(fun) => fun - | None => "" - } - let second = switch __second { - | Some(second) => second - | None => "" - } - - React.string(first ++ fun ++ second) - } - /** Doc Comment For M4 */ - let make = { - let \"JsxV4$M4" = (props: props<_>) => make(props) - - \"JsxV4$M4" - } -} - -let _ = React.jsx(M4.make, {first: "abc"}) -// ^def - -// React.null - let make = { - let \"JsxV4$MM" = props => make(props) - - \"JsxV4$MM" - } -} - -module Other = { - type props<'name> = {name: 'name} - - let make = ({name, _}: props<_>) => React.string(name) - let make = { - let \"JsxV4$Other" = (props: props<_>) => make(props) - - \"JsxV4$Other" - } -} - -// ^int Definition src/JsxV4.res 8:9 {"uri": "JsxV4.res", "range": {"start": {"line": 5, "character": 6}, "end": {"line": 5, "character": 10}}} diff --git a/analysis/tests/src/expected/LongIdentTest.res.txt b/analysis/tests/src/expected/LongIdentTest.res.txt index 4e26d9203..1c12fccf8 100644 --- a/analysis/tests/src/expected/LongIdentTest.res.txt +++ b/analysis/tests/src/expected/LongIdentTest.res.txt @@ -1,10 +1,3 @@ -module Map = TableclothMap - -let zz = Map.add -// ^hov -// Triggers the processing of `Of(M)._t` and Lident.Apply ends up in the AST -// even though it's not expressible in ReScript syntax. -// This simulates ReScript projects with OCaml dependencies containing ident apply. Hover src/LongIdentTest.res 2:13 {"contents": {"kind": "markdown", "value": "```rescript\nint\n```"}} diff --git a/analysis/tests/src/expected/ModuleStuff.res.txt b/analysis/tests/src/expected/ModuleStuff.res.txt index 13210ac76..e69de29bb 100644 --- a/analysis/tests/src/expected/ModuleStuff.res.txt +++ b/analysis/tests/src/expected/ModuleStuff.res.txt @@ -1,5 +0,0 @@ -/*** This is a top level module doc. */ - -module Nested = { - /*** Module doc for nested. */ -} diff --git a/analysis/tests/src/expected/Objects.res.txt b/analysis/tests/src/expected/Objects.res.txt index 3b32ca8b9..e69de29bb 100644 --- a/analysis/tests/src/expected/Objects.res.txt +++ b/analysis/tests/src/expected/Objects.res.txt @@ -1,11 +0,0 @@ -type objT = {"name": string, "age": int} - -type nestedObjT = {"y": objT} - -module Rec = { - type recordt = {xx: int, ss: string} - - let recordVal: recordt = assert(false) -} - -let object: objT = {"name": "abc", "age": 4} diff --git a/analysis/tests/src/expected/Patterns.res.txt b/analysis/tests/src/expected/Patterns.res.txt index 119e20c11..5c119ffb7 100644 --- a/analysis/tests/src/expected/Patterns.res.txt +++ b/analysis/tests/src/expected/Patterns.res.txt @@ -1,24 +1,15 @@ +Definition src/Patterns.res 20:10 +{"uri": "Patterns.res", "range": {"start": {"line": 3, "character": 7}, "end": {"line": 3, "character": 10}}} - Syntax error! - src/Patterns.res:18:11-16 +Definition src/Patterns.res 25:11 +{"uri": "Patterns.res", "range": {"start": {"line": 9, "character": 7}, "end": {"line": 9, "character": 11}}} - 16 │ let A([v1, _, _]) | _ as v1 = assert false - 17 │ - 18 │ let lazy lazyy = lazy 3 - 19 │ } - 20 │ +Definition src/Patterns.res 28:11 +{"uri": "Patterns.res", "range": {"start": {"line": 11, "character": 7}, "end": {"line": 11, "character": 8}}} - Did you forget a `=` here? +Definition src/Patterns.res 31:11 +{"uri": "Patterns.res", "range": {"start": {"line": 15, "character": 9}, "end": {"line": 15, "character": 11}}} - - Syntax error! - src/Patterns.res:18:24-25 - - 16 │ let A([v1, _, _]) | _ as v1 = assert false - 17 │ - 18 │ let lazy lazyy = lazy 3 - 19 │ } - 20 │ - - consecutive statements on a line must be separated by ';' or a newline +Definition src/Patterns.res 34:11 +{"uri": "Patterns.res", "range": {"start": {"line": 17, "character": 11}, "end": {"line": 17, "character": 16}}} diff --git a/analysis/tests/src/expected/PolyRec.res.txt b/analysis/tests/src/expected/PolyRec.res.txt index 46d8a9c7d..64c790174 100644 --- a/analysis/tests/src/expected/PolyRec.res.txt +++ b/analysis/tests/src/expected/PolyRec.res.txt @@ -1,17 +1,3 @@ -let rec sum = x => - switch x { - | #Leaf => 0 - | #Node(value, left, right) => value + left->sum + right->sum - } - -let myTree = #Node( - 1, - #Node(2, #Node(4, #Leaf, #Leaf), #Node(6, #Leaf, #Leaf)), - #Node(3, #Node(5, #Leaf, #Leaf), #Node(7, #Leaf, #Leaf)), -) - -let () = myTree->sum->Js.log -// ^hov Hover src/PolyRec.res 12:10 {"contents": {"kind": "markdown", "value": "```rescript\n([#Leaf | #Node(int, 'a, 'a)] as 'a)\n```"}} diff --git a/analysis/tests/src/expected/QueryFile.res.txt b/analysis/tests/src/expected/QueryFile.res.txt index 0ba6f3d1d..e69de29bb 100644 --- a/analysis/tests/src/expected/QueryFile.res.txt +++ b/analysis/tests/src/expected/QueryFile.res.txt @@ -1,6 +0,0 @@ -module Types = { - type byAddress = SchemaAssets.input_ByAddress - type location = SchemaAssets.input_Location - - type variables = {location: location} -} diff --git a/analysis/tests/src/expected/RecModules.res.txt b/analysis/tests/src/expected/RecModules.res.txt index 461860257..62e3e825c 100644 --- a/analysis/tests/src/expected/RecModules.res.txt +++ b/analysis/tests/src/expected/RecModules.res.txt @@ -1,25 +1,3 @@ -module rec A: { - type t - - @send external child: t => B.t = "child" -} = A - -and B: { - type t - - @send external parent: t => A.t = "parent" -} = B - -module C = { - type t - - @send external createA: t => A.t = "createA" -} - -module MC = C -// ^hov -module MA = A -// ^hov Hover src/RecModules.res 18:12 {"contents": {"kind": "markdown", "value": "```rescript\nmodule C: {\n type t\n let createA: t => A.t\n}\n```"}} diff --git a/analysis/tests/src/expected/RecordCompletion.res.txt b/analysis/tests/src/expected/RecordCompletion.res.txt index 05ef9e25b..90787363b 100644 --- a/analysis/tests/src/expected/RecordCompletion.res.txt +++ b/analysis/tests/src/expected/RecordCompletion.res.txt @@ -1,27 +1,3 @@ -type t = {n: array} - -let t = {n: []} - -type t2 = {n2: t} - -let t2 = {n2: t} - -// t.n->m -// ^com - -// t2.n2.n->m -// ^com - -module R = { - type t = {name: string} -} - -let n = {R.name: ""} -// n.R. -// ^com - -// n.R. xx -// ^com Complete src/RecordCompletion.res 8:9 posCursor:[8:9] posNoWhite:[8:8] Found expr:[8:3->8:9] Completable: Cpath Value[t].n->m diff --git a/analysis/tests/src/expected/RecoveryOnProp.res.txt b/analysis/tests/src/expected/RecoveryOnProp.res.txt index 1c16f7f77..59b9e8f8e 100644 --- a/analysis/tests/src/expected/RecoveryOnProp.res.txt +++ b/analysis/tests/src/expected/RecoveryOnProp.res.txt @@ -1,15 +1,3 @@ -let name = "" - -let _ = -
{ - () - // let _: Res - // ^com - }} - name="abc"> - {React.string(name)} -
Complete src/RecoveryOnProp.res 6:26 posCursor:[6:26] posNoWhite:[6:25] Found expr:[3:3->11:8] JSX 3:6] onClick[4:4->4:11]=...[4:13->0:-1]> _children:None diff --git a/analysis/tests/src/expected/References.res.txt b/analysis/tests/src/expected/References.res.txt index ef209d2a9..ea3108dae 100644 --- a/analysis/tests/src/expected/References.res.txt +++ b/analysis/tests/src/expected/References.res.txt @@ -1,28 +1,3 @@ -let x = 12 -// ^ref - -let a = x - -let b = a - -let c = x - -let foo = (~xx) => xx + 1 -// ^ref - -module M: { - let aa: int -} = { - let aa = 10 -} - -let bb = M.aa -let cc = bb -let dd = M.aa -// ^ref - -let _ = -// ^ref References src/References.res 0:4 [ {"uri": "Cross.res", "range": {"start": {"line": 0, "character": 26}, "end": {"line": 0, "character": 27}}}, diff --git a/analysis/tests/src/expected/ReferencesWithInterface.res.txt b/analysis/tests/src/expected/ReferencesWithInterface.res.txt index 2b8f27d3b..33f2d105d 100644 --- a/analysis/tests/src/expected/ReferencesWithInterface.res.txt +++ b/analysis/tests/src/expected/ReferencesWithInterface.res.txt @@ -1,5 +1,3 @@ -let x = 2 -// ^ref References src/ReferencesWithInterface.res 0:4 [ {"uri": "Cross.res", "range": {"start": {"line": 9, "character": 52}, "end": {"line": 9, "character": 53}}}, diff --git a/analysis/tests/src/expected/ReferencesWithInterface.resi.txt b/analysis/tests/src/expected/ReferencesWithInterface.resi.txt index fc7516ec3..3e96fbc75 100644 --- a/analysis/tests/src/expected/ReferencesWithInterface.resi.txt +++ b/analysis/tests/src/expected/ReferencesWithInterface.resi.txt @@ -1,5 +1,3 @@ -let x: int -// ^ref References src/ReferencesWithInterface.resi 0:4 [ {"uri": "Cross.res", "range": {"start": {"line": 9, "character": 52}, "end": {"line": 9, "character": 53}}}, diff --git a/analysis/tests/src/expected/Rename.res.txt b/analysis/tests/src/expected/Rename.res.txt index a1a18d3e0..5cd2adfee 100644 --- a/analysis/tests/src/expected/Rename.res.txt +++ b/analysis/tests/src/expected/Rename.res.txt @@ -1,14 +1,3 @@ -let x = 12 -// ^ren y - -let a = x - -let b = a - -let c = x - -let foo = (~xx) => xx + 1 -// ^ren yy Rename src/Rename.res 0:4 y [ { diff --git a/analysis/tests/src/expected/RenameWithInterface.res.txt b/analysis/tests/src/expected/RenameWithInterface.res.txt index 641e23004..a13988fa9 100644 --- a/analysis/tests/src/expected/RenameWithInterface.res.txt +++ b/analysis/tests/src/expected/RenameWithInterface.res.txt @@ -1,5 +1,3 @@ -let x = 2 -// ^ren y Rename src/RenameWithInterface.res 0:4 y [ { diff --git a/analysis/tests/src/expected/RenameWithInterface.resi.txt b/analysis/tests/src/expected/RenameWithInterface.resi.txt index 696b3c104..2a1dabb44 100644 --- a/analysis/tests/src/expected/RenameWithInterface.resi.txt +++ b/analysis/tests/src/expected/RenameWithInterface.resi.txt @@ -1,5 +1,3 @@ -let x: int -// ^ren y Rename src/RenameWithInterface.resi 0:4 y [ { diff --git a/analysis/tests/src/expected/Reprod.res.txt b/analysis/tests/src/expected/Reprod.res.txt index c053377ca..d0be9994c 100644 --- a/analysis/tests/src/expected/Reprod.res.txt +++ b/analysis/tests/src/expected/Reprod.res.txt @@ -1,59 +1,3 @@ -module Query = { - let use = (~variables: QueryFile.Types.variables) => { - ignore(variables) - "" - } -} - -// let x = Query.use(~variables={location: ByAddress()}) -// ^com - -type nestedRecord = {nested: bool} - -type rec someRecord = { - first: int, - second: (bool, option), - optThird: option<[#first | #second(someRecord)]>, - nest: nestedRecord, -} - -type somePolyVariant = [#one | #two(bool) | #three(someRecord, bool)] - -type someVariant = One | Two(bool) | Three(someRecord, bool) - -type paramRecord<'a, 'b> = { - first: 'a, - second: 'b, -} - -let record: paramRecord = { - first: One, - second: {city: "city"}, -} - -// switch record { | {first: }} -// ^com - -// switch record { | {second: }} -// ^com - -// TODO: Functions, aliases/definitions, records, variants, polyvariants, tuples - -let res: result = Ok(One) - -// switch res { | Ok() } -// ^com - -// switch res { | Error() } -// ^com - -let resOpt: result, unit> = Ok(None) - -// switch resOpt { | Ok() } -// ^com - -// switch resOpt { | Ok(Some()) } -// ^com Complete src/Reprod.res 7:53 posCursor:[7:53] posNoWhite:[7:52] Found expr:[7:11->7:56] Pexp_apply ...[7:11->7:20] (~variables7:22->7:31=...[7:32->7:55]) diff --git a/analysis/tests/src/expected/SchemaAssets.res.txt b/analysis/tests/src/expected/SchemaAssets.res.txt index b83ff5c0d..e69de29bb 100644 --- a/analysis/tests/src/expected/SchemaAssets.res.txt +++ b/analysis/tests/src/expected/SchemaAssets.res.txt @@ -1,6 +0,0 @@ -@live -type rec input_ByAddress = {city: string} -@tag("__$inputUnion") -and input_Location = - | @as("byAddress") ByAddress(input_ByAddress) - | @as("byId") ById(string) diff --git a/analysis/tests/src/expected/ShadowedBelt.res.txt b/analysis/tests/src/expected/ShadowedBelt.res.txt index 143c0e915..e69de29bb 100644 --- a/analysis/tests/src/expected/ShadowedBelt.res.txt +++ b/analysis/tests/src/expected/ShadowedBelt.res.txt @@ -1,3 +0,0 @@ -module List = { - let map = (l, fn) => List.map(fn, l) -} diff --git a/analysis/tests/src/expected/SignatureHelp.res.txt b/analysis/tests/src/expected/SignatureHelp.res.txt index 29f6b3a8f..580401264 100644 --- a/analysis/tests/src/expected/SignatureHelp.res.txt +++ b/analysis/tests/src/expected/SignatureHelp.res.txt @@ -1,166 +1,3 @@ -type someVariant = One | Two | Three - -/** Does stuff. */ -let someFunc = (one: int, ~two: option=?, ~three: unit => unit, ~four: someVariant, ()) => { - ignore(one) - ignore(two) - ignore(three()) - ignore(four) -} - -let otherFunc = (first: string, second: int, third: float) => { - ignore(first) - ignore(second) - ignore(third) -} - -// let _ = someFunc( -// ^she - -// let _ = someFunc(1 -// ^she - -// let _ = someFunc(123, ~two -// ^she - -// let _ = someFunc(123, ~two="123" -// ^she - -// let _ = someFunc(123, ~two="123", ~four -// ^she - -// let _ = someFunc(123, ~two="123", ~four=O -// ^she - -// let _ = otherFunc( -// ^she - -// let _ = otherFunc("123" -// ^she - -// let _ = otherFunc("123", 123, 123.0) -// ^she - -// let _ = Completion.Lib.foo(~age -// ^she - -let iAmSoSpecial = (iJustHaveOneArg: string) => { - ignore(iJustHaveOneArg) -} - -// let _ = iAmSoSpecial( -// ^she - -// let _ = "hello"->otherFunc(1 -// ^she - -let fn = (age: int, name: string, year: int) => { - ignore(age) - ignore(name) - ignore(year) -} - -// let _ = fn(22, ) -// ^she - -// let _ = fn(22, , 2023) -// ^she - -// let _ = fn(12, "hello", ) -// ^she - -// let _ = fn({ iAmSoSpecial() }) -// ^she - -// let _ = fn({ iAmSoSpecial({ someFunc() }) }) -// ^she - -/** This is my own special thing. */ -type mySpecialThing = string - -type t = - | /** One is cool. */ One({miss?: bool, hit?: bool, stuff?: string}) - | /** Two is fun! */ Two(mySpecialThing) - | /** Three is... three */ Three(mySpecialThing, array>) - -let _one = One({}) -// ^she - -let _one = One({miss: true}) -// ^she - -let _one = One({hit: true, miss: true}) -// ^she - -let two = Two("true") -// ^she - -let three = Three("", []) -// ^she - -let three2 = Three("", []) -// ^she - -let _deepestTakesPrecedence = [12]->Js.Array2.map(v => - if v > 0 { - One({}) - // ^she - } else { - Two("") - } -) - -/** Main docstring here. */ -let map = (arr, mapper) => { - Array.map(mapper, arr) -} - -let _usesCorrectTypeInfo = [12]->map(v => v) -// ^she - -/** Type x... */ -type x = { - age?: int, - name?: string, -} - -/** Type tt! */ -type tt = One - -/** Some stuff */ -let stuffers = (x: x, y: tt) => { - ignore(x) - ignore(y) - "hello" -} - -let _ = stuffers({}, One) -// ^she - -let _ = stuffers({}, One) -// ^she - -let _ = switch _one { -| One({hit: _hit}) => "" -// ^she -| One(_a) => "" -// ^she -| Two(_ms) => "" -// ^she -| Three(_a, []) => "" -// ^she -| Three(_, _b) => "" -// ^she -} - -let _bb = Ok(true) -// ^she - -let _bbb = Error("err") -// ^she - -let _cc = Some(true) -// ^she Signature help src/SignatureHelp.res 16:20 posCursor:[16:19] posNoWhite:[16:18] Found expr:[16:11->16:20] Pexp_apply ...[16:11->16:19] (...[46:0->16:20]) diff --git a/analysis/tests/src/expected/TypeAtPosCompletion.res.txt b/analysis/tests/src/expected/TypeAtPosCompletion.res.txt index 03f0876d1..377ec83f1 100644 --- a/analysis/tests/src/expected/TypeAtPosCompletion.res.txt +++ b/analysis/tests/src/expected/TypeAtPosCompletion.res.txt @@ -1,28 +1,3 @@ -type optRecord = { - name: string, - age?: int, - online?: bool, -} - -let optRecord = { - name: "Hello", - // ^com -} - -type someVariant = One(int, optRecord) - -let x = One( - 1, - { - name: "What", - // ^com - }, -) - -let arr = [ - optRecord, - // ^com -] Complete src/TypeAtPosCompletion.res 7:17 posCursor:[7:17] posNoWhite:[7:15] Found expr:[6:16->9:1] Completable: Cexpression CTypeAtPos()->recordBody diff --git a/analysis/tests/src/expected/TypeDefinition.res.txt b/analysis/tests/src/expected/TypeDefinition.res.txt index fb164890b..46a968e8f 100644 --- a/analysis/tests/src/expected/TypeDefinition.res.txt +++ b/analysis/tests/src/expected/TypeDefinition.res.txt @@ -1,28 +1,3 @@ -type variant = Foo | Bar - -type record = {item: string} -// ^typ - -let x = Foo -// ^typ - -let y = {item: "foo"} -// ^typ - -type obj = {"foo": string} - -let obj: obj = {"foo": "bar"} -// ^typ - -let f = r => r.item -// ^typ - -let g = v => - switch v { - // ^typ - | Foo => "Foo" - | Bar => "Bar" - } TypeDefinition src/TypeDefinition.res 2:9 {"uri": "TypeDefinition.res", "range": {"start": {"line": 2, "character": 5}, "end": {"line": 2, "character": 11}}} diff --git a/analysis/tests/src/expected/Xform.res.txt b/analysis/tests/src/expected/Xform.res.txt index 98737c1dc..2b38ddf41 100644 --- a/analysis/tests/src/expected/Xform.res.txt +++ b/analysis/tests/src/expected/Xform.res.txt @@ -1,148 +1,3 @@ -type kind = First | Second | Third | Fourth(int) -type r = {name: string, age: int} - -let ret = _ => assert(false) -let kind = assert(false) - -if kind == First { - // ^xfm - ret("First") -} else { - ret("Not First") -} - -#kind("First", {name: "abc", age: 3}) != kind ? ret("Not First") : ret("First") -// ^xfm - -let name = "hello" -// ^xfm - -let annotated: int = 34 -// ^xfm - -module T = { - type r = {a: int, x: string} -} - -let foo = x => - // ^xfm - switch x { - | None => 33 - | Some(q) => q.T.a + 1 - // ^xfm - } - -let withAs = (~x as name) => name + 1 -// ^xfm - -@react.component -let make = (~name) => React.string(name) -// ^xfm - -let _ = (~x) => x + 1 -// ^xfm - -// -// Add braces to the body of a function -// - -let noBraces = () => name -// ^xfm - -let nested = () => { - let _noBraces = (_x, _y, _z) => "someNewFunc" - // ^xfm -} - -let bar = () => { - module Inner = { - let foo = (_x, y, _z) => - switch y { - | #some => 3 - | #stuff => 4 - } - //^xfm - } - Inner.foo(1, ...) -} - -module ExtractableModule = { - /** Doc comment. */ - type t = int - // A comment here - let doStuff = a => a + 1 - // ^xfm -} - -let variant = First - -let _x = switch variant { -| First => "first" -| _ => "other" -// ^xfm -} - -let _x = switch variant { -| First | Second => "first" -| _ => "other" -// ^xfm -} - -let _x = switch variant { -| First if 1 > 2 => "first" -| Second => "second" -| _ => "other" -// ^xfm -} - -let polyvariant: [#first | #second | #"illegal identifier" | #third(int)] = #first - -let _y = switch polyvariant { -| #first => "first" -| _ => "other" -// ^xfm -} - -let _y = switch polyvariant { -| #first | #second => "first" -| _ => "other" -// ^xfm -} - -let variantOpt = Some(variant) - -let _x = switch variantOpt { -| Some(First) => "first" -| _ => "other" -// ^xfm -} - -let _x = switch variantOpt { -| Some(First) | Some(Second) => "first" -| _ => "other" -// ^xfm -} - -let _x = switch variantOpt { -| Some(First | Second) => "first" -| _ => "other" -// ^xfm -} - -let polyvariantOpt = Some(polyvariant) - -let _x = switch polyvariantOpt { -| Some(#first) => "first" -| None => "nothing" -| _ => "other" -// ^xfm -} - -let _x = switch polyvariantOpt { -| Some(#first | #second) => "first" -| _ => "other" -// ^xfm -} Xform src/Xform.res 6:5 posCursor:[6:3] posNoWhite:[6:1] Found expr:[6:0->11:1] Completable: Cpath Value[kind] diff --git a/analysis/vendor/res_syntax/res_cli.ml b/analysis/vendor/res_syntax/res_cli.ml index d5fca5d13..d4436e911 100644 --- a/analysis/vendor/res_syntax/res_cli.ml +++ b/analysis/vendor/res_syntax/res_cli.ml @@ -308,7 +308,7 @@ module CliArgProcessor = struct [@@raises exit] end -let () = +(*let () = if not !Sys.interactive then ( ResClflags.parse (); CliArgProcessor.process_file ~is_interface:!ResClflags.interface @@ -317,4 +317,4 @@ let () = ~jsx_version:!ResClflags.jsx_version ~jsx_module:!ResClflags.jsx_module ~jsx_mode:!ResClflags.jsx_mode ~typechecker:!ResClflags.typechecker !ResClflags.file) -[@@raises exit] +[@@raises exit]*) From f0a983a5deb2aa89884cfced74a57112096301e1 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Thu, 30 May 2024 20:45:08 +0200 Subject: [PATCH 3/3] changelog --- CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 22fabea6d..bd0182db5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -40,6 +40,10 @@ - Add code action for expanding catch-all patterns. https://github.com/rescript-lang/rescript-vscode/pull/987 - Add code actions for removing unused code (per item and for an entire file), driven by `reanalyze`. https://github.com/rescript-lang/rescript-vscode/pull/989 +#### :house: Internal + +- Update parser and compiler support files to the latest version. https://github.com/rescript-lang/rescript-vscode/pull/998 + ## 1.50.0 #### :rocket: New Feature