From c998144eeeedb6eb8035d11f7af2e522a77892a9 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Sun, 11 Aug 2024 16:54:43 -0700 Subject: [PATCH] chore: format the codebase with ocamlformat (#2789) --- .ocamlformat | 27 + .ocamlformat-ignore | 6 + nix/shell.nix | 4 +- rtop/reason_util.ml | 25 +- rtop/reason_utop.ml | 96 +- rtop/rtop.ml | 39 +- src/menhir-recover/attributes.ml | 253 +- src/menhir-recover/emitter.ml | 308 +- src/menhir-recover/emitter.mli | 3 +- src/menhir-recover/main.ml | 65 +- src/menhir-recover/recovery_custom.ml | 307 +- src/menhir-recover/recovery_intf.ml | 34 +- src/menhir-recover/synthesis.ml | 283 +- src/menhir-recover/utils.ml | 42 +- src/reason-parser/menhir_error_processor.ml | 61 +- src/reason-parser/merlin_recovery.ml | 140 +- src/reason-parser/merlin_recovery.mli | 45 +- src/reason-parser/reason_attributes.ml | 120 +- src/reason-parser/reason_comment.ml | 50 +- src/reason-parser/reason_config.ml | 14 +- src/reason-parser/reason_errors.ml | 179 +- src/reason-parser/reason_errors.mli | 36 +- src/reason-parser/reason_heuristics.ml | 122 +- src/reason-parser/reason_layout.ml | 332 +- src/reason-parser/reason_lexer.ml | 206 +- src/reason-parser/reason_lexer.mli | 12 +- src/reason-parser/reason_location.ml | 87 +- src/reason-parser/reason_multi_parser.ml | 60 +- src/reason-parser/reason_multi_parser.mli | 15 +- src/reason-parser/reason_oprint.ml | 1428 +- src/reason-parser/reason_parser_def.mli | 12 +- src/reason-parser/reason_parser_explain.ml | 158 +- src/reason-parser/reason_pprint_ast.ml | 17442 +++++++++-------- src/reason-parser/reason_pprint_ast.mli | 33 +- src/reason-parser/reason_recover_parser.ml | 64 +- src/reason-parser/reason_recover_parser.mli | 5 +- src/reason-parser/reason_single_parser.ml | 272 +- src/reason-parser/reason_single_parser.mli | 15 +- src/reason-parser/reason_toolchain.ml | 266 +- src/reason-parser/reason_toolchain_conf.ml | 72 +- src/reason-parser/reason_toolchain_ocaml.ml | 133 +- src/reason-parser/reason_toolchain_reason.ml | 78 +- src/refmt/eol_convert.ml | 17 +- src/refmt/eol_detect.ml | 30 +- src/refmt/git_commit.mli | 5 +- src/refmt/package.ml | 6 +- src/refmt/printer_maker.ml | 83 +- src/refmt/reason_implementation_printer.ml | 120 +- src/refmt/reason_interface_printer.ml | 99 +- src/refmt/refmt.ml | 137 +- src/refmt/refmt_args.ml | 68 +- src/refmttype/reason_format_type.ml | 35 +- src/refmttype/reason_type_of_ocaml_type.ml | 54 +- 53 files changed, 12750 insertions(+), 10853 deletions(-) create mode 100644 .ocamlformat create mode 100644 .ocamlformat-ignore diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 000000000..893c04f50 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,27 @@ +break-infix = fit-or-vertical +break-infix-before-func = false +break-fun-decl = fit-or-vertical +break-separators = before +break-sequences = true +cases-exp-indent = 2 +dock-collection-brackets = false +field-space = loose +if-then-else = keyword-first +indicate-multiline-delimiters = no +infix-precedence = parens +leading-nested-match-parens = true +let-and = sparse +let-module = sparse +ocp-indent-compat = true +parens-tuple = multi-line-only +parse-docstrings = true +sequence-blank-line = preserve-one +sequence-style = terminator +single-case = sparse +space-around-arrays= true +space-around-lists= true +space-around-records= true +space-around-variants= true +type-decl = sparse +wrap-comments = true +wrap-fun-args = false diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore new file mode 100644 index 000000000..01c3eb3de --- /dev/null +++ b/.ocamlformat-ignore @@ -0,0 +1,6 @@ +src/vendored-omp/** +src/reason-parser/vendor/** +test/**.cppo.ml +src/**.cppo.ml +src/**.cppo.mli +rtop/**.cppo.ml diff --git a/nix/shell.nix b/nix/shell.nix index 1a45ecba7..0d824cbb8 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -11,7 +11,7 @@ mkShell { inputsFrom = [ reason ]; + nativeBuildInputs = with ocamlPackages; [ utop merlin odoc ocamlformat ]; buildInputs = - with ocamlPackages; [ utop merlin odoc ] - ++ (if release-mode then [ cacert curl dune-release git ] else [ ]); + with ocamlPackages; (if release-mode then [ cacert curl dune-release git ] else [ ]); } diff --git a/rtop/reason_util.ml b/rtop/reason_util.ml index 056fa1464..a9ae97459 100644 --- a/rtop/reason_util.ml +++ b/rtop/reason_util.ml @@ -17,7 +17,8 @@ let extract_exn src name = try ignore (!Toploop.parse_toplevel_phrase (Lexing.from_string src)); assert false - with exn -> + with + | exn -> assert (Printexc.exn_slot_name exn = name); exn @@ -25,17 +26,13 @@ let exn_Lexer_Error = extract_exn "\128" "Lexer.Error" let exn_Syntaxerr_Error = extract_exn "fun" "Syntaxerr.Error" let correctly_catch_parse_errors fn lexbuf = - (*let kind = if !Toploop.input_name = "//toplevel//" then `Toplevel else `Batch in*) + (*let kind = if !Toploop.input_name = "//toplevel//" then `Toplevel else + `Batch in*) fn lexbuf - (*with exn when kind = `Toplevel -> - (* In expunged toplevel, we have a split-brain situation where toplevel - and m17n have different internal IDs for the "same" exceptions. - Fixup. *) - raise - (match exn with - (* FIXME... Maybe? *) - (*| Reason_lexer.Error _ -> transmogrify_exn exn exn_Lexer_Error*) - | Syntaxerr.Error _ -> transmogrify_exn exn exn_Syntaxerr_Error - | Reason_syntax_util.Error (loc, _) -> transmogrify_exn (Syntaxerr.Error(Syntaxerr.Other loc)) exn_Syntaxerr_Error - | _ -> exn) - *) +(*with exn when kind = `Toplevel -> (* In expunged toplevel, we have a + split-brain situation where toplevel and m17n have different internal IDs for + the "same" exceptions. Fixup. *) raise (match exn with (* FIXME... Maybe? *) + (*| Reason_lexer.Error _ -> transmogrify_exn exn exn_Lexer_Error*) | + Syntaxerr.Error _ -> transmogrify_exn exn exn_Syntaxerr_Error | + Reason_syntax_util.Error (loc, _) -> transmogrify_exn + (Syntaxerr.Error(Syntaxerr.Other loc)) exn_Syntaxerr_Error | _ -> exn) *) diff --git a/rtop/reason_utop.ml b/rtop/reason_utop.ml index 6ae55c6b1..f3fc02fd1 100644 --- a/rtop/reason_utop.ml +++ b/rtop/reason_utop.ml @@ -1,6 +1,4 @@ -(** - * Some of this was coppied from @whitequark's m17n project. - *) +(** * Some of this was coppied from \@whitequark's m17n project. *) (* * Portions Copyright (c) 2015-present, Facebook, Inc. * @@ -17,7 +15,9 @@ module ToploopBackup = struct let print_out_sig_item = !Toploop.print_out_sig_item let print_out_signature = !Toploop.print_out_signature let print_out_phrase = !Toploop.print_out_phrase - let[@ocaml.warning "-3"] current_show = Hashtbl.find Toploop.directive_table "show" + + let[@ocaml.warning "-3"] current_show = + Hashtbl.find Toploop.directive_table "show" end let rec lident_operator_map mapper li = @@ -25,32 +25,38 @@ let rec lident_operator_map mapper li = match li with | Lident s -> Lident (mapper s) | Ldot (x, s) -> Ldot (x, mapper s) - | Lapply (x, y) -> Lapply (lident_operator_map mapper x, lident_operator_map mapper y) + | Lapply (x, y) -> + Lapply (lident_operator_map mapper x, lident_operator_map mapper y) + +type top_kind = + | RTop + | UTop -type top_kind = RTop | UTop let current_top = ref RTop let init_reason () = - if List.exists ((=) "camlp4o") !Topfind.predicates || - List.exists ((=) "camlp4r") !Topfind.predicates then - print_endline "Reason is incompatible with camlp4!" - else begin + if List.exists (( = ) "camlp4o") !Topfind.predicates + || List.exists (( = ) "camlp4r") !Topfind.predicates + then print_endline "Reason is incompatible with camlp4!" + else let use_file x = - List.map Reason_toolchain.To_current.copy_toplevel_phrase + List.map + Reason_toolchain.To_current.copy_toplevel_phrase (Reason_toolchain.RE.use_file x) in current_top := RTop; UTop.set_phrase_terminator ";"; - UTop.prompt := fst (React.S.create LTerm_text. - (eval [B_fg (LTerm_style.green); S "Reason # "])); - UTop.parse_toplevel_phrase := UTop.parse_default ( - Reason_util.correctly_catch_parse_errors - (fun x -> Reason_toolchain.To_current.copy_toplevel_phrase - (Reason_toolchain.RE.toplevel_phrase x)) - ); - UTop.parse_use_file := UTop.parse_default ( - Reason_util.correctly_catch_parse_errors use_file - ); + UTop.prompt := + fst + (React.S.create + LTerm_text.(eval [ B_fg LTerm_style.green; S "Reason # " ])); + UTop.parse_toplevel_phrase := + UTop.parse_default + (Reason_util.correctly_catch_parse_errors (fun x -> + Reason_toolchain.To_current.copy_toplevel_phrase + (Reason_toolchain.RE.toplevel_phrase x))); + UTop.parse_use_file := + UTop.parse_default (Reason_util.correctly_catch_parse_errors use_file); UTop.history_file_name := Some (Filename.concat LTerm_resources.home ".rtop-history"); @@ -59,10 +65,8 @@ let init_reason () = (* Printing in Reason syntax *) let open Reason_toolchain.From_current in let wrap f g fmt x = g fmt (f x) in - Toploop.print_out_value := - wrap copy_out_value Reason_oprint.print_out_value; - Toploop.print_out_type := - wrap copy_out_type Reason_oprint.print_out_type; + Toploop.print_out_value := wrap copy_out_value Reason_oprint.print_out_value; + Toploop.print_out_type := wrap copy_out_type Reason_oprint.print_out_type; Toploop.print_out_class_type := wrap copy_out_class_type Reason_oprint.print_out_class_type; Toploop.print_out_module_type := @@ -75,25 +79,32 @@ let init_reason () = wrap (List.map copy_out_sig_item) Reason_oprint.print_out_signature; Toploop.print_out_phrase := wrap copy_out_phrase Reason_oprint.print_out_phrase; - let current_show_fn = match ToploopBackup.current_show with - | Toploop.Directive_ident fn -> fn - | _ -> assert false + let current_show_fn = + match ToploopBackup.current_show with + | Toploop.Directive_ident fn -> fn + | _ -> assert false in - Hashtbl.replace (Toploop.directive_table [@ocaml.warning "-3"]) "show" - (Toploop.Directive_ident (fun li -> - let li' = lident_operator_map Reason_syntax_util.reason_to_ml_swap li in - current_show_fn li')); - end + Hashtbl.replace + (Toploop.directive_table [@ocaml.warning "-3"]) + "show" + (Toploop.Directive_ident + (fun li -> + let li' = + lident_operator_map Reason_syntax_util.reason_to_ml_swap li + in + current_show_fn li')) let init_ocaml () = current_top := UTop; UTop.set_phrase_terminator ";;"; - UTop.prompt := fst (React.S.create LTerm_text. - (eval[B_fg (LTerm_style.green); S "OCaml # "])); + UTop.prompt := + fst + (React.S.create + LTerm_text.(eval [ B_fg LTerm_style.green; S "OCaml # " ])); UTop.parse_toplevel_phrase := UTop.parse_toplevel_phrase_default; UTop.parse_use_file := UTop.parse_use_file_default; UTop.history_file_name := - Some (Filename.concat LTerm_resources.home ".utop-history"); + Some (Filename.concat LTerm_resources.home ".utop-history"); Toploop.print_out_value := ToploopBackup.print_out_value; Toploop.print_out_type := ToploopBackup.print_out_type; @@ -103,14 +114,17 @@ let init_ocaml () = Toploop.print_out_sig_item := ToploopBackup.print_out_sig_item; Toploop.print_out_signature := ToploopBackup.print_out_signature; Toploop.print_out_phrase := ToploopBackup.print_out_phrase; - Hashtbl.replace (Toploop.directive_table [@ocaml.warning "-3"]) "show" ToploopBackup.current_show + Hashtbl.replace + (Toploop.directive_table [@ocaml.warning "-3"]) + "show" + ToploopBackup.current_show let toggle_syntax () = - match !current_top with - | RTop -> init_ocaml () - | UTop -> init_reason () + match !current_top with RTop -> init_ocaml () | UTop -> init_reason () let _ = - Hashtbl.add (Toploop.directive_table [@ocaml.warning "-3"]) "toggle_syntax" + Hashtbl.add + (Toploop.directive_table [@ocaml.warning "-3"]) + "toggle_syntax" (Toploop.Directive_none toggle_syntax); init_reason () diff --git a/rtop/rtop.ml b/rtop/rtop.ml index e98c292db..b42e2adad 100644 --- a/rtop/rtop.ml +++ b/rtop/rtop.ml @@ -1,25 +1,24 @@ -let () = UTop.require ["reason.ocaml-migrate-parsetree"; "menhirLib";] +let () = UTop.require [ "reason.ocaml-migrate-parsetree"; "menhirLib" ] -let () = try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") with | Not_found -> ();; - -let () = UTop.require ["reason.easy_format"; "reason";] +let () = + try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") with + | Not_found -> () +let () = UTop.require [ "reason.easy_format"; "reason" ] let () = Reason_toploop.main () - let () = Reason_utop.init_reason () -let () = print_string -" - ___ _______ ________ _ __ - / _ \\/ __/ _ | / __/ __ \\/ |/ / - / , _/ _// __ |_\\ \\/ /_/ / / - /_/|_/___/_/ |_/___/\\____/_/|_/ - - Execute statements/let bindings. Hit after the semicolon. Ctrl-d to quit. - - > let myVar = \"Hello Reason!\"; - > let myList: list(string) = [\"first\", \"second\"]; - > #use \"./src/myFile.re\"; /* loads the file into here */ -" - -let () = UTop_main.main () \ No newline at end of file +let () = + print_string + "\n\ + \ ___ _______ ________ _ __\n\ + \ / _ \\/ __/ _ | / __/ __ \\/ |/ /\n\ + \ / , _/ _// __ |_\\ \\/ /_/ / /\n\ + \ /_/|_/___/_/ |_/___/\\____/_/|_/\n\n\ + \ Execute statements/let bindings. Hit after the semicolon. \ + Ctrl-d to quit.\n\n\ + \ > let myVar = \"Hello Reason!\";\n\ + \ > let myList: list(string) = [\"first\", \"second\"];\n\ + \ > #use \"./src/myFile.re\"; /* loads the file into here */\n" + +let () = UTop_main.main () diff --git a/src/menhir-recover/attributes.ml b/src/menhir-recover/attributes.ml index 6c2c18606..cc2493b89 100644 --- a/src/menhir-recover/attributes.ml +++ b/src/menhir-recover/attributes.ml @@ -8,30 +8,27 @@ open Utils Menhir-recover. The attributes that are relevant to Menhir-recover are always prefixed with - `recover.`. - An attribute with the same prefix and that is not understood by + `recover.`. An attribute with the same prefix and that is not understood by Menhir-recover will produce a warning message (to detect a typo or a - misplaced attribute). -*) + misplaced attribute). *) (** Specification of attributes that are meaningful for recovery *) module type ATTRIBUTES = sig - (** The Menhir grammar to which these apply *) module G : GRAMMAR + (** The Menhir grammar to which these apply *) (** Recovery cost - When the parser is in an error state, Menhir-recover will invent some input - that recovers from this error. In most grammars, this problem has many - solutions, often an infinity. + When the parser is in an error state, Menhir-recover will invent some + input that recovers from this error. In most grammars, this problem has + many solutions, often an infinity. But not all solutions are equally nice. Some will have repetitions, some will generate undesirable AST nodes or trigger error reductions... To guide this process, a cost can be associated to each symbol (terminal - or non-terminal), and the cost of the recovery will be the sum of the - cost of all symbols in the generated sentence. - *) + or non-terminal), and the cost of the recovery will be the sum of the cost + of all symbols in the generated sentence. *) (** Symbol cost @@ -40,52 +37,42 @@ module type ATTRIBUTES = sig %token PLUS [@recover.cost 1.0] - expr [@recover.cost 1.0]: - ... - ; - *) + expr [@recover.cost 1.0]: ... ; *) + val cost_of_symbol : G.symbol -> Cost.t (** Cost of a grammar symbol *) - val cost_of_symbol : G.symbol -> Cost.t (** Item cost - The cost can be applied to a specific item (an occurrence of a symbol in - a rule). + The cost can be applied to a specific item (an occurrence of a symbol in a + rule). - In this case, the more specific cost will replace the global cost for - this specific occurrence. + In this case, the more specific cost will replace the global cost for this + specific occurrence. - expr: - | INT PLUS [@recover.cost 0.0] INT { ... } - | INT TIMES [@recover.cost 10.0] INT { ... } - ; + expr: | INT PLUS [@recover.cost 0.0] INT \{ ... \} | INT TIMES + [@recover.cost 10.0] INT \{ ... \} ; In this example, if an error happens just after an integer in an expression, the `PLUS` rule will be favored over the `TIMES` rule because - the first token is more expensive. - *) + the first token is more expensive. *) - (** Penalty (added cost) for shifting an item *) val penalty_of_item : G.production * int -> Cost.t + (** Penalty (added cost) for shifting an item *) (** Reduction cost - The last place where a `recover.cost` is accepted is in a production. - This is convenient to prevent the recovery to trigger some semantic - actions. + The last place where a `recover.cost` is accepted is in a production. This + is convenient to prevent the recovery to trigger some semantic actions. - expr: - LPAREN expr error { ... } [@recover.cost infinity] - ; + expr: LPAREN expr error \{ ... \} [@recover.cost infinity] ; It would not make much sense for the recovery to select an error rule. Associating an infinite cost to the production ensures that this never - happen. - *) + happen. *) + val cost_of_prod : G.production -> Cost.t (** Cost of reducing a production *) - val cost_of_prod : G.production -> Cost.t (** Meaning of costs @@ -102,8 +89,7 @@ module type ATTRIBUTES = sig used. **TODO**: specify how null values are treated with respect to minimal - cost, can the algorithm diverge? - *) + cost, can the algorithm diverge? *) (** Recovery expressions @@ -113,39 +99,35 @@ module type ATTRIBUTES = sig The `recover.expr` attribute associates an ocaml expression to a symbol. This expression should evaluate to a semantic value for this symbol. - %token IDENT [@recover.expr "invalid-identifier"] + %token IDENT [@recover.expr "invalid-identifier"] When applied to non-terminals, it is particularly useful to produce a value that could not be the result of a normal parse. - expr [@recover.expr Invalid_expression]: - ... - ; + expr [@recover.expr Invalid_expression]: ... ; Here `Invalid_expression` is a node added to the AST for the purpose of identifying parts that were recovered. Furthermore, specifying fallback values for non-terminals prevents Menhir-recover from generating a hardly predictable sequence of tokens - just for filling holes in the AST. - *) + just for filling holes in the AST. *) - (** An optional ocaml expression that should evaluate to a - semantic value valid for this terminal. *) - val default_terminal : G.terminal -> string option + val default_terminal : G.terminal -> string option + (** An optional ocaml expression that should evaluate to a semantic value + valid for this terminal. *) - (** An optional ocaml expression that should evaluate to a - semantic value valid for this non-terminal. *) val default_nonterminal : G.nonterminal -> string option + (** An optional ocaml expression that should evaluate to a semantic value + valid for this non-terminal. *) (** The expressions are evaluated every time a new instance of a symbol is - needed, although it is not specified whether every evaluation will be - kept in the final solution (at run time, the algorithm is free to explore + needed, although it is not specified whether every evaluation will be kept + in the final solution (at run time, the algorithm is free to explore different branches and throw them away as needed). **TODO**: decide how information can be communicated with recovery - expressions (for instance the current location of the parser) - *) + expressions (for instance the current location of the parser) *) (** Recovery prelude @@ -155,145 +137,149 @@ module type ATTRIBUTES = sig code of `recover.expr` expressions. It is useful for defining definitions shared by the recovery expressions, - in the same way as `%{ ... %}` is used to share definitions in semantic - actions of the grammar. - *) + in the same way as `%\{ ... %\}` is used to share definitions in semantic + actions of the grammar. *) + val default_prelude : Format.formatter -> unit (** Output the grammar prelude in this formatter *) - val default_prelude : Format.formatter -> unit -end (* module type ATTRIBUTES *) +end +(* module type ATTRIBUTES *) -module Recover_attributes (G : GRAMMAR) - : ATTRIBUTES with module G = G = -struct +module Recover_attributes (G : GRAMMAR) : ATTRIBUTES with module G = G = struct module G = G open G let string_starts_with str ~prefix = let len = String.length prefix in - (String.length str >= len) && - (try - for i = 0 to len - 1 do - if str.[i] <> prefix.[i] then raise Exit; - done; - true - with Exit -> false) + String.length str >= len + && + try + for i = 0 to len - 1 do + if str.[i] <> prefix.[i] then raise Exit + done; + true + with + | Exit -> false let prefix = "recover." - - let all_attributes = [ - "recover.cost"; - "recover.expr"; - "recover.prelude"; - ] + let all_attributes = [ "recover.cost"; "recover.expr"; "recover.prelude" ] let validate_attribute accepted kind attr = let label = Attribute.label attr in - if string_starts_with ~prefix label && - not (List.mem label accepted) then ( + if string_starts_with ~prefix label && not (List.mem label accepted) + then let split_pos pos = - (pos.Lexing.pos_fname, - pos.Lexing.pos_lnum, - pos.Lexing.pos_cnum - pos.Lexing.pos_bol) + ( pos.Lexing.pos_fname + , pos.Lexing.pos_lnum + , pos.Lexing.pos_cnum - pos.Lexing.pos_bol ) in let range () range = let s = Printf.sprintf in let sf, sl, sc = split_pos (Range.startp range) in let ef, el, ec = split_pos (Range.endp range) in - if sf <> ef then - s "%s:%d.%d-%s:%d.%d" sf sl sc ef el ec - else if sl <> el then - s "%s:%d.%d-%d.%d" sf sl sc el ec - else if sc <> ec then - s "%s:%d.%d-%d" sf sl sc ec - else - s "%s:%d.%d" sf sl sc + if sf <> ef + then s "%s:%d.%d-%s:%d.%d" sf sl sc ef el ec + else if sl <> el + then s "%s:%d.%d-%d.%d" sf sl sc el ec + else if sc <> ec + then s "%s:%d.%d-%d" sf sl sc ec + else s "%s:%d.%d" sf sl sc in let f fmt = Printf.ksprintf prerr_endline fmt in - if List.mem label all_attributes then - f "%a: attribute %S cannot be put in %s" - range (Attribute.position attr) label kind + if List.mem label all_attributes + then + f + "%a: attribute %S cannot be put in %s" + range + (Attribute.position attr) + label + kind else - f "%a: attribute %S is not recognized (found in %s)" - range (Attribute.position attr) label kind - ) + f + "%a: attribute %S is not recognized (found in %s)" + range + (Attribute.position attr) + label + kind let validate_attributes accepted kind attrs = List.iter (validate_attribute accepted kind) attrs let () = validate_attributes - ["recover.prelude"] "grammar attributes" + [ "recover.prelude" ] + "grammar attributes" Grammar.attributes; let symbol prj attrs = validate_attributes - ["recover.cost"; "recover.expr"] "symbol attributes" + [ "recover.cost"; "recover.expr" ] + "symbol attributes" (prj attrs) in Nonterminal.iter (symbol G.Nonterminal.attributes); Terminal.iter (symbol G.Terminal.attributes); Production.iter (fun p -> - validate_attributes - [ "recover.cost"; - (* recover.expr: a lie to prevent warnings on an unfortunate - interaction between menhir inlining and attributes *) - "recover.expr" - ] "production attributes" + validate_attributes + [ "recover.cost" + ; (* recover.expr: a lie to prevent warnings on an unfortunate + interaction between menhir inlining and attributes *) + "recover.expr" + ] + "production attributes" (Production.attributes p); Array.iter - (fun (_,_,attrs) -> - validate_attributes ["recover.cost"] "item attributes" attrs) - (Production.rhs p) - ) + (fun (_, _, attrs) -> + validate_attributes [ "recover.cost" ] "item attributes" attrs) + (Production.rhs p)) let cost_of_attributes prj attrs = - Cost.of_int ( - List.fold_left - (fun total attr -> - if Attribute.has_label "recover.cost" attr then - total + int_of_string (Attribute.payload attr) - else total) - 0 (prj attrs) - ) + Cost.of_int + (List.fold_left + (fun total attr -> + if Attribute.has_label "recover.cost" attr + then total + int_of_string (Attribute.payload attr) + else total) + 0 + (prj attrs)) let cost_of_symbol = let measure ~has_default prj attrs = - if List.exists (Attribute.has_label "recover.expr") (prj attrs) || has_default + if List.exists (Attribute.has_label "recover.expr") (prj attrs) + || has_default then cost_of_attributes prj attrs else Cost.infinite in - let ft = Terminal.tabulate - (fun t -> measure ~has_default:(Terminal.typ t = None) Terminal.attributes t) + let ft = + Terminal.tabulate (fun t -> + measure ~has_default:(Terminal.typ t = None) Terminal.attributes t) in let fn = Nonterminal.tabulate (measure ~has_default:false Nonterminal.attributes) in function - | T t -> begin match Terminal.kind t with - | `ERROR -> Cost.infinite - | _ -> ft t - end + | T t -> (match Terminal.kind t with `ERROR -> Cost.infinite | _ -> ft t) | N n -> fn n let cost_of_prod = Production.tabulate (cost_of_attributes Production.attributes) let penalty_of_item = - let f = Production.tabulate @@ fun p -> - Array.map (cost_of_attributes (fun (_,_,a) -> a)) - (Production.rhs p) + let f = + Production.tabulate @@ fun p -> + Array.map (cost_of_attributes (fun (_, _, a) -> a)) (Production.rhs p) in - fun (p,i) -> + fun (p, i) -> let costs = f p in if i < Array.length costs then costs.(i) else cost_of_prod p let default_prelude ppf = - List.iter (fun a -> - if Attribute.has_label "recover.prelude" a then - Format.fprintf ppf "%s\n" (Attribute.payload a) - ) Grammar.attributes + List.iter + (fun a -> + if Attribute.has_label "recover.prelude" a + then Format.fprintf ppf "%s\n" (Attribute.payload a)) + Grammar.attributes - let default_expr ?(fallback="raise Not_found") attrs = + let default_expr ?(fallback = "raise Not_found") attrs = match List.find (Attribute.has_label "recover.expr") attrs with | exception Not_found -> fallback | attr -> Attribute.payload attr @@ -301,11 +287,10 @@ struct let default_terminal t = match Terminal.kind t with | `REGULAR | `ERROR | `EOF -> - let fallback = match Terminal.typ t with - | None -> Some "()" - | Some _ -> None - in - Some (default_expr ?fallback (Terminal.attributes t)) + let fallback = + match Terminal.typ t with None -> Some "()" | Some _ -> None + in + Some (default_expr ?fallback (Terminal.attributes t)) | `PSEUDO -> None let default_nonterminal n = diff --git a/src/menhir-recover/emitter.ml b/src/menhir-recover/emitter.ml index 92ac07e2d..79eef49ae 100644 --- a/src/menhir-recover/emitter.ml +++ b/src/menhir-recover/emitter.ml @@ -14,77 +14,62 @@ type var = int module Codesharing (G : GRAMMAR) (S : SYNTHESIZER with module G := G) - (R : RECOVERY with module G := G) : -sig - + (R : RECOVERY with module G := G) : sig type instr = | IRef of var | IAbort | IReduce of G.production - | IShift of G.symbol + | IShift of G.symbol val compile : R.item list -> instr list list * (R.item -> instr list) - end = struct - open S - (* Rewrite trivial indirections: - Seq [x] => x - ys @ [Seq xs] => ys @ xs - *) + (* Rewrite trivial indirections: Seq [x] => x ys @ [Seq xs] => ys @ xs *) let rec normalize_actions = function | [] -> [] - | [Seq v] -> normalize_actions v - | (x :: xs) -> normalize_action x :: normalize_actions xs + | [ Seq v ] -> normalize_actions v + | x :: xs -> normalize_action x :: normalize_actions xs and normalize_action = function - | Abort | Reduce _ | Shift _ as a -> a - | Seq [v] -> normalize_action v - | Seq v -> - match normalize_actions v with - | [x] -> x - | xs -> Seq xs + | (Abort | Reduce _ | Shift _) as a -> a + | Seq [ v ] -> normalize_action v + | Seq v -> (match normalize_actions v with [ x ] -> x | xs -> Seq xs) - (* Find sharing opportunities. - If the same sequence of action occurs multiple times, the funtion - will associate a unique identifier to the sequence. + (* Find sharing opportunities. If the same sequence of action occurs multiple + times, the funtion will associate a unique identifier to the sequence. - [share actions] returns a pair - [(bindings, lookup) : action list array * (action list -> int option)] + [share actions] returns a pair [(bindings, lookup) : action list array * + (action list -> int option)] - The [bindings] array contains all action lists that are worth sharing. - The [lookup] function returns the index of an action list if is - is in the array. - *) + The [bindings] array contains all action lists that are worth sharing. The + [lookup] function returns the index of an action list if is is in the + array. *) let share actions = let occurrence_table = Hashtbl.create 113 in - begin - let order = ref 0 in - let rec iter_list = function - | [] | [_] -> () - | (x :: xs) as xxs -> - match Hashtbl.find occurrence_table xxs with - | occurrences, _index -> incr occurrences - | exception Not_found -> - let index = ref (-1) in - Hashtbl.add occurrence_table xxs (ref 1, index); - iter x; iter_list xs; - index := !order; - incr order - and iter = function - | Abort | Reduce _ | Shift _ -> () - | Seq xs -> iter_list xs - in - List.iter iter_list actions; - end; + (let order = ref 0 in + let rec iter_list = function + | [] | [ _ ] -> () + | x :: xs as xxs -> + (match Hashtbl.find occurrence_table xxs with + | occurrences, _index -> incr occurrences + | exception Not_found -> + let index = ref (-1) in + Hashtbl.add occurrence_table xxs (ref 1, index); + iter x; + iter_list xs; + index := !order; + incr order) + and iter = function + | Abort | Reduce _ | Shift _ -> () + | Seq xs -> iter_list xs + in + List.iter iter_list actions); let bindings = let register actions (occurrences, index) to_share = - if !occurrences > 1 - then (!index, actions) :: to_share - else to_share + if !occurrences > 1 then (!index, actions) :: to_share else to_share in let to_share = Hashtbl.fold register occurrence_table [] in let order_actions (o1, _) (o2, _) = compare o1 (o2 : int) in @@ -99,7 +84,7 @@ end = struct | exception Not_found -> None | index -> Some index in - (bindings, lookup) + bindings, lookup let item_to_actions (st, prod, pos) = normalize_actions (snd (S.solve (Tail (st, prod, pos)))) @@ -108,18 +93,18 @@ end = struct | IRef of int | IAbort | IReduce of G.production - | IShift of G.symbol + | IShift of G.symbol let rec compile_one ~sharing = function - | Abort -> [IAbort] - | Reduce p -> [IReduce p] - | Shift s -> [IShift s] - | Seq xs -> share_seq ~sharing xs + | Abort -> [ IAbort ] + | Reduce p -> [ IReduce p ] + | Shift s -> [ IShift s ] + | Seq xs -> share_seq ~sharing xs and share_seq ~sharing seq = match sharing seq with | None -> compile_seq ~sharing seq - | Some index -> [IRef index] + | Some index -> [ IRef index ] and compile_seq ~sharing = function | [] -> [] @@ -133,103 +118,119 @@ end = struct let bindings, sharing = share actions in let bindings = List.map (compile_seq ~sharing) bindings in let compile_item item = share_seq ~sharing (item_to_actions item) in - (bindings, compile_item) + bindings, compile_item end module Make (G : GRAMMAR) (A : ATTRIBUTES with module G := G) (S : SYNTHESIZER with module G := G) - (R : RECOVERY with module G := G) : -sig + (R : RECOVERY with module G := G) : sig val emit : Format.formatter -> unit end = struct - open G open Format let emit_default_value ppf = - fprintf ppf "open %s\n\n" + fprintf + ppf + "open %s\n\n" (String.capitalize_ascii (Filename.basename Grammar.basename)); fprintf ppf "module Default = struct\n"; A.default_prelude ppf; fprintf ppf " let value (type a) : a %s.symbol -> a = function\n" menhir; Terminal.iter (fun t -> - match A.default_terminal t with - | None -> () - | Some str -> - fprintf ppf " | %s.T %s.T_%s -> %s\n" - menhir menhir (Terminal.name t) str - ); + match A.default_terminal t with + | None -> () + | Some str -> + fprintf + ppf + " | %s.T %s.T_%s -> %s\n" + menhir + menhir + (Terminal.name t) + str); Nonterminal.iter (fun n -> - match A.default_nonterminal n with - | None -> () - | Some str -> - fprintf ppf " | %s.N %s.N_%s -> %s\n" - menhir menhir (Nonterminal.mangled_name n) str - ); - (*fprintf ppf " | _ -> raise Not_found\n"; should be exhaustive*) + match A.default_nonterminal n with + | None -> () + | Some str -> + fprintf + ppf + " | %s.N %s.N_%s -> %s\n" + menhir + menhir + (Nonterminal.mangled_name n) + str); + (*fprintf ppf " | _ -> raise Not_found\n"; should be exhaustive*) fprintf ppf "end\n\n"; fprintf ppf "let default_value = Default.value\n\n" let emit_defs ppf = fprintf ppf "open %s\n\n" menhir; - fprintf ppf "type action =\n\ - \ | Abort\n\ - \ | R of int\n\ - \ | S : 'a symbol -> action\n\ - \ | Sub of action list\n\n"; - fprintf ppf "type decision =\n\ - \ | Nothing\n\ - \ | One of action list\n\ - \ | Select of (int -> action list)\n\n" + fprintf + ppf + "type action =\n\ + \ | Abort\n\ + \ | R of int\n\ + \ | S : 'a symbol -> action\n\ + \ | Sub of action list\n\n"; + fprintf + ppf + "type decision =\n\ + \ | Nothing\n\ + \ | One of action list\n\ + \ | Select of (int -> action list)\n\n" let emit_depth ppf = let open Format in fprintf ppf "let depth =\n [|"; Lr1.iter (fun st -> - let items = G.Lr0.items (G.Lr1.lr0 st) in - let positions = List.map snd items in - let depth = List.fold_left max 0 positions in - fprintf ppf "%d;" depth - ); + let items = G.Lr0.items (G.Lr1.lr0 st) in + let positions = List.map snd items in + let depth = List.fold_left max 0 positions in + fprintf ppf "%d;" depth); fprintf ppf "|]\n\n" let emit_can_pop ppf = Format.fprintf ppf "let can_pop (type a) : a terminal -> bool = function\n"; G.Terminal.iter (fun t -> - if G.Terminal.kind t = `REGULAR && G.Terminal.typ t = None then - Format.fprintf ppf " | T_%s -> true\n" (G.Terminal.name t)); + if G.Terminal.kind t = `REGULAR && G.Terminal.typ t = None + then Format.fprintf ppf " | T_%s -> true\n" (G.Terminal.name t)); Format.fprintf ppf " | _ -> false\n\n" - module C = Codesharing(G)(S)(R) + module C = Codesharing (G) (S) (R) let emit_recoveries ppf = let all_cases = - Lr1.fold (fun st acc -> - try let {R. cases; _} = R.recover st in - let cases = List.map (fun (st', items) -> - (list_last items), - (match st' with None -> -1 | Some st' -> Lr1.to_int st') - ) cases - in - let cases = match group_assoc cases with - | [] -> `Nothing - | [(instr, _)] -> `One instr - | xs -> `Select xs - in - (cases, (Lr1.to_int st)) :: acc - with _ -> acc - ) -[] -in + Lr1.fold + (fun st acc -> + try + let { R.cases; _ } = R.recover st in + let cases = + List.map + (fun (st', items) -> + ( list_last items + , match st' with None -> -1 | Some st' -> Lr1.to_int st' )) + cases + in + let cases = + match group_assoc cases with + | [] -> `Nothing + | [ (instr, _) ] -> `One instr + | xs -> `Select xs + in + (cases, Lr1.to_int st) :: acc + with + | _ -> acc) + [] + in let all_cases = group_assoc all_cases in let all_items = let items_in_case (case, _states) = match case with | `Nothing -> [] - | `One item -> [item] + | `One item -> [ item ] | `Select items -> List.map fst items in List.flatten (List.map items_in_case all_cases) @@ -251,37 +252,41 @@ in List.iteri emit_shared globals; let emit_item ppf item = emit_instrs ppf (get_instr item) in fprintf ppf " function\n"; - List.iter (fun (cases, states) -> - fprintf ppf " "; - List.iter (fprintf ppf "| %d ") states; - fprintf ppf "-> "; - match cases with - | `Nothing -> fprintf ppf "Nothing\n"; - | `One item -> fprintf ppf "One %a\n" emit_item item - | `Select xs -> - fprintf ppf "Select (function\n"; - if safe then ( - List.iter (fun (item, cases) -> - fprintf ppf " "; - List.iter (fprintf ppf "| %d ") cases; - fprintf ppf "-> %a\n" emit_item item; - ) xs; - fprintf ppf " | _ -> raise Not_found)\n" - ) else ( - match List.sort - (fun (_,a) (_,b) -> compare (List.length b) (List.length a)) - xs - with - | (item, _) :: xs -> - List.iter (fun (item, cases) -> + List.iter + (fun (cases, states) -> + fprintf ppf " "; + List.iter (fprintf ppf "| %d ") states; + fprintf ppf "-> "; + match cases with + | `Nothing -> fprintf ppf "Nothing\n" + | `One item -> fprintf ppf "One %a\n" emit_item item + | `Select xs -> + fprintf ppf "Select (function\n"; + if safe + then ( + List.iter + (fun (item, cases) -> fprintf ppf " "; List.iter (fprintf ppf "| %d ") cases; - fprintf ppf "-> %a\n" emit_item item; - ) xs; - fprintf ppf " | _ -> %a)\n" emit_item item - | [] -> assert false - ) - ) all_cases; + fprintf ppf "-> %a\n" emit_item item) + xs; + fprintf ppf " | _ -> raise Not_found)\n") + else ( + match + List.sort + (fun (_, a) (_, b) -> compare (List.length b) (List.length a)) + xs + with + | (item, _) :: xs -> + List.iter + (fun (item, cases) -> + fprintf ppf " "; + List.iter (fprintf ppf "| %d ") cases; + fprintf ppf "-> %a\n" emit_item item) + xs; + fprintf ppf " | _ -> %a)\n" emit_item item + | [] -> assert false)) + all_cases; fprintf ppf " | _ -> raise Not_found\n" @@ -289,15 +294,19 @@ in let case t = match Terminal.kind t with | `REGULAR | `EOF -> - fprintf ppf " | %s.T_%s -> %s%s\n" - menhir (Terminal.name t) - (Terminal.name t) (if Terminal.typ t <> None then " v" else "") + fprintf + ppf + " | %s.T_%s -> %s%s\n" + menhir + (Terminal.name t) + (Terminal.name t) + (if Terminal.typ t <> None then " v" else "") | `ERROR -> - fprintf ppf " | %s.T_%s -> assert false\n" - menhir (Terminal.name t) + fprintf ppf " | %s.T_%s -> assert false\n" menhir (Terminal.name t) | `PSEUDO -> () in - fprintf ppf + fprintf + ppf "let token_of_terminal (type a) (t : a %s.terminal) (v : a) : token =\n\ \ match t with\n" menhir; @@ -305,11 +314,13 @@ in let emit_nullable ppf = let print_n n = - if Nonterminal.nullable n then - fprintf ppf " | N_%s -> true\n" (Nonterminal.mangled_name n) + if Nonterminal.nullable n + then fprintf ppf " | N_%s -> true\n" (Nonterminal.mangled_name n) in - fprintf ppf "let nullable (type a) : a MenhirInterpreter.nonterminal -> bool =\n\ - \ let open MenhirInterpreter in function\n"; + fprintf + ppf + "let nullable (type a) : a MenhirInterpreter.nonterminal -> bool =\n\ + \ let open MenhirInterpreter in function\n"; Nonterminal.iter print_n; fprintf ppf " | _ -> false\n" @@ -321,5 +332,4 @@ in emit_recoveries ppf; emit_token_of_terminal ppf; emit_nullable ppf - end diff --git a/src/menhir-recover/emitter.mli b/src/menhir-recover/emitter.mli index 47ea7e1d2..b2b0a0f80 100644 --- a/src/menhir-recover/emitter.mli +++ b/src/menhir-recover/emitter.mli @@ -7,7 +7,6 @@ module Make (G : GRAMMAR) (A : ATTRIBUTES with module G := G) (S : SYNTHESIZER with module G := G) - (R : RECOVERY with module G := G) : -sig + (R : RECOVERY with module G := G) : sig val emit : Format.formatter -> unit end diff --git a/src/menhir-recover/main.ml b/src/menhir-recover/main.ml index f04d49b9d..bfd59d23c 100644 --- a/src/menhir-recover/main.ml +++ b/src/menhir-recover/main.ml @@ -5,8 +5,7 @@ let name = ref "" let verbose = ref false let usage () = - Printf.eprintf "Usage: %s [-v] file.cmly\n" - Sys.argv.(0); + Printf.eprintf "Usage: %s [-v] file.cmly\n" Sys.argv.(0); exit 1 let () = @@ -15,49 +14,53 @@ let () = | "-v" -> verbose := true | arg -> if !name = "" then name := arg else usage () done; - if !name = "" then - usage () + if !name = "" then usage () -module G = Cmly_read.Read (struct let filename = !name end) -module A = Attributes.Recover_attributes(G) +module G = Cmly_read.Read (struct + let filename = !name + end) + +module A = Attributes.Recover_attributes (G) let () = let open Format in let ppf = Format.err_formatter in - if !verbose then begin + if !verbose + then ( let open G in Lr1.iter (fun (st : lr1) -> - fprintf ppf "\n# LR(1) state #%d\n\n" (st :> int); - fprintf ppf "Items:\n"; - Print.itemset ppf (Lr0.items (Lr1.lr0 st)); - fprintf ppf "Transitions:\n"; - List.iter (fun (sym,(st' : lr1)) -> - fprintf ppf " - on %a, goto #%d\n" - Print.symbol sym - (st' :> int) - ) (Lr1.transitions st); - fprintf ppf "Reductions:\n"; - List.iter (fun (t,ps) -> - let p : production = List.hd ps in - fprintf ppf " - on %a, reduce %d:\n %a\n" - Print.terminal t - (p :> int) Print.production p - ) (Lr1.reductions st [@alert "-deprecated"]); - ); + fprintf ppf "\n# LR(1) state #%d\n\n" (st :> int); + fprintf ppf "Items:\n"; + Print.itemset ppf (Lr0.items (Lr1.lr0 st)); + fprintf ppf "Transitions:\n"; + List.iter + (fun (sym, (st' : lr1)) -> + fprintf ppf " - on %a, goto #%d\n" Print.symbol sym (st' :> int)) + (Lr1.transitions st); + fprintf ppf "Reductions:\n"; + List.iter + (fun (t, ps) -> + let p : production = List.hd ps in + fprintf + ppf + " - on %a, reduce %d:\n %a\n" + Print.terminal + t + (p :> int) + Print.production + p) + (Lr1.reductions st [@alert "-deprecated"])); Production.iter (fun (p : production) -> - fprintf ppf "\n# Production p%d\n%a" - (p :> int) Print.production p - ); - end + fprintf ppf "\n# Production p%d\n%a" (p :> int) Print.production p)) -module S = Synthesis.Synthesizer(G)(A) +module S = Synthesis.Synthesizer (G) (A) let () = if !verbose then S.report Format.err_formatter -module R = Recover(G)(S) +module R = Recover (G) (S) (*let () = if !verbose then R.report Format.err_formatter*) -module E = Emitter.Make(G)(A)(S)(R) +module E = Emitter.Make (G) (A) (S) (R) let () = E.emit Format.std_formatter diff --git a/src/menhir-recover/recovery_custom.ml b/src/menhir-recover/recovery_custom.ml index f939d95ba..6fab4808c 100644 --- a/src/menhir-recover/recovery_custom.ml +++ b/src/menhir-recover/recovery_custom.ml @@ -6,48 +6,47 @@ module type RECOVERY = sig type item = G.lr1 * G.production * int - type recovery = { - prefix: int; - cases: (G.lr1 option * item list) list; - } - (** [prefix] is the size of the known prefix of the stack. - It means that in the kernel of current state, there is an item whose dot - is at position [prefix]. - (we know the incoming symbols for these stack frames and we can enumerate - the possible state numbers). + type recovery = + { prefix : int + ; cases : (G.lr1 option * item list) list + } + (** [prefix] is the size of the known prefix of the stack. It means that in + the kernel of current state, there is an item whose dot is at position + [prefix]. (we know the incoming symbols for these stack frames and we can + enumerate the possible state numbers). [cases] is a mapping that associates to each possible state found at - stack.[-prefix] - (or None if the stack is empty) a list of reductions to execute. + stack.[-prefix] (or None if the stack is empty) a list of reductions to + execute. - The actual list of actions to reduce an item [(state, prod, pos)] is - given by - [Synthesizer.solution (Trail (state, prod, pos))] - *) + The actual list of actions to reduce an item [(state, prod, pos)] is given + by [Synthesizer.solution (Trail (state, prod, pos))] *) val recover : G.lr1 -> recovery val report : Format.formatter -> unit end -module Recover (G : GRAMMAR) (S : SYNTHESIZER with module G := G) - : RECOVERY with module G := G = -struct +module Recover (G : GRAMMAR) (S : SYNTHESIZER with module G := G) : + RECOVERY with module G := G = struct open G open Utils type item = lr1 * production * int - type recovery = { - prefix: int; - cases: (G.lr1 option * item list) list; - } + type recovery = + { prefix : int + ; cases : (G.lr1 option * item list) list + } - type trace = { cost : Cost.t; items : item list } + type trace = + { cost : Cost.t + ; items : item list + } module Trace = struct type t = trace - let min tr1 tr2 = - Cost.arg_min (fun t -> t.cost) tr1 tr2 + + let min tr1 tr2 = Cost.arg_min (fun t -> t.cost) tr1 tr2 let cat tr1 tr2 = { cost = Cost.add tr1.cost tr2.cost; items = tr1.items @ tr2.items } @@ -57,201 +56,227 @@ struct type level = (nonterminal * Trace.t) list type t = level list - let rec merge_level l1 l2 : level = match l1, l2 with + let rec merge_level l1 l2 : level = + match l1, l2 with | [], l -> l | l, [] -> l - | ((nt1, c1) :: xs1), (x2 :: xs2) -> - let (nt2, c2) = x2 in - match compare nt1 nt2 with - | 0 -> - let x = (nt1, Trace.min c1 c2) in - x :: merge_level xs1 xs2 - | n when n > 0 -> x2 :: merge_level l1 xs2 - | _ -> (nt1, c1) :: merge_level xs1 l2 + | (nt1, c1) :: xs1, x2 :: xs2 -> + let nt2, c2 = x2 in + (match compare nt1 nt2 with + | 0 -> + let x = nt1, Trace.min c1 c2 in + x :: merge_level xs1 xs2 + | n when n > 0 -> x2 :: merge_level l1 xs2 + | _ -> (nt1, c1) :: merge_level xs1 l2) - let rec merge l1 l2 : t = match l1, l2 with + let rec merge l1 l2 : t = + match l1, l2 with | [], l -> l | l, [] -> l - | (x1 :: l1), (x2 :: l2) -> - let x' = merge_level x1 x2 in - x' :: merge l1 l2 + | x1 :: l1, x2 :: l2 -> + let x' = merge_level x1 x2 in + x' :: merge l1 l2 end let synthesize = let rec add_nt tr nt = function - | [] -> [(nt, tr)] + | [] -> [ nt, tr ] | x :: xs -> - match compare nt (fst x) with - | 0 -> (nt, Trace.min tr (snd x)) :: xs + (match compare nt (fst x) with + | 0 -> (nt, Trace.min tr (snd x)) :: xs | c when c < 0 -> (nt, tr) :: xs - | _ -> x :: add_nt tr nt xs + | _ -> x :: add_nt tr nt xs) in let add_item cost item stack = - let (_, prod, pos) = item in - if Cost.is_infinite cost then stack else - let stack_hd = function - | [] -> [] - | x :: _ -> x - and stack_tl = function - | [] -> [] - | _ :: xs -> xs - in + let _, prod, pos = item in + if Cost.is_infinite cost + then stack + else + let stack_hd = function [] -> [] | x :: _ -> x + and stack_tl = function [] -> [] | _ :: xs -> xs in let rec aux stack = function - | 0 -> add_nt {cost; items = [item]} (Production.lhs prod) - (stack_hd stack) :: stack_tl stack + | 0 -> + add_nt + { cost; items = [ item ] } + (Production.lhs prod) + (stack_hd stack) + :: stack_tl stack | n -> stack_hd stack :: aux (stack_tl stack) (n - 1) in aux stack pos in Lr1.tabulate (fun st -> - List.fold_left (fun acc (prod, pos) -> - if pos = 0 then acc else ( - let cost, _actions = S.solve (S.Tail (st, prod, pos)) in - add_item cost (st, prod, pos) acc - ) - ) - [] (Lr0.items (Lr1.lr0 st)) - ) + List.fold_left + (fun acc (prod, pos) -> + if pos = 0 + then acc + else + let cost, _actions = S.solve (S.Tail (st, prod, pos)) in + add_item cost (st, prod, pos) acc) + [] + (Lr0.items (Lr1.lr0 st))) let step st ntss = let seen = ref Bytes.empty in let mem n = - let off = n lsr 3 and mask = 1 lsl (n land 7) in - Bytes.length !seen > off && - (Char.code (Bytes.get !seen off) land mask <> 0) + let off = n lsr 3 + and mask = 1 lsl (n land 7) in + Bytes.length !seen > off && Char.code (Bytes.get !seen off) land mask <> 0 in let mark_seen n = - let off = n lsr 3 and mask = 1 lsl (n land 7) in + let off = n lsr 3 + and mask = 1 lsl (n land 7) in let len = Bytes.length !seen in - (if len <= off then - seen := Bytes.cat !seen (Bytes.make (off + 1 - len) '\000')); + if len <= off + then seen := Bytes.cat !seen (Bytes.make (off + 1 - len) '\000'); let code = Char.code (Bytes.get !seen off) lor mask in Bytes.set !seen off (Char.chr code) in let rec aux = function | [] -> [] | ((nt, tr) :: x) :: xs - when not (mem (Nonterminal.to_int nt)) && - not (Nonterminal.kind nt = `START) -> - mark_seen (Nonterminal.to_int nt); - let st' = List.assoc (N nt) (Lr1.transitions st) in - let xs' = synthesize st' in - let xs' = match xs' with - | [] -> [] - | _ :: xs -> xs - in - let merge_trace (nt,tr') = (nt, Trace.cat tr' tr) in - let xs' = List.map (List.map merge_trace) xs' in - aux (State.merge xs' (x :: xs)) + when (not (mem (Nonterminal.to_int nt))) + && not (Nonterminal.kind nt = `START) -> + mark_seen (Nonterminal.to_int nt); + let st' = List.assoc (N nt) (Lr1.transitions st) in + let xs' = synthesize st' in + let xs' = match xs' with [] -> [] | _ :: xs -> xs in + let merge_trace (nt, tr') = nt, Trace.cat tr' tr in + let xs' = List.map (List.map merge_trace) xs' in + aux (State.merge xs' (x :: xs)) | (_ :: x) :: xs -> aux (x :: xs) | [] :: xs -> xs in aux ntss - let init st = ((st, [st]), step st (synthesize st)) + let init st = (st, [ st ]), step st (synthesize st) let pred = (* Compute lr1 predecessor relation *) let tbl1 = Array.make Lr1.count [] in - let revert_transition s1 (sym,s2) = - assert (match Lr0.incoming (Lr1.lr0 s2) with - | None -> false - | Some sym' -> sym = sym'); + let revert_transition s1 (sym, s2) = + assert ( + match Lr0.incoming (Lr1.lr0 s2) with + | None -> false + | Some sym' -> sym = sym'); tbl1.(Lr1.to_int s2) <- s1 :: tbl1.(Lr1.to_int s2) in - Lr1.iter - (fun lr1 -> List.iter (revert_transition lr1) (Lr1.transitions lr1)); - (fun lr1 -> tbl1.(Lr1.to_int lr1)) + Lr1.iter (fun lr1 -> + List.iter (revert_transition lr1) (Lr1.transitions lr1)); + fun lr1 -> tbl1.(Lr1.to_int lr1) let expand stuck_states ((st, sts), nts) = - List.map (fun st' -> - let nts' = step st' nts in - if nts' = [] then (stuck_states := st' :: !stuck_states); - ((st', st' :: sts), nts') - ) + List.map + (fun st' -> + let nts' = step st' nts in + if nts' = [] then stuck_states := st' :: !stuck_states; + (st', st' :: sts), nts') (pred st) - let all_stuck_states : (Lr1.t, int ref) Hashtbl.t = - Hashtbl.create 7 + let all_stuck_states : (Lr1.t, int ref) Hashtbl.t = Hashtbl.create 7 let recover st : recovery = (* How big is the known prefix of the stack *) let known_prefix = let items = Lr0.items (Lr1.lr0 st) in - List.fold_left (fun pos (_, pos') -> max pos pos') - (snd (List.hd items)) (List.tl items) + List.fold_left + (fun pos (_, pos') -> max pos pos') + (snd (List.hd items)) + (List.tl items) in (* Walk this prefix *) let stuck = ref false in let stuck_states = ref [] in let traces = - let acc = ref [init st] in + let acc = ref [ init st ] in for _i = 1 to known_prefix - 1 do acc := List.concat (List.map (expand stuck_states) !acc) done; !acc in - (*Printf.printf "trace(%d): %d items\n%!" - (Lr1.to_int st) (List.length traces);*) + (*Printf.printf "trace(%d): %d items\n%!" (Lr1.to_int st) (List.length + traces);*) (* Last step *) let process_trace trace = match expand stuck_states trace with - | [] -> (* Initial state *) - assert (snd trace = []); [] + | [] -> + (* Initial state *) + assert (snd trace = []); + [] | states -> - let select_trace traces = - (* Pick a trace with minimal cost, somewhat arbitrary *) - match List.flatten traces with - | [] -> - List.iter (fun st -> + let select_trace traces = + (* Pick a trace with minimal cost, somewhat arbitrary *) + match List.flatten traces with + | [] -> + List.iter + (fun st -> let r = - try Hashtbl.find all_stuck_states st - with Not_found -> + try Hashtbl.find all_stuck_states st with + | Not_found -> let r = ref 0 in Hashtbl.add all_stuck_states st r; r in - incr r - ) !stuck_states; - stuck := true; - stuck_states := []; - None - | (_, trace) :: alternatives -> - Some (List.fold_left (fun tr1 (_,tr2) -> Trace.min tr1 tr2) trace alternatives) - in - let select_expansion = function - | (_, []) -> - (* Reached stack bottom *) - (None, select_trace (snd trace)) - | ((st, _sts), trace') -> - (Some st, select_trace trace') - in - List.map select_expansion states + incr r) + !stuck_states; + stuck := true; + stuck_states := []; + None + | (_, trace) :: alternatives -> + Some + (List.fold_left + (fun tr1 (_, tr2) -> Trace.min tr1 tr2) + trace + alternatives) + in + let select_expansion = function + | _, [] -> + (* Reached stack bottom *) + None, select_trace (snd trace) + | (st, _sts), trace' -> Some st, select_trace trace' + in + List.map select_expansion states in let cases = - List.flatten @@ List.map (fun trace -> - List.fold_right - (fun (st, tr') acc -> match tr' with - | Some { items ; _ } -> (st, items) :: acc - | None -> acc) - (process_trace trace) [] - ) traces; + List.flatten + @@ List.map + (fun trace -> + List.fold_right + (fun (st, tr') acc -> + match tr' with + | Some { items; _ } -> (st, items) :: acc + | None -> acc) + (process_trace trace) + []) + traces in - if !stuck then - Format.printf "Not enough annotation to recover from state %d:\n%a\n%!" - (Lr1.to_int st) Print.itemset (Lr0.items (Lr1.lr0 st)); + if !stuck + then + Format.printf + "Not enough annotation to recover from state %d:\n%a\n%!" + (Lr1.to_int st) + Print.itemset + (Lr0.items (Lr1.lr0 st)); { prefix = known_prefix; cases } let recover = Lr1.tabulate recover let () = - let all_stuck_states = Hashtbl.fold (fun k v acc -> (k, !v) :: acc) all_stuck_states [] in - let all_stuck_states = List.sort (fun (_,v1) (_,v2) -> compare v2 v1) all_stuck_states in - List.iter (fun (st, count) -> - Format.printf "# State %d is preventing recovery from %d states:\n%a\n\n%!" - (Lr1.to_int st) count - Print.itemset (Lr0.items (Lr1.lr0 st)) - ) all_stuck_states + let all_stuck_states = + Hashtbl.fold (fun k v acc -> (k, !v) :: acc) all_stuck_states [] + in + let all_stuck_states = + List.sort (fun (_, v1) (_, v2) -> compare v2 v1) all_stuck_states + in + List.iter + (fun (st, count) -> + Format.printf + "# State %d is preventing recovery from %d states:\n%a\n\n%!" + (Lr1.to_int st) + count + Print.itemset + (Lr0.items (Lr1.lr0 st))) + all_stuck_states let report _ppf = () end diff --git a/src/menhir-recover/recovery_intf.ml b/src/menhir-recover/recovery_intf.ml index fc88de422..243f20b3f 100644 --- a/src/menhir-recover/recovery_intf.ml +++ b/src/menhir-recover/recovery_intf.ml @@ -5,28 +5,26 @@ module type RECOVERY = sig type item = G.lr1 * G.production * int - type recovery = { - prefix: int; - cases: (G.lr1 option * item list) list; - } - (** [prefix] is the size of the known prefix of the stack. - It means that in the kernel of current state, there is an item whose dot - is at position [prefix]. - (we know the incoming symbols for these stack frames and we can enumerate - the possible state numbers). + type recovery = + { prefix : int + ; cases : (G.lr1 option * item list) list + } + (** [prefix] is the size of the known prefix of the stack. It means that in + the kernel of current state, there is an item whose dot is at position + [prefix]. (we know the incoming symbols for these stack frames and we can + enumerate the possible state numbers). [cases] is a mapping that associates to each possible state found at - stack.[-prefix] - (or None if the stack is empty) a list of reductions to execute. + stack.[-prefix] (or None if the stack is empty) a list of reductions to + execute. - The actual list of actions to reduce an item [(state, prod, pos)] is - given by - [Synthesizer.solution (Trail (state, prod, pos))] - *) + The actual list of actions to reduce an item [(state, prod, pos)] is given + by [Synthesizer.solution (Trail (state, prod, pos))] *) val recover : G.lr1 -> recovery end -module type RECOVER = - functor (G : GRAMMAR) (S : Synthesis.SYNTHESIZER with module G := G) -> - (RECOVERY with module G := G) +module type RECOVER = functor + (G : GRAMMAR) + (S : Synthesis.SYNTHESIZER with module G := G) + -> RECOVERY with module G := G diff --git a/src/menhir-recover/synthesis.ml b/src/menhir-recover/synthesis.ml index 440495380..845157e28 100644 --- a/src/menhir-recover/synthesis.ml +++ b/src/menhir-recover/synthesis.ml @@ -11,42 +11,34 @@ module type SYNTHESIZER = sig There are two situations we want to synthesize solution for: - - `Head` is when the dot is just in front of some non-terminal, - and we would like to find a way to move the dot to the right of - this symbol (by executing a sequence of actions that results in - this non-terminal being pushed on the stack) + - `Head` is when the dot is just in front of some non-terminal, and we + would like to find a way to move the dot to the right of this symbol (by + executing a sequence of actions that results in this non-terminal being + pushed on the stack) - - `Tail` is when the dot is in some production that we would like - to reduce. - *) + - `Tail` is when the dot is in some production that we would like to + reduce. *) type variable = | Head of G.lr1 * G.nonterminal | Tail of G.lr1 * G.production * int - (* The integer parameter in `Tail` is the position of the dot in - the production we are trying to reduce. This is necessary to - uniquely identify a production that occurs multiple time in a - state. + (* The integer parameter in `Tail` is the position of the dot in the + production we are trying to reduce. This is necessary to uniquely identify + a production that occurs multiple time in a state. For instance, in the grammar: - %token INT - %token PLUS + %token INT %token PLUS - expr: - | INT { $1 } (*const*) - | expr PLUS expr { $1 + $2 } (*add*) + expr: | INT \{ $1 \} (*const*) | expr PLUS expr \{ $1 + $2 \} (*add*) - Synthesizing `Head (st0, expr)` when `expr PLUS . expr` is in - `st0` will output the actions to get to the state `st'` - containing `expr PLUS expr .`. + Synthesizing `Head (st0, expr)` when `expr PLUS . expr` is in `st0` will + output the actions to get to the state `st'` containing `expr PLUS expr .`. - Synthesizing `Tail (st1, add, 1)` when `expr . PLUS expr` is in - `st1` will output the actions that end up reducing `add` (which - will likely be shifting `PLUS`, synthesizing `Head (st0, expr)` - and reducing add). - *) + Synthesizing `Tail (st1, add, 1)` when `expr . PLUS expr` is in `st1` will + output the actions that end up reducing `add` (which will likely be + shifting `PLUS`, synthesizing `Head (st0, expr)` and reducing add). *) val variable_to_string : variable -> string (** A human readable representation of a [variable]. *) @@ -58,17 +50,16 @@ module type SYNTHESIZER = sig type action = | Abort | Reduce of G.production - | Shift of G.symbol - | Seq of action list + | Shift of G.symbol + | Seq of action list - (* `Abort` is issued if there is no solution. This is the case for instance - if there is a semantic value that the synthesizer cannot produce, or a + (* `Abort` is issued if there is no solution. This is the case for instance if + there is a semantic value that the synthesizer cannot produce, or a production with an infinite cost. `Shift` and `Reduce` are direct actions to execute on the parser. - `Seq` is a sequence of action. - *) + `Seq` is a sequence of action. *) val action_to_string : action -> string (** A human readable representation of an action. *) @@ -82,9 +73,8 @@ end (** Synthesizer implementation *) -module Synthesizer (G : GRAMMAR) (A : ATTRIBUTES with module G = G) - : SYNTHESIZER with module G := G = -struct +module Synthesizer (G : GRAMMAR) (A : ATTRIBUTES with module G = G) : + SYNTHESIZER with module G := G = struct open G type variable = @@ -93,31 +83,30 @@ struct let variable_to_string = function | Head (st, n) -> - Printf.sprintf "Head (#%d, %s)" - (Lr1.to_int st) (Nonterminal.name n) + Printf.sprintf "Head (#%d, %s)" (Lr1.to_int st) (Nonterminal.name n) | Tail (st, prod, pos) -> - Printf.sprintf "Tail (#%d, p%d, %d)" - (Lr1.to_int st) (Production.to_int prod) pos + Printf.sprintf + "Tail (#%d, p%d, %d)" + (Lr1.to_int st) + (Production.to_int prod) + pos type action = | Abort | Reduce of production - | Shift of symbol - | Seq of action list + | Shift of symbol + | Seq of action list let rec action_to_string = function | Abort -> "Abort" | Reduce prod -> "Reduce p" ^ string_of_int (Production.to_int prod) - | Shift sym -> "Shift " ^ (symbol_name sym) + | Shift sym -> "Shift " ^ symbol_name sym | Seq actions -> "Seq [" ^ String.concat "; " (List.map action_to_string actions) ^ "]" - - (** The synthesizer specify the cost as a system of equations of the form - $$ - x_i = \min_{j} ({\kappa_{i,j} + \sum_{k}x_{i,j,k}}) - $$ - which can be read as follow: + (** The synthesizer specify the cost as a system of equations of the form $$ + x_i = \min_\{j\} (\{\kappa_\{i,j\} + \sum_\{k\}x_\{i,j,k\}\}) $$ which can + be read as follow: - $x_i$ are variables, the thing we would like to know the cost of (the `Head` and `Tail` defined above) @@ -126,8 +115,8 @@ struct instance, to synthesize a _non-terminal_, each production that reduces to this _non-terminal_ is a valid candidate) - - each of these candidates is made of a constant and the sum of a - possibly empty list of other variables + - each of these candidates is made of a constant and the sum of a possibly + empty list of other variables Variables are valued in $\left[0,+\infin\right]$ (and the empty $\sum$ defaults to $0$, the empty $min$ to $+\infin$). @@ -135,167 +124,165 @@ struct The solution is the least fixed point of this system computed by [Fix](https://gitlab.inria.fr/fpottier/fix) library. - $$ - \begin{align} - \text{head}_{st,nt} = & \min \left\{ \begin{array}{ll} - \text{cost}(\text{empty-reductions}(st,nt))\\ - \text{tail-reductions}(st,nt) - \end{array} - \right. - \\ - \text{empty-reductions}(st,nt) = & - \\ - \text{tail}_{st,prod,i} = & - \end{align} - $$ + $$ \begin\{align\} \text\{head\}_\{st,nt\} = & \min \left\{ + \begin\{array\}\{ll\} \text\{cost\}(\text\{empty-reductions\}(st,nt))\\ + \text\{tail-reductions\}(st,nt) \end\{array\} \right. \\ + \text\{empty-reductions\}(st,nt) = & \\ \text\{tail\}_\{st,prod,i\} = & + \end\{align\} $$ For a variable `Head (st, nt)` , the branches are the different productions that can reduce to `nt` and starts from state `st`. The - constant is the same for all branches, $\kappa_{i,j} = \kappa_i$, - *) + constant is the same for all branches, $\kappa_\{i,j\} = \kappa_i$, *) let cost_of_prod p = Cost.add (Cost.of_int 1) (A.cost_of_prod p) let cost_of_symbol s = Cost.add (Cost.of_int 1) (A.cost_of_symbol s) let penalty_of_item i = A.penalty_of_item i - let app var v = v var + let bottom = Cost.infinite, [ Abort ] - let bottom = (Cost.infinite, [Abort]) - - let var var = match var with + let var var = + match var with | Head _ -> app var - | Tail (_,prod,pos) -> + | Tail (_, prod, pos) -> let prod_len = Array.length (Production.rhs prod) in assert (pos <= prod_len); if pos < prod_len then app var - else const (cost_of_prod prod, [Reduce prod]) + else const (cost_of_prod prod, [ Reduce prod ]) let productions = let table = Array.make Nonterminal.count [] in Production.iter (fun p -> - let nt = Nonterminal.to_int (Production.lhs p) in - table.(nt) <- p :: table.(nt) - ); - (fun nt -> table.(Nonterminal.to_int nt)) + let nt = Nonterminal.to_int (Production.lhs p) in + table.(nt) <- p :: table.(nt)); + fun nt -> table.(Nonterminal.to_int nt) let cost_of = function | Head (st, nt) -> - begin fun v -> - let minimize_over_prod (cost,_ as solution) prod = - let (cost', _) as solution' = v (Tail (st, prod, 0)) in + fun v -> + let minimize_over_prod ((cost, _) as solution) prod = + let ((cost', _) as solution') = v (Tail (st, prod, 0)) in if cost <= cost' then solution else solution' in List.fold_left minimize_over_prod bottom (productions nt) - end - | Tail (st, prod, pos) -> let prod_len = Array.length (Production.rhs prod) in assert (pos <= prod_len); let penalty = penalty_of_item (prod, pos) in - if Cost.is_infinite penalty then - const bottom - else if pos = prod_len then - let can_reduce = List.exists - (fun (_,prods) -> List.mem prod prods) (Lr1.reductions st [@alert "-deprecated"]) + if Cost.is_infinite penalty + then const bottom + else if pos = prod_len + then + let can_reduce = + List.exists + (fun (_, prods) -> List.mem prod prods) + (Lr1.reductions st [@alert "-deprecated"]) in - const (if can_reduce - then (cost_of_prod prod, [Reduce prod]) - else (Cost.infinite, [Abort])) + const + (if can_reduce + then cost_of_prod prod, [ Reduce prod ] + else Cost.infinite, [ Abort ]) else let head = let sym, _, _ = (Production.rhs prod).(pos) in let cost = cost_of_symbol sym in if Cost.is_infinite cost - then match sym with - | T _ -> const bottom - | N n -> var (Head (st, n)) - else const (cost, [Shift sym]) + then match sym with T _ -> const bottom | N n -> var (Head (st, n)) + else const (cost, [ Shift sym ]) in let tail = let sym, _, _ = (Production.rhs prod).(pos) in match List.assoc sym (Lr1.transitions st) with | st' -> var (Tail (st', prod, pos + 1)) | exception Not_found -> - (*report "no transition: #%d (%d,%d)\n" - st.lr1_index prod.p_index pos;*) + (*report "no transition: #%d (%d,%d)\n" st.lr1_index prod.p_index + pos;*) const bottom in - (fun v -> - let costh, actionh = head v in - let costt, actiont = tail v in - (Cost.add costh costt, Seq actionh :: actiont) - ) + fun v -> + let costh, actionh = head v in + let costt, actiont = tail v in + Cost.add costh costt, Seq actionh :: actiont let solve = - (* For > 4.02 - let module Solver = Fix.Fix.ForType (struct - type t = variable - end) (struct + (* For > 4.02 let module Solver = Fix.Fix.ForType (struct type t = variable + end) (struct type property = Cost.t * action list let bottom = + (Cost.infinite, [Abort]) let equal (x, _ : property) (y, _ : property) : + bool = Cost.compare x y = 0 let is_maximal _ = false end) in *) + let module Solver = + Fix.Make + (struct + type key = variable + type 'data t = (key, 'data) Hashtbl.t + + let create () = Hashtbl.create 97 + let clear tbl = Hashtbl.clear tbl + let add key value tbl = Hashtbl.add tbl key value + let find key tbl = Hashtbl.find tbl key + let iter f tbl = Hashtbl.iter f tbl + end) + (struct type property = Cost.t * action list - let bottom = (Cost.infinite, [Abort]) - let equal (x, _ : property) (y, _ : property) : bool = + + let bottom = Cost.infinite, [ Abort ] + + let equal ((x, _) : property) ((y, _) : property) : bool = Cost.compare x y = 0 + let is_maximal _ = false end) - in - *) - let module Solver = Fix.Make (struct - type key = variable - type 'data t = (key, 'data) Hashtbl.t - let create () = Hashtbl.create 97 - let clear tbl = Hashtbl.clear tbl - let add key value tbl = Hashtbl.add tbl key value - let find key tbl = Hashtbl.find tbl key - let iter f tbl = Hashtbl.iter f tbl - end) (struct - type property = Cost.t * action list - let bottom = (Cost.infinite, [Abort]) - let equal (x, _ : property) (y, _ : property) : bool = - Cost.compare x y = 0 - let is_maximal _ = false - end) in Solver.lfp cost_of let report ppf = let open Format in - let solutions = Lr1.fold + let solutions = + Lr1.fold (fun st acc -> match - List.fold_left (fun (item, (cost, _ as solution)) (prod, pos) -> - let cost', _ as solution' = solve (Tail (st, prod, pos)) in - if cost' < cost then - (Some (prod, pos), solution') - else - (item, solution) - ) (None, bottom) (Lr0.items (Lr1.lr0 st)) + List.fold_left + (fun (item, ((cost, _) as solution)) (prod, pos) -> + let ((cost', _) as solution') = + solve (Tail (st, prod, pos)) + in + if cost' < cost + then Some (prod, pos), solution' + else item, solution) + (None, bottom) + (Lr0.items (Lr1.lr0 st)) with | None, _ -> fprintf ppf "no synthesis from %d\n" (Lr1.to_int st); acc - | Some item, cost -> (item, (cost, st)) :: acc - ) [] + | Some item, cost -> (item, (cost, st)) :: acc) + [] in let fprintf = Format.fprintf in let rec print_action ppf = function | Abort -> fprintf ppf "Abort" - | Reduce prod -> fprintf ppf "Reduce %d" (Production.to_int prod) - | Shift (T t) -> fprintf ppf "Shift (T %s)" (Terminal.name t) - | Shift (N n) -> fprintf ppf "Shift (N %s)" (Nonterminal.mangled_name n) - | Seq actions -> fprintf ppf "Seq %a" print_actions actions - and print_actions ppf = Utils.pp_list print_action ppf - in - List.iter (fun (item, states) -> - fprintf ppf "# Item (%d,%d)\n" - (Production.to_int (fst item)) (snd item); - Print.item ppf item; - List.iter (fun ((cost, actions), states) -> - fprintf ppf "at cost %d from states %a:\n%a\n\n" - (cost : Cost.t :> int) - (Utils.pp_list (fun ppf st -> - fprintf ppf "#%d" (Lr1.to_int st))) states - print_actions actions - ) (group_assoc states) - ) (group_assoc solutions) + | Reduce prod -> fprintf ppf "Reduce %d" (Production.to_int prod) + | Shift (T t) -> fprintf ppf "Shift (T %s)" (Terminal.name t) + | Shift (N n) -> fprintf ppf "Shift (N %s)" (Nonterminal.mangled_name n) + | Seq actions -> fprintf ppf "Seq %a" print_actions actions + and print_actions ppf = Utils.pp_list print_action ppf in + List.iter + (fun (item, states) -> + fprintf + ppf + "# Item (%d,%d)\n" + (Production.to_int (fst item)) + (snd item); + Print.item ppf item; + List.iter + (fun ((cost, actions), states) -> + fprintf + ppf + "at cost %d from states %a:\n%a\n\n" + (cost : Cost.t :> int) + (Utils.pp_list (fun ppf st -> fprintf ppf "#%d" (Lr1.to_int st))) + states + print_actions + actions) + (group_assoc states)) + (group_assoc solutions) end diff --git a/src/menhir-recover/utils.ml b/src/menhir-recover/utils.ml index ef41da0c8..e19887c83 100644 --- a/src/menhir-recover/utils.ml +++ b/src/menhir-recover/utils.ml @@ -1,42 +1,37 @@ -let const c = fun _ -> c +let const c _ = c let group_assoc l = let cons k v acc = (k, List.rev v) :: acc in let rec aux k v vs acc = function | [] -> List.rev (cons k (v :: vs) acc) | (k', v') :: xs when compare k k' = 0 -> - if compare v v' = 0 then - aux k v vs acc xs - else - aux k v' (v :: vs) acc xs - | (k', v') :: xs -> - aux k' v' [] (cons k (v :: vs) acc) xs + if compare v v' = 0 then aux k v vs acc xs else aux k v' (v :: vs) acc xs + | (k', v') :: xs -> aux k' v' [] (cons k (v :: vs) acc) xs in - match List.sort compare l with - | [] -> [] - | (k, v) :: xs -> aux k v [] [] xs + match List.sort compare l with [] -> [] | (k, v) :: xs -> aux k v [] [] xs let rec list_last = function - | [x] -> x + | [ x ] -> x | _ :: xs -> list_last xs | [] -> invalid_arg "list_last" let pp_list f ppf = function | [] -> Format.fprintf ppf "[]" | x :: xs -> - Format.fprintf ppf "[%a" f x; - List.iter (Format.fprintf ppf "; %a" f) xs; - Format.fprintf ppf "]" + Format.fprintf ppf "[%a" f x; + List.iter (Format.fprintf ppf "; %a" f) xs; + Format.fprintf ppf "]" let rec list_filter_map f = function | [] -> [] | x :: xs -> - match f x with + (match f x with | None -> list_filter_map f xs - | Some x' -> x' :: list_filter_map f xs + | Some x' -> x' :: list_filter_map f xs) module Cost : sig type t = private int + val zero : t val infinite : t val compare : t -> t -> int @@ -47,20 +42,19 @@ module Cost : sig val arg_min : ('a -> t) -> 'a -> 'a -> 'a end = struct type t = int + let zero = 0 let infinite = max_int let compare : t -> t -> int = compare + let add t1 t2 = let result = t1 + t2 in - if result < 0 then infinite - else result + if result < 0 then infinite else result + let of_int x = - if x < 0 - then invalid_arg "Cost.of_int: cost must be positive" - else x + if x < 0 then invalid_arg "Cost.of_int: cost must be positive" else x + let to_int x = x let is_infinite x = x = infinite - let arg_min f a b = - if compare (f a) (f b) <= 0 then a else b - + let arg_min f a b = if compare (f a) (f b) <= 0 then a else b end diff --git a/src/reason-parser/menhir_error_processor.ml b/src/reason-parser/menhir_error_processor.ml index 84b4eee87..d35288b74 100644 --- a/src/reason-parser/menhir_error_processor.ml +++ b/src/reason-parser/menhir_error_processor.ml @@ -1,52 +1,53 @@ (* This file is an executable run at build time to generate a file called - _build/default/src/reason-parser/reason_parser_explain_raw.ml + _build/default/src/reason-parser/reason_parser_explain_raw.ml - That generated file pattern-matches on the error codes that are related to - e.g. accidentally using a reserved keyword as an identifier. Once we get those - error codes, the file reason_parser_explain.ml is run (at parsing time, aka - when you run refmt) and provides a more helpful message for these categories - of errors, than the default "". + That generated file pattern-matches on the error codes that are related to + e.g. accidentally using a reserved keyword as an identifier. Once we get + those error codes, the file reason_parser_explain.ml is run (at parsing time, + aka when you run refmt) and provides a more helpful message for these + categories of errors, than the default "". - Why can't we just check in reason_parser_explain_raw.ml and avoid this build- - time file generation? Because the error code are dependent on the logic - generated by the Menhir parser, and that logic changes when we modify the - parser. Aka, each time we modify the reason_parser, we need to regenerate the - potentially changed error code -*) + Why can't we just check in reason_parser_explain_raw.ml and avoid this build- + time file generation? Because the error code are dependent on the logic + generated by the Menhir parser, and that logic changes when we modify the + parser. Aka, each time we modify the reason_parser, we need to regenerate the + potentially changed error code *) open MenhirSdk -module G = Cmly_read.Read(struct let filename = Sys.argv.(1) end) +module G = Cmly_read.Read (struct + let filename = Sys.argv.(1) + end) + open G let print fmt = Printf.ksprintf print_endline fmt -(* We want to detect any state where an identifier is admissible. - That way, we can assume that if a keyword is used and rejceted, the user was - intending to put an identifier. *) +(* We want to detect any state where an identifier is admissible. That way, we + can assume that if a keyword is used and rejceted, the user was intending to + put an identifier. *) let states_transitioning_on pred = let keep_state lr1 = (* There are two kind of transitions (leading to SHIFT or REDUCE), detect those who accept identifiers *) - List.exists (fun (term, _) -> pred (T term)) (Lr1.reductions lr1 [@alert "-deprecated"]) || - List.exists (fun (sym, _) -> pred sym) (Lr1.transitions lr1) + List.exists + (fun (term, _) -> pred (T term)) + (Lr1.reductions lr1 [@alert "-deprecated"]) + || List.exists (fun (sym, _) -> pred sym) (Lr1.transitions lr1) in (* Now we filter the list of all states and keep the interesting ones *) G.Lr1.fold (fun lr1 acc -> if keep_state lr1 then lr1 :: acc else acc) [] let print_transitions_on name pred = (* Produce a function that will be linked into the reason parser to recognize - states at runtime. - TODO: a more compact encoding could be used, for now we don't care and - just pattern matches on states. - *) + states at runtime. TODO: a more compact encoding could be used, for now we + don't care and just pattern matches on states. *) print "let transitions_on_%s = function" name; - begin match states_transitioning_on pred with - | [] -> prerr_endline ("no states matches " ^ name ^ " predicate"); - | states -> - List.iter (fun lr1 -> print " | %d" (Lr1.to_int lr1)) states; - print " -> true" - end; + (match states_transitioning_on pred with + | [] -> prerr_endline ("no states matches " ^ name ^ " predicate") + | states -> + List.iter (fun lr1 -> print " | %d" (Lr1.to_int lr1)) states; + print " -> true"); print " | _ -> false\n" let terminal_find name = @@ -62,6 +63,6 @@ let () = List.iter (fun term -> let symbol = T (terminal_find term) in - let name = (String.lowercase_ascii term) [@ocaml.warning "-3"] in - print_transitions_on name ((=) symbol)) + let name = (String.lowercase_ascii term [@ocaml.warning "-3"]) in + print_transitions_on name (( = ) symbol)) [ "LIDENT"; "UIDENT"; "SEMI"; "RBRACKET"; "RPAREN"; "RBRACE" ] diff --git a/src/reason-parser/merlin_recovery.ml b/src/reason-parser/merlin_recovery.ml index 8ba08e9f8..7b26216ef 100644 --- a/src/reason-parser/merlin_recovery.ml +++ b/src/reason-parser/merlin_recovery.ml @@ -1,5 +1,5 @@ -let split_pos {Lexing. pos_lnum; pos_bol; pos_cnum; _} = - (pos_lnum, pos_cnum - pos_bol) +let split_pos { Lexing.pos_lnum; pos_bol; pos_cnum; _ } = + pos_lnum, pos_cnum - pos_bol let rev_filter ~f xs = let rec aux f acc = function @@ -32,29 +32,24 @@ module Make | Select of (int -> action list) val depth : int array - val recover : int -> decision - val guide : 'a Parser.symbol -> bool - val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token - val nullable : 'a Parser.nonterminal -> bool end) = struct - - type 'a candidate = { - line: int; - min_col: int; - max_col: int; - env: 'a Parser.env; - } - - type 'a candidates = { - shifted: Parser.xsymbol option; - final: 'a option; - candidates: 'a candidate list; - } + type 'a candidate = + { line : int + ; min_col : int + ; max_col : int + ; env : 'a Parser.env + } + + type 'a candidates = + { shifted : Parser.xsymbol option + ; final : 'a option + ; candidates : 'a candidate list + } module T = struct [@@@ocaml.warning "-37"] @@ -66,6 +61,7 @@ struct | HandlingError of 'a Parser.env | Accepted of 'a | Rejected + external inj : 'a checkpoint -> 'a Parser.checkpoint = "%identity" end @@ -74,21 +70,22 @@ struct | Parser.HandlingError _ | Parser.Rejected -> `Fail | Parser.AboutToReduce _ when not allow_reduction -> `Fail | Parser.Accepted v -> `Accept v - | Parser.Shifting _ | Parser.AboutToReduce _ as checkpoint -> + | (Parser.Shifting _ | Parser.AboutToReduce _) as checkpoint -> aux true (Parser.resume checkpoint) | Parser.InputNeeded env as checkpoint -> `Recovered (checkpoint, env) in aux allow_reduction (Parser.offer (T.inj (T.InputNeeded env)) token) - let rec follow_guide col env = match Parser.top env with + let rec follow_guide col env = + match Parser.top env with | None -> col | Some (Parser.Element (state, _, pos, _)) -> - if Recovery.guide (Parser.incoming_symbol state) then + if Recovery.guide (Parser.incoming_symbol state) + then match Parser.pop env with | None -> col | Some env -> follow_guide (snd (split_pos pos)) env - else - col + else col let candidate env = let line, min_col, max_col = @@ -97,16 +94,17 @@ struct | Some (Parser.Element (state, _, pos, _)) -> let depth = Recovery.depth.(Parser.number state) in let line, col = split_pos pos in - if depth = 0 then - line, col, col + if depth = 0 + then line, col, col else - let col' = match Parser.pop_many depth env with + let col' = + match Parser.pop_many depth env with | None -> max_int | Some env -> - match Parser.top env with + (match Parser.top env with | None -> max_int | Some (Parser.Element (_, _, pos, _)) -> - follow_guide (snd (split_pos pos)) env + follow_guide (snd (split_pos pos)) env) in line, min col col', max col col' in @@ -116,7 +114,8 @@ struct let _, startp, _ = token in let line, col = split_pos startp in let more_indented candidate = - line <> candidate.line && candidate.min_col > col in + line <> candidate.line && candidate.min_col > col + in let recoveries = let rec aux = function | x :: xs when more_indented x -> aux xs @@ -125,8 +124,8 @@ struct aux r.candidates in let same_indented candidate = - line = candidate.line || - (candidate.min_col <= col && col <= candidate.max_col) + line = candidate.line + || (candidate.min_col <= col && col <= candidate.max_col) in let recoveries = let rec aux = function @@ -137,27 +136,26 @@ struct in let rec aux = function | [] -> `Fail - | x :: xs -> match feed_token ~allow_reduction:true token x.env with - | `Fail -> - aux xs + | x :: xs -> + (match feed_token ~allow_reduction:true token x.env with + | `Fail -> aux xs | `Recovered (checkpoint, _) -> `Ok (checkpoint, x.env) - | `Accept v -> - begin match aux xs with - | `Fail -> `Accept v - | x -> x - end + | `Accept v -> (match aux xs with `Fail -> `Accept v | x -> x)) in aux recoveries let decide env = let rec nth_state env n = - if n = 0 then + if n = 0 + then match Parser.top env with | None -> -1 (*allow giving up recovery on empty files*) | Some (Parser.Element (state, _, _, _)) -> Parser.number state else match Parser.pop env with - | None -> assert (n = 1); -1 + | None -> + assert (n = 1); + -1 | Some env -> nth_state env (n - 1) in let st = nth_state env 0 in @@ -169,7 +167,8 @@ struct let generate (type a) (env : a Parser.env) = let module E = struct exception Result of a - end in + end + in let shifted = ref None in let rec aux acc env = match Parser.top env with @@ -177,51 +176,52 @@ struct | Some (Parser.Element (_state, _, _startp, endp)) -> let actions = decide env in let candidate0 = candidate env in - let rec eval (env : a Parser.env) : Recovery.action -> a Parser.env = function - | Recovery.Abort -> - raise Not_found + let rec eval (env : a Parser.env) : Recovery.action -> a Parser.env + = function + | Recovery.Abort -> raise Not_found | Recovery.R prod -> let prod = Parser.find_production prod in Parser.force_reduction prod env | Recovery.S (Parser.N n as sym) -> let xsym = Parser.X sym in - if !shifted = None && not (Recovery.nullable n) then - shifted := Some xsym; - let loc = {Location. loc_start = endp; loc_end = endp; loc_ghost = true} in + if !shifted = None && not (Recovery.nullable n) + then shifted := Some xsym; + let loc = + { Location.loc_start = endp; loc_end = endp; loc_ghost = true } + in let v = Recovery.default_value loc sym in Parser.feed sym endp v endp env | Recovery.S (Parser.T t as sym) -> let xsym = Parser.X sym in if !shifted = None then shifted := Some xsym; - let loc = {Location. loc_start = endp; loc_end = endp; loc_ghost = true} in + let loc = + { Location.loc_start = endp; loc_end = endp; loc_ghost = true } + in let v = Recovery.default_value loc sym in - let token = (Recovery.token_of_terminal t v, endp, endp) in - begin match feed_token ~allow_reduction:true token env with - | `Fail -> assert false - | `Accept v -> raise (E.Result v) - | `Recovered (_,env) -> env - end - | Recovery.Sub actions -> - List.fold_left eval env actions + let token = Recovery.token_of_terminal t v, endp, endp in + (match feed_token ~allow_reduction:true token env with + | `Fail -> assert false + | `Accept v -> raise (E.Result v) + | `Recovered (_, env) -> env) + | Recovery.Sub actions -> List.fold_left eval env actions in - match - rev_scan_left [] ~f:eval ~init:env actions - |> List.map (fun env -> {candidate0 with env}) - with + (match + rev_scan_left [] ~f:eval ~init:env actions + |> List.map (fun env -> { candidate0 with env }) + with | exception Not_found -> None, acc - | exception (E.Result v) -> Some v, acc + | exception E.Result v -> Some v, acc | [] -> None, acc - | (candidate :: _) as candidates -> - aux (candidates @ acc) candidate.env + | candidate :: _ as candidates -> aux (candidates @ acc) candidate.env) in let final, candidates = aux [] env in - (!shifted, final, candidates) + !shifted, final, candidates let generate env = let shifted, final, candidates = generate env in - let candidates = rev_filter candidates - ~f:(fun t -> not (Parser.env_has_default_reduction t.env)) + let candidates = + rev_filter candidates ~f:(fun t -> + not (Parser.env_has_default_reduction t.env)) in - { shifted; final; candidates = (candidate env) :: candidates } - + { shifted; final; candidates = candidate env :: candidates } end diff --git a/src/reason-parser/merlin_recovery.mli b/src/reason-parser/merlin_recovery.mli index 449c2b0a7..883882279 100644 --- a/src/reason-parser/merlin_recovery.mli +++ b/src/reason-parser/merlin_recovery.mli @@ -15,38 +15,29 @@ module Make | Select of (int -> action list) val depth : int array - val can_pop : 'a Parser.terminal -> bool - val recover : int -> decision - val guide : 'a Parser.symbol -> bool - val token_of_terminal : 'a Parser.terminal -> 'a -> Parser.token - val nullable : 'a Parser.nonterminal -> bool - end) : -sig - - type 'a candidate = { - line: int; - min_col: int; - max_col: int; - env: 'a Parser.env; - } - - type 'a candidates = { - shifted: Parser.xsymbol option; - final: 'a option; - candidates: 'a candidate list; - } - - val attempt : 'a candidates -> - Parser.token * Lexing.position * Lexing.position -> - [> `Accept of 'a - | `Fail - | `Ok of 'a Parser.checkpoint * 'a Parser.env ] + end) : sig + type 'a candidate = + { line : int + ; min_col : int + ; max_col : int + ; env : 'a Parser.env + } + + type 'a candidates = + { shifted : Parser.xsymbol option + ; final : 'a option + ; candidates : 'a candidate list + } + + val attempt : + 'a candidates + -> Parser.token * Lexing.position * Lexing.position + -> [> `Accept of 'a | `Fail | `Ok of 'a Parser.checkpoint * 'a Parser.env ] val generate : 'a Parser.env -> 'a candidates - end diff --git a/src/reason-parser/reason_attributes.ml b/src/reason-parser/reason_attributes.ml index 3de647c07..e1f555a04 100644 --- a/src/reason-parser/reason_attributes.ml +++ b/src/reason-parser/reason_attributes.ml @@ -1,70 +1,89 @@ open Ppxlib +type attributesPartition = + { arityAttrs : attributes + ; docAttrs : attributes + ; stdAttrs : attributes + ; jsxAttrs : attributes + ; stylisticAttrs : attributes + ; uncurried : bool + } (** Kinds of attributes *) -type attributesPartition = { - arityAttrs : attributes; - docAttrs : attributes; - stdAttrs : attributes; - jsxAttrs : attributes; - stylisticAttrs : attributes; - uncurried : bool -} (** Partition attributes into kinds *) -let rec partitionAttributes ?(partDoc=false) ?(allowUncurry=true) attrs : attributesPartition = +let rec partitionAttributes ?(partDoc = false) ?(allowUncurry = true) attrs : + attributesPartition + = match attrs with | [] -> - {arityAttrs=[]; docAttrs=[]; stdAttrs=[]; jsxAttrs=[]; stylisticAttrs=[]; uncurried = false} - | ({ attr_name = {txt = ("u" | "bs")}; attr_payload = PStr []; _ } as attr)::atTl -> + { arityAttrs = [] + ; docAttrs = [] + ; stdAttrs = [] + ; jsxAttrs = [] + ; stylisticAttrs = [] + ; uncurried = false + } + | ({ attr_name = { txt = "u" | "bs" }; attr_payload = PStr []; _ } as attr) + :: atTl -> let partition = partitionAttributes ~partDoc ~allowUncurry atTl in - if allowUncurry then - {partition with uncurried = true} - else {partition with stdAttrs=attr::partition.stdAttrs} - | ({ attr_name = {txt="JSX"}; _ } as jsx)::atTl -> + if allowUncurry + then { partition with uncurried = true } + else { partition with stdAttrs = attr :: partition.stdAttrs } + | ({ attr_name = { txt = "JSX" }; _ } as jsx) :: atTl -> let partition = partitionAttributes ~partDoc ~allowUncurry atTl in - {partition with jsxAttrs=jsx::partition.jsxAttrs} - | ({ attr_name = {txt="explicit_arity"}; _} as arity_attr)::atTl - | ({ attr_name = {txt="implicit_arity"}; _} as arity_attr)::atTl -> + { partition with jsxAttrs = jsx :: partition.jsxAttrs } + | ({ attr_name = { txt = "explicit_arity" }; _ } as arity_attr) :: atTl + | ({ attr_name = { txt = "implicit_arity" }; _ } as arity_attr) :: atTl -> let partition = partitionAttributes ~partDoc ~allowUncurry atTl in - {partition with arityAttrs=arity_attr::partition.arityAttrs} - | ({ attr_name = {txt="ocaml.text"}; _} as doc)::atTl when partDoc = true -> + { partition with arityAttrs = arity_attr :: partition.arityAttrs } + | ({ attr_name = { txt = "ocaml.text" }; _ } as doc) :: atTl + when partDoc = true -> let partition = partitionAttributes ~partDoc ~allowUncurry atTl in - {partition with docAttrs=doc::partition.docAttrs} - | ({ attr_name = {txt="ocaml.doc" | "ocaml.text"}; _} as doc)::atTl when partDoc = true -> + { partition with docAttrs = doc :: partition.docAttrs } + | ({ attr_name = { txt = "ocaml.doc" | "ocaml.text" }; _ } as doc) :: atTl + when partDoc = true -> let partition = partitionAttributes ~partDoc ~allowUncurry atTl in - {partition with docAttrs=doc::partition.docAttrs} - | ({ attr_name = {txt="reason.raw_literal"}; _} as attr) :: atTl -> + { partition with docAttrs = doc :: partition.docAttrs } + | ({ attr_name = { txt = "reason.raw_literal" }; _ } as attr) :: atTl -> let partition = partitionAttributes ~partDoc ~allowUncurry atTl in - {partition with stylisticAttrs=attr::partition.stylisticAttrs} - | ({ attr_name = {txt="reason.preserve_braces"}; _} as attr) :: atTl -> + { partition with stylisticAttrs = attr :: partition.stylisticAttrs } + | ({ attr_name = { txt = "reason.preserve_braces" }; _ } as attr) :: atTl -> let partition = partitionAttributes ~partDoc ~allowUncurry atTl in - {partition with stylisticAttrs=attr::partition.stylisticAttrs} - | ({ attr_name = {txt="reason.openSyntaxNotation"}; _} as attr) :: atTl -> + { partition with stylisticAttrs = attr :: partition.stylisticAttrs } + | ({ attr_name = { txt = "reason.openSyntaxNotation" }; _ } as attr) :: atTl + -> let partition = partitionAttributes ~partDoc ~allowUncurry atTl in - {partition with stylisticAttrs=attr::partition.stylisticAttrs} + { partition with stylisticAttrs = attr :: partition.stylisticAttrs } | atHd :: atTl -> let partition = partitionAttributes ~partDoc ~allowUncurry atTl in - {partition with stdAttrs=atHd::partition.stdAttrs} + { partition with stdAttrs = atHd :: partition.stdAttrs } -let extractStdAttrs attrs = - (partitionAttributes attrs).stdAttrs +let extractStdAttrs attrs = (partitionAttributes attrs).stdAttrs let extract_raw_literal attrs = let rec loop acc = function - | { attr_name = {txt="reason.raw_literal"}; - attr_payload = - PStr [{pstr_desc = Pstr_eval({pexp_desc = Pexp_constant(Pconst_string(text, _, None))}, _)}]} + | { attr_name = { txt = "reason.raw_literal" } + ; attr_payload = + PStr + [ { pstr_desc = + Pstr_eval + ( { pexp_desc = Pexp_constant (Pconst_string (text, _, None)) + } + , _ ) + } + ] + } :: rest -> - (Some text, List.rev_append acc rest) - | [] -> (None, List.rev acc) + Some text, List.rev_append acc rest + | [] -> None, List.rev acc | attr :: rest -> loop (attr :: acc) rest in loop [] attrs let without_stylistic_attrs attrs = let rec loop acc = function - | attr :: rest when (partitionAttributes [attr]).stylisticAttrs != [] -> - loop acc rest + | attr :: rest when (partitionAttributes [ attr ]).stylisticAttrs != [] -> + loop acc rest | [] -> List.rev acc | attr :: rest -> loop (attr :: acc) rest in @@ -72,28 +91,27 @@ let without_stylistic_attrs attrs = (* TODO: Make this fast and not filter *) let has_jsx_attributes = - let is_jsx_attribute { attr_name = {txt}; _} = txt = "JSX" in + let is_jsx_attribute { attr_name = { txt }; _ } = txt = "JSX" in fun attrs -> List.exists is_jsx_attribute attrs let has_preserve_braces_attrs = - let is_preserve_braces_attr { attr_name = {txt}; _} = + let is_preserve_braces_attr { attr_name = { txt }; _ } = txt = "reason.preserve_braces" in - fun stylisticAttrs -> - List.exists is_preserve_braces_attr stylisticAttrs + fun stylisticAttrs -> List.exists is_preserve_braces_attr stylisticAttrs let maybe_remove_stylistic_attrs attrs ~should_preserve = - if should_preserve then - attrs + if should_preserve + then attrs else - List.filter (function - | { attr_name = {txt="reason.raw_literal"}; _} -> true - | _ -> false) + List.filter + (function + | { attr_name = { txt = "reason.raw_literal" }; _ } -> true + | _ -> false) attrs let has_open_notation_attr = - let is_open_notation_attr { attr_name = {txt}; _} = + let is_open_notation_attr { attr_name = { txt }; _ } = txt = "reason.openSyntaxNotation" in - fun stylisticAttrs -> - List.exists is_open_notation_attr stylisticAttrs + fun stylisticAttrs -> List.exists is_open_notation_attr stylisticAttrs diff --git a/src/reason-parser/reason_comment.ml b/src/reason-parser/reason_comment.ml index 4ef4a54ce..febcec8ef 100644 --- a/src/reason-parser/reason_comment.ml +++ b/src/reason-parser/reason_comment.ml @@ -8,18 +8,19 @@ let string_of_category = function | EndOfLine -> "End of Line" | SingleLine -> "SingleLine" -type t = { - location: Location.t; - category: category; - text: string; -} +type t = + { location : Location.t + ; category : category + ; text : string + } let category t = t.category - let location t = t.location let dump ppf t = - Format.fprintf ppf "%d (%d:%d)-%d (%d:%d) -- %s:||%s||" + Format.fprintf + ppf + "%d (%d:%d)-%d (%d:%d) -- %s:||%s||" t.location.loc_start.pos_cnum t.location.loc_start.pos_lnum (t.location.loc_start.pos_cnum - t.location.loc_start.pos_bol) @@ -29,8 +30,7 @@ let dump ppf t = (string_of_category t.category) t.text -let dump_list ppf list = - List.iter (Format.fprintf ppf "%a\n" dump) list +let dump_list ppf list = List.iter (Format.fprintf ppf "%a\n" dump) list let wrap t = match t.text with @@ -38,28 +38,26 @@ let wrap t = | txt when Reason_syntax_util.isLineComment txt -> "//" (* single line comments of the form `// comment` have a `\n` at the end *) - ^ (String.sub txt 0 (String.length txt - 1)) + ^ String.sub txt 0 (String.length txt - 1) ^ Reason_syntax_util.EOLMarker.string | txt when txt.[0] = '*' && txt.[1] <> '*' -> - (*CHECK: this comment printing seems fishy. - It apply to invalid docstrings. - In this case, it will add a spurious '*'. - E.g. /** - * bla */ - In an invalid context is turned into - /*** - * bla */ - I think this case should be removed. - *) + (* CHECK: this comment printing seems fishy. + * It apply to invalid docstrings. + * In this case, it will add a spurious '*'. + * E.g. /** + * * bla */ + * In an invalid context is turned into + * /*** + * * bla */ + * I think this case should be removed. + *) "/**" ^ txt ^ "*/" | txt -> "/*" ^ txt ^ "*/" -let is_doc t = - String.length t.text > 0 && t.text.[0] == '*' - -let make ~location category text = - { text; category; location } +let is_doc t = String.length t.text > 0 && t.text.[0] == '*' +let make ~location category text = { text; category; location } -let isLineComment {category; text} = match category with +let isLineComment { category; text } = + match category with | SingleLine -> Reason_syntax_util.isLineComment text | EndOfLine | Regular -> false diff --git a/src/reason-parser/reason_config.ml b/src/reason-parser/reason_config.ml index 158967fcc..551b1c9a5 100644 --- a/src/reason-parser/reason_config.ml +++ b/src/reason-parser/reason_config.ml @@ -1,12 +1,6 @@ -(** - * Copyright (c) 2015-present, Facebook, Inc. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) +(** * Copyright (c) 2015-present, Facebook, Inc. * * This source code is + licensed under the MIT license found in the * LICENSE file in the root + directory of this source tree. *) let recoverable = ref false - -let configure ~r = ( - recoverable := r; -) +let configure ~r = recoverable := r diff --git a/src/reason-parser/reason_errors.ml b/src/reason-parser/reason_errors.ml index 2fcff0b81..393c854e7 100644 --- a/src/reason-parser/reason_errors.ml +++ b/src/reason-parser/reason_errors.ml @@ -1,15 +1,3 @@ -(* There are three main categories of error: - - _lexer errors_, thrown by Reason_lexer when the source **text is malformed** - and no token can be produced - - _concrete parsing errors_, thrown by the menhir parser / parsing loop - when a **token is unexpected** - - _abstract parsing errors_, thrown by hand-written semantic actions or - further AST checks, when the source text was incorrect but this restriction - was too fine to be captured by the grammar rules - - A fourth case is when unknown / unexpected error occurs. -*) - open Ppxlib type lexing_error = @@ -36,69 +24,69 @@ type reason_error = exception Reason_error of reason_error * Location.t -let catch_errors - : (reason_error * Location.t) list ref option ref - = ref None +let catch_errors : (reason_error * Location.t) list ref option ref = ref None let raise_error error loc = match !catch_errors with | None -> raise (Reason_error (error, loc)) | Some caught -> caught := (error, loc) :: !caught -let raise_fatal_error error loc = - raise (Reason_error (error, loc)) +let raise_fatal_error error loc = raise (Reason_error (error, loc)) let recover_non_fatal_errors f = let catch_errors0 = !catch_errors in let errors = ref [] in catch_errors := Some errors; - let result = - match f () with - | x -> Ok x - | exception exn -> Error exn - in + let result = match f () with x -> Ok x | exception exn -> Error exn in catch_errors := catch_errors0; - (result, List.rev !errors) + result, List.rev !errors (* Report lexing errors *) let format_lexing_error ppf = function | Illegal_character c -> - Format.fprintf ppf "Illegal character (%s)" (Char.escaped c) + Format.fprintf ppf "Illegal character (%s)" (Char.escaped c) | Illegal_escape s -> - Format.fprintf ppf "Illegal backslash escape in string or character (%s)" s - | Unterminated_comment _ -> - Format.fprintf ppf "Comment not terminated" - | Unterminated_string -> - Format.fprintf ppf "String literal not terminated" + Format.fprintf ppf "Illegal backslash escape in string or character (%s)" s + | Unterminated_comment _ -> Format.fprintf ppf "Comment not terminated" + | Unterminated_string -> Format.fprintf ppf "String literal not terminated" | Unterminated_string_in_comment (_, loc) -> - Format.fprintf ppf "This comment contains an unterminated string literal@.\ - %aString literal begins here" - Ocaml_util.print_loc loc + Format.fprintf + ppf + "This comment contains an unterminated string literal@.%aString literal \ + begins here" + Ocaml_util.print_loc + loc | Keyword_as_label kwd -> - Format.fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd - | Invalid_literal s -> - Format.fprintf ppf "Invalid literal %s" s + Format.fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd + | Invalid_literal s -> Format.fprintf ppf "Invalid literal %s" s -let format_parsing_error ppf msg = - Format.fprintf ppf "%s" msg +let format_parsing_error ppf msg = Format.fprintf ppf "%s" msg let format_ast_error ppf = function | Not_expecting (loc, nonterm) -> - Format.fprintf ppf + Format.fprintf + ppf "Syntax error: %a%s not expected." - Ocaml_util.print_loc loc nonterm + Ocaml_util.print_loc + loc + nonterm | Applicative_path loc -> - Format.fprintf ppf - "Syntax error: %aapplicative paths of the form F(X).t \ - are not supported when the option -no-app-func is set." - Ocaml_util.print_loc loc + Format.fprintf + ppf + "Syntax error: %aapplicative paths of the form F(X).t are not supported \ + when the option -no-app-func is set." + Ocaml_util.print_loc + loc | Variable_in_scope (loc, var) -> - Format.fprintf ppf "%aIn this scoped type, variable '%s \ - is reserved for the local type %s." - Ocaml_util.print_loc loc var var - | Other_syntax_error msg -> - Format.fprintf ppf "%s" msg + Format.fprintf + ppf + "%aIn this scoped type, variable '%s is reserved for the local type %s." + Ocaml_util.print_loc + loc + var + var + | Other_syntax_error msg -> Format.fprintf ppf "%s" msg let format_error ppf = function | Lexing_error err -> format_lexing_error ppf err @@ -106,8 +94,7 @@ let format_error ppf = function | Ast_error err -> format_ast_error ppf err let report_error ppf ~loc err = - Format.fprintf ppf "@[%a@]@." - (Ocaml_util.print_error loc format_error) err + Format.fprintf ppf "@[%a@]@." (Ocaml_util.print_error loc format_error) err let recover_parser_error f loc msg = if !Reason_config.recoverable @@ -116,52 +103,50 @@ let recover_parser_error f loc msg = let () = Printexc.register_printer (function - | Reason_error (err, loc) -> - let _ = Format.flush_str_formatter () in - report_error Format.str_formatter ~loc err; - Some (Format.flush_str_formatter ()) - | _ -> None - ) - -let str_eval_message text = { - Parsetree. - pstr_loc = Location.none; - pstr_desc = Pstr_eval ( - { pexp_loc = Location.none; - pexp_desc = Pexp_constant (Parsetree.Pconst_string (text, Location.none, None)); - pexp_attributes = []; - pexp_loc_stack = []; - }, - [] - ); -} - -(** Generate a suitable extension node for Merlin's consumption, - for the purposes of reporting a parse error - only used - in recovery mode. - Parse error will prevent Merlin from reporting subsequent errors, as they - might be due wrong recovery decisions and will confuse the user. - *) + | Reason_error (err, loc) -> + let _ = Format.flush_str_formatter () in + report_error Format.str_formatter ~loc err; + Some (Format.flush_str_formatter ()) + | _ -> None) + +let str_eval_message text = + { Parsetree.pstr_loc = Location.none + ; pstr_desc = + Pstr_eval + ( { pexp_loc = Location.none + ; pexp_desc = + Pexp_constant + (Parsetree.Pconst_string (text, Location.none, None)) + ; pexp_attributes = [] + ; pexp_loc_stack = [] + } + , [] ) + } + +(** Generate a suitable extension node for Merlin's consumption, for the + purposes of reporting a parse error - only used in recovery mode. Parse + error will prevent Merlin from reporting subsequent errors, as they might be + due wrong recovery decisions and will confuse the user. *) let error_extension_node_from_recovery loc msg = - recover_parser_error (fun loc msg -> - let str = { Location. loc; txt = "merlin.syntax-error" } in - let payload = [ str_eval_message msg ] in - (str, Parsetree.PStr payload) - ) loc msg - -(** Generate a suitable extension node for OCaml consumption, - for the purposes of reporting a syntax error. - Contrary to [error_extension_node_from_recovery], these work both with - OCaml and with Merlin. - *) + recover_parser_error + (fun loc msg -> + let str = { Location.loc; txt = "merlin.syntax-error" } in + let payload = [ str_eval_message msg ] in + str, Parsetree.PStr payload) + loc + msg + +(** Generate a suitable extension node for OCaml consumption, for the purposes + of reporting a syntax error. Contrary to + [error_extension_node_from_recovery], these work both with OCaml and with + Merlin. *) let error_extension_node loc msg = - recover_parser_error (fun loc msg -> - let str = { Location. loc; txt = "ocaml.error" } in - let payload = [ - str_eval_message msg; - (* if_highlight *) - str_eval_message msg; - ] in - (str, Parsetree.PStr payload) - ) loc msg - + recover_parser_error + (fun loc msg -> + let str = { Location.loc; txt = "ocaml.error" } in + let payload = + [ str_eval_message msg; (* if_highlight *) str_eval_message msg ] + in + str, Parsetree.PStr payload) + loc + msg diff --git a/src/reason-parser/reason_errors.mli b/src/reason-parser/reason_errors.mli index 2a8ac2e6c..0d19e3b5e 100644 --- a/src/reason-parser/reason_errors.mli +++ b/src/reason-parser/reason_errors.mli @@ -1,12 +1,11 @@ -(* There are three main categories of error: - - _lexer errors_, thrown by Reason_lexer when the source **text is malformed** - and no token can be produced - - _concrete parsing errors_, thrown by the menhir parser / parsing loop - when a **token is unexpected** - - _abstract parsing errors_, thrown by hand-written semantic actions or - further AST checks, when the source text was incorrect but this restriction - was too fine to be captured by the grammar rules -*) +(** There are three main categories of error: + - _lexer errors_, thrown by Reason_lexer when the source **text is + malformed** and no token can be produced + - _concrete parsing errors_, thrown by the menhir parser / parsing loop when + a **token is unexpected** + - _abstract parsing errors_, thrown by hand-written semantic actions or + further AST checks, when the source text was incorrect but this + restriction was too fine to be captured by the grammar rules *) open Ppxlib @@ -37,17 +36,24 @@ exception Reason_error of reason_error * Location.t val raise_error : reason_error -> Location.t -> unit val raise_fatal_error : reason_error -> Location.t -> 'a -val recover_non_fatal_errors : (unit -> 'a) -> - ('a, exn) result * (reason_error * Location.t) list +val recover_non_fatal_errors : + (unit -> 'a) + -> ('a, exn) result * (reason_error * Location.t) list val recover_parser_error : - (Location.t -> string -> 'a) -> Location.t -> string -> 'a + (Location.t -> string -> 'a) + -> Location.t + -> string + -> 'a val report_error : Format.formatter -> loc:Location.t -> reason_error -> unit val error_extension_node_from_recovery : - Location.t -> string -> string Location.loc * Parsetree.payload + Location.t + -> string + -> string Location.loc * Parsetree.payload val error_extension_node : - Location.t -> string -> string Location.loc * Parsetree.payload - + Location.t + -> string + -> string Location.loc * Parsetree.payload diff --git a/src/reason-parser/reason_heuristics.ml b/src/reason-parser/reason_heuristics.ml index d2384da89..f501c4928 100644 --- a/src/reason-parser/reason_heuristics.ml +++ b/src/reason-parser/reason_heuristics.ml @@ -3,9 +3,9 @@ open Ppxlib let is_punned_labelled_expression e lbl = match e.pexp_desc with | Pexp_ident { txt } - | Pexp_constraint ({pexp_desc = Pexp_ident { txt }}, _) - | Pexp_coerce ({pexp_desc = Pexp_ident { txt }}, _, _) -> - (Reason_syntax_util.parse_lid lbl) = txt + | Pexp_constraint ({ pexp_desc = Pexp_ident { txt } }, _) + | Pexp_coerce ({ pexp_desc = Pexp_ident { txt } }, _, _) -> + Reason_syntax_util.parse_lid lbl = txt | _ -> false (* We manually check the length of `Thing.map(foo, bar, baz`, @@ -16,49 +16,50 @@ let is_punned_labelled_expression e lbl = * where the sum of the string contents and identifier names are less than the print width *) let funAppCallbackExceedsWidth ~printWidth ~args ~funExpr () = - let funLen = begin match funExpr.pexp_desc with + let funLen = + match funExpr.pexp_desc with | Pexp_ident ident -> - let identList = Longident.flatten_exn ident.txt in - let lengthOfDots = List.length identList - 1 in - let len = List.fold_left (fun acc curr -> - acc + (String.length curr)) lengthOfDots identList in - len + let identList = Longident.flatten_exn ident.txt in + let lengthOfDots = List.length identList - 1 in + let len = + List.fold_left + (fun acc curr -> acc + String.length curr) + lengthOfDots + identList + in + len | _ -> -1 - end in + in (* eats an argument & substract its length from the printWidth * as soon as the print width reaches a sub-zero value, * we know the print width is exceeded & returns *) let rec aux len = function | _ when len < 0 -> true | [] -> false - | arg::args -> - begin match arg with - | (label, ({ pexp_desc = Pexp_ident ident } as e)) -> - let identLen = List.fold_left (fun acc curr -> - acc + (String.length curr) - ) len (Longident.flatten_exn ident.txt) in - begin match label with + | arg :: args -> + (match arg with + | label, ({ pexp_desc = Pexp_ident ident } as e) -> + let identLen = + List.fold_left + (fun acc curr -> acc + String.length curr) + len + (Longident.flatten_exn ident.txt) + in + (match label with | Nolabel -> aux (len - identLen) args | Labelled s when is_punned_labelled_expression e s -> - aux (len - (identLen + 1)) args - | Labelled s -> - aux (len - (identLen + 2 + String.length s)) args - | Optional s -> - aux (len - (identLen + 3 + String.length s)) args - end - | (label, {pexp_desc = Pexp_constant (Pconst_string (str, _, _))}) -> + aux (len - (identLen + 1)) args + | Labelled s -> aux (len - (identLen + 2 + String.length s)) args + | Optional s -> aux (len - (identLen + 3 + String.length s)) args) + | label, { pexp_desc = Pexp_constant (Pconst_string (str, _, _)) } -> let strLen = String.length str in - begin match label with + (match label with | Nolabel -> aux (len - strLen) args - | Labelled s -> - aux (len - (strLen + 2 + String.length s)) args - | Optional s -> - aux (len - (strLen + 3 + String.length s)) args - end + | Labelled s -> aux (len - (strLen + 2 + String.length s)) args + | Optional s -> aux (len - (strLen + 3 + String.length s)) args) | _ -> (* if we encounter a non-string or non-identifier argument exit *) - true - end + true) in aux (printWidth - funLen) args @@ -86,51 +87,50 @@ let singleTokenPatternOmmitTrail txt = String.length txt < 4 *) let bsExprCanBeUncurried expr = match Parsetree.(expr.pexp_desc) with - | Pexp_fun _ - | Pexp_apply _ -> true + | Pexp_fun _ | Pexp_apply _ -> true | _ -> false let isUnderscoreIdent expr = match Parsetree.(expr.pexp_desc) with - | Pexp_ident ({txt = Lident "_"}) -> true + | Pexp_ident { txt = Lident "_" } -> true | _ -> false -let isPipeFirst e = match Parsetree.(e.pexp_desc) with - | Pexp_ident({txt = Longident.Lident("|.")}) -> true - | Pexp_apply( - {pexp_desc = Pexp_ident({txt = Longident.Lident("|.")})}, - _ - ) -> true +let isPipeFirst e = + match Parsetree.(e.pexp_desc) with + | Pexp_ident { txt = Longident.Lident "|." } -> true + | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Longident.Lident "|." } }, _) + -> + true | _ -> false let isUnderscoreApplication expr = match expr with - | {pexp_attributes = []; pexp_desc = Pexp_fun( - Nolabel, - None, - { - ppat_desc = Ppat_var({txt = "__x"}); - ppat_attributes = [] - }, - _ - ) - } -> true + | { pexp_attributes = [] + ; pexp_desc = + Pexp_fun + ( Nolabel + , None + , { ppat_desc = Ppat_var { txt = "__x" }; ppat_attributes = [] } + , _ ) + } -> + true | _ -> false (*
{items->Belt.Array.map(ReasonReact.string)->ReasonReact.array}
; * An application with pipe first inside jsx children requires special treatment. * Jsx children don't allow expression application, hence we need the braces * preserved in this case. *) -let isPipeFirstWithNonSimpleJSXChild e = match Parsetree.(e.pexp_desc) with - | Pexp_apply( - {pexp_desc = Pexp_ident({txt = Longident.Lident("|.")})}, - [Nolabel, {pexp_desc = Pexp_apply(_)}; _] - ) -> true - +let isPipeFirstWithNonSimpleJSXChild e = + match Parsetree.(e.pexp_desc) with + | Pexp_apply + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "|." } } + , [ (Nolabel, { pexp_desc = Pexp_apply _ }); _ ] ) -> + true (* Handle
{url->a(b, _)}
; * underscore sugar needs protection *) - | Pexp_apply( - {pexp_desc = Pexp_ident({txt = Longident.Lident("|.")})}, - [_; Nolabel, fe] - ) when isUnderscoreApplication fe -> true + | Pexp_apply + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "|." } } + , [ _; (Nolabel, fe) ] ) + when isUnderscoreApplication fe -> + true | _ -> false diff --git a/src/reason-parser/reason_layout.ml b/src/reason-parser/reason_layout.ml index 9dccc90d0..3b709496f 100644 --- a/src/reason-parser/reason_layout.ml +++ b/src/reason-parser/reason_layout.ml @@ -7,75 +7,48 @@ type break_criterion = (* Always_rec not only will break, it will break recursively up to the root *) | Always_rec -(* - Modeling separators: - Special ability to render the final separator distinctly. This is so we can - replace them when they do/don't occur next to newlines. +(* Modeling separators: Special ability to render the final separator + distinctly. This is so we can replace them when they do/don't occur next to + newlines. - If sepLeft:true - { - final item1 - sep item2 - sep item3 - } + If sepLeft:true { final item1 sep item2 sep item3 } - If sepLeft:false - { - item1 sep - item2 sep - item3 final - } -*) + If sepLeft:false { item1 sep item2 sep item3 final } *) (* You can't determine the final separator unless you specify a separator *) type separator = | NoSep | Sep of string | SepFinal of string * string -(** - * Module concerning info to correctly interleave whitespace above a layout node. - *) +(** * Module concerning info to correctly interleave whitespace above a layout + node. *) module WhitespaceRegion = struct - type t = { - (* range of the region *) - range: Reason_location.Range.t; - (* inserted comments into the whitespace region *) - comments: Reason_comment.t list; - (* amount of newlines to be interleaved *) - newlines: int; - } - - let make ~range ~newlines () = { - range; - comments = []; - newlines; - } + type t = + { (* range of the region *) + range : Reason_location.Range.t + ; (* inserted comments into the whitespace region *) + comments : Reason_comment.t list + ; (* amount of newlines to be interleaved *) + newlines : int + } + let make ~range ~newlines () = { range; comments = []; newlines } let newlines t = t.newlines let range t = t.range let comments t = t.comments - - let addComment t comment = { t with - comments = comment::t.comments - } - - let modifyNewlines t newNewlines = { t with - newlines = newNewlines - } + let addComment t comment = { t with comments = comment :: t.comments } + let modifyNewlines t newNewlines = { t with newlines = newNewlines } end -(** - * These represent "intent to format" the AST, with some parts being annotated - * with original source location. The benefit of tracking this in an - * intermediate structure, is that we can then interleave comments throughout - * the tree before generating the final representation. That prevents the - * formatting code from having to thread comments everywhere. - * - * The final representation is rendered using Easy_format. - *) +(** * These represent "intent to format" the AST, with some parts being + annotated * with original source location. The benefit of tracking this in + an * intermediate structure, is that we can then interleave comments + throughout * the tree before generating the final representation. That + prevents the * formatting code from having to thread comments everywhere. * + * The final representation is rendered using Easy_format. *) type t = | SourceMap of Location.t * t (* a layout with location info *) - | Sequence of config * (t list) + | Sequence of config * t list | Label of (Easy_format.t -> Easy_format.t -> Easy_format.t) * t * t | Easy of Easy_format.t (* Extra variant representing "intent to interleave whitespace" above a @@ -85,37 +58,37 @@ type t = * have been formatted/inserted. *) | Whitespace of WhitespaceRegion.t * t -and config = { - break: break_criterion; - (* Break setting that becomes activated if a comment becomes interleaved into - * this list. Typically, if not specified, the behavior from [break] will be - * used. - *) - wrap: string * string; - inline: bool * bool; - sep: separator; - indent: int; - sepLeft: bool; - preSpace: bool; - (* Really means space_after_separator *) - postSpace: bool; - pad: bool * bool; - (* A function, because the system might rearrange your previous settings, and - * a function allows you to not be locked into some configuration that is made - * out of date by the formatting system (suppose it removes the separator - * token etc.) Having a function allows you to instruct our formatter how to - * extend the "freshest" notion of the list config when comments are - * interleaved. *) - listConfigIfCommentsInterleaved: (config -> config) option; - - (* Formatting to use if an item in a list had an end-of-line comment appended *) - listConfigIfEolCommentsInterleaved: (config -> config) option; -} +and config = + { break : break_criterion + ; (* Break setting that becomes activated if a comment becomes interleaved into + * this list. Typically, if not specified, the behavior from [break] will be + * used. + *) + wrap : string * string + ; inline : bool * bool + ; sep : separator + ; indent : int + ; sepLeft : bool + ; preSpace : bool + ; (* Really means space_after_separator *) + postSpace : bool + ; pad : bool * bool + ; (* A function, because the system might rearrange your previous settings, and + * a function allows you to not be locked into some configuration that is made + * out of date by the formatting system (suppose it removes the separator + * token etc.) Having a function allows you to instruct our formatter how to + * extend the "freshest" notion of the list config when comments are + * interleaved. *) + listConfigIfCommentsInterleaved : (config -> config) option + ; (* Formatting to use if an item in a list had an end-of-line comment + appended *) + listConfigIfEolCommentsInterleaved : (config -> config) option + } let string_of_easy = function - | Easy_format.Atom (s,_) -> s - | Easy_format.List (_,_) -> "list" - | Easy_format.Label (_,_) -> "label" + | Easy_format.Atom (s, _) -> s + | Easy_format.List (_, _) -> "list" + | Easy_format.Label (_, _) -> "label" | Easy_format.Custom _ -> "custom" let indent_more indent = " " ^ indent @@ -123,34 +96,41 @@ let indent_more indent = " " ^ indent let dump_easy ppf easy = let printf fmt = Format.fprintf ppf fmt in let rec traverse indent = function - | Easy_format.Atom (s,_) -> - printf "%s Atom:'%s'\n" indent s + | Easy_format.Atom (s, _) -> printf "%s Atom:'%s'\n" indent s | Easy_format.List ((opening, sep, closing, config), items) -> - let break = (match config.wrap_body with - | `No_breaks -> "No_breaks" - | `Wrap_atoms -> "Wrap_atoms" - | `Never_wrap -> "Never_wrap" - | `Force_breaks -> "Force_breaks" - | `Force_breaks_rec -> "Force_breaks_rec" - | `Always_wrap -> "Always_wrap") in - printf "%s List: open %s close %s sep %s break %s \n" - indent opening closing sep break; + let break = + match config.wrap_body with + | `No_breaks -> "No_breaks" + | `Wrap_atoms -> "Wrap_atoms" + | `Never_wrap -> "Never_wrap" + | `Force_breaks -> "Force_breaks" + | `Force_breaks_rec -> "Force_breaks_rec" + | `Always_wrap -> "Always_wrap" + in + printf + "%s List: open %s close %s sep %s break %s \n" + indent + opening + closing + sep + break; let _ = List.map (traverse (indent_more indent)) items in () | Easy_format.Label ((left, config), right) -> - let break = match config.label_break with + let break = + match config.label_break with | `Never -> "Never" | `Always_rec -> "Always_rec" | `Auto -> "Auto" - | `Always -> "Always" in + | `Always -> "Always" + in printf "%s Label (break = %s): \n" indent break; printf " %s left \n" indent; let indent' = indent_more indent in traverse indent' left; printf " %s right \n" indent; - traverse indent' right; - | Easy_format.Custom _ -> - printf "custom \n" + traverse indent' right + | Easy_format.Custom _ -> printf "custom \n" in traverse "" easy @@ -158,24 +138,35 @@ let dump ppf layout = let printf fmt = Format.fprintf ppf fmt in let rec traverse indent = function | SourceMap (loc, layout) -> - printf "%s SourceMap [(%d:%d)-(%d:%d)]\n" indent + printf + "%s SourceMap [(%d:%d)-(%d:%d)]\n" + indent loc.loc_start.Lexing.pos_lnum (loc.loc_start.Lexing.pos_cnum - loc.loc_start.Lexing.pos_bol) loc.loc_end.Lexing.pos_lnum (loc.loc_end.Lexing.pos_cnum - loc.loc_end.Lexing.pos_bol); traverse (indent_more indent) layout | Sequence (config, layout_list) -> - let break = match config.break with - | Never -> "Never" - | IfNeed -> "if need" - | Always -> "Always" - | Always_rec -> "Always_rec" in - let sep = match config.sep with + let break = + match config.break with + | Never -> "Never" + | IfNeed -> "if need" + | Always -> "Always" + | Always_rec -> "Always_rec" + in + let sep = + match config.sep with | NoSep -> "NoSep" | Sep s -> "Sep '" ^ s ^ "'" - | SepFinal (s, finalSep) -> "SepFinal ('" ^ s ^ "', '" ^ finalSep ^ "')" in - printf "%s Sequence of %d, sep: %s, stick_to_left: %s break: %s\n" - indent (List.length layout_list) sep (string_of_bool config.sepLeft) break; + | SepFinal (s, finalSep) -> "SepFinal ('" ^ s ^ "', '" ^ finalSep ^ "')" + in + printf + "%s Sequence of %d, sep: %s, stick_to_left: %s break: %s\n" + indent + (List.length layout_list) + sep + (string_of_bool config.sepLeft) + break; List.iter (traverse (indent_more indent)) layout_list | Label (_, left, right) -> printf "%s Label: \n" indent; @@ -183,64 +174,68 @@ let dump ppf layout = let indent' = indent_more (indent_more indent) in traverse indent' left; printf " %s right \n" indent; - traverse indent' right; - | Easy e -> - printf "%s Easy: '%s' \n" indent (string_of_easy e) + traverse indent' right + | Easy e -> printf "%s Easy: '%s' \n" indent (string_of_easy e) | Whitespace (region, sublayout) -> - printf" %s Whitespace (%d) [%d %d]:\n" indent region.newlines region.range.lnum_start region.range.lnum_end; - (traverse (indent_more indent) sublayout) + printf + " %s Whitespace (%d) [%d %d]:\n" + indent + region.newlines + region.range.lnum_start + region.range.lnum_end; + traverse (indent_more indent) sublayout in traverse "" layout -let source_map ?(loc=Location.none) layout = - if loc = Location.none then layout - else SourceMap (loc, layout) +let source_map ?(loc = Location.none) layout = + if loc = Location.none then layout else SourceMap (loc, layout) -let default_list_settings = { - Easy_format.space_after_opening = false; - space_after_separator = false; - space_before_separator = false; - separators_stick_left = true; - space_before_closing = false; - stick_to_label = true; - align_closing = true; - wrap_body = `No_breaks; - indent_body = 0; - list_style = Some "list"; - opening_style = None; - body_style = None; - separator_style = None; - closing_style = None; -} +let default_list_settings = + { Easy_format.space_after_opening = false + ; space_after_separator = false + ; space_before_separator = false + ; separators_stick_left = true + ; space_before_closing = false + ; stick_to_label = true + ; align_closing = true + ; wrap_body = `No_breaks + ; indent_body = 0 + ; list_style = Some "list" + ; opening_style = None + ; body_style = None + ; separator_style = None + ; closing_style = None + } let easy_settings_from_config - { break; wrap; inline; indent; preSpace; postSpace; pad; sep } = - (* TODO: Stop handling separators in Easy_format since we handle most of - them before Easy_format anyways. There's just some that we still rely on - Easy_format for. Easy_format's sep wasn't powerful enough. - *) - let (opn, cls) = wrap in - let (padOpn, padCls) = pad in - let (inlineStart, inlineEnd) = inline in - let sepStr = match sep with NoSep -> "" | Sep s | SepFinal(s, _) -> s in - (opn, sepStr, cls, - { default_list_settings with - Easy_format. - wrap_body = (match break with - | Never -> `No_breaks - (* Yes, `Never_wrap is a horrible name - really means "if needed". *) - | IfNeed -> `Never_wrap - | Always -> `Force_breaks - | Always_rec -> `Force_breaks_rec - ); - indent_body = indent; - space_after_separator = postSpace; - space_before_separator = preSpace; - space_after_opening = padOpn; - space_before_closing = padCls; - stick_to_label = inlineStart; - align_closing = not inlineEnd; - }) + { break; wrap; inline; indent; preSpace; postSpace; pad; sep } + = + (* TODO: Stop handling separators in Easy_format since we handle most of them + before Easy_format anyways. There's just some that we still rely on + Easy_format for. Easy_format's sep wasn't powerful enough. *) + let opn, cls = wrap in + let padOpn, padCls = pad in + let inlineStart, inlineEnd = inline in + let sepStr = match sep with NoSep -> "" | Sep s | SepFinal (s, _) -> s in + ( opn + , sepStr + , cls + , { default_list_settings with + Easy_format.wrap_body = + (match break with + | Never -> `No_breaks + (* Yes, `Never_wrap is a horrible name - really means "if needed". *) + | IfNeed -> `Never_wrap + | Always -> `Force_breaks + | Always_rec -> `Force_breaks_rec) + ; indent_body = indent + ; space_after_separator = postSpace + ; space_before_separator = preSpace + ; space_after_opening = padOpn + ; space_before_closing = padCls + ; stick_to_label = inlineStart + ; align_closing = not inlineEnd + } ) let to_easy_format layout = let rec traverse = function @@ -249,32 +244,29 @@ let to_easy_format layout = Easy_format.List (easy_settings_from_config config, items) | Label (labelFormatter, left, right) -> labelFormatter (traverse left) (traverse right) - | SourceMap (_, subLayout) -> - traverse subLayout + | SourceMap (_, subLayout) -> traverse subLayout | Easy e -> e - | Whitespace (_, subLayout) -> - traverse subLayout + | Whitespace (_, subLayout) -> traverse subLayout in traverse layout -(** [getLocFromLayout] recursively takes the unioned location of its children, - * and returns the max one *) +(** [getLocFromLayout] recursively takes the unioned location of its children, * + and returns the max one *) let get_location layout = let union loc1 loc2 = - match (loc1, loc2) with + match loc1, loc2 with | None, _ -> loc2 | _, None -> loc1 - | Some loc1, Some loc2 -> - Some {loc1 with Location.loc_end = loc2.Location.loc_end} + | Some loc1, Some loc2 -> + Some { loc1 with Location.loc_end = loc2.Location.loc_end } in let rec traverse = function | Sequence (_, subLayouts) -> let locs = List.map traverse subLayouts in List.fold_left union None locs - | Label (_, left, right) -> - union (traverse left) (traverse right) + | Label (_, left, right) -> union (traverse left) (traverse right) | SourceMap (loc, _) -> Some loc - | Whitespace(_, sub) -> traverse sub + | Whitespace (_, sub) -> traverse sub | _ -> None in traverse layout diff --git a/src/reason-parser/reason_lexer.ml b/src/reason-parser/reason_lexer.ml index f68831c02..3c77d62b3 100644 --- a/src/reason-parser/reason_lexer.ml +++ b/src/reason-parser/reason_lexer.ml @@ -2,52 +2,51 @@ open Reason_parser type 'a positioned = 'a * Lexing.position * Lexing.position -type t = { - declarative_lexer_state: Reason_declarative_lexer.state; - lexbuf: Lexing.lexbuf; - mutable comments: (string * Location.t) list; - mutable queued_tokens: token positioned list; - mutable queued_exn: exn option; - mutable last_cnum: int; - mutable completion_ident_offset: int; - completion_ident_pos: Lexing.position -} +type t = + { declarative_lexer_state : Reason_declarative_lexer.state + ; lexbuf : Lexing.lexbuf + ; mutable comments : (string * Location.t) list + ; mutable queued_tokens : token positioned list + ; mutable queued_exn : exn option + ; mutable last_cnum : int + ; mutable completion_ident_offset : int + ; completion_ident_pos : Lexing.position + } let init ?insert_completion_ident lexbuf = let declarative_lexer_state = Reason_declarative_lexer.make () in let completion_ident_offset, completion_ident_pos = match insert_completion_ident with - | None -> (min_int, Lexing.dummy_pos) - | Some pos -> (pos.Lexing.pos_cnum, pos) + | None -> min_int, Lexing.dummy_pos + | Some pos -> pos.Lexing.pos_cnum, pos in - { declarative_lexer_state; lexbuf; - comments = []; - queued_tokens = []; - queued_exn = None; - last_cnum = -1; - completion_ident_offset; - completion_ident_pos; + { declarative_lexer_state + ; lexbuf + ; comments = [] + ; queued_tokens = [] + ; queued_exn = None + ; last_cnum = -1 + ; completion_ident_offset + ; completion_ident_pos } let lexbuf state = state.lexbuf let rec token state = match - Reason_declarative_lexer.token - state.declarative_lexer_state state.lexbuf + Reason_declarative_lexer.token state.declarative_lexer_state state.lexbuf with | COMMENT (s, comment_loc) -> - state.comments <- (s, comment_loc) :: state.comments; - token state + state.comments <- (s, comment_loc) :: state.comments; + token state | tok -> tok (* Routines for manipulating lexer state *) let save_triple lexbuf tok = - (tok, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p) + tok, lexbuf.Lexing.lex_start_p, lexbuf.Lexing.lex_curr_p -let fake_triple t (_, pos, _) = - (t, pos, pos) +let fake_triple t (_, pos, _) = t, pos, pos (* insert ES6_FUN *) @@ -59,47 +58,39 @@ let closing_of = function | _ -> assert false let inject_es6_fun = function - | tok :: acc -> - tok :: fake_triple ES6_FUN tok :: acc + | tok :: acc -> tok :: fake_triple ES6_FUN tok :: acc | _ -> assert false -let is_triggering_token = function - | EQUALGREATER | COLON -> true - | _ -> false +let is_triggering_token = function EQUALGREATER | COLON -> true | _ -> false let rec lex_balanced_step state closing acc tok = let lexbuf = state.lexbuf in let acc = save_triple lexbuf tok :: acc in match tok, closing with - | (RPAREN, RPAREN) | (RBRACE, RBRACE) | (RBRACKET, RBRACKET) -> - acc - | ((RPAREN | RBRACE | RBRACKET | EOF), _) -> + | RPAREN, RPAREN | RBRACE, RBRACE | RBRACKET, RBRACKET -> acc + | (RPAREN | RBRACE | RBRACKET | EOF), _ -> raise (Lex_balanced_failed (acc, None)) - | (( LBRACKET | LBRACKETLESS | LBRACKETGREATER - | LBRACKETAT - | LBRACKETPERCENT | LBRACKETPERCENTPERCENT ), _) -> + | ( ( LBRACKET | LBRACKETLESS | LBRACKETGREATER | LBRACKETAT | LBRACKETPERCENT + | LBRACKETPERCENTPERCENT ) + , _ ) -> lex_balanced state closing (lex_balanced state RBRACKET acc) - | ((LPAREN | LBRACE), _) -> + | (LPAREN | LBRACE), _ -> let rparen = - try lex_balanced state (closing_of tok) [] - with (Lex_balanced_failed (rparen, None)) -> + try lex_balanced state (closing_of tok) [] with + | Lex_balanced_failed (rparen, None) -> raise (Lex_balanced_failed (rparen @ acc, None)) in - begin match token state with - | exception exn -> - raise (Lex_balanced_failed (rparen @ acc, Some exn)) + (match token state with + | exception exn -> raise (Lex_balanced_failed (rparen @ acc, Some exn)) | tok' -> let acc = if is_triggering_token tok' then inject_es6_fun acc else acc in - lex_balanced_step state closing (rparen @ acc) tok' - end - | ((LIDENT _ | UNDERSCORE), _) -> - begin match token state with - | exception exn -> - raise (Lex_balanced_failed (acc, Some exn)) + lex_balanced_step state closing (rparen @ acc) tok') + | (LIDENT _ | UNDERSCORE), _ -> + (match token state with + | exception exn -> raise (Lex_balanced_failed (acc, Some exn)) | tok' -> let acc = if is_triggering_token tok' then inject_es6_fun acc else acc in - lex_balanced_step state closing acc tok' - end + lex_balanced_step state closing acc tok') (* `...` with a closing `}` indicates that we're definitely not in an es6_fun * Image the following: * true ? (Update({...a, b: 1}), None) : x; @@ -113,37 +104,35 @@ let rec lex_balanced_step state closing acc tok = * We exit here, to indicate that an expression needs to be parsed instead * of a pattern. *) - | (DOTDOTDOT, RBRACE) -> acc + | DOTDOTDOT, RBRACE -> acc | _ -> lex_balanced state closing acc and lex_balanced state closing acc = match token state with - | exception exn -> - raise (Lex_balanced_failed (acc, Some exn)) + | exception exn -> raise (Lex_balanced_failed (acc, Some exn)) | tok -> lex_balanced_step state closing acc tok -let lookahead_esfun state (tok, _, _ as lparen) = +let lookahead_esfun state ((tok, _, _) as lparen) = match lex_balanced state (closing_of tok) [] with - | exception (Lex_balanced_failed (tokens, exn)) -> - state.queued_tokens <- List.rev tokens; - state.queued_exn <- exn; - lparen + | exception Lex_balanced_failed (tokens, exn) -> + state.queued_tokens <- List.rev tokens; + state.queued_exn <- exn; + lparen | tokens -> - begin match token state with - | exception exn -> + (match token state with + | exception exn -> + state.queued_tokens <- List.rev tokens; + state.queued_exn <- Some exn; + lparen + | token -> + let tokens = save_triple state.lexbuf token :: tokens in + if is_triggering_token token + then ( + state.queued_tokens <- lparen :: List.rev tokens; + fake_triple ES6_FUN lparen) + else ( state.queued_tokens <- List.rev tokens; - state.queued_exn <- Some exn; - lparen - | token -> - let tokens = save_triple state.lexbuf token :: tokens in - if is_triggering_token token then ( - state.queued_tokens <- lparen :: List.rev tokens; - fake_triple ES6_FUN lparen - ) else ( - state.queued_tokens <- List.rev tokens; - lparen - ) - end + lparen)) let token state = let lexbuf = state.lexbuf in @@ -151,54 +140,50 @@ let token state = | [], Some exn -> state.queued_exn <- None; raise exn - | [(LPAREN, _, _) as lparen], None -> - lookahead_esfun state lparen - | [(LBRACE, _, _) as lparen], None -> - lookahead_esfun state lparen + | [ ((LPAREN, _, _) as lparen) ], None -> lookahead_esfun state lparen + | [ ((LBRACE, _, _) as lparen) ], None -> lookahead_esfun state lparen | [], None -> - begin match token state with - | LPAREN | LBRACE as tok -> - lookahead_esfun state (save_triple state.lexbuf tok) + (match token state with + | (LPAREN | LBRACE) as tok -> + lookahead_esfun state (save_triple state.lexbuf tok) | (LIDENT _ | UNDERSCORE) as tok -> - let tok = save_triple lexbuf tok in - begin match token state with - | exception exn -> - state.queued_exn <- Some exn; - tok - | tok' -> - if is_triggering_token tok' then ( - state.queued_tokens <- [tok; save_triple lexbuf tok']; - fake_triple ES6_FUN tok - ) else ( - state.queued_tokens <- [save_triple lexbuf tok']; - tok - ) - end - | token -> save_triple lexbuf token - end + let tok = save_triple lexbuf tok in + (match token state with + | exception exn -> + state.queued_exn <- Some exn; + tok + | tok' -> + if is_triggering_token tok' + then ( + state.queued_tokens <- [ tok; save_triple lexbuf tok' ]; + fake_triple ES6_FUN tok) + else ( + state.queued_tokens <- [ save_triple lexbuf tok' ]; + tok)) + | token -> save_triple lexbuf token) | x :: xs, _ -> - state.queued_tokens <- xs; x + state.queued_tokens <- xs; + x let token state = let space_start = state.last_cnum in - let (token', start_p, curr_p) as token = token state in + let ((token', start_p, curr_p) as token) = token state in let token_start = start_p.Lexing.pos_cnum in let token_stop = curr_p.Lexing.pos_cnum in state.last_cnum <- token_stop; - if state.completion_ident_offset > min_int && - space_start <= state.completion_ident_offset && - token_stop >= state.completion_ident_offset then ( + if state.completion_ident_offset > min_int + && space_start <= state.completion_ident_offset + && token_stop >= state.completion_ident_offset + then ( match token' with - | LIDENT _ | UIDENT _ - when token_start <= state.completion_ident_offset -> + | (LIDENT _ | UIDENT _) when token_start <= state.completion_ident_offset -> state.completion_ident_offset <- min_int; token | _ -> state.queued_tokens <- token :: state.queued_tokens; state.completion_ident_offset <- min_int; - (LIDENT "_", state.completion_ident_pos, state.completion_ident_pos) - ) else - token + LIDENT "_", state.completion_ident_pos, state.completion_ident_pos) + else token type comment = string * Location.t type invalid_docstrings = comment list @@ -206,16 +191,15 @@ type invalid_docstrings = comment list let empty_invalid_docstrings = [] let add_invalid_docstring text loc_start loc_end invalid_docstrings = - let loc = {Location. loc_start; loc_end; loc_ghost = false} in - ((text, loc) :: invalid_docstrings) + let loc = { Location.loc_start; loc_end; loc_ghost = false } in + (text, loc) :: invalid_docstrings let get_comments state invalid_docstrings = let cnum (_, loc) = loc.Location.loc_start.Lexing.pos_cnum in let rec merge_comments acc = function | [], xs | xs, [] -> List.rev_append xs acc - | ((x :: _) as xs), (y :: ys) when cnum x >= cnum y -> + | (x :: _ as xs), y :: ys when cnum x >= cnum y -> merge_comments (y :: acc) (xs, ys) - | x :: xs, ys -> - merge_comments (x :: acc) (xs, ys) + | x :: xs, ys -> merge_comments (x :: acc) (xs, ys) in merge_comments [] (state.comments, invalid_docstrings) diff --git a/src/reason-parser/reason_lexer.mli b/src/reason-parser/reason_lexer.mli index 7b99a849f..cf1064865 100644 --- a/src/reason-parser/reason_lexer.mli +++ b/src/reason-parser/reason_lexer.mli @@ -9,12 +9,16 @@ val lexbuf : t -> Lexing.lexbuf type comment = string * Location.t -(* Some docstrings are not accepted by the parser - and turned into comments. *) +(* Some docstrings are not accepted by the parser and turned into comments. *) type invalid_docstrings + val empty_invalid_docstrings : invalid_docstrings + val add_invalid_docstring : - string -> Lexing.position -> Lexing.position -> - invalid_docstrings -> invalid_docstrings + string + -> Lexing.position + -> Lexing.position + -> invalid_docstrings + -> invalid_docstrings val get_comments : t -> invalid_docstrings -> comment list diff --git a/src/reason-parser/reason_location.ml b/src/reason-parser/reason_location.ml index 870d21336..caad2353a 100644 --- a/src/reason-parser/reason_location.ml +++ b/src/reason-parser/reason_location.ml @@ -1,63 +1,47 @@ module Range = struct - (** [t] represents an interval, including endpoints, - * delimited by two linenumbers. *) - type t = { - lnum_start: int; - lnum_end: int - } + type t = + { lnum_start : int + ; lnum_end : int + } + (** [t] represents an interval, including endpoints, * delimited by two + linenumbers. *) - (** - * make a range delimited by [loc1] and [loc2] - * 1| let a = 1; - * 2| - * 3| - * 4| - * 5| let b = 2; - * If loc1 represents `let a = 1` and loc2 represents `let b = 2`, - * we get the range: {lnum_start: 2; lnum_end 4} - *) - let makeRangeBetween loc1 loc2 = Location.{ - lnum_start = loc1.loc_end.pos_lnum + 1; - lnum_end = loc2.loc_start.pos_lnum - 1; - } + (** * make a range delimited by [loc1] and [loc2] * 1| let a = 1; * 2| * 3| * + 4| * 5| let b = 2; * If loc1 represents `let a = 1` and loc2 represents + `let b = 2`, * we get the range: \{lnum_start: 2; lnum_end 4\} *) + let makeRangeBetween loc1 loc2 = + Location. + { lnum_start = loc1.loc_end.pos_lnum + 1 + ; lnum_end = loc2.loc_start.pos_lnum - 1 + } (** check whether [range] contains the [loc] *) - let containsLoc range (loc: Location.t) = + let containsLoc range (loc : Location.t) = range.lnum_start <= loc.loc_start.pos_lnum && range.lnum_end >= loc.loc_end.pos_lnum - (** - * checks if [range] contains whitespace. - * When comments are passed, the computation - * takes the height of the comments into account. - * - * Example: - * 1| let a = 1; - * 2| - * 3| /* a multi- - * 4| line comment */ - * 5| let b = 1; - * The range (line 2 - line 4) has whitespace. - * - * 1| let a = 1; - * 2| /* a multi- - * 3| line comment */ - * 4| let b = 1; - * The range (line 2 - line 3) does not have whitespace. - *) + (** * checks if [range] contains whitespace. * When comments are passed, the + computation * takes the height of the comments into account. * * Example: + * 1| let a = 1; * 2| * 3| /* a multi- * 4| line comment */ * 5| let b = 1; + * The range (line 2 - line 4) has whitespace. * * 1| let a = 1; * 2| /* a + multi- * 3| line comment */ * 4| let b = 1; * The range (line 2 - line 3) + does not have whitespace. *) let containsWhitespace ?comments ~range () = (* compute the amount of lines the comments occupy in the given range *) - let h = match comments with - | Some(comments) -> - List.fold_left (fun acc (curr : Reason_comment.t) -> - let cl = Reason_comment.location curr in - let startLnum = cl.loc_start.pos_lnum in - let endLnum = cl.loc_end.pos_lnum in - if containsLoc range cl then - acc + (endLnum - startLnum + 1) - else acc - ) 0 comments - | None -> 0 + let h = + match comments with + | Some comments -> + List.fold_left + (fun acc (curr : Reason_comment.t) -> + let cl = Reason_comment.location curr in + let startLnum = cl.loc_start.pos_lnum in + let endLnum = cl.loc_end.pos_lnum in + if containsLoc range cl + then acc + (endLnum - startLnum + 1) + else acc) + 0 + comments + | None -> 0 in range.lnum_end - range.lnum_start - h >= 0 end @@ -65,4 +49,3 @@ end (** compute if there's space (one or more line) between [loc1] and [loc2] *) let hasSpaceBetween loc1 loc2 = Location.(loc1.loc_start.pos_lnum - loc2.loc_end.pos_lnum) > 1 - diff --git a/src/reason-parser/reason_multi_parser.ml b/src/reason-parser/reason_multi_parser.ml index 6408700c7..fbb7fdb8c 100644 --- a/src/reason-parser/reason_multi_parser.ml +++ b/src/reason-parser/reason_multi_parser.ml @@ -2,8 +2,7 @@ module S = Reason_single_parser type 'a parser = 'a S.parser list -let initial entry_point position = - [S.initial entry_point position] +let initial entry_point position = [ S.initial entry_point position ] type 'a step = | Intermediate of 'a parser @@ -13,56 +12,45 @@ type 'a step = let rec fork token = function | [] -> [] | x :: xs -> - begin match S.step x token with + (match S.step x token with | S.Intermediate x' -> x :: x' :: fork token xs - | _ -> x :: fork token xs - end + | _ -> x :: fork token xs) let rec progress_successful token acc = function | [] -> Intermediate (List.rev acc) | x :: xs -> - begin match S.step x token with - | S.Intermediate p -> - progress_successful token (p :: acc) xs - | S.Error -> - progress_successful token acc xs - | S.Success (result, ds) -> Success (result, ds) - end + (match S.step x token with + | S.Intermediate p -> progress_successful token (p :: acc) xs + | S.Error -> progress_successful token acc xs + | S.Success (result, ds) -> Success (result, ds)) let step parsers token = match token with - | (Reason_parser.ES6_FUN, _, _) -> + | Reason_parser.ES6_FUN, _, _ -> (* Fork case *) Intermediate (fork token parsers) | _ -> (* Regular case *) - match parsers with - | [x] -> + (match parsers with + | [ x ] -> (* Fast-path: One parser *) - begin match S.step x token with - | S.Intermediate parser -> Intermediate [parser] - | S.Success (result, ds) -> Success (result, ds) - | S.Error -> Error - end + (match S.step x token with + | S.Intermediate parser -> Intermediate [ parser ] + | S.Success (result, ds) -> Success (result, ds) + | S.Error -> Error) (* Parallel parsing case *) | x :: xs -> - begin match S.step x token with - | S.Intermediate p -> progress_successful token [p] xs - | S.Success (result, ds) -> Success (result, ds) - | S.Error -> - begin match progress_successful token [] xs with - | Intermediate [] -> Error - | result -> result - end - end + (match S.step x token with + | S.Intermediate p -> progress_successful token [ p ] xs + | S.Success (result, ds) -> Success (result, ds) + | S.Error -> + (match progress_successful token [] xs with + | Intermediate [] -> Error + | result -> result)) (* Impossible case *) - | [] -> assert false + | [] -> assert false) (* Interface for recovery *) -let recover cp ds = - [S.recover cp ds] - -let recovery_env = function - | [] -> assert false - | x :: _xs -> S.recovery_env x +let recover cp ds = [ S.recover cp ds ] +let recovery_env = function [] -> assert false | x :: _xs -> S.recovery_env x diff --git a/src/reason-parser/reason_multi_parser.mli b/src/reason-parser/reason_multi_parser.mli index f9c1853a5..47b700928 100644 --- a/src/reason-parser/reason_multi_parser.mli +++ b/src/reason-parser/reason_multi_parser.mli @@ -1,8 +1,9 @@ type 'a parser val initial : - (Lexing.position -> 'a Reason_parser.MenhirInterpreter.checkpoint) -> - Lexing.position -> 'a parser + (Lexing.position -> 'a Reason_parser.MenhirInterpreter.checkpoint) + -> Lexing.position + -> 'a parser type 'a step = | Intermediate of 'a parser @@ -14,10 +15,10 @@ val step : 'a parser -> Reason_parser.token Reason_lexer.positioned -> 'a step (* Interface for recovery *) val recover : - 'a Reason_parser.MenhirInterpreter.checkpoint -> - Reason_lexer.invalid_docstrings -> - 'a parser + 'a Reason_parser.MenhirInterpreter.checkpoint + -> Reason_lexer.invalid_docstrings + -> 'a parser val recovery_env : - 'a parser -> - 'a Reason_parser.MenhirInterpreter.env * Reason_lexer.invalid_docstrings + 'a parser + -> 'a Reason_parser.MenhirInterpreter.env * Reason_lexer.invalid_docstrings diff --git a/src/reason-parser/reason_oprint.ml b/src/reason-parser/reason_oprint.ml index f1d7a9f1c..15119754d 100644 --- a/src/reason-parser/reason_oprint.ml +++ b/src/reason-parser/reason_oprint.ml @@ -46,43 +46,40 @@ *) (* Hello! Welcome to the Reason "outcome printer" logic. This logic takes the - AST nodes and turn them into text, for Merlin, rtop and terminal errors - reporting to be in Reason syntax. - - If you've navigated around in the Reason codebase, you might have seen the - other printer called reason_pprint_ast, our actual, main pretty-printer. Why - is this one separated from reason_pprint_ast? Because the outcome printer's - use-case is a bit different and needs different entry points blablabla... - These are mostly excuses. But for example, currently, `Js.t({. foo: bar})` by - itself is *invalid syntax* for a pretty printer (the correct, minimal valid - code would be `type myObject = Js.t({. foo: bar})`), but the terminal error - report do want to provide just that snippet and have you print it. Hopefully - OCaml can unify actual code pretty-printing and terminal type info pretty- - printing one day. - - This also means the outcome printer doesn't use the normal Parsetree, - Ast_helper and others you might have seen in other files. It has its own - small AST definition here: - https://github.com/ocaml/ocaml/blob/4.04/typing/outcometree.mli - - The rest of this file's logic is just pattern-matching on these tree node - variants & using Format to pretty-print them nicely. - *) + AST nodes and turn them into text, for Merlin, rtop and terminal errors + reporting to be in Reason syntax. -(* - This file's shared between the Reason repo and the BuckleScript repo. In - Reason, it's in src/reason-parser/. In BuckleScript, it's in - jscomp/outcome_printer/. We periodically copy this file from Reason (the - source of truth) to BuckleScript, then uncomment the #if #else #end cppo - macros you see in the file. That's because BuckleScript's on OCaml 4.02 while - Reason's on 4.04; so the #if macros surround the pieces of code that are - different between the two compilers. - - When you modify this file, please make sure you're not dragging in too many - things. You don't necessarily have to test the file on both Reason and - BuckleScript; ping @chenglou and a few others and we'll keep them synced up by - patching the right parts, through the power of types(tm) -*) + If you've navigated around in the Reason codebase, you might have seen the + other printer called reason_pprint_ast, our actual, main pretty-printer. Why + is this one separated from reason_pprint_ast? Because the outcome printer's + use-case is a bit different and needs different entry points blablabla... + These are mostly excuses. But for example, currently, `Js.t({. foo: bar})` by + itself is *invalid syntax* for a pretty printer (the correct, minimal valid + code would be `type myObject = Js.t({. foo: bar})`), but the terminal error + report do want to provide just that snippet and have you print it. Hopefully + OCaml can unify actual code pretty-printing and terminal type info pretty- + printing one day. + + This also means the outcome printer doesn't use the normal Parsetree, + Ast_helper and others you might have seen in other files. It has its own + small AST definition here: + https://github.com/ocaml/ocaml/blob/4.04/typing/outcometree.mli + + The rest of this file's logic is just pattern-matching on these tree node + variants & using Format to pretty-print them nicely. *) + +(* This file's shared between the Reason repo and the BuckleScript repo. In + Reason, it's in src/reason-parser/. In BuckleScript, it's in + jscomp/outcome_printer/. We periodically copy this file from Reason (the + source of truth) to BuckleScript, then uncomment the #if #else #end cppo + macros you see in the file. That's because BuckleScript's on OCaml 4.02 while + Reason's on 4.04; so the #if macros surround the pieces of code that are + different between the two compilers. + + When you modify this file, please make sure you're not dragging in too many + things. You don't necessarily have to test the file on both Reason and + BuckleScript; ping @chenglou and a few others and we'll keep them synced up + by patching the right parts, through the power of types(tm) *) open Format module Reason_ast = Reason_omp.Ast_414 @@ -91,78 +88,81 @@ open Outcometree exception Ellipsis -let cautious f ppf arg = - try f ppf arg with - Ellipsis -> fprintf ppf "..." +let cautious f ppf arg = try f ppf arg with Ellipsis -> fprintf ppf "..." -let rec print_ident ppf = - function - Oide_ident s -> pp_print_string ppf s.printed_name +let rec print_ident ppf = function + | Oide_ident s -> pp_print_string ppf s.printed_name | Oide_dot (id, s) -> - print_ident ppf id; pp_print_char ppf '.'; pp_print_string ppf s + print_ident ppf id; + pp_print_char ppf '.'; + pp_print_string ppf s | Oide_apply (id1, id2) -> - fprintf ppf "%a(%a)" print_ident id1 print_ident id2 + fprintf ppf "%a(%a)" print_ident id1 print_ident id2 let parenthesized_ident name = - (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]) + List.mem name [ "or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr" ] || - (match name.[0] with - 'a'..'z' | 'A'..'Z' | '\223'..'\246' | '\248'..'\255' | '_' -> - false - | _ -> true) + match name.[0] with + | 'a' .. 'z' | 'A' .. 'Z' | '\223' .. '\246' | '\248' .. '\255' | '_' -> false + | _ -> true let value_ident ppf name = - if parenthesized_ident name then - fprintf ppf "( %s )" (Reason_syntax_util.ml_to_reason_swap name) - else - pp_print_string ppf name + if parenthesized_ident name + then fprintf ppf "( %s )" (Reason_syntax_util.ml_to_reason_swap name) + else pp_print_string ppf name (* Values *) let valid_float_lexeme s = let l = String.length s in let rec loop i = - if i >= l then s ^ "." else - match s.[i] with - | '0' .. '9' | '-' -> loop (i+1) - | _ -> s - in loop 0 + if i >= l + then s ^ "." + else match s.[i] with '0' .. '9' | '-' -> loop (i + 1) | _ -> s + in + loop 0 let float_repres f = match classify_float f with - FP_nan -> "nan" - | FP_infinite -> - if f < 0.0 then "neg_infinity" else "infinity" + | FP_nan -> "nan" + | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" | _ -> - let float_val = - let s1 = Printf.sprintf "%.12g" f in - if f = float_of_string s1 then s1 else + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = float_of_string s1 + then s1 + else let s2 = Printf.sprintf "%.15g" f in - if f = float_of_string s2 then s2 else - Printf.sprintf "%.18g" f - in valid_float_lexeme float_val + if f = float_of_string s2 then s2 else Printf.sprintf "%.18g" f + in + valid_float_lexeme float_val let parenthesize_if_neg ppf fmt v isneg = if isneg then pp_print_char ppf '('; fprintf ppf fmt v; if isneg then pp_print_char ppf ')' - - let print_out_value ppf tree = - let rec print_tree_1 ppf = - function - (* for the next few cases, please see context at https://github.com/facebook/reason/pull/1516#issuecomment-337069150 *) - | Oval_constr (name, [Oval_constr ((Oide_ident { printed_name = "()" }), [])]) -> + let rec print_tree_1 ppf = function + (* for the next few cases, please see context at + https://github.com/facebook/reason/pull/1516#issuecomment-337069150 *) + | Oval_constr + (name, [ Oval_constr (Oide_ident { printed_name = "()" }, []) ]) -> (* for normal variants, but sugar Foo(()) to Foo() *) - fprintf ppf "@[<1>%a()@]" print_ident name - | Oval_constr (name, [param]) -> + fprintf ppf "@[<1>%a()@]" print_ident name + | Oval_constr (name, [ param ]) -> (* for normal variants *) - fprintf ppf "@[<1>%a(%a)@]" print_ident name print_constr_param param + fprintf ppf "@[<1>%a(%a)@]" print_ident name print_constr_param param | Oval_constr (name, (_ :: _ as params)) -> - fprintf ppf "@[<1>%a(%a)@]" print_ident name - (print_tree_list print_tree_1 ",") params - | Oval_variant (name, Some (Oval_constr ((Oide_ident { printed_name = "()" }), []))) -> + fprintf + ppf + "@[<1>%a(%a)@]" + print_ident + name + (print_tree_list print_tree_1 ",") + params + | Oval_variant + (name, Some (Oval_constr (Oide_ident { printed_name = "()" }, []))) -> (* for polymorphic variants, but sugar `foo(()) to `foo() *) fprintf ppf "@[<2>`%s()@]" name | Oval_variant (name, Some param) -> @@ -176,48 +176,44 @@ let print_out_value ppf tree = | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n) | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0) | tree -> print_simple_tree ppf tree - and print_simple_tree ppf = - function - Oval_int i -> fprintf ppf "%i" i + and print_simple_tree ppf = function + | Oval_int i -> fprintf ppf "%i" i | Oval_int32 i -> fprintf ppf "%lil" i | Oval_int64 i -> fprintf ppf "%LiL" i | Oval_nativeint i -> fprintf ppf "%nin" i | Oval_float f -> pp_print_string ppf (float_repres f) | Oval_char c -> fprintf ppf "%C" c | Oval_string (s, _, _) -> - begin try fprintf ppf "\"%s\"" (Reason_syntax_util.escape_string s) with - Invalid_argument s when s = "String.create" -> fprintf ppf "" - end + (try fprintf ppf "\"%s\"" (Reason_syntax_util.escape_string s) with + | Invalid_argument s when s = "String.create" -> + fprintf ppf "") | Oval_list tl -> - fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ",") tl + fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ",") tl | Oval_array tl -> - fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ",") tl + fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ",") tl | Oval_constr (name, []) -> print_ident ppf name | Oval_variant (name, None) -> fprintf ppf "`%s" name | Oval_stuff s -> pp_print_string ppf s | Oval_record fel -> - fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel + fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel | Oval_ellipsis -> raise Ellipsis | Oval_printer f -> f ppf | Oval_tuple tree_list -> - fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list + fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree - and print_fields first ppf = - function - [] -> () + and print_fields first ppf = function + | [] -> () | (name, tree) :: fields -> - if not first then fprintf ppf ",@ "; - fprintf ppf "@[<1>%a:@ %a@]" print_ident name (cautious print_tree_1) - tree; - print_fields false ppf fields + if not first then fprintf ppf ",@ "; + fprintf ppf "@[<1>%a:@ %a@]" print_ident name (cautious print_tree_1) tree; + print_fields false ppf fields and print_tree_list print_item sep ppf tree_list = - let rec print_list first ppf = - function - [] -> () + let rec print_list first ppf = function + | [] -> () | tree :: tree_list -> - if not first then fprintf ppf "%s@ " sep; - print_item ppf tree; - print_list false ppf tree_list + if not first then fprintf ppf "%s@ " sep; + print_item ppf tree; + print_list false ppf tree_list in cautious (print_list true) ppf tree_list in @@ -225,16 +221,20 @@ let print_out_value ppf tree = (* Types *) -let rec print_list_init pr sep ppf = - function - [] -> () - | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l +let rec print_list_init pr sep ppf = function + | [] -> () + | a :: l -> + sep ppf; + pr ppf a; + print_list_init pr sep ppf l -let rec print_list pr sep ppf = - function - [] -> () - | [a] -> pr ppf a - | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l +let rec print_list pr sep ppf = function + | [] -> () + | [ a ] -> pr ppf a + | a :: l -> + pr ppf a; + sep ppf; + print_list pr sep ppf l let pr_present = print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") @@ -243,601 +243,739 @@ let pr_vars = print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") let get_label lbl = - if lbl = "" then Reason_ast.Asttypes.Nolabel - else if String.get lbl 0 = '?' then - Optional (String.sub lbl 1 @@ String.length lbl - 1) + if lbl = "" + then Reason_ast.Asttypes.Nolabel + else if String.get lbl 0 = '?' + then Optional (String.sub lbl 1 @@ (String.length lbl - 1)) else Labelled lbl let get_arg_suffix ppf lab = match get_label lab with - | Nolabel -> "" - | Labelled lab -> - pp_print_string ppf "~"; - pp_print_string ppf lab; - pp_print_string ppf ": "; - "" - | Optional lab -> - pp_print_string ppf "~"; - pp_print_string ppf lab; - pp_print_string ppf ": "; - "=?" - - -let rec print_out_type ppf = - function - | Otyp_alias (ty, s) -> - fprintf ppf "@[%a@ as '%s@]" print_out_type ty s + | Nolabel -> "" + | Labelled lab -> + pp_print_string ppf "~"; + pp_print_string ppf lab; + pp_print_string ppf ": "; + "" + | Optional lab -> + pp_print_string ppf "~"; + pp_print_string ppf lab; + pp_print_string ppf ": "; + "=?" + +let rec print_out_type ppf = function + | Otyp_alias (ty, s) -> fprintf ppf "@[%a@ as '%s@]" print_out_type ty s | Otyp_poly (sl, ty) -> - fprintf ppf "@[%a.@ %a@]" - pr_vars sl - print_out_type ty - | ty -> - print_out_type_1 ~uncurried:false ppf ty + fprintf ppf "@[%a.@ %a@]" pr_vars sl print_out_type ty + | ty -> print_out_type_1 ~uncurried:false ppf ty and print_arg ppf (lab, typ) = let suffix = get_arg_suffix ppf lab in print_out_type_2 ppf typ; - pp_print_string ppf suffix; - -and print_out_type_1 ~uncurried ppf = - function - (Otyp_arrow _ as x) -> - let rec collect_args acc typ = match typ with - | Otyp_arrow (lbl, ty1, ty2) -> - collect_args ((lbl, ty1)::acc) ty2 - | _ -> (List.rev acc, typ) - in - pp_open_box ppf 0; - let (args, result) = collect_args [] x in - let should_wrap_with_parens = - (* uncurried arguments are always wrapped in parens *) - if uncurried then true - else match args with - | [_, Otyp_tuple _] -> true - | [_, Otyp_arrow _] -> true + pp_print_string ppf suffix + +and print_out_type_1 ~uncurried ppf = function + | Otyp_arrow _ as x -> + let rec collect_args acc typ = + match typ with + | Otyp_arrow (lbl, ty1, ty2) -> collect_args ((lbl, ty1) :: acc) ty2 + | _ -> List.rev acc, typ + in + pp_open_box ppf 0; + let args, result = collect_args [] x in + let should_wrap_with_parens = + (* uncurried arguments are always wrapped in parens *) + if uncurried + then true + else + match args with + | [ (_, Otyp_tuple _) ] -> true + | [ (_, Otyp_arrow _) ] -> true (* single argument should not be wrapped *) - | ["", _] -> false + | [ ("", _) ] -> false | _ -> true - in - if should_wrap_with_parens then pp_print_string ppf "("; - if uncurried then fprintf ppf ".@ "; - print_list print_arg (fun ppf -> fprintf ppf ",@ ") ppf args; - if should_wrap_with_parens then pp_print_string ppf ")"; - - pp_print_string ppf " =>"; - pp_print_space ppf (); - print_out_type_1 ~uncurried ppf result; - pp_close_box ppf () + in + if should_wrap_with_parens then pp_print_string ppf "("; + if uncurried then fprintf ppf ".@ "; + print_list print_arg (fun ppf -> fprintf ppf ",@ ") ppf args; + if should_wrap_with_parens then pp_print_string ppf ")"; + + pp_print_string ppf " =>"; + pp_print_space ppf (); + print_out_type_1 ~uncurried ppf result; + pp_close_box ppf () | ty -> print_out_type_2 ppf ty -and print_out_type_2 ppf = - function - Otyp_tuple tyl -> - fprintf ppf "@[<0>(%a)@]" (print_typlist print_simple_out_type ",") tyl + +and print_out_type_2 ppf = function + | Otyp_tuple tyl -> + fprintf ppf "@[<0>(%a)@]" (print_typlist print_simple_out_type ",") tyl | ty -> print_simple_out_type ppf ty -and print_simple_out_type ppf = - function - Otyp_class (ng, id, tyl) -> - fprintf ppf "@[%s#%a%a@]" (if ng then "_" else "") - print_ident id print_typargs tyl +and print_simple_out_type ppf = function + | Otyp_class (ng, id, tyl) -> + fprintf + ppf + "@[%s#%a%a@]" + (if ng then "_" else "") + print_ident + id + print_typargs + tyl (* BuckleScript-specific external. See the manual for the usage of [@bs]. This - [@bs] is processed into a type that looks like `Js.Internal.fn ...`. This - leaks during error reporting, where the type is printed. Here, we print it - back from `Js.Internal.fn([ `Arity_2 ('c, 'd) ], 'e)` into `('a => 'b => int) [@bs]` *) + [@bs] is processed into a type that looks like `Js.Internal.fn ...`. This + leaks during error reporting, where the type is printed. Here, we print it + back from `Js.Internal.fn([ `Arity_2 ('c, 'd) ], 'e)` into `('a => 'b => + int) [@bs]` *) (* same for `Js.Internal.fn(...)`. Either might shown *) - | Otyp_constr ( - (Oide_dot ( - (Oide_dot - ((Oide_ident { printed_name = "Js" }), "Internal") - | Oide_ident { printed_name = "Js_internal" }), - ("fn" | "meth" as name) - ) as id), - ([Otyp_variant(_, Ovar_fields [variant, _, tys], _, _); result] as tyl) - ) -> - (* Otyp_arrow *) - let make tys result = - if tys = [] then - Otyp_arrow ("", Otyp_constr (Oide_ident { printed_name = "unit" }, []),result) - else - match tys with - | [ Otyp_tuple tys as single] -> - if variant = "Arity_1" then - Otyp_arrow ("", single, result) - else - List.fold_right (fun x acc -> Otyp_arrow ("", x, acc)) tys result - | [single] -> - Otyp_arrow ("", single, result) - | _ -> - raise_notrace Not_found - in - begin match (make tys result) with - | exception _ -> - begin - pp_open_box ppf 0; - print_typargs ppf tyl; - print_ident ppf id; - pp_close_box ppf () - end - | res -> - begin match name with - | "fn" -> print_out_type_1 ~uncurried:true ppf res - | "meth" -> fprintf ppf "@[<0>(%a)@ [@mel.meth]@]" (print_out_type_1 ~uncurried:false) res - | _ -> assert false - end - end - (* also BuckleScript-specific. See the comment in the previous pattern *) - | Otyp_constr ( - (Oide_dot ( - (Oide_dot ((Oide_ident { printed_name = "Js" }), "Internal") - | Oide_ident { printed_name = "Js_internal" }), "meth_callback" ) as id - ), - ([Otyp_variant(_, Ovar_fields [variant, _, tys], _,_); result] as tyl) - ) -> - let make tys result = + | Otyp_constr + ( (Oide_dot + ( ( Oide_dot (Oide_ident { printed_name = "Js" }, "Internal") + | Oide_ident { printed_name = "Js_internal" } ) + , (("fn" | "meth") as name) ) as id) + , ([ Otyp_variant (_, Ovar_fields [ (variant, _, tys) ], _, _); result ] + as tyl) ) -> + (* Otyp_arrow *) + let make tys result = + if tys = [] + then + Otyp_arrow + ("", Otyp_constr (Oide_ident { printed_name = "unit" }, []), result) + else match tys with - | [Otyp_tuple tys as single] -> - if variant = "Arity_1" then - Otyp_arrow ("", single, result) - else - List.fold_right (fun x acc -> Otyp_arrow("", x, acc) ) tys result - | [single] -> - Otyp_arrow ("", single, result) - | _ -> - raise_notrace Not_found - in - begin match (make tys result) with - | exception _ -> - begin - pp_open_box ppf 0; - print_typargs ppf tyl; - print_ident ppf id; - pp_close_box ppf () - end - | res -> - fprintf ppf "@[<0>(%a)@ [@mel.this]@]" (print_out_type_1 ~uncurried:false) res - end - (* also BuckleScript-specific. Turns Js.t({. foo: bar}) into {. "foo": bar} *) - | Otyp_constr ( - (Oide_dot ((Oide_ident { printed_name = "Js" }), "t")), - [Otyp_object (fields, rest)] - ) -> - let dot = match rest with - Some non_gen -> (if non_gen then "_" else "") ^ ".." - | None -> "." - in - fprintf ppf "@[<2>{%s %a}@]" dot (print_object_fields ~quote_fields:true) fields - - | Otyp_constr (id, tyl) -> + | [ (Otyp_tuple tys as single) ] -> + if variant = "Arity_1" + then Otyp_arrow ("", single, result) + else List.fold_right (fun x acc -> Otyp_arrow ("", x, acc)) tys result + | [ single ] -> Otyp_arrow ("", single, result) + | _ -> raise_notrace Not_found + in + (match make tys result with + | exception _ -> pp_open_box ppf 0; + print_typargs ppf tyl; print_ident ppf id; - begin match tyl with - | [] -> () - | _ -> - print_typargs ppf tyl; - end; pp_close_box ppf () + | res -> + (match name with + | "fn" -> print_out_type_1 ~uncurried:true ppf res + | "meth" -> + fprintf + ppf + "@[<0>(%a)@ [@mel.meth]@]" + (print_out_type_1 ~uncurried:false) + res + | _ -> assert false)) + (* also BuckleScript-specific. See the comment in the previous pattern *) + | Otyp_constr + ( (Oide_dot + ( ( Oide_dot (Oide_ident { printed_name = "Js" }, "Internal") + | Oide_ident { printed_name = "Js_internal" } ) + , "meth_callback" ) as id) + , ([ Otyp_variant (_, Ovar_fields [ (variant, _, tys) ], _, _); result ] + as tyl) ) -> + let make tys result = + match tys with + | [ (Otyp_tuple tys as single) ] -> + if variant = "Arity_1" + then Otyp_arrow ("", single, result) + else List.fold_right (fun x acc -> Otyp_arrow ("", x, acc)) tys result + | [ single ] -> Otyp_arrow ("", single, result) + | _ -> raise_notrace Not_found + in + (match make tys result with + | exception _ -> + pp_open_box ppf 0; + print_typargs ppf tyl; + print_ident ppf id; + pp_close_box ppf () + | res -> + fprintf + ppf + "@[<0>(%a)@ [@mel.this]@]" + (print_out_type_1 ~uncurried:false) + res) + (* also BuckleScript-specific. Turns Js.t({. foo: bar}) into {. "foo": bar} *) + | Otyp_constr + ( Oide_dot (Oide_ident { printed_name = "Js" }, "t") + , [ Otyp_object (fields, rest) ] ) -> + let dot = + match rest with + | Some non_gen -> (if non_gen then "_" else "") ^ ".." + | None -> "." + in + fprintf + ppf + "@[<2>{%s %a}@]" + dot + (print_object_fields ~quote_fields:true) + fields + | Otyp_constr (id, tyl) -> + pp_open_box ppf 0; + print_ident ppf id; + (match tyl with [] -> () | _ -> print_typargs ppf tyl); + pp_close_box ppf () | Otyp_object (fields, rest) -> - let dot = match rest with - Some non_gen -> (if non_gen then "_" else "") ^ ".." - | None -> "." + let dot = + match rest with + | Some non_gen -> (if non_gen then "_" else "") ^ ".." + | None -> "." in - fprintf ppf "@[<2>{%s %a}@]" dot (print_object_fields ~quote_fields:false) fields + fprintf + ppf + "@[<2>{%s %a}@]" + dot + (print_object_fields ~quote_fields:false) + fields | Otyp_stuff s -> pp_print_string ppf s | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s | Otyp_variant (non_gen, row_fields, closed, tags) -> - let print_present ppf = - function - None | Some [] -> () - | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l - in - let print_fields ppf = - function - Ovar_fields fields -> - print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") - ppf fields - | Ovar_typ typ -> print_simple_out_type ppf typ - in - fprintf ppf "%s[%s@[@[%a@]%a ]@]" (if non_gen then "_" else "") - (if closed then if tags = None then " " else "< " - else if tags = None then "> " else "? ") - print_fields row_fields - print_present tags - | Otyp_alias _ | Otyp_poly _ as ty -> - fprintf ppf "@[<1>(%a)@]" print_out_type ty; - | Otyp_tuple _ | Otyp_arrow _ as ty -> + let print_present ppf = function + | None | Some [] -> () + | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l + in + let print_fields ppf = function + | Ovar_fields fields -> + print_list + print_row_field + (fun ppf -> fprintf ppf "@;<1 -2>| ") + ppf + fields + | Ovar_typ typ -> print_simple_out_type ppf typ + in + fprintf + ppf + "%s[%s@[@[%a@]%a ]@]" + (if non_gen then "_" else "") + (if closed + then if tags = None then " " else "< " + else if tags = None + then "> " + else "? ") + print_fields + row_fields + print_present + tags + | (Otyp_alias _ | Otyp_poly _) as ty -> + fprintf ppf "@[<1>(%a)@]" print_out_type ty + | (Otyp_tuple _ | Otyp_arrow _) as ty -> (* no parentheses needed; the callsites already wrap these *) - fprintf ppf "@[<1>%a@]" print_out_type ty; - | Otyp_abstract | Otyp_open - | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> () - + fprintf ppf "@[<1>%a@]" print_out_type ty + | Otyp_abstract | Otyp_open | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) + -> + () | Otyp_module (p, ntyls) -> - fprintf ppf "@[<1>(module %a" print_ident p; - let first = ref true in - List.iter - (fun (s, t) -> - let sep = if !first then (first := false; "with") else "and" in - fprintf ppf " %s type %s = %a" sep s print_out_type t) - ntyls; - fprintf ppf ")@]" + fprintf ppf "@[<1>(module %a" print_ident p; + let first = ref true in + List.iter + (fun (s, t) -> + let sep = + if !first + then ( + first := false; + "with") + else "and" + in + fprintf ppf " %s type %s = %a" sep s print_out_type t) + ntyls; + fprintf ppf ")@]" | Otyp_attribute (t, attr) -> - fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name + fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name -and print_object_fields ~quote_fields ppf = - function - [] -> () - | [field, typ] -> - let field = (if quote_fields then "\"" ^ field ^ "\"" else field) in +and print_object_fields ~quote_fields ppf = function + | [] -> () + | [ (field, typ) ] -> + let field = if quote_fields then "\"" ^ field ^ "\"" else field in fprintf ppf "%s: %a" field print_out_type typ; (print_object_fields ~quote_fields) ppf [] | (field, typ) :: rest -> - let field = (if quote_fields then "\"" ^ field ^ "\"" else field) in - fprintf ppf "%s: %a,@ %a" field print_out_type typ (print_object_fields ~quote_fields) rest + let field = if quote_fields then "\"" ^ field ^ "\"" else field in + fprintf + ppf + "%s: %a,@ %a" + field + print_out_type + typ + (print_object_fields ~quote_fields) + rest + and print_row_field ppf (l, opt_amp, tyl) = - let pr_of ppf = - if opt_amp then fprintf ppf " &@ " - else fprintf ppf "" in - let parens = match tyl with - | [ (Otyp_tuple _) ] -> false (* tuples already have parentheses *) + let pr_of ppf = if opt_amp then fprintf ppf " &@ " else fprintf ppf "" in + let parens = + match tyl with + | [ Otyp_tuple _ ] -> false (* tuples already have parentheses *) (* [< `Ok(string & int) ] ----> string & int * [< `Ok(string) ] -----> string *) - | _::_ -> true - | _ -> false in - fprintf ppf "@[`%s%t%s%a%s@]" + | _ :: _ -> true + | _ -> false + in + fprintf + ppf + "@[`%s%t%s%a%s@]" l pr_of (if parens then "(" else "") - (print_typlist print_out_type " &") tyl + (print_typlist print_out_type " &") + tyl (if parens then ")" else "") -and print_typlist print_elem sep ppf = - function - [] -> () - | [ty] -> print_elem ppf ty + +and print_typlist print_elem sep ppf = function + | [] -> () + | [ ty ] -> print_elem ppf ty | ty :: tyl -> - print_elem ppf ty; - pp_print_string ppf sep; - pp_print_space ppf (); - print_typlist print_elem sep ppf tyl -and print_out_wrap_type ppf = - function - | (Otyp_constr (_, _::_)) as ty -> - print_out_type ppf ty + print_elem ppf ty; + pp_print_string ppf sep; + pp_print_space ppf (); + print_typlist print_elem sep ppf tyl + +and print_out_wrap_type ppf = function + | Otyp_constr (_, _ :: _) as ty -> print_out_type ppf ty | ty -> print_simple_out_type ppf ty -and print_typargs ppf = - function - [] -> () - | [ty1] -> - pp_print_string ppf "("; - print_out_wrap_type ppf ty1; - pp_print_string ppf ")" + +and print_typargs ppf = function + | [] -> () + | [ ty1 ] -> + pp_print_string ppf "("; + print_out_wrap_type ppf ty1; + pp_print_string ppf ")" | tyl -> - pp_print_string ppf "("; - pp_open_box ppf 1; - print_typlist print_out_wrap_type "," ppf tyl; - pp_close_box ppf (); - pp_print_string ppf ")" + pp_print_string ppf "("; + pp_open_box ppf 1; + print_typlist print_out_wrap_type "," ppf tyl; + pp_close_box ppf (); + pp_print_string ppf ")" let out_type = ref print_out_type let variance = function - | Reason_omp.Ast_414.Asttypes.NoVariance -> "" - | Covariant -> "+" - | Contravariant -> "-" + | Reason_omp.Ast_414.Asttypes.NoVariance -> "" + | Covariant -> "+" + | Contravariant -> "-" let type_parameter ppf (ty, (var, _)) = - fprintf ppf "%s%s" - (variance var) - (if ty = "_" then ty else "'"^ty) + fprintf ppf "%s%s" (variance var) (if ty = "_" then ty else "'" ^ ty) -let print_out_class_params ppf = - function - [] -> () +let print_out_class_params ppf = function + | [] -> () | tyl -> - fprintf ppf "(@[<1>%a@])@ " - (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) - tyl + fprintf + ppf + "(@[<1>%a@])@ " + (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) + tyl -let rec print_out_class_type ppf = - function - Octy_constr (id, tyl) -> - let pr_tyl ppf = - function - [] -> () - | tyl -> - fprintf ppf "@[<1> %a@]" (print_typlist print_out_wrap_type "") tyl - in - fprintf ppf "@[%a%a@]" print_ident id pr_tyl tyl +let rec print_out_class_type ppf = function + | Octy_constr (id, tyl) -> + let pr_tyl ppf = function + | [] -> () + | tyl -> + fprintf ppf "@[<1> %a@]" (print_typlist print_out_wrap_type "") tyl + in + fprintf ppf "@[%a%a@]" print_ident id pr_tyl tyl | Octy_arrow (lab, argument_type, return_class_type) -> - (* class arrow types need to be printed differently. For one, you can't do: - - class a: a => b - - because due to existing parsing issues, the `a` neds to be wrapped in parens (unlike normal arrow types). - We can change this logic once this is no longer true - *) - let rec print_class_type_arguments_that_might_be_arrow ppf = function - | Otyp_arrow ("", typ1, typ2) -> - fprintf ppf "@[%a,@ %a@]" - print_out_type typ1 - print_class_type_arguments_that_might_be_arrow typ2 - | Otyp_arrow (_, typ1, typ2) -> - fprintf ppf "@[~%s: %a,@ %a@]" - lab - print_out_type typ1 - print_class_type_arguments_that_might_be_arrow typ2 - | argument_not_arrow -> fprintf ppf "%a" print_out_type argument_not_arrow - in - fprintf ppf "@[(%a) =>@ %a@]" - print_class_type_arguments_that_might_be_arrow argument_type - print_out_class_type return_class_type + (* class arrow types need to be printed differently. For one, you can't do: + + class a: a => b + + because due to existing parsing issues, the `a` neds to be wrapped in + parens (unlike normal arrow types). We can change this logic once this is + no longer true *) + let rec print_class_type_arguments_that_might_be_arrow ppf = function + | Otyp_arrow ("", typ1, typ2) -> + fprintf + ppf + "@[%a,@ %a@]" + print_out_type + typ1 + print_class_type_arguments_that_might_be_arrow + typ2 + | Otyp_arrow (_, typ1, typ2) -> + fprintf + ppf + "@[~%s: %a,@ %a@]" + lab + print_out_type + typ1 + print_class_type_arguments_that_might_be_arrow + typ2 + | argument_not_arrow -> fprintf ppf "%a" print_out_type argument_not_arrow + in + fprintf + ppf + "@[(%a) =>@ %a@]" + print_class_type_arguments_that_might_be_arrow + argument_type + print_out_class_type + return_class_type | Octy_signature (self_ty, csil) -> - let pr_param ppf = - function - Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty - | None -> () - in - fprintf ppf "@[@[<2>{%a@]@ %a@;<1 -2>}@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf ";@ ")) - csil -and print_out_class_sig_item ppf = - function - Ocsg_constraint (ty1, ty2) -> - fprintf ppf "@[<2>as %a =@ %a@]" print_out_type ty1 - print_out_type ty2 + let pr_param ppf = function + | Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty + | None -> () + in + fprintf + ppf + "@[@[<2>{%a@]@ %a@;<1 -2>}@]" + pr_param + self_ty + (print_list print_out_class_sig_item (fun ppf -> fprintf ppf ";@ ")) + csil + +and print_out_class_sig_item ppf = function + | Ocsg_constraint (ty1, ty2) -> + fprintf ppf "@[<2>as %a =@ %a@]" print_out_type ty1 print_out_type ty2 | Ocsg_method (name, priv, virt, ty) -> - fprintf ppf "@[<2>%s%s%s:@ %a@]" - (if priv then "pri " else "pub ") (if virt then "virtual " else "") - name print_out_type ty + fprintf + ppf + "@[<2>%s%s%s:@ %a@]" + (if priv then "pri " else "pub ") + (if virt then "virtual " else "") + name + print_out_type + ty | Ocsg_value (name, mut, vr, ty) -> - fprintf ppf "@[<2>val %s%s%s:@ %a@]" - (if mut then "mutable " else "") - (if vr then "virtual " else "") - name print_out_type ty + fprintf + ppf + "@[<2>val %s%s%s:@ %a@]" + (if mut then "mutable " else "") + (if vr then "virtual " else "") + name + print_out_type + ty (* Signature *) let is_rec_next = function - | Osig_class (_, _, _, _, Orec_next)::_ - | Osig_class_type (_, _, _, _, Orec_next)::_ - | Osig_module (_, _, Orec_next)::_ - | Osig_type (_, Orec_next)::_ -> true + | Osig_class (_, _, _, _, Orec_next) :: _ + | Osig_class_type (_, _, _, _, Orec_next) :: _ + | Osig_module (_, _, Orec_next) :: _ + | Osig_type (_, Orec_next) :: _ -> + true | _ -> false -let rec print_out_functor ppf = - function - Omty_functor (None, mty_res) -> - fprintf ppf "() %a" print_out_functor mty_res +let rec print_out_functor ppf = function + | Omty_functor (None, mty_res) -> + fprintf ppf "() %a" print_out_functor mty_res | Omty_functor (Some (name, mty_arg), mty_res) -> - let name = match name with | None -> "_" | Some name -> name in - fprintf ppf "(%s : %a) => %a" name - print_out_module_type mty_arg print_out_functor mty_res + let name = match name with None -> "_" | Some name -> name in + fprintf + ppf + "(%s : %a) => %a" + name + print_out_module_type + mty_arg + print_out_functor + mty_res | m -> fprintf ppf "%a" print_out_module_type m -and print_out_module_type ppf = - function - Omty_abstract -> () - | Omty_functor _ as t -> - fprintf ppf "@[<2>%a@]" print_out_functor t + +and print_out_module_type ppf = function + | Omty_abstract -> () + | Omty_functor _ as t -> fprintf ppf "@[<2>%a@]" print_out_functor t | Omty_ident id -> fprintf ppf "%a" print_ident id | Omty_signature sg -> - fprintf ppf "@[{@ %a@;<1 -2>}@]" print_out_signature sg + fprintf ppf "@[{@ %a@;<1 -2>}@]" print_out_signature sg | Omty_alias id -> fprintf ppf "(module %a)" print_ident id -and print_out_signature ppf = - function - [] -> () - | [item] -> - fprintf ppf "%a;" print_out_sig_item item - | Osig_typext(ext, Oext_first) :: items -> - (* Gather together the extension constructors *) - let rec gather_extensions acc items = - match items with - Osig_typext(ext, Oext_next) :: items -> - gather_extensions - ( { ocstr_name = ext.oext_name; - ocstr_args = ext.oext_args; - ocstr_return_type = ext.oext_ret_type; - } :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, items = + +and print_out_signature ppf = function + | [] -> () + | [ item ] -> fprintf ppf "%a;" print_out_sig_item item + | Osig_typext (ext, Oext_first) :: items -> + (* Gather together the extension constructors *) + let rec gather_extensions acc items = + match items with + | Osig_typext (ext, Oext_next) :: items -> gather_extensions - [ { ocstr_name = ext.oext_name - ; ocstr_args = ext.oext_args - ; ocstr_return_type = ext.oext_ret_type - } ] + ({ ocstr_name = ext.oext_name + ; ocstr_args = ext.oext_args + ; ocstr_return_type = ext.oext_ret_type + } + :: acc) items - in - let te = - { otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - let sep = if is_rec_next items then "" else ";" in - fprintf ppf "%a%s@ %a" print_out_type_extension te sep print_out_signature items + | _ -> List.rev acc, items + in + let exts, items = + gather_extensions + [ { ocstr_name = ext.oext_name + ; ocstr_args = ext.oext_args + ; ocstr_return_type = ext.oext_ret_type + } + ] + items + in + let te = + { otyext_name = ext.oext_type_name + ; otyext_params = ext.oext_type_params + ; otyext_constructors = exts + ; otyext_private = ext.oext_private + } + in + let sep = if is_rec_next items then "" else ";" in + fprintf + ppf + "%a%s@ %a" + print_out_type_extension + te + sep + print_out_signature + items | item :: items -> - let sep = if is_rec_next items then "" else ";" in - fprintf ppf "%a%s@ %a" print_out_sig_item item sep print_out_signature items -and print_out_sig_item ppf = - function - Osig_class (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %s %a@,:@ %a@]" - (if rs = Orec_next then "and" else "class") - (if vir_flag then " virtual" else "") name print_out_class_params params - print_out_class_type clt + let sep = if is_rec_next items then "" else ";" in + fprintf ppf "%a%s@ %a" print_out_sig_item item sep print_out_signature items + +and print_out_sig_item ppf = function + | Osig_class (vir_flag, name, params, clt, rs) -> + fprintf + ppf + "@[<2>%s%s@ %s %a@,:@ %a@]" + (if rs = Orec_next then "and" else "class") + (if vir_flag then " virtual" else "") + name + print_out_class_params + params + print_out_class_type + clt | Osig_class_type (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %s %a@,=@ %a@]" - (if rs = Orec_next then "and" else "class type") - (if vir_flag then " virtual" else "") name print_out_class_params params - print_out_class_type clt + fprintf + ppf + "@[<2>%s%s@ %s %a@,=@ %a@]" + (if rs = Orec_next then "and" else "class type") + (if vir_flag then " virtual" else "") + name + print_out_class_params + params + print_out_class_type + clt | Osig_typext (ext, Oext_exception) -> - fprintf ppf "@[<2>exception %a@]" - print_out_constr - { ocstr_name = ext.oext_name - ; ocstr_args = ext.oext_args - ; ocstr_return_type = ext.oext_ret_type - } - | Osig_typext (ext, _) -> - print_out_extension_constructor ppf ext + fprintf + ppf + "@[<2>exception %a@]" + print_out_constr + { ocstr_name = ext.oext_name + ; ocstr_args = ext.oext_args + ; ocstr_return_type = ext.oext_ret_type + } + | Osig_typext (ext, _) -> print_out_extension_constructor ppf ext | Osig_modtype (name, Omty_abstract) -> - fprintf ppf "@[<2>module type %s@]" name + fprintf ppf "@[<2>module type %s@]" name | Osig_modtype (name, mty) -> - fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty + fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty | Osig_module (name, Omty_alias id, _) -> - fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id + fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id | Osig_module (name, mty, rs) -> - fprintf ppf "@[<2>%s %s:@ %a@]" - (match rs with Orec_not -> "module" - | Orec_first -> "module rec" - | Orec_next -> "and") - name print_out_module_type mty - | Osig_type(td, rs) -> - print_out_type_decl - (match rs with - | Orec_not -> "type nonrec" - | Orec_first -> "type" - | Orec_next -> "and") - ppf td - | Osig_ellipsis -> - fprintf ppf "..." - | Osig_value {oval_name; oval_type; oval_prims; oval_attributes} -> - let printAttributes ppf = List.iter (fun a -> fprintf ppf "[@@%s]" a.oattr_name) in + fprintf + ppf + "@[<2>%s %s:@ %a@]" + (match rs with + | Orec_not -> "module" + | Orec_first -> "module rec" + | Orec_next -> "and") + name + print_out_module_type + mty + | Osig_type (td, rs) -> + print_out_type_decl + (match rs with + | Orec_not -> "type nonrec" + | Orec_first -> "type" + | Orec_next -> "and") + ppf + td + | Osig_ellipsis -> fprintf ppf "..." + | Osig_value { oval_name; oval_type; oval_prims; oval_attributes } -> + let printAttributes ppf = + List.iter (fun a -> fprintf ppf "[@@%s]" a.oattr_name) + in let keyword = if oval_prims = [] then "let" else "external" in - let (hackyBucklescriptExternalAnnotation, rhsValues) = List.partition (fun item -> - (* "BS:" is considered as a bucklescript external annotation, `[@mel.module]` and the sort. - - "What's going on here? Isn't [@mel.foo] supposed to be an attribute in oval_attributes?" - Usually yes. But here, we're intercepting things a little too late. BuckleScript already - finished its pre/post-processing work before we get to print anything. The original - attribute is already gone, replaced by a "BS:asdfasdfasd" thing here. - *) - String.length item >= 4 && item.[0] = 'M' && item.[1] = 'E' && item.[1] = 'L' && item.[3] = ':' - ) oval_prims in - let print_right_hand_side ppf = - function - [] -> () + let hackyBucklescriptExternalAnnotation, rhsValues = + List.partition + (fun item -> + (* "BS:" is considered as a bucklescript external annotation, + `[@mel.module]` and the sort. + + "What's going on here? Isn't [@mel.foo] supposed to be an + attribute in oval_attributes?" Usually yes. But here, we're + intercepting things a little too late. BuckleScript already + finished its pre/post-processing work before we get to print + anything. The original attribute is already gone, replaced by a + "BS:asdfasdfasd" thing here. *) + String.length item >= 4 + && item.[0] = 'M' + && item.[1] = 'E' + && item.[1] = 'L' + && item.[3] = ':') + oval_prims + in + let print_right_hand_side ppf = function + | [] -> () | s :: sl -> - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl + fprintf ppf "@ = \"%s\"" s; + List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl in - fprintf ppf "@[<2>%a%a%s %a:@ %a%a@]" - (fun ppf -> List.iter (fun _ -> fprintf ppf "[@@mel...]@ ")) hackyBucklescriptExternalAnnotation - printAttributes oval_attributes + fprintf + ppf + "@[<2>%a%a%s %a:@ %a%a@]" + (fun ppf -> List.iter (fun _ -> fprintf ppf "[@@mel...]@ ")) + hackyBucklescriptExternalAnnotation + printAttributes + oval_attributes keyword - value_ident oval_name - !out_type oval_type - print_right_hand_side rhsValues + value_ident + oval_name + !out_type + oval_type + print_right_hand_side + rhsValues and print_out_type_decl kwd ppf td = let print_constraints ppf = List.iter (fun (ty1, ty2) -> - fprintf ppf "@ @[<2>constraint %a =@ %a@]" print_out_type ty1 - print_out_type ty2) + fprintf + ppf + "@ @[<2>constraint %a =@ %a@]" + print_out_type + ty1 + print_out_type + ty2) td.otype_cstrs in let type_defined ppf = match td.otype_params with - [] -> pp_print_string ppf td.otype_name - | [param] -> fprintf ppf "@[%s(%a)@]" td.otype_name type_parameter param + | [] -> pp_print_string ppf td.otype_name + | [ param ] -> fprintf ppf "@[%s(%a)@]" td.otype_name type_parameter param | _ -> - fprintf ppf "@[%s(@[%a@])@]" - td.otype_name - (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) - td.otype_params + fprintf + ppf + "@[%s(@[%a@])@]" + td.otype_name + (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) + td.otype_params in - let print_manifest ppf = - function - Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" print_out_type ty + let print_manifest ppf = function + | Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" print_out_type ty | _ -> () in let print_name_params ppf = fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type in let ty = - match td.otype_type with - Otyp_manifest (_, ty) -> ty - | _ -> td.otype_type + match td.otype_type with Otyp_manifest (_, ty) -> ty | _ -> td.otype_type in let print_private ppf = function - Reason_omp.Ast_414.Asttypes.Private -> fprintf ppf " pri" - | Public -> () + | Reason_omp.Ast_414.Asttypes.Private -> fprintf ppf " pri" + | Public -> () in let print_out_tkind ppf = function - | Otyp_abstract -> () - | Otyp_record lbls -> - fprintf ppf " =%a {%a@;<1 -2>}" - print_private td.otype_private - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls - | Otyp_sum constrs -> - fprintf ppf " =%a@;<1 2>%a" - print_private td.otype_private - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - | Otyp_open -> - fprintf ppf " = .." - | ty -> - fprintf ppf " =%a@;<1 2>%a" - print_private td.otype_private - print_out_type ty + | Otyp_abstract -> () + | Otyp_record lbls -> + fprintf + ppf + " =%a {%a@;<1 -2>}" + print_private + td.otype_private + (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) + lbls + | Otyp_sum constrs -> + fprintf + ppf + " =%a@;<1 2>%a" + print_private + td.otype_private + (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) + constrs + | Otyp_open -> fprintf ppf " = .." + | ty -> + fprintf + ppf + " =%a@;<1 2>%a" + print_private + td.otype_private + print_out_type + ty in - fprintf ppf "@[<2>@[%t%a@]%t@]" + fprintf + ppf + "@[<2>@[%t%a@]%t@]" print_name_params - print_out_tkind ty + print_out_tkind + ty print_constraints -and print_out_constr ppf {ocstr_name =name; ocstr_args = tyl; ocstr_return_type = ret_type_opt} = +and print_out_constr + ppf + { ocstr_name = name; ocstr_args = tyl; ocstr_return_type = ret_type_opt } + = match ret_type_opt with | None -> - begin match tyl with - | [] -> - pp_print_string ppf name - | [Otyp_record lbls] -> - fprintf ppf "@[<2>%s({%a@;<1 -2>})@]" name - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls - | _ -> - fprintf ppf "@[<2>%s(%a)@]" name - (print_typlist print_simple_out_type ",") tyl - end + (match tyl with + | [] -> pp_print_string ppf name + | [ Otyp_record lbls ] -> + fprintf + ppf + "@[<2>%s({%a@;<1 -2>})@]" + name + (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) + lbls + | _ -> + fprintf + ppf + "@[<2>%s(%a)@]" + name + (print_typlist print_simple_out_type ",") + tyl) | Some ret_type -> - begin match tyl with - | [] -> - fprintf ppf "@[<2>%s:@ %a@]" name print_simple_out_type ret_type - | [Otyp_record lbls] -> - fprintf ppf "@[<2>%s({%a@;<1 -2>}): %a@]" name - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls - print_simple_out_type ret_type - | _ -> - fprintf ppf "@[<2>%s(%a): %a@]" name - (print_typlist print_simple_out_type ",") tyl - print_simple_out_type ret_type - end - + (match tyl with + | [] -> fprintf ppf "@[<2>%s:@ %a@]" name print_simple_out_type ret_type + | [ Otyp_record lbls ] -> + fprintf + ppf + "@[<2>%s({%a@;<1 -2>}): %a@]" + name + (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) + lbls + print_simple_out_type + ret_type + | _ -> + fprintf + ppf + "@[<2>%s(%a): %a@]" + name + (print_typlist print_simple_out_type ",") + tyl + print_simple_out_type + ret_type) and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s%s:@ %a@]," (if mut then "mutable " else "") name - print_out_type arg + fprintf + ppf + "@[<2>%s%s:@ %a@]," + (if mut then "mutable " else "") + name + print_out_type + arg and print_out_extension_constructor ppf ext = let print_extended_type ppf = let print_type_parameter ppf ty = - fprintf ppf "%s" - (if ty = "_" then ty else "'"^ty) + fprintf ppf "%s" (if ty = "_" then ty else "'" ^ ty) in - match ext.oext_type_params with - [] -> fprintf ppf "%s" ext.oext_type_name - | [ty_param] -> - fprintf ppf "@[%a@ %s@]" - print_type_parameter - ty_param - ext.oext_type_name - | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) - ext.oext_type_params - ext.oext_type_name + match ext.oext_type_params with + | [] -> fprintf ppf "%s" ext.oext_type_name + | [ ty_param ] -> + fprintf ppf "@[%a@ %s@]" print_type_parameter ty_param ext.oext_type_name + | _ -> + fprintf + ppf + "@[(@[%a)@]@ %s@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + ext.oext_type_params + ext.oext_type_name in - fprintf ppf "@[type %t +=%s@;<1 2>%a@]" + fprintf + ppf + "@[type %t +=%s@;<1 2>%a@]" print_extended_type - (if ext.oext_private = Reason_omp.Ast_414.Asttypes.Private then " pri" else "") + (if ext.oext_private = Reason_omp.Ast_414.Asttypes.Private + then " pri" + else "") print_out_constr { ocstr_name = ext.oext_name ; ocstr_args = ext.oext_args @@ -847,24 +985,27 @@ and print_out_extension_constructor ppf ext = and print_out_type_extension ppf te = let print_extended_type ppf = let print_type_parameter ppf ty = - fprintf ppf "%s" - (if ty = "_" then ty else "'"^ty) + fprintf ppf "%s" (if ty = "_" then ty else "'" ^ ty) in match te.otyext_params with - [] -> fprintf ppf "%s" te.otyext_name - | [param] -> - fprintf ppf "@[%a@ %s@]" - print_type_parameter param - te.otyext_name + | [] -> fprintf ppf "%s" te.otyext_name + | [ param ] -> + fprintf ppf "@[%a@ %s@]" print_type_parameter param te.otyext_name | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) - te.otyext_params - te.otyext_name + fprintf + ppf + "@[(@[%a)@]@ %s@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + te.otyext_params + te.otyext_name in - fprintf ppf "@[type %t +=%s@;<1 2>%a@]" + fprintf + ppf + "@[type %t +=%s@;<1 2>%a@]" print_extended_type - (if te.otyext_private = Reason_omp.Ast_414.Asttypes.Private then " pri" else "") + (if te.otyext_private = Reason_omp.Ast_414.Asttypes.Private + then " pri" + else "") (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) te.otyext_constructors @@ -872,51 +1013,56 @@ and print_out_type_extension ppf te = let print_out_exception ppf exn outv = match exn with - Sys.Break -> fprintf ppf "Interrupted.@." + | Sys.Break -> fprintf ppf "Interrupted.@." | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." | Stack_overflow -> - fprintf ppf "Stack overflow during evaluation (looping recursion?).@." + fprintf ppf "Stack overflow during evaluation (looping recursion?).@." | _ -> fprintf ppf "@[Exception:@ %a.@]@." print_out_value outv -let rec print_items ppf = - function - [] -> () - | (Osig_typext(ext, Oext_first), None) :: items -> - (* Gather together extension constructors *) - let rec gather_extensions acc items = - match items with - (Osig_typext(ext, Oext_next), None) :: items -> - gather_extensions - ({ocstr_name = ext.oext_name; ocstr_args = ext.oext_args; ocstr_return_type = ext.oext_ret_type} :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, items = +let rec print_items ppf = function + | [] -> () + | (Osig_typext (ext, Oext_first), None) :: items -> + (* Gather together extension constructors *) + let rec gather_extensions acc items = + match items with + | (Osig_typext (ext, Oext_next), None) :: items -> gather_extensions - [{ ocstr_name = ext.oext_name; ocstr_args = ext.oext_args; ocstr_return_type = ext.oext_ret_type}] + ({ ocstr_name = ext.oext_name + ; ocstr_args = ext.oext_args + ; ocstr_return_type = ext.oext_ret_type + } + :: acc) items - in - let te = - { otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - fprintf ppf "@[%a@]" print_out_type_extension te; - if items <> [] then fprintf ppf "@ %a" print_items items + | _ -> List.rev acc, items + in + let exts, items = + gather_extensions + [ { ocstr_name = ext.oext_name + ; ocstr_args = ext.oext_args + ; ocstr_return_type = ext.oext_ret_type + } + ] + items + in + let te = + { otyext_name = ext.oext_type_name + ; otyext_params = ext.oext_type_params + ; otyext_constructors = exts + ; otyext_private = ext.oext_private + } + in + fprintf ppf "@[%a@]" print_out_type_extension te; + if items <> [] then fprintf ppf "@ %a" print_items items | (tree, valopt) :: items -> - begin match valopt with - Some v -> - fprintf ppf "@[<2>%a =@ %a;@]" print_out_sig_item tree - print_out_value v - | None -> fprintf ppf "@[%a;@]" print_out_sig_item tree - end; - if items <> [] then fprintf ppf "@ %a" print_items items - -let print_out_phrase ppf = - function - Ophr_eval (outv, ty) -> - fprintf ppf "@[- : %a@ =@ %a@]@." print_out_type ty print_out_value outv + (match valopt with + | Some v -> + fprintf ppf "@[<2>%a =@ %a;@]" print_out_sig_item tree print_out_value v + | None -> fprintf ppf "@[%a;@]" print_out_sig_item tree); + if items <> [] then fprintf ppf "@ %a" print_items items + +let print_out_phrase ppf = function + | Ophr_eval (outv, ty) -> + fprintf ppf "@[- : %a@ =@ %a@]@." print_out_type ty print_out_value outv | Ophr_signature [] -> () | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv diff --git a/src/reason-parser/reason_parser_def.mli b/src/reason-parser/reason_parser_def.mli index 17df73b02..813173107 100644 --- a/src/reason-parser/reason_parser_def.mli +++ b/src/reason-parser/reason_parser_def.mli @@ -4,9 +4,9 @@ type labelled_parameter = | Term of Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern | Type of string -type let_bindings = { - lbs_bindings: Parsetree.value_binding list; - lbs_rec: Asttypes.rec_flag; - lbs_extension: (Parsetree.attributes * string Asttypes.loc) option; - lbs_loc: Location.t; -} +type let_bindings = + { lbs_bindings : Parsetree.value_binding list + ; lbs_rec : Asttypes.rec_flag + ; lbs_extension : (Parsetree.attributes * string Asttypes.loc) option + ; lbs_loc : Location.t + } diff --git a/src/reason-parser/reason_parser_explain.ml b/src/reason-parser/reason_parser_explain.ml index ef1890730..7ac2e318d 100644 --- a/src/reason-parser/reason_parser_explain.ml +++ b/src/reason-parser/reason_parser_explain.ml @@ -5,130 +5,146 @@ module Interp = Parser.MenhirInterpreter module Raw = Reason_parser_explain_raw let identlike_keywords = - let reverse_table = lazy ( - let table = Hashtbl.create 7 in - let flip_add k v = Hashtbl.add table v k in - Hashtbl.iter flip_add Reason_declarative_lexer.keyword_table; - table - ) in + let reverse_table = + lazy + (let table = Hashtbl.create 7 in + let flip_add k v = Hashtbl.add table v k in + Hashtbl.iter flip_add Reason_declarative_lexer.keyword_table; + table) + in function - | Parser.SIG -> Some "sig" + | Parser.SIG -> Some "sig" | Parser.MODULE -> Some "module" - | Parser.BEGIN -> Some "begin" - | Parser.END -> Some "end" + | Parser.BEGIN -> Some "begin" + | Parser.END -> Some "end" | Parser.OBJECT -> Some "object" | Parser.SWITCH -> Some "switch" - | Parser.TO -> Some "to" - | Parser.THEN -> Some "then" - | Parser.TYPE -> Some "type" + | Parser.TO -> Some "to" + | Parser.THEN -> Some "then" + | Parser.TYPE -> Some "type" | token -> - match Hashtbl.find (Lazy.force reverse_table) token with + (match Hashtbl.find (Lazy.force reverse_table) token with | name -> Some name - | exception Not_found -> None + | exception Not_found -> None) let keyword_confused_with_ident state token = match identlike_keywords token with - | Some name when Raw.transitions_on_lident state - || Raw.transitions_on_uident state -> - (name ^ " is a reserved keyword, it cannot be used as an identifier. Try `" ^ name ^ "_` or `_" ^ name ^ "` instead") + | Some name + when Raw.transitions_on_lident state || Raw.transitions_on_uident state -> + name + ^ " is a reserved keyword, it cannot be used as an identifier. Try `" + ^ name + ^ "_` or `_" + ^ name + ^ "` instead" | _ -> raise Not_found let uppercased_instead_of_lowercased state token = match token with | Parser.UIDENT name when Raw.transitions_on_lident state -> let name = String.uncapitalize_ascii name in - if Hashtbl.mem Reason_declarative_lexer.keyword_table name then - "variables and labels should be lowercased" + if Hashtbl.mem Reason_declarative_lexer.keyword_table name + then "variables and labels should be lowercased" else Printf.sprintf "variables and labels should be lowercased. Try `%s'" name | _ -> raise Not_found let semicolon_might_be_missing state _token = (*let state = Interp.current_state_number env in*) - if Raw.transitions_on_semi state then - "syntax error, consider adding a `;' before" - else - raise Not_found + if Raw.transitions_on_semi state + then "syntax error, consider adding a `;' before" + else raise Not_found let token_specific_message = function | Parser.UNDERSCORE -> - "underscore is not a valid identifier. Use _ only in pattern matching and partial function application" - | _ -> - raise Not_found + "underscore is not a valid identifier. Use _ only in pattern matching and \ + partial function application" + | _ -> raise Not_found let unclosed_parenthesis is_opening_symbol closing_symbol check_function env = let state = Interp.current_state_number env in - if check_function state then + if check_function state + then let rec find_opening_location = function | None -> None | Some env -> let found = match Interp.top env with | Some (Interp.Element (state, _, startp, endp)) - when (is_opening_symbol (Interp.X (Interp.incoming_symbol state))) -> + when is_opening_symbol (Interp.X (Interp.incoming_symbol state)) -> Some (startp, endp) | Some (Interp.Element (state, _, _, _)) - when (Interp.X (Interp.incoming_symbol state) = closing_symbol) -> + when Interp.X (Interp.incoming_symbol state) = closing_symbol -> raise Not_found | _ -> None in - match found with + (match found with | Some _ -> found - | _ -> find_opening_location (Interp.pop env) + | _ -> find_opening_location (Interp.pop env)) in - try find_opening_location (Some env) - with Not_found -> None - else - None + try find_opening_location (Some env) with Not_found -> None + else None let check_unclosed env = let check (message, opening_symbols, closing_symbol, check_function) = match - unclosed_parenthesis (fun x -> List.mem x opening_symbols) - closing_symbol check_function env + unclosed_parenthesis + (fun x -> List.mem x opening_symbols) + closing_symbol + check_function + env with | None -> None | Some (loc_start, _) -> - Some (Format.asprintf "Unclosed %S (opened line %d, column %d)" - message loc_start.pos_lnum - (loc_start.pos_cnum - loc_start.pos_bol)) + Some + (Format.asprintf + "Unclosed %S (opened line %d, column %d)" + message + loc_start.pos_lnum + (loc_start.pos_cnum - loc_start.pos_bol)) in let rec check_list = function | [] -> raise Not_found | x :: xs -> - match check x with - | None -> check_list xs - | Some result -> result + (match check x with None -> check_list xs | Some result -> result) in - check_list [ - ("(", Interp.[X (T T_LPAREN)], - Interp.X (T T_RPAREN), - Raw.transitions_on_rparen); - ("{", Interp.[X (T T_LBRACE); X (T T_LBRACELESS)], - Interp.X (T T_RBRACE), - Raw.transitions_on_rbrace); - ("[", Interp.[ X (T T_LBRACKET); X (T T_LBRACKETAT); - X (T T_LBRACKETBAR); X (T T_LBRACKETGREATER); - X (T T_LBRACKETLESS); X (T T_LBRACKETPERCENT); - X (T T_LBRACKETPERCENTPERCENT); ], - Interp.X (T T_RBRACKET), - Raw.transitions_on_rbracket); - ] + check_list + [ ( "(" + , Interp.[ X (T T_LPAREN) ] + , Interp.X (T T_RPAREN) + , Raw.transitions_on_rparen ) + ; ( "{" + , Interp.[ X (T T_LBRACE); X (T T_LBRACELESS) ] + , Interp.X (T T_RBRACE) + , Raw.transitions_on_rbrace ) + ; ( "[" + , Interp. + [ X (T T_LBRACKET) + ; X (T T_LBRACKETAT) + ; X (T T_LBRACKETBAR) + ; X (T T_LBRACKETGREATER) + ; X (T T_LBRACKETLESS) + ; X (T T_LBRACKETPERCENT) + ; X (T T_LBRACKETPERCENTPERCENT) + ] + , Interp.X (T T_RBRACKET) + , Raw.transitions_on_rbracket ) + ] let message env (token, _, _) = let state = Interp.current_state_number env in (* Identify a keyword used as an identifier *) - try keyword_confused_with_ident state token - with Not_found -> - try check_unclosed env - with Not_found -> - (* Identify an uppercased identifier in a lowercase place *) - try uppercased_instead_of_lowercased state token - with Not_found -> - try semicolon_might_be_missing state token - with Not_found -> - try token_specific_message token - with Not_found -> - (* Is there a message for this specific state ? *) - (* TODO: we don't know what to say *) - "Syntax error" + try keyword_confused_with_ident state token with + | Not_found -> + (try check_unclosed env with + | Not_found -> + (* Identify an uppercased identifier in a lowercase place *) + (try uppercased_instead_of_lowercased state token with + | Not_found -> + (try semicolon_might_be_missing state token with + | Not_found -> + (try token_specific_message token with + | Not_found -> + (* Is there a message for this specific state ? *) + (* TODO: we don't know what to say *) + "Syntax error")))) diff --git a/src/reason-parser/reason_pprint_ast.ml b/src/reason-parser/reason_pprint_ast.ml index 1c3c2b397..1b0837ffe 100644 --- a/src/reason-parser/reason_pprint_ast.ml +++ b/src/reason-parser/reason_pprint_ast.ml @@ -47,10 +47,8 @@ (* TODO more fine-grained precedence pretty-printing *) module Easy_format = Vendored_easy_format - open Ppxlib open Easy_format - module Comment = Reason_comment module Layout = Reason_layout module WhitespaceRegion = Layout.WhitespaceRegion @@ -60,21 +58,23 @@ let source_map = Layout.source_map exception NotPossible of string -let commaTrail = Layout.SepFinal (",", Reason_syntax_util.TrailingCommaMarker.string) -let commaSep = Layout.Sep (",") +let commaTrail = + Layout.SepFinal (",", Reason_syntax_util.TrailingCommaMarker.string) -type ruleInfoData = { - reducePrecedence: precedence; - shiftPrecedence: precedence; -} +let commaSep = Layout.Sep "," + +type ruleInfoData = + { reducePrecedence : precedence + ; shiftPrecedence : precedence + } and ruleCategory = (* Printing will be parsed with very high precedence, so not much need to worry about ensuring it will reduce correctly. In short, you can put `FunctionApplication` content anywhere around an infix identifier without - wrapping in parens. For example `myFunc x y z` or `if x {y} else {z}` - The layout is kept in list form only to allow for elegant wrapping rules - to take into consideration the *number* of high precedence parsed items. *) + wrapping in parens. For example `myFunc x y z` or `if x {y} else {z}` The + layout is kept in list form only to allow for elegant wrapping rules to + take into consideration the *number* of high precedence parsed items. *) | FunctionApplication of Layout.t list (* Care should be taken to ensure the rule that caused it to be parsed will reduce again on the printed output - context should carefully consider @@ -82,14 +82,16 @@ and ruleCategory = | SpecificInfixPrecedence of ruleInfoData * resolvedRule (* Not safe to include anywhere between infix operators without wrapping in parens. This describes expressions like `fun x => x` which doesn't fit into - our simplistic algorithm for printing function applications separated by infix. + our simplistic algorithm for printing function applications separated by + infix. It might be possible to include these in between infix, but there are tricky rules to determining when these must be guarded by parens (it depends highly on context that is hard to reason about). It's so nuanced - that it's easier just to always wrap them in parens. *) + that it's easier just to always wrap them in parens. *) | PotentiallyLowPrecedence of Layout.t - (* Simple means it is clearly one token (such as (anything) or [anything] or identifier *) + (* Simple means it is clearly one token (such as (anything) or [anything] or + identifier *) | Simple of Layout.t (* Represents a ruleCategory where the precedence has been resolved. @@ -143,50 +145,50 @@ type infixChain = (* Helpers for dealing with extension nodes (%expr) *) let expression_extension_sugar x = - if x.pexp_attributes != [] then None - else match x.pexp_desc with - | Pexp_extension (name, PStr [{pstr_desc = Pstr_eval(expr, [])}]) + if x.pexp_attributes != [] + then None + else + match x.pexp_desc with + | Pexp_extension (name, PStr [ { pstr_desc = Pstr_eval (expr, []) } ]) when name.txt <> "mel.obj" -> Some (name, expr) | _ -> None let expression_immediate_extension_sugar x = match expression_extension_sugar x with - | None -> (None, x) + | None -> None, x | Some (name, expr) -> - match expr.pexp_desc with + (match expr.pexp_desc with | Pexp_for _ | Pexp_while _ | Pexp_ifthenelse _ | Pexp_function _ | Pexp_newtype _ | Pexp_try _ | Pexp_match _ -> - (Some name, expr) - | _ -> (None, x) + Some name, expr + | _ -> None, x) let expression_not_immediate_extension_sugar x = match expression_immediate_extension_sugar x with - | (Some _, _) -> None - | (None, _) -> expression_extension_sugar x + | Some _, _ -> None + | None, _ -> expression_extension_sugar x let add_extension_sugar keyword = function | None -> keyword | Some str -> keyword ^ "%" ^ str.txt -let override = function - | Override -> "!" - | Fresh -> "" +let override = function Override -> "!" | Fresh -> "" let add_open_extension_sugar ~override:open_override extension = let base = "open" in match extension, open_override with | extension, Fresh -> add_extension_sugar base extension - | None, Override -> base ^ (override open_override) + | None, Override -> base ^ override open_override | Some _, Override -> - (* need to add a space between `!` and `%foo` otherwise it can't be - parsed back *) - add_extension_sugar (base ^ (override open_override) ^ " ") extension + (* need to add a space between `!` and `%foo` otherwise it can't be parsed + back *) + add_extension_sugar (base ^ override open_override ^ " ") extension -let string_equal : string -> string -> bool = (=) +let string_equal : string -> string -> bool = ( = ) -let string_loc_equal: string Asttypes.loc -> string Asttypes.loc -> bool = - fun l1 l2 -> l1.txt = l2.txt +let string_loc_equal : string Asttypes.loc -> string Asttypes.loc -> bool = + fun l1 l2 -> l1.txt = l2.txt let longident_same l1 l2 = let rec equal l1 l2 = @@ -194,110 +196,101 @@ let longident_same l1 l2 = | Lident l1, Lident l2 -> string_equal l1 l2 | Ldot (path1, l1), Ldot (path2, l2) -> equal path1 path2 && string_equal l1 l2 - | Lapply (l11, l12), Lapply (l21, l22) -> - equal l11 l21 && equal l12 l22 + | Lapply (l11, l12), Lapply (l21, l22) -> equal l11 l21 && equal l12 l22 | _ -> false in equal l1.txt l2.txt -(* A variant of List.for_all2 that returns false instead of failing on lists - of different size *) -let for_all2' pred l1 l2 = - try List.for_all2 pred l1 l2 - with | _ -> false +(* A variant of List.for_all2 that returns false instead of failing on lists of + different size *) +let for_all2' pred l1 l2 = try List.for_all2 pred l1 l2 with _ -> false -(* - Checks to see if two types are the same modulo the process of varification - which turns abstract types into type variables of the same name. - For example, [same_ast_modulo_varification] would consider (a => b) and ('a - => 'b) to have the same ast. This is useful in recovering syntactic sugar - for explicit polymorphic types with locally abstract types. +(* Checks to see if two types are the same modulo the process of varification + which turns abstract types into type variables of the same name. For example, + [same_ast_modulo_varification] would consider (a => b) and ('a => 'b) to have + the same ast. This is useful in recovering syntactic sugar for explicit + polymorphic types with locally abstract types. Does not compare attributes, or extensions intentionally. TODO: This has one more issue: We need to compare only accepting t1's type variables, to be considered compatible with t2's type constructors - not the - other way around. - *) + other way around. *) let same_ast_modulo_varification_and_extensions t1 t2 = - let rec loop t1 t2 = match (t1.ptyp_desc, t2.ptyp_desc) with - (* Importantly, cover the case where type constructors (of the form [a]) - are converted to type vars of the form ['a]. - *) - | (Ptyp_constr({txt=Lident s1}, []), Ptyp_var s2) -> string_equal s1 s2 - (* Now cover the case where type variables (of the form ['a]) are - converted to type constructors of the form [a]. - *) - | (Ptyp_var s1, Ptyp_constr({txt=Lident s2}, [])) -> string_equal s1 s2 + let rec loop t1 t2 = + match t1.ptyp_desc, t2.ptyp_desc with + (* Importantly, cover the case where type constructors (of the form [a]) are + converted to type vars of the form ['a]. *) + | Ptyp_constr ({ txt = Lident s1 }, []), Ptyp_var s2 -> string_equal s1 s2 + (* Now cover the case where type variables (of the form ['a]) are converted + to type constructors of the form [a]. *) + | Ptyp_var s1, Ptyp_constr ({ txt = Lident s2 }, []) -> string_equal s1 s2 (* Now cover the typical case *) - | (Ptyp_constr(longident1, lst1), Ptyp_constr(longident2, lst2)) -> - longident_same longident1 longident2 && - for_all2' loop lst1 lst2 - | (Ptyp_any, Ptyp_any) -> true - | (Ptyp_var x1, Ptyp_var x2) -> string_equal x1 x2 - | (Ptyp_arrow (label1, core_type1, core_type1'), Ptyp_arrow (label2, core_type2, core_type2')) -> - begin - match label1, label2 with - | Nolabel, Nolabel -> true - | Labelled s1, Labelled s2 -> string_equal s1 s2 - | Optional s1, Optional s2 -> string_equal s1 s2 - | _ -> false - end && - loop core_type1 core_type2 && - loop core_type1' core_type2' - | (Ptyp_tuple lst1, Ptyp_tuple lst2) -> for_all2' loop lst1 lst2 - | (Ptyp_object (lst1, o1), Ptyp_object (lst2, o2)) -> - let tester = fun t1 t2 -> + | Ptyp_constr (longident1, lst1), Ptyp_constr (longident2, lst2) -> + longident_same longident1 longident2 && for_all2' loop lst1 lst2 + | Ptyp_any, Ptyp_any -> true + | Ptyp_var x1, Ptyp_var x2 -> string_equal x1 x2 + | ( Ptyp_arrow (label1, core_type1, core_type1') + , Ptyp_arrow (label2, core_type2, core_type2') ) -> + (match label1, label2 with + | Nolabel, Nolabel -> true + | Labelled s1, Labelled s2 -> string_equal s1 s2 + | Optional s1, Optional s2 -> string_equal s1 s2 + | _ -> false) + && loop core_type1 core_type2 + && loop core_type1' core_type2' + | Ptyp_tuple lst1, Ptyp_tuple lst2 -> for_all2' loop lst1 lst2 + | Ptyp_object (lst1, o1), Ptyp_object (lst2, o2) -> + let tester t1 t2 = match t1.pof_desc, t2.pof_desc with | Otag (s1, t1), Otag (s2, t2) -> - string_equal s1.txt s2.txt && - loop t1 t2 + string_equal s1.txt s2.txt && loop t1 t2 | Oinherit t1, Oinherit t2 -> loop t1 t2 | _ -> false in for_all2' tester lst1 lst2 && o1 = o2 - | (Ptyp_class (longident1, lst1), Ptyp_class (longident2, lst2)) -> - longident_same longident1 longident2 && - for_all2' loop lst1 lst2 - | (Ptyp_alias(core_type1, string1), Ptyp_alias(core_type2, string2)) -> - loop core_type1 core_type2 && - string_equal string1 string2 - | (Ptyp_variant(row_field_list1, flag1, lbl_lst_option1), Ptyp_variant(row_field_list2, flag2, lbl_lst_option2)) -> - for_all2' rowFieldEqual row_field_list1 row_field_list2 && - flag1 = flag2 && - lbl_lst_option1 = lbl_lst_option2 - | (Ptyp_poly (string_lst1, core_type1), Ptyp_poly (string_lst2, core_type2))-> - for_all2' string_loc_equal string_lst1 string_lst2 && - loop core_type1 core_type2 - | (Ptyp_package(longident1, lst1), Ptyp_package (longident2, lst2)) -> - longident_same longident1 longident2 && - for_all2' testPackageType lst1 lst2 - | (Ptyp_extension (s1, _), Ptyp_extension (s2, _)) -> + | Ptyp_class (longident1, lst1), Ptyp_class (longident2, lst2) -> + longident_same longident1 longident2 && for_all2' loop lst1 lst2 + | Ptyp_alias (core_type1, string1), Ptyp_alias (core_type2, string2) -> + loop core_type1 core_type2 && string_equal string1 string2 + | ( Ptyp_variant (row_field_list1, flag1, lbl_lst_option1) + , Ptyp_variant (row_field_list2, flag2, lbl_lst_option2) ) -> + for_all2' rowFieldEqual row_field_list1 row_field_list2 + && flag1 = flag2 + && lbl_lst_option1 = lbl_lst_option2 + | Ptyp_poly (string_lst1, core_type1), Ptyp_poly (string_lst2, core_type2) + -> + for_all2' string_loc_equal string_lst1 string_lst2 + && loop core_type1 core_type2 + | Ptyp_package (longident1, lst1), Ptyp_package (longident2, lst2) -> + longident_same longident1 longident2 + && for_all2' testPackageType lst1 lst2 + | Ptyp_extension (s1, _), Ptyp_extension (s2, _) -> string_equal s1.txt s2.txt | _ -> false and testPackageType (lblLongIdent1, ct1) (lblLongIdent2, ct2) = - longident_same lblLongIdent1 lblLongIdent2 && - loop ct1 ct2 - and rowFieldEqual f1 f2 = match (f1.prf_desc, f2.prf_desc) with - | ((Rtag(label1, flag1, lst1)), (Rtag (label2, flag2, lst2))) -> - string_equal label1.txt label2.txt && - flag1 = flag2 && - for_all2' loop lst1 lst2 - | (Rinherit t1, Rinherit t2) -> loop t1 t2 + longident_same lblLongIdent1 lblLongIdent2 && loop ct1 ct2 + and rowFieldEqual f1 f2 = + match f1.prf_desc, f2.prf_desc with + | Rtag (label1, flag1, lst1), Rtag (label2, flag2, lst2) -> + string_equal label1.txt label2.txt + && flag1 = flag2 + && for_all2' loop lst1 lst2 + | Rinherit t1, Rinherit t2 -> loop t1 t2 | _ -> false in loop t1 t2 let expandLocation pos ~expand:(startPos, endPos) = { pos with - loc_start = { - pos.loc_start with + loc_start = + { pos.loc_start with Lexing.pos_cnum = pos.loc_start.Lexing.pos_cnum + startPos - }; - loc_end = { - pos.loc_end with + } + ; loc_end = + { pos.loc_end with Lexing.pos_cnum = pos.loc_end.Lexing.pos_cnum + endPos - } + } } (* Computes the location of the attribute with the lowest line number @@ -308,147 +301,146 @@ let expandLocation pos ~expand:(startPos, endPos) = * 2| let f = ... by the attr on line 1, not the lnum of the `let` *) let rec firstAttrLoc loc = function - | ({ attr_name = attrLoc; _} : Parsetree.attribute) ::attrs -> - if attrLoc.loc.loc_start.pos_lnum < loc.loc_start.pos_lnum - && not attrLoc.loc.loc_ghost - then - firstAttrLoc attrLoc.loc attrs - else - firstAttrLoc loc attrs + | ({ attr_name = attrLoc; _ } : Parsetree.attribute) :: attrs -> + if attrLoc.loc.loc_start.pos_lnum < loc.loc_start.pos_lnum + && not attrLoc.loc.loc_ghost + then firstAttrLoc attrLoc.loc attrs + else firstAttrLoc loc attrs | [] -> loc let extractLocationFromValBindList expr vbs = let rec extract loc = function - | x::xs -> - let {pvb_expr} = x in - let loc = {loc with loc_end = pvb_expr.pexp_loc.loc_end} in - extract loc xs + | x :: xs -> + let { pvb_expr } = x in + let loc = { loc with loc_end = pvb_expr.pexp_loc.loc_end } in + extract loc xs | [] -> loc in - let loc = match vbs with - | x::xs -> - let {pvb_pat; pvb_expr} = x in - let loc = {pvb_pat.ppat_loc with loc_end = pvb_expr.pexp_loc.loc_end} in - extract loc xs + let loc = + match vbs with + | x :: xs -> + let { pvb_pat; pvb_expr } = x in + let loc = { pvb_pat.ppat_loc with loc_end = pvb_expr.pexp_loc.loc_end } in + extract loc xs | [] -> expr.pexp_loc in { loc with loc_start = expr.pexp_loc.loc_start } -let extractLocValBinding {pvb_pat; pvb_expr; pvb_attributes;} = +let extractLocValBinding { pvb_pat; pvb_expr; pvb_attributes } = let estimatedLoc = firstAttrLoc pvb_pat.ppat_loc pvb_attributes in - {estimatedLoc with loc_end = pvb_expr.pexp_loc.loc_end} + { estimatedLoc with loc_end = pvb_expr.pexp_loc.loc_end } -let extractLocBindingOp {pbop_pat; pbop_exp} = +let extractLocBindingOp { pbop_pat; pbop_exp } = let estimatedLoc = firstAttrLoc pbop_pat.ppat_loc [] in - {estimatedLoc with loc_end = pbop_exp.pexp_loc.loc_end} + { estimatedLoc with loc_end = pbop_exp.pexp_loc.loc_end } -let extractLocModuleBinding {pmb_expr; pmb_attributes} = +let extractLocModuleBinding { pmb_expr; pmb_attributes } = let estimatedLoc = firstAttrLoc pmb_expr.pmod_loc pmb_attributes in - {estimatedLoc with loc_end = pmb_expr.pmod_loc.loc_end} + { estimatedLoc with loc_end = pmb_expr.pmod_loc.loc_end } -let extractLocModDecl {pmd_type; pmd_attributes} = +let extractLocModDecl { pmd_type; pmd_attributes } = let estimatedLoc = firstAttrLoc pmd_type.pmty_loc pmd_attributes in - {estimatedLoc with loc_end = pmd_type.pmty_loc.loc_end} + { estimatedLoc with loc_end = pmd_type.pmty_loc.loc_end } let rec sequentialIfBlocks x = match x with - | Some ({pexp_desc=Pexp_ifthenelse (e1, e2, els)}) -> ( - let (nestedIfs, finalExpression) = (sequentialIfBlocks els) in - ((e1, e2)::nestedIfs, finalExpression) - ) - | Some e -> ([], Some e) - | None -> ([], None) + | Some { pexp_desc = Pexp_ifthenelse (e1, e2, els) } -> + let nestedIfs, finalExpression = sequentialIfBlocks els in + (e1, e2) :: nestedIfs, finalExpression + | Some e -> [], Some e + | None -> [], None (* - TODO: IDE integration beginning with Vim: - - - Create recovering version of parser that creates regions of "unknown" - content in between let sequence bindings (anything between semicolons, - really). - - Use Easy_format's "style" features to tag each known node. - - Turn those style annotations into editor highlight commands. - - Editors have a set of keys that retrigger the parsing/rehighlighting - process (typically newline/semi/close-brace). - - On every parsing/rehighlighting, this pretty printer can be used to - determine the highlighting of recovered regions, and the editor plugin can - relegate highlighting of malformed regions to the editor which mostly does - so based on token patterns. - -*) + * TODO: IDE integration beginning with Vim: + * + * - Create recovering version of parser that creates regions of "unknown" + * content in between let sequence bindings (anything between semicolons, + * really). + * - Use Easy_format's "style" features to tag each known node. + * - Turn those style annotations into editor highlight commands. + * - Editors have a set of keys that retrigger the parsing/rehighlighting + * process (typically newline/semi/close-brace). + * - On every parsing/rehighlighting, this pretty printer can be used to + * determine the highlighting of recovered regions, and the editor plugin can + * relegate highlighting of malformed regions to the editor which mostly does + * so based on token patterns. + * + *) (* - @avoidSingleTokenWrapping - - +-----------------------------+ - |+------+ | Another label - || let ( \ | - || a | Label | - || o | | The thing to the right of any label must be a - || p _+ label RHS | list in order for it to wrap correctly. Lists - || ): / v | will wrap if they need to/can. NON-lists will - |+--+ sixteenTuple = echoTuple|( wrap (indented) even though they're no lists! - +---/ 0,\---------------------+ To prevent a single item from wrapping, make - 0, an unbreakable list via ensureSingleTokenSticksToLabel. - 0 - ); In general, the best approach for indenting - let bindings is to keep building up labels from - the "let", always ensuring things that you want - to wrap will either be lists or guarded in - [ensureSingleTokenSticksToLabel]. - If you must join several lists together (via =) - (or colon), ensure that joining is done via - [makeList] (which won't break), and that new - list is always appended to the left - hand side of the label. (So that the right hand - side may always be the untouched list that you want - to wrap with aligned closing). - Always make sure rhs of the label are the - - Creating nested labels will preserve the original - indent location ("let" in this - case) as long as that nesting is - done on the left hand side of the labels. - -*) + * @avoidSingleTokenWrapping + * + * +-----------------------------+ + * |+------+ | Another label + * || let ( \ | + * || a | Label | + * || o | | The thing to the right of any label must be a + * || p _+ label RHS | list in order for it to wrap correctly. Lists + * || ): / v | will wrap if they need to/can. NON-lists will + * |+--+ sixteenTuple = echoTuple|( wrap (indented) even though they're no lists! + * +---/ 0,\---------------------+ To prevent a single item from wrapping, make + * 0, an unbreakable list via ensureSingleTokenSticksToLabel. + * 0 + * ); + * In general, the best approach for indenting + * let bindings is to keep building up labels from + * the "let", always ensuring things that you want + * to wrap will either be lists or guarded in + * [ensureSingleTokenSticksToLabel]. + * If you must join several lists together (via =) + * (or colon), ensure that joining is done via + * [makeList] (which won't break), and that new + * list is always appended to the left + * hand side of the label. (So that the right hand + * side may always be the untouched list that you want + * to wrap with aligned closing). + * Always make sure rhs of the label are the + * + * Creating nested labels will preserve the original + * indent location ("let" in this + * case) as long as that nesting is + * done on the left hand side of the labels. + * + *) (* - Table 2.1. Precedence and associativity. - Precedence from highest to lowest: From RWOC, modified to include != - --------------------------------------- - - Operator prefix Associativity - !..., ?..., ~... Prefix - ., .(, .[ - - function application, constructor, assert, lazy Left associative - -, -. Prefix - **..., lsl, lsr, asr Right associative - *..., /..., %..., mod, land, lor, lxor Left associative - +..., -... Left associative - :: Right associative - @..., ^... Right associative ---- - != Left associative (INFIXOP0 listed first in lexer) - =..., <..., >..., |..., &..., $... Left associative (INFIXOP0) - =, <, > Left associative (IN SAME row as INFIXOP0 listed after) ---- - &, && Right associative - or, || Right associative - , - - :=, = Right associative - if - - ; Right associative - - - Note: It would be much better if &... and |... were in separate precedence - groups just as & and | are. This way, we could encourage custom infix - operators to use one of the two precedences and no one would be confused as - to precedence (leading &, | are intuitive). Two precedence classes for the - majority of infix operators is totally sufficient. - - TODO: Free up the (&) operator from pervasives so it can be reused for - something very common such as string concatenation or list appending. - - let x = tail & head; + * Table 2.1. Precedence and associativity. + * Precedence from highest to lowest: From RWOC, modified to include != + * --------------------------------------- + * + * Operator prefix Associativity + * !..., ?..., ~... Prefix + * ., .(, .[ - + * function application, constructor, assert, lazy Left associative + * -, -. Prefix + * **..., lsl, lsr, asr Right associative + * *..., /..., %..., mod, land, lor, lxor Left associative + * +..., -... Left associative + * :: Right associative + * @..., ^... Right associative + * + * != Left associative (INFIXOP0 listed first in lexer) + * =..., <..., >..., |..., &..., $... Left associative (INFIXOP0) + * =, <, > Left associative (IN SAME row as INFIXOP0 listed after) + * + * &, && Right associative + * or, || Right associative + * , - + * :=, = Right associative + * if - + * ; Right associative + * + * + * Note: It would be much better if &... and |... were in separate precedence + * groups just as & and | are. This way, we could encourage custom infix + * operators to use one of the two precedences and no one would be confused as + * to precedence (leading &, | are intuitive). Two precedence classes for the + * majority of infix operators is totally sufficient. + * + * TODO: Free up the (&) operator from pervasives so it can be reused for + * something very common such as string concatenation or list appending. + * + * let x = tail & head; *) (* "Almost Simple Prefix" function applications parse with the rule: @@ -463,26 +455,26 @@ let rec sequentialIfBlocks x = "expression" (not simple). All unary operators are mapped into an identifier beginning with "~". - TODO: Migrate all "almost simple prefix" to "unsary prefix". When `!` - becomes "not", then it will make more sense that !myFunc (arg) is parsed as - !(myFunc arg) instead of (!myFunc) arg. + TODO: Migrate all "almost simple prefix" to "unsary prefix". When `!` becomes + "not", then it will make more sense that !myFunc (arg) is parsed as !(myFunc + arg) instead of (!myFunc) arg. *) +let almost_simple_prefix_symbols = [ '!'; '?'; '~' ] - *) -let almost_simple_prefix_symbols = [ '!'; '?'; '~'] ;; (* Subset of prefix symbols that have special "unary precedence" *) -let unary_minus_prefix_symbols = [ "~-"; "~-."] ;; -let unary_plus_prefix_symbols = ["~+"; "~+." ] ;; -let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; - '$'; '%'; '\\'; '#' ] +let unary_minus_prefix_symbols = [ "~-"; "~-." ] +let unary_plus_prefix_symbols = [ "~+"; "~+." ] + +let infix_symbols = + [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; '$'; '%'; '\\'; '#' ] + (* this should match "kwdopchar" from reason_declarative_lexer.mll *) let special_infix_strings = - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "!=="] + [ "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "!==" ] let updateToken = "=" let sharpOpEqualToken = "#=" let pipeFirstToken = "->" -let requireIndentFor = [updateToken; ":="] - +let requireIndentFor = [ updateToken; ":=" ] let namedArgSym = "~" let requireNoSpaceFor tok = @@ -491,168 +483,146 @@ let requireNoSpaceFor tok = let funToken = "fun" let getPrintableUnaryIdent s = - if List.mem s unary_minus_prefix_symbols || - List.mem s unary_plus_prefix_symbols - then String.sub s 1 (String.length s -1) + if List.mem s unary_minus_prefix_symbols + || List.mem s unary_plus_prefix_symbols + then String.sub s 1 (String.length s - 1) else s -(* determines if the string is an infix string. - checks backwards, first allowing a renaming postfix ("_102") which - may have resulted from Pexp -> Texp -> Pexp translation, then checking - if all the characters in the beginning of the string are valid infix - characters. *) +(* determines if the string is an infix string. checks backwards, first allowing + a renaming postfix ("_102") which may have resulted from Pexp -> Texp -> Pexp + translation, then checking if all the characters in the beginning of the + string are valid infix characters. *) let printedStringAndFixity = function | s when List.mem s special_infix_strings -> Infix s | "^" -> UnaryPostfix "^" | s when List.mem s.[0] infix_symbols -> Infix s (* Correctness under assumption that unary operators are stored in AST with leading "~" *) - | s when List.mem s.[0] almost_simple_prefix_symbols && - not (List.mem s special_infix_strings) && - not (s = "?") -> ( - (* What *kind* of prefix fixity? *) - if List.mem s unary_plus_prefix_symbols then - UnaryPlusPrefix (getPrintableUnaryIdent s) - else if List.mem s unary_minus_prefix_symbols then - UnaryMinusPrefix (getPrintableUnaryIdent s) - else if s = "!" then - UnaryNotPrefix s - else - AlmostSimplePrefix s - ) + | s + when List.mem s.[0] almost_simple_prefix_symbols + && (not (List.mem s special_infix_strings)) + && not (s = "?") -> + if (* What *kind* of prefix fixity? *) + List.mem s unary_plus_prefix_symbols + then UnaryPlusPrefix (getPrintableUnaryIdent s) + else if List.mem s unary_minus_prefix_symbols + then UnaryMinusPrefix (getPrintableUnaryIdent s) + else if s = "!" + then UnaryNotPrefix s + else AlmostSimplePrefix s | s when Reason_syntax_util.is_letop s -> Letop s | s when Reason_syntax_util.is_andop s -> Andop s | _ -> Normal - (* Also, this doesn't account for != and !== being infixop!!! *) -let isSimplePrefixToken s = match printedStringAndFixity s with +let isSimplePrefixToken s = + match printedStringAndFixity s with | AlmostSimplePrefix _ | UnaryPostfix "^" -> true | _ -> false - (* Convenient bank of information that represents the parser's precedence - rankings. Each instance describes a precedence table entry. The function + rankings. Each instance describes a precedence table entry. The function tests either a token string encountered by the parser, or (in the case of `CustomPrecedence`) the string name of a custom rule precedence declared using %prec *) -let rules = [ - [ - (TokenPrecedence, (fun s -> (Left, s = pipeFirstToken))); - (TokenPrecedence, (fun s -> (Left, s.[0] = '#' && - s <> sharpOpEqualToken && - s <> "#"))); - (TokenPrecedence, (fun s -> (Left, s = "."))); - (CustomPrecedence, (fun s -> (Left, s = "prec_lbracket"))); - ]; - [ - (CustomPrecedence, (fun s -> (Nonassoc, s = "prec_functionAppl"))); - ]; - [ - (TokenPrecedence, (fun s -> (Right, isSimplePrefixToken s))); - ]; - [ - (TokenPrecedence, (fun s -> (Left, s = sharpOpEqualToken))); - ]; - [ - (CustomPrecedence, (fun s -> (Nonassoc, s = "prec_unary"))); - ]; - (* Note the special case for "*\*", BARBAR, and LESSMINUS, AMPERSAND(s) *) - [ - (TokenPrecedence, (fun s -> (Right, s = "**"))); - (TokenPrecedence, (fun s -> (Right, String.length s > 1 && s.[0] == '*' && s.[1] == '\\' && s.[2] == '*'))); - (TokenPrecedence, (fun s -> (Right, s = "lsl"))); - (TokenPrecedence, (fun s -> (Right, s = "lsr"))); - (TokenPrecedence, (fun s -> (Right, s = "asr"))); - ]; - [ - (TokenPrecedence, (fun s -> (Left, s.[0] == '*' && (String.length s == 1 || s != "*\\*")))); - (TokenPrecedence, (fun s -> (Left, s.[0] == '/'))); - (TokenPrecedence, (fun s -> (Left, s.[0] == '%' ))); - (TokenPrecedence, (fun s -> (Left, s = "mod" ))); - (TokenPrecedence, (fun s -> (Left, s = "land" ))); - (TokenPrecedence, (fun s -> (Left, s = "lor" ))); - (TokenPrecedence, (fun s -> (Left, s = "lxor" ))); - ]; - [ - (* Even though these use the same *tokens* as unary plus/minus at parse - time, when unparsing infix -/+, the CustomPrecedence rule would be - incorrect to use, and instead we need a rule that models what infix - parsing would use - just the regular token precedence without a custom - precedence. *) - (TokenPrecedence, - (fun s -> ( - Left, - if String.length s > 1 && s.[0] == '+' && s.[1] == '+' then - (* - Explicitly call this out as false because the other ++ case below - should have higher *lexing* priority. ++operator_chars* is considered an - entirely different token than +(non_plus_operator_chars)* - *) - false - else - s.[0] == '+' - ))); - (TokenPrecedence, (fun s -> (Left, s.[0] == '-' && s <> pipeFirstToken))); - (TokenPrecedence, (fun s -> (Left, s = "!" ))); - ]; - [ - (TokenPrecedence, (fun s -> (Right, s = "::"))); - ]; - [ - (TokenPrecedence, (fun s -> (Right, s.[0] == '@'))); - (TokenPrecedence, (fun s -> (Right, s.[0] == '^'))); - (TokenPrecedence, (fun s -> (Right, String.length s > 1 && s.[0] == '+' && s.[1] == '+'))); - ]; - [ - (TokenPrecedence, (fun s -> (Left, s.[0] == '=' && not (s = "=") && not (s = "=>")))); - (TokenPrecedence, (fun s -> (Left, s.[0] == '<' && not (s = "<")))); - (TokenPrecedence, (fun s -> (Left, s.[0] == '>' && not (s = ">")))); - (TokenPrecedence, (fun s -> (Left, s = "!="))); (* Not preset in the RWO table! *) - (TokenPrecedence, (fun s -> (Left, s = "!=="))); (* Not preset in the RWO table! *) - (TokenPrecedence, (fun s -> (Left, s = "=="))); - (TokenPrecedence, (fun s -> (Left, s = "==="))); - (TokenPrecedence, (fun s -> (Left, s = "<"))); - (TokenPrecedence, (fun s -> (Left, s = ">"))); - (TokenPrecedence, (fun s -> (Left, s.[0] == '|' && not (s = "||")))); - (TokenPrecedence, (fun s -> (Left, s.[0] == '&' && not (s = "&") && not (s = "&&")))); - (TokenPrecedence, (fun s -> (Left, s.[0] == '$'))); - ]; - [ - (CustomPrecedence, (fun s -> (Left, s = funToken))); - ]; - [ - (TokenPrecedence, (fun s -> (Right, s = "&"))); - (TokenPrecedence, (fun s -> (Right, s = "&&"))); - ]; - [ - (TokenPrecedence, (fun s -> (Right, s = "or"))); - (TokenPrecedence, (fun s -> (Right, s = "||"))); - ]; - [ - (* The Left shouldn't ever matter in practice. Should never get in a - situation with two consecutive infix ? - the colon saves us. *) - (TokenPrecedence, (fun s -> (Left, s = "?"))); - ]; - [ - (TokenPrecedence, (fun s -> (Right, s = ":="))); - ]; - [ - (TokenPrecedence, (fun s -> (Right, s = updateToken))); - ]; - (* It's important to account for ternary ":" being lower precedence than "?" *) - [ - (TokenPrecedence, (fun s -> (Right, s = ":"))) - ]; - [ - (TokenPrecedence, (fun s -> (Nonassoc, s = "=>"))); - ]; -] +let rules = + [ [ (TokenPrecedence, fun s -> Left, s = pipeFirstToken) + ; ( TokenPrecedence + , fun s -> Left, s.[0] = '#' && s <> sharpOpEqualToken && s <> "#" ) + ; (TokenPrecedence, fun s -> Left, s = ".") + ; (CustomPrecedence, fun s -> Left, s = "prec_lbracket") + ] + ; [ (CustomPrecedence, fun s -> Nonassoc, s = "prec_functionAppl") ] + ; [ (TokenPrecedence, fun s -> Right, isSimplePrefixToken s) ] + ; [ (TokenPrecedence, fun s -> Left, s = sharpOpEqualToken) ] + ; [ (CustomPrecedence, fun s -> Nonassoc, s = "prec_unary") ] + ; (* Note the special case for "*\*", BARBAR, and LESSMINUS, AMPERSAND(s) *) + [ (TokenPrecedence, fun s -> Right, s = "**") + ; ( TokenPrecedence + , fun s -> + ( Right + , String.length s > 1 && s.[0] == '*' && s.[1] == '\\' && s.[2] == '*' + ) ) + ; (TokenPrecedence, fun s -> Right, s = "lsl") + ; (TokenPrecedence, fun s -> Right, s = "lsr") + ; (TokenPrecedence, fun s -> Right, s = "asr") + ] + ; [ ( TokenPrecedence + , fun s -> Left, s.[0] == '*' && (String.length s == 1 || s != "*\\*") ) + ; (TokenPrecedence, fun s -> Left, s.[0] == '/') + ; (TokenPrecedence, fun s -> Left, s.[0] == '%') + ; (TokenPrecedence, fun s -> Left, s = "mod") + ; (TokenPrecedence, fun s -> Left, s = "land") + ; (TokenPrecedence, fun s -> Left, s = "lor") + ; (TokenPrecedence, fun s -> Left, s = "lxor") + ] + ; [ (* Even though these use the same *tokens* as unary plus/minus at parse + time, when unparsing infix -/+, the CustomPrecedence rule would be + incorrect to use, and instead we need a rule that models what infix + parsing would use - just the regular token precedence without a custom + precedence. *) + ( TokenPrecedence + , fun s -> + ( Left + , if String.length s > 1 && s.[0] == '+' && s.[1] == '+' + then + (* Explicitly call this out as false because the other ++ case + below should have higher *lexing* priority. ++operator_chars* + is considered an entirely different token than + +(non_plus_operator_chars)* *) + false + else s.[0] == '+' ) ) + ; (TokenPrecedence, fun s -> Left, s.[0] == '-' && s <> pipeFirstToken) + ; (TokenPrecedence, fun s -> Left, s = "!") + ] + ; [ (TokenPrecedence, fun s -> Right, s = "::") ] + ; [ (TokenPrecedence, fun s -> Right, s.[0] == '@') + ; (TokenPrecedence, fun s -> Right, s.[0] == '^') + ; ( TokenPrecedence + , fun s -> Right, String.length s > 1 && s.[0] == '+' && s.[1] == '+' ) + ] + ; [ ( TokenPrecedence + , fun s -> Left, s.[0] == '=' && (not (s = "=")) && not (s = "=>") ) + ; (TokenPrecedence, fun s -> Left, s.[0] == '<' && not (s = "<")) + ; (TokenPrecedence, fun s -> Left, s.[0] == '>' && not (s = ">")) + ; (TokenPrecedence, fun s -> Left, s = "!=") + ; (* Not preset in the RWO table! *) + (TokenPrecedence, fun s -> Left, s = "!==") + ; (* Not preset in the RWO table! *) + (TokenPrecedence, fun s -> Left, s = "==") + ; (TokenPrecedence, fun s -> Left, s = "===") + ; (TokenPrecedence, fun s -> Left, s = "<") + ; (TokenPrecedence, fun s -> Left, s = ">") + ; (TokenPrecedence, fun s -> Left, s.[0] == '|' && not (s = "||")) + ; ( TokenPrecedence + , fun s -> Left, s.[0] == '&' && (not (s = "&")) && not (s = "&&") ) + ; (TokenPrecedence, fun s -> Left, s.[0] == '$') + ] + ; [ (CustomPrecedence, fun s -> Left, s = funToken) ] + ; [ (TokenPrecedence, fun s -> Right, s = "&") + ; (TokenPrecedence, fun s -> Right, s = "&&") + ] + ; [ (TokenPrecedence, fun s -> Right, s = "or") + ; (TokenPrecedence, fun s -> Right, s = "||") + ] + ; [ (* The Left shouldn't ever matter in practice. Should never get in a + situation with two consecutive infix ? - the colon saves us. *) + (TokenPrecedence, fun s -> Left, s = "?") + ] + ; [ (TokenPrecedence, fun s -> Right, s = ":=") ] + ; [ (TokenPrecedence, fun s -> Right, s = updateToken) ] + ; (* It's important to account for ternary ":" being lower precedence than + "?" *) + [ (TokenPrecedence, fun s -> Right, s = ":") ] + ; [ (TokenPrecedence, fun s -> Nonassoc, s = "=>") ] + ] (* remove all prefixing backslashes, e.g. \=== becomes === *) let without_prefixed_backslashes str = - if str = "" then str - else if String.get str 0 = '\\' then String.sub str 1 (String.length str - 1) + if str = "" + then str + else if String.get str 0 = '\\' + then String.sub str 1 (String.length str - 1) else str let indexOfFirstMatch ~prec lst = @@ -660,52 +630,55 @@ let indexOfFirstMatch ~prec lst = | [] -> None | [] :: tl -> aux (n + 1) tl | ((kind, tester) :: hdTl) :: tl -> - match prec, kind with + (match prec, kind with | Token str, TokenPrecedence | Custom str, CustomPrecedence -> let associativity, foundMatch = tester str in - if foundMatch - then Some (associativity, n) - else aux n (hdTl::tl) - | _ -> aux n (hdTl::tl) + if foundMatch then Some (associativity, n) else aux n (hdTl :: tl) + | _ -> aux n (hdTl :: tl)) in aux 0 lst (* Assuming it's an infix function application. *) let precedenceInfo ~prec = (* Removes prefixed backslashes in order to do proper conversion *) - let prec = match prec with + let prec = + match prec with | Token str -> Token (without_prefixed_backslashes str) | Custom _ -> prec in indexOfFirstMatch ~prec rules -let isLeftAssociative ~prec = match precedenceInfo ~prec with +let isLeftAssociative ~prec = + match precedenceInfo ~prec with | None -> false | Some (Left, _) -> true | Some (Right, _) -> false | Some (Nonassoc, _) -> false -let isRightAssociative ~prec = match precedenceInfo ~prec with +let isRightAssociative ~prec = + match precedenceInfo ~prec with | None -> false | Some (Right, _) -> true | Some (Left, _) -> false | Some (Nonassoc, _) -> false let higherPrecedenceThan c1 c2 = - match ((precedenceInfo ~prec:c1), (precedenceInfo ~prec:c2)) with - | (_, None) - | (None, _) -> - let (str1, str2) = match (c1, c2) with - | (Token s1, Token s2) -> ("Token " ^ s1, "Token " ^ s2) - | (Token s1, Custom s2) -> ("Token " ^ s1, "Custom " ^ s2) - | (Custom s1, Token s2) -> ("Custom " ^ s1, "Token " ^ s2) - | (Custom s1, Custom s2) -> ("Custom " ^ s1, "Custom " ^ s2) + match precedenceInfo ~prec:c1, precedenceInfo ~prec:c2 with + | _, None | None, _ -> + let str1, str2 = + match c1, c2 with + | Token s1, Token s2 -> "Token " ^ s1, "Token " ^ s2 + | Token s1, Custom s2 -> "Token " ^ s1, "Custom " ^ s2 + | Custom s1, Token s2 -> "Custom " ^ s1, "Token " ^ s2 + | Custom s1, Custom s2 -> "Custom " ^ s1, "Custom " ^ s2 in - raise (NotPossible ("Cannot determine precedence of two checks " ^ str1 ^ " vs. " ^ str2)) - | (Some (_, p1), Some (_, p2)) -> p1 < p2 + raise + (NotPossible + ("Cannot determine precedence of two checks " ^ str1 ^ " vs. " ^ str2)) + | Some (_, p1), Some (_, p2) -> p1 < p2 let printedStringAndFixityExpr = function - | {pexp_desc = Pexp_ident {txt=Lident l}} -> printedStringAndFixity l + | { pexp_desc = Pexp_ident { txt = Lident l } } -> printedStringAndFixity l | _ -> Normal (* which identifiers are in fact operators needing parentheses *) @@ -721,14 +694,14 @@ let needs_parens txt = | Andop _ -> true | Normal -> false -(* some infixes need spaces around parens to avoid clashes with comment - syntax. This isn't needed for comment syntax /* */ *) -let needs_spaces txt = - txt.[0]='*' || txt.[String.length txt - 1] = '*' +(* some infixes need spaces around parens to avoid clashes with comment syntax. + This isn't needed for comment syntax /* */ *) +let needs_spaces txt = txt.[0] = '*' || txt.[String.length txt - 1] = '*' -let rec orList = function (* only consider ((A|B)|C)*) - | {ppat_desc = Ppat_or (p1, p2)} -> (orList p1) @ (orList p2) - | x -> [x] +let rec orList = function + (* only consider ((A|B)|C)*) + | { ppat_desc = Ppat_or (p1, p2) } -> orList p1 @ orList p2 + | x -> [ x ] (* variance encoding: need to sync up with the [parser.mly] *) let type_variance = function @@ -736,10 +709,7 @@ let type_variance = function | Covariant -> "+" | Contravariant -> "-" -let moduleIdent ident = - match ident.txt with - | None -> "_" - | Some name -> name +let moduleIdent ident = match ident.txt with None -> "_" | Some name -> name type construct = [ `cons of expression list @@ -747,35 +717,35 @@ type construct = | `nil | `normal | `simple of Longident.t - | `tuple ] + | `tuple + ] let view_expr x = match x.pexp_desc with - | Pexp_construct ( {txt= Lident "()"},_) -> `tuple - | Pexp_construct ( {txt= Lident "[]"},_) -> `nil - | Pexp_construct ( {txt= Lident"::"},Some _) -> - let rec loop exp acc = match exp with - | {pexp_desc=Pexp_construct ({txt=Lident "[]"},_)} -> - (List.rev acc,true) - | {pexp_desc= - Pexp_construct ({txt=Lident "::"}, - Some ({pexp_desc= Pexp_tuple([e1;e2])}))} -> - loop e2 (e1::acc) - | e -> (List.rev (e::acc),false) in - let (ls,b) = loop x [] in - if b - then `list ls - else `cons ls - | Pexp_construct (x,None) -> `simple x.txt + | Pexp_construct ({ txt = Lident "()" }, _) -> `tuple + | Pexp_construct ({ txt = Lident "[]" }, _) -> `nil + | Pexp_construct ({ txt = Lident "::" }, Some _) -> + let rec loop exp acc = + match exp with + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, _) } -> + List.rev acc, true + | { pexp_desc = + Pexp_construct + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ e1; e2 ] }) + } -> + loop e2 (e1 :: acc) + | e -> List.rev (e :: acc), false + in + let ls, b = loop x [] in + if b then `list ls else `cons ls + | Pexp_construct (x, None) -> `simple x.txt | _ -> `normal let is_simple_list_expr x = - match view_expr x with - | `list _ | `cons _ -> true - | _ -> false + match view_expr x with `list _ | `cons _ -> true | _ -> false let is_simple_construct : construct -> bool = function - | `nil | `tuple | `list _ | `simple _ | `cons _ -> true + | `nil | `tuple | `list _ | `simple _ | `cons _ -> true | `normal -> false let uncurriedTable = Hashtbl.create 42 @@ -786,25 +756,25 @@ let uncurriedTable = Hashtbl.create 42 * *) let is_single_unit_construct exprList = match exprList with - | x::[] -> + | x :: [] -> let view = view_expr x in - (match view with - | `tuple -> true - | _ -> false) + (match view with `tuple -> true | _ -> false) | _ -> false -let detectTernary l = match l with - | [{ - pc_lhs={ppat_desc=Ppat_construct ({txt=Lident "true"}, _)}; - pc_guard=None; - pc_rhs=ifTrue - }; - { - pc_lhs={ppat_desc=Ppat_construct ({txt=Lident "false"}, _)}; - pc_guard=None; - pc_rhs=ifFalse - }] -> Some (ifTrue, ifFalse) +let detectTernary l = + match l with + | [ { pc_lhs = { ppat_desc = Ppat_construct ({ txt = Lident "true" }, _) } + ; pc_guard = None + ; pc_rhs = ifTrue + } + ; { pc_lhs = { ppat_desc = Ppat_construct ({ txt = Lident "false" }, _) } + ; pc_guard = None + ; pc_rhs = ifFalse + } + ] -> + Some (ifTrue, ifFalse) | _ -> None + type funcApplicationLabelStyle = (* No attaching to the label, but if the entire application fits on one line, the entire application will appear next to the label as you 'd expect. *) @@ -814,4200 +784,5025 @@ type funcApplicationLabelStyle = let x = firstTerm (secondTerm_1 secondTerm_2) thirdTerm; - Ideally, we'd be able to attach all but the last argument into the label any - time all but the last term will fit - and *not* when (attaching all but + Ideally, we'd be able to attach all but the last argument into the label + any time all but the last term will fit - and *not* when (attaching all but the last term isn't enough to prevent a wrap) - But there's no way to tell ahead of time if it would prevent a wrap. - However, the number two is somewhat convenient. This models the - indentation that you'd prefer in non-curried syntax languages like - JavaScript, where application only ever has two terms. - *) + However, the number two is somewhat convenient. This models the indentation + that you'd prefer in non-curried syntax languages like JavaScript, where + application only ever has two terms. *) | WrapFinalListyItemIfFewerThan of int -type formatSettings = { - (* Whether or not to expect that the original parser that generated the AST - would have annotated constructor argument tuples with explicit arity to - indicate that they are multiple arguments. (True if parsed in original - OCaml AST, false if using Reason parser). - *) - constructorTupleImplicitArity: bool; - space: int; - - (* For curried arguments in function *definitions* only: Number of [space]s - to offset beyond the [let] keyword. Default 1. - *) - listsRecordsIndent: int; - - indentWrappedPatternArgs: int; - - indentMatchCases: int; - - (* Amount to indent in label-like constructs such as wrapped function - applications, etc - or even record fields. This is not the same concept as an - indented curried argument list. *) - indentAfterLabels: int; - - (* Amount to indent after the opening brace of switch/try. - Here's an example of what it would look like w/ [trySwitchIndent = 2]: - Sticks the expression to the last item in a sequence in several [X | Y | Z - => expr], and forces X, Y, Z to be split onto several lines. (Otherwise, - sticking to Z would result in hanging expressions). TODO: In the first case, - it's clear that we want patterns to have an "extra" indentation with matching - in a "match". Create extra config param to pass to [self#pattern] for extra - indentation in this one case. - - switch x { - | TwoCombos - (HeresTwoConstructorArguments x y) - (HeresTwoConstructorArguments a b) => - ((a + b) + x) + y; - | Short - | AlsoHasARecord a b {x, y} => ( - retOne, - retTwo - ) - | AlsoHasARecord a b {x, y} => - callMyFunction - withArg - withArg - withArg - withArg; - } - *) - trySwitchIndent: int; - - - (* In the case of two term function application (when flattened), the first - term should become part of the label, and the second term should be able to wrap - This doesn't effect n != 2. - - [true] - let x = reallyShort allFitsOnOneLine; - let x = someFunction { - reallyLongObject: true, - thatWouldntFitOnThe: true, - firstLine: true - }; - - [false] - let x = reallyShort allFitsOnOneLine; - let x = - someFunction - { - reallyLongObject: true, - thatWouldntFitOnThe: true, - firstLine: true - }; - *) - funcApplicationLabelStyle: funcApplicationLabelStyle; - - funcCurriedPatternStyle: funcApplicationLabelStyle; - - width: int; - - assumeExplicitArity: bool; - - constructorLists: string list; -} - -let defaultSettings = { - constructorTupleImplicitArity = false; - space = 1; - listsRecordsIndent = 2; - indentWrappedPatternArgs = 2; - indentMatchCases = 2; - indentAfterLabels = 2; - trySwitchIndent = 0; - funcApplicationLabelStyle = WrapFinalListyItemIfFewerThan 3; - (* WrapFinalListyItemIfFewerThan is currently a bad idea for curried - arguments: It looks great in some cases: - - let myFun (a:int) :( - int, - string - ) => (a, "this is a"); - - But horrible in others: - - let myFun - { - myField, - yourField - } :someReturnType => myField + yourField; - - let myFun - { // Curried arg wraps - myField, - yourField - } : ( // But the last is "listy" so it docks - int, // To the [let]. - int, - int - ) => myField + yourField; - - We probably want some special listy label docking/wrapping mode for - curried function bindings. - - *) - funcCurriedPatternStyle = NeverWrapFinalItem; - width = 80; - assumeExplicitArity = false; - constructorLists = []; -} +type formatSettings = + { (* Whether or not to expect that the original parser that generated the AST + would have annotated constructor argument tuples with explicit arity to + indicate that they are multiple arguments. (True if parsed in original + OCaml AST, false if using Reason parser). *) + constructorTupleImplicitArity : bool + ; space : int + ; (* For curried arguments in function *definitions* only: Number of [space]s + to offset beyond the [let] keyword. Default 1. *) + listsRecordsIndent : int + ; indentWrappedPatternArgs : int + ; indentMatchCases : int + ; (* Amount to indent in label-like constructs such as wrapped function + applications, etc - or even record fields. This is not the same concept + as an indented curried argument list. *) + indentAfterLabels : int + ; (* Amount to indent after the opening brace of switch/try. + * Here's an example of what it would look like w/ [trySwitchIndent = 2]: + * Sticks the expression to the last item in a sequence in several [X | Y | Z + * => expr], and forces X, Y, Z to be split onto several lines. (Otherwise, + * sticking to Z would result in hanging expressions). TODO: In the first case, + * it's clear that we want patterns to have an "extra" indentation with matching + * in a "match". Create extra config param to pass to [self#pattern] for extra + * indentation in this one case. + * + * switch x { + * | TwoCombos + * (HeresTwoConstructorArguments x y) + * (HeresTwoConstructorArguments a b) => + * ((a + b) + x) + y; + * | Short + * | AlsoHasARecord a b {x, y} => ( + * retOne, + * retTwo + * ) + * | AlsoHasARecord a b {x, y} => + * callMyFunction + * withArg + * withArg + * withArg + * withArg; + * } + *) + trySwitchIndent : int + ; (* In the case of two term function application (when flattened), the first + * term should become part of the label, and the second term should be able to wrap + * This doesn't effect n != 2. + * + * [true] + * let x = reallyShort allFitsOnOneLine; + * let x = someFunction { + * reallyLongObject: true, + * thatWouldntFitOnThe: true, + * firstLine: true + * }; + * + * [false] + * let x = reallyShort allFitsOnOneLine; + * let x = + * someFunction + * { + * reallyLongObject: true, + * thatWouldntFitOnThe: true, + * firstLine: true + * }; + *) + funcApplicationLabelStyle : funcApplicationLabelStyle + ; funcCurriedPatternStyle : funcApplicationLabelStyle + ; width : int + ; assumeExplicitArity : bool + ; constructorLists : string list + } + +let defaultSettings = + { constructorTupleImplicitArity = false + ; space = 1 + ; listsRecordsIndent = 2 + ; indentWrappedPatternArgs = 2 + ; indentMatchCases = 2 + ; indentAfterLabels = 2 + ; trySwitchIndent = 0 + ; funcApplicationLabelStyle = WrapFinalListyItemIfFewerThan 3 + ; (* WrapFinalListyItemIfFewerThan is currently a bad idea for curried + * arguments: It looks great in some cases: + * + * let myFun (a:int) :( + * int, + * string + * ) => (a, "this is a"); + * + * But horrible in others: + * + * let myFun + * { + * myField, + * yourField + * } :someReturnType => myField + yourField; + * + * let myFun + * { // Curried arg wraps + * myField, + * yourField + * } : ( // But the last is "listy" so it docks + * int, // To the [let]. + * int, + * int + * ) => myField + yourField; + * + * We probably want some special listy label docking/wrapping mode for + * curried function bindings. + * + *) + funcCurriedPatternStyle = NeverWrapFinalItem + ; width = 80 + ; assumeExplicitArity = false + ; constructorLists = [] + } + let configuredSettings = ref defaultSettings -let configure ~width ~assumeExplicitArity ~constructorLists = ( - configuredSettings := {defaultSettings with width; assumeExplicitArity; constructorLists} -) +let configure ~width ~assumeExplicitArity ~constructorLists = + configuredSettings := + { defaultSettings with width; assumeExplicitArity; constructorLists } let createFormatter () = -let module Formatter = struct + let module Formatter = struct + let settings = !configuredSettings -let settings = !configuredSettings + (* How do we make + * this a label? + * + * /---------------------\ + * let myVal = (oneThing, { + * field: [], + * anotherField: blah + * }); + * + * But in this case, this wider region a label? + * /------------------------------------------------------\ + * let myVal = callSomeFunc (oneThing, {field: [], anotherField: blah}, { + * boo: 'hi' + * }); + * + * This is difficult. You must form a label from the preorder traversal of every + * node - except the last encountered in the traversal. An easier heuristic is: + * + * - The last argument to a functor application is expanded. + * + * React.CreateClass SomeThing { + * let render {props} => { + * }; + * } + * + * - The last argument to a function application is expanded on the same line. + * - Only if it's not curried with another invocation. + * -- Optionally: "only if everything else is an atom" + * -- Optionally: "only if there are no other args" + * + * React.createClass someThing { + * render: fn x => y, + * } + * + * !!! NOT THIS + * React.createClass someThing { + * render: fn x => y, + * } + * somethingElse + *) + let isArityClear attrs = + !configuredSettings.assumeExplicitArity + || List.exists + (function + | { attr_name = { txt = "explicit_arity" }; _ } -> true + | _ -> false) + attrs + + let default_indent_body = settings.listsRecordsIndent * settings.space + + let makeList + ?listConfigIfCommentsInterleaved + ?listConfigIfEolCommentsInterleaved + ?(break = Layout.Never) + ?(wrap = "", "") + ?(inline = true, false) + ?(sep = Layout.NoSep) + ?(indent = default_indent_body) + ?(sepLeft = true) + ?(preSpace = false) + ?(postSpace = false) + ?(pad = false, false) + lst + = + let config = + { Layout.listConfigIfCommentsInterleaved + ; listConfigIfEolCommentsInterleaved + ; break = (if lst = [] then Layout.IfNeed else break) + ; wrap + ; inline + ; sep + ; indent + ; sepLeft + ; preSpace + ; postSpace + ; pad + } + in + Layout.Sequence (config, lst) -(* How do we make - this a label? + let makeAppList = function + | [ hd ] -> hd + | l -> makeList ~inline:(true, true) ~postSpace:true ~break:IfNeed l - /---------------------\ - let myVal = (oneThing, { - field: [], - anotherField: blah - }); + let makeTup ?(wrap = "", "") ?(trailComma = true) ?(uncurried = false) l = + let lwrap, rwrap = wrap in + let lparen = lwrap ^ if uncurried then "(. " else "(" in + makeList + ~wrap:(lparen, ")" ^ rwrap) + ~sep:(if trailComma then commaTrail else commaSep) + ~postSpace:true + ~break:IfNeed + l + + let ensureSingleTokenSticksToLabel x = + let listConfigIfCommentsInterleaved cfg = + let inline = true, true + and postSpace = true + and indent = 0 in + { cfg with Layout.break = Always_rec; postSpace; indent; inline } + in + makeList ~listConfigIfCommentsInterleaved [ x ] + + let unbreakLabelFormatter formatter = + let newFormatter labelTerm term = + match formatter labelTerm term with + | Easy_format.Label ((labelTerm, settings), term) -> + Easy_format.Label + ((labelTerm, { settings with label_break = `Never }), term) + | _ -> failwith "not a label" + in + newFormatter + + let inlineLabel labelTerm term = + let settings = + { label_break = `Never + ; space_after_label = true + ; indent_after_label = 0 + ; label_style = Some "inlineLabel" + } + in + Easy_format.Label ((labelTerm, settings), term) + + (* Just for debugging: Set debugWithHtml = true *) + let debugWithHtml = ref false + + let html_escape_string s = + let buf = Buffer.create (2 * String.length s) in + for i = 0 to String.length s - 1 do + match s.[i] with + | '&' -> Buffer.add_string buf "&" + | '<' -> Buffer.add_string buf "<" + | '>' -> Buffer.add_string buf ">" + | c -> Buffer.add_char buf c + done; + Buffer.contents buf + + let html_escape = `Escape_string html_escape_string + + let html_style = + [ "atom", { Easy_format.tag_open = ""; tag_close = "" } + ; "body", { tag_open = ""; tag_close = "" } + ; "list", { tag_open = ""; tag_close = "" } + ; "op", { tag_open = ""; tag_close = "" } + ; "cl", { tag_open = ""; tag_close = "" } + ; "sep", { tag_open = ""; tag_close = "" } + ; "label", { tag_open = ""; tag_close = "" } + ] - But in this case, this wider region a label? - /------------------------------------------------------\ - let myVal = callSomeFunc (oneThing, {field: [], anotherField: blah}, { - boo: 'hi' - }); + let easyLabel + ?(break = `Auto) + ?(space = false) + ?(indent = settings.indentAfterLabels) + labelTerm + term + = + let settings = + { label_break = break + ; space_after_label = space + ; indent_after_label = indent + ; label_style = Some "label" + } + in + Easy_format.Label ((labelTerm, settings), term) - This is difficult. You must form a label from the preorder traversal of every - node - except the last encountered in the traversal. An easier heuristic is: + let label ?break ?space ?indent (labelTerm : Layout.t) (term : Layout.t) = + Layout.Label (easyLabel ?break ?indent ?space, labelTerm, term) - - The last argument to a functor application is expanded. + let atom ?loc str = + let style = { Easy_format.atom_style = Some "atomClss" } in + source_map ?loc (Layout.Easy (Easy_format.Atom (str, style))) - React.CreateClass SomeThing { - let render {props} => { - }; - } + (** Take x,y,z and n and generate [x, y, z, ...n] *) + let makeES6List ?wrap:(lwrap, rwrap = "", "") lst last = + makeList + ~wrap:(lwrap ^ "[", "]" ^ rwrap) + ~break:IfNeed + ~postSpace:true + ~sep:commaTrail + (lst @ [ makeList [ atom "..."; last ] ]) - - The last argument to a function application is expanded on the same line. - - Only if it's not curried with another invocation. - -- Optionally: "only if everything else is an atom" - -- Optionally: "only if there are no other args" + let makeNonIndentedBreakingList lst = + (* No align closing: So that semis stick to the ends of every break *) + makeList ~break:Always_rec ~indent:0 ~inline:(true, true) lst - React.createClass someThing { - render: fn x => y, - } + (* Like a could place with other breakableInline lists without + upsetting final semicolons *) + let makeSpacedBreakableInlineList lst = + makeList ~break:IfNeed ~inline:(true, true) ~postSpace:true lst - !!! NOT THIS - React.createClass someThing { - render: fn x => y, - } - somethingElse -*) + let makeCommaBreakableListSurround opn cls lst = + makeList ~break:IfNeed ~postSpace:true ~sep:(Sep ",") ~wrap:(opn, cls) lst -let isArityClear attrs = - (!configuredSettings).assumeExplicitArity || - List.exists - (function - | { attr_name = {txt="explicit_arity"}; _} -> true - | _ -> false - ) - attrs - -let default_indent_body = - settings.listsRecordsIndent * settings.space - -let makeList - ?listConfigIfCommentsInterleaved - ?listConfigIfEolCommentsInterleaved - ?(break=Layout.Never) - ?(wrap=("", "")) - ?(inline=(true, false)) - ?(sep=Layout.NoSep) - ?(indent=default_indent_body) - ?(sepLeft=true) - ?(preSpace=false) - ?(postSpace=false) - ?(pad=(false,false)) - lst = - let config = - { Layout. - listConfigIfCommentsInterleaved; listConfigIfEolCommentsInterleaved; - break = if lst = [] then Layout.IfNeed else break; wrap; inline; sep; indent; sepLeft; preSpace; postSpace; pad; - } - in - Layout.Sequence (config, lst) - -let makeAppList = function - | [hd] -> hd - | l -> makeList ~inline:(true, true) ~postSpace:true ~break:IfNeed l - -let makeTup ?(wrap=("", ""))?(trailComma=true) ?(uncurried = false) l = - let (lwrap, rwrap) = wrap in - let lparen = lwrap ^ (if uncurried then "(. " else "(") in - makeList - ~wrap:(lparen, ")" ^ rwrap) - ~sep:(if trailComma then commaTrail else commaSep) - ~postSpace:true - ~break:IfNeed l - -let ensureSingleTokenSticksToLabel x = - let listConfigIfCommentsInterleaved cfg = - let inline = (true, true) and postSpace = true and indent = 0 in - {cfg with Layout.break=Always_rec; postSpace; indent; inline} - in - makeList ~listConfigIfCommentsInterleaved [x] - -let unbreakLabelFormatter formatter = - let newFormatter labelTerm term = - match formatter labelTerm term with - | Easy_format.Label ((labelTerm, settings), term) -> - Easy_format.Label ((labelTerm, - {settings with label_break = `Never}), - term) - | _ -> failwith "not a label" - in newFormatter - -let inlineLabel labelTerm term = - let settings = { - label_break = `Never; - space_after_label = true; - indent_after_label = 0; - label_style = Some "inlineLabel"; - } in - Easy_format.Label ((labelTerm, settings), term) - - -(* Just for debugging: Set debugWithHtml = true *) -let debugWithHtml = ref false - -let html_escape_string s = - let buf = Buffer.create (2 * String.length s) in - for i = 0 to String.length s - 1 do - match s.[i] with - '&' -> Buffer.add_string buf "&" - | '<' -> Buffer.add_string buf "<" - | '>' -> Buffer.add_string buf ">" - | c -> Buffer.add_char buf c - done; - Buffer.contents buf - -let html_escape = `Escape_string html_escape_string - -let html_style = [ - "atom", { Easy_format.tag_open = ""; tag_close = "" }; - "body", { tag_open = ""; tag_close = "" }; - "list", { tag_open = ""; tag_close = "" }; - "op", { tag_open = ""; tag_close = "" }; - "cl", { tag_open = ""; tag_close = "" }; - "sep", { tag_open = ""; tag_close = "" }; - "label", { tag_open = ""; tag_close = "" }; -] - -let easyLabel - ?(break=`Auto) ?(space=false) ?(indent=settings.indentAfterLabels) - labelTerm term = - let settings = { - label_break = break; - space_after_label = space; - indent_after_label = indent; - label_style = Some "label"; - } in - Easy_format.Label ((labelTerm, settings), term) - -let label ?break ?space ?indent (labelTerm:Layout.t) (term:Layout.t) = - Layout.Label (easyLabel ?break ?indent ?space, labelTerm, term) - -let atom ?loc str = - let style = { Easy_format.atom_style = Some "atomClss" } in - source_map ?loc (Layout.Easy (Easy_format.Atom(str, style))) - -(** Take x,y,z and n and generate [x, y, z, ...n] *) -let makeES6List ?wrap:((lwrap,rwrap)=("", "")) lst last = - makeList - ~wrap:(lwrap ^ "[", "]" ^ rwrap) - ~break:IfNeed ~postSpace:true ~sep:commaTrail - (lst @ [makeList [atom "..."; last]]) - -let makeNonIndentedBreakingList lst = - (* No align closing: So that semis stick to the ends of every break *) - makeList ~break:Always_rec ~indent:0 ~inline:(true, true) lst - -(* Like a could place with other breakableInline lists without upsetting final semicolons *) -let makeSpacedBreakableInlineList lst = - makeList ~break:IfNeed ~inline:(true, true) ~postSpace:true lst - -let makeCommaBreakableListSurround opn cls lst = - makeList ~break:IfNeed ~postSpace:true ~sep:(Sep ",") ~wrap:(opn, cls) lst - -(* TODO: Allow configuration of spacing around colon symbol *) - -let formatPrecedence ?(inline=false) ?(wrap=("(", ")")) ?loc formattedTerm = - source_map ?loc (makeList ~inline:(true, inline) ~wrap ~break:IfNeed [formattedTerm]) - -let wrap fn term = - ignore (Format.flush_str_formatter ()); - fn Format.str_formatter term; - atom (Format.flush_str_formatter ()) - -(* Don't use `trim` since it kills line return too? *) -let rec beginsWithStar_ line length idx = - if idx = length then false else - match String.get line idx with - | '*' -> true - | '\t' | ' ' -> beginsWithStar_ line length (idx + 1) - | _ -> false + (* TODO: Allow configuration of spacing around colon symbol *) -let beginsWithStar line = beginsWithStar_ line (String.length line) 0 - -let rec numLeadingSpace_ line length idx accum = - if idx = length then accum else - match String.get line idx with - | '\t' | ' ' -> numLeadingSpace_ line length (idx + 1) (accum + 1) - | _ -> accum - -let numLeadingSpace line = numLeadingSpace_ line (String.length line) 0 0 - -(* Computes the smallest leading spaces for non-empty lines *) -let smallestLeadingSpaces strs = - let rec smallestLeadingSpaces curMin strs = match strs with - | [] -> curMin - | ""::tl -> smallestLeadingSpaces curMin tl - | hd::tl -> - let leadingSpace = numLeadingSpace hd in - let nextMin = min curMin leadingSpace in - smallestLeadingSpaces nextMin tl - in - smallestLeadingSpaces 99999 strs - -let rec isSequencey = function - | Layout.SourceMap (_, sub) -> isSequencey sub - | Layout.Sequence _ -> true - | Layout.Label (_, _, _) -> false - | Layout.Easy (Easy_format.List _) -> true - | Layout.Easy _ -> false - | Layout.Whitespace (_, sub) -> isSequencey sub - -let inline ?(preSpace=false) ?(postSpace=false) labelTerm term = - makeList [labelTerm; term] - ~inline:(true, true) ~postSpace ~preSpace ~indent:0 ~break:Layout.Never - -let breakline labelTerm term = - makeList [labelTerm; term] - ~inline:(true, true) ~indent:0 ~break:Always_rec - -let insertBlankLines n term = - if n = 0 - then term - else makeList ~inline:(true, true) ~indent:0 ~break:Always_rec - (Array.to_list (Array.make n (atom "")) @ [term]) - -let string_after s n = String.sub s n (String.length s - n) - -(* This is a special-purpose functions only used by `formatComment_`. Notice we -skip a char below during usage because we know the comment starts with `/*` *) -let rec lineZeroMeaningfulContent_ line length idx accum = - if idx = length then None - else - let ch = String.get line idx in - if ch = '\t' || ch = ' ' || ch = '*' then - lineZeroMeaningfulContent_ line length (idx + 1) (accum + 1) - else Some accum - -let lineZeroMeaningfulContent line = - lineZeroMeaningfulContent_ line (String.length line) 1 0 - -let formatComment_ txt = - let commLines = - Reason_syntax_util.split_by ~keep_empty:true (fun x -> x = '\n') - (Comment.wrap txt) - in - match commLines with - | [] -> atom "" - | [hd] -> - atom hd - | zero::one::tl -> - let attemptRemoveCount = (smallestLeadingSpaces (one::tl)) in - let leftPad = - if beginsWithStar one then 1 - else match lineZeroMeaningfulContent zero with - | None -> 1 - | Some num -> num + 1 - in - let padNonOpeningLine s = - let numLeadingSpaceForThisLine = numLeadingSpace s in - if String.length s == 0 then "" - else (String.make leftPad ' ') ^ - (string_after s (min attemptRemoveCount numLeadingSpaceForThisLine)) in - let lines = zero :: List.map padNonOpeningLine (one::tl) in - makeList ~inline:(true, true) ~indent:0 ~break:Always_rec (List.map atom lines) - -let formatComment comment = - source_map ~loc:(Comment.location comment) (formatComment_ comment) - -let[@tail_mod_cons] rec append ?(space=false) txt = function - | Layout.SourceMap (loc, sub) -> - Layout.SourceMap (loc, append ~space txt sub) - | Sequence (config, l) when snd config.wrap <> "" -> - let sep = if space then " " else "" in - Sequence ({config with wrap=(fst config.wrap, snd config.wrap ^ sep ^ txt)}, l) - | Sequence (config, []) -> - Sequence (config, [atom txt]) - | Sequence ({sep=NoSep} as config, l) - | Sequence ({sep=Sep("")} as config, l) -> - let sub = appendSub txt ~space l in - Sequence (config, sub) - | Label (formatter, left, right) -> - Label (formatter, left, append ~space txt right) - | Whitespace(info, sub) -> - Whitespace(info, append ~space txt sub) - | layout -> - (inline [@tailcall false]) ~postSpace:space layout (atom txt) -and[@tail_mod_cons] appendSub txt ~space layouts = - match layouts with - | [] -> [] - | [ layout ] -> [ append ~space txt layout ] - | layout :: xs -> layout :: appendSub txt ~space xs - -let appendSep spaceBeforeSep sep layout = - append (if spaceBeforeSep then " " ^ sep else sep) layout - -let rec flattenCommentAndSep ?spaceBeforeSep:(spaceBeforeSep=false) ?sepStr = function - | Layout.SourceMap (loc, sub) -> - Layout.SourceMap (loc, flattenCommentAndSep ~spaceBeforeSep ?sepStr sub) - | Layout.Whitespace(info, sub) -> - Layout.Whitespace(info, flattenCommentAndSep ~spaceBeforeSep ?sepStr sub) - | layout -> - begin - match sepStr with - | None -> layout - | Some sep -> appendSep spaceBeforeSep sep layout - end - -let rec preOrderWalk f layout = - match f layout with - | Layout.Sequence (listConfig, sublayouts) -> - let newSublayouts = List.map (preOrderWalk f) sublayouts in - Layout.Sequence (listConfig, newSublayouts) - | Layout.Label (formatter, left, right) -> - let newLeftLayout = preOrderWalk f left in - let newRightLayout = preOrderWalk f right in - Layout.Label (formatter, newLeftLayout, newRightLayout) - | Layout.SourceMap (loc, sub) -> - Layout.SourceMap (loc, preOrderWalk f sub) - | Layout.Easy _ as layout -> layout - | Layout.Whitespace (info, sub) -> - Layout.Whitespace(info, preOrderWalk f sub) - -(** Recursively unbreaks a layout to make sure they stay within the same line *) -let unbreaklayout = preOrderWalk (function - | Layout.Sequence (listConfig, sublayouts) -> - Layout.Sequence ({listConfig with break=Layout.Never}, sublayouts) - | Layout.Label (formatter, left, right) -> - Layout.Label (unbreakLabelFormatter formatter, left, right) - | layout -> layout -) - -(** [consolidateSeparator layout] walks the [layout], extract separators out of each - * list and insert them into PrintTree as separated items - *) -let consolidateSeparator l = preOrderWalk (function - | Sequence (listConfig, sublayouts) when listConfig.sep != NoSep && listConfig.sepLeft -> - (* TODO: Support !sepLeft, and this should apply to the *first* separator if !sepLeft. *) - let[@tail_mod_cons] rec mapSublayout layouts = - match (listConfig.sep, layouts) with - | (NoSep, _) -> raise (NotPossible "We already covered this case. This shouldn't happen.") - | (Sep _, [ layout ]) -> [ layout ] - | ((SepFinal (sepStr, _) | Sep sepStr), layout :: l2 :: xs) -> - flattenCommentAndSep ~spaceBeforeSep:listConfig.preSpace ~sepStr:sepStr layout - :: mapSublayout (l2 :: xs) - | (SepFinal (_, finalSepStr), [ layout ]) -> - [ flattenCommentAndSep ~spaceBeforeSep:listConfig.preSpace ~sepStr:finalSepStr layout ] - | (_, []) -> [] - in - let layoutsWithSepAndComment = mapSublayout sublayouts in - let sep = Layout.NoSep in - let preSpace = false in - Sequence ({listConfig with sep; preSpace}, layoutsWithSepAndComment) - | layout -> layout -) l - - -(** [insertLinesAboveItems layout] walks the [layout] and insert empty lines *) -let insertLinesAboveItems items = preOrderWalk (function - | Whitespace(region, sub) -> - insertBlankLines (WhitespaceRegion.newlines region) sub - | layout -> layout -) items - -let insertCommentIntoWhitespaceRegion comment region subLayout = - let cl = Comment.location comment in - let range = WhitespaceRegion.range region in - (* append the comment to the list of inserted comments in the whitespace region *) - let nextRegion = WhitespaceRegion.addComment region comment in - let formattedComment = formatComment comment in - match WhitespaceRegion.comments region with - (* the comment inserted into the whitespace region is the first in the region *) - | [] -> - (* - * 1| let a = 1; - * 2| - * 3| /* comment at end of whitespace region */ - * 4| let b = 2; - *) - if range.lnum_end = cl.loc_end.pos_lnum then - let subLayout = breakline formattedComment subLayout in - Layout.Whitespace(nextRegion, subLayout) - - (* - * 1| let a = 1; - * 2| /* comment at start of whitespace region */ - * 3| - * 4| let b = 2; - *) - else if range.lnum_start = cl.loc_start.pos_lnum then - let subLayout = breakline formattedComment (insertBlankLines 1 subLayout) in - let nextRegion = WhitespaceRegion.modifyNewlines nextRegion 0 in - Whitespace(nextRegion, subLayout) - - (* - * 1| let a = 1; - * 2| - * 3| /* comment floats in whitespace region */ - * 4| - * 5| let b = 2; - *) + let formatPrecedence ?(inline = false) ?(wrap = "(", ")") ?loc formattedTerm + = + source_map + ?loc + (makeList ~inline:(true, inline) ~wrap ~break:IfNeed [ formattedTerm ]) + + let wrap fn term = + ignore (Format.flush_str_formatter ()); + fn Format.str_formatter term; + atom (Format.flush_str_formatter ()) + + (* Don't use `trim` since it kills line return too? *) + let rec beginsWithStar_ line length idx = + if idx = length + then false + else + match String.get line idx with + | '*' -> true + | '\t' | ' ' -> beginsWithStar_ line length (idx + 1) + | _ -> false + + let beginsWithStar line = beginsWithStar_ line (String.length line) 0 + + let rec numLeadingSpace_ line length idx accum = + if idx = length + then accum + else + match String.get line idx with + | '\t' | ' ' -> numLeadingSpace_ line length (idx + 1) (accum + 1) + | _ -> accum + + let numLeadingSpace line = numLeadingSpace_ line (String.length line) 0 0 + + (* Computes the smallest leading spaces for non-empty lines *) + let smallestLeadingSpaces strs = + let rec smallestLeadingSpaces curMin strs = + match strs with + | [] -> curMin + | "" :: tl -> smallestLeadingSpaces curMin tl + | hd :: tl -> + let leadingSpace = numLeadingSpace hd in + let nextMin = min curMin leadingSpace in + smallestLeadingSpaces nextMin tl + in + smallestLeadingSpaces 99999 strs + + let rec isSequencey = function + | Layout.SourceMap (_, sub) -> isSequencey sub + | Layout.Sequence _ -> true + | Layout.Label (_, _, _) -> false + | Layout.Easy (Easy_format.List _) -> true + | Layout.Easy _ -> false + | Layout.Whitespace (_, sub) -> isSequencey sub + + let inline ?(preSpace = false) ?(postSpace = false) labelTerm term = + makeList + [ labelTerm; term ] + ~inline:(true, true) + ~postSpace + ~preSpace + ~indent:0 + ~break:Layout.Never + + let breakline labelTerm term = + makeList + [ labelTerm; term ] + ~inline:(true, true) + ~indent:0 + ~break:Always_rec + + let insertBlankLines n term = + if n = 0 + then term + else + makeList + ~inline:(true, true) + ~indent:0 + ~break:Always_rec + (Array.to_list (Array.make n (atom "")) @ [ term ]) + + let string_after s n = String.sub s n (String.length s - n) + + (* This is a special-purpose functions only used by `formatComment_`. Notice + we skip a char below during usage because we know the comment starts with + `/*` *) + let rec lineZeroMeaningfulContent_ line length idx accum = + if idx = length + then None else - let subLayout = breakline formattedComment (insertBlankLines 1 subLayout) in - Whitespace(nextRegion, subLayout) - - (* The whitespace region contains already inserted comments *) - | prevComment::_cs -> - let pcl = Comment.location prevComment in - (* check if the comment is attached to the start of the region *) - let attachedToStartRegion = cl.loc_start.pos_lnum = range.lnum_start in - let nextRegion = + let ch = String.get line idx in + if ch = '\t' || ch = ' ' || ch = '*' + then lineZeroMeaningfulContent_ line length (idx + 1) (accum + 1) + else Some accum + + let lineZeroMeaningfulContent line = + lineZeroMeaningfulContent_ line (String.length line) 1 0 + + let formatComment_ txt = + let commLines = + Reason_syntax_util.split_by + ~keep_empty:true + (fun x -> x = '\n') + (Comment.wrap txt) + in + match commLines with + | [] -> atom "" + | [ hd ] -> atom hd + | zero :: one :: tl -> + let attemptRemoveCount = smallestLeadingSpaces (one :: tl) in + let leftPad = + if beginsWithStar one + then 1 + else + match lineZeroMeaningfulContent zero with + | None -> 1 + | Some num -> num + 1 + in + let padNonOpeningLine s = + let numLeadingSpaceForThisLine = numLeadingSpace s in + if String.length s == 0 + then "" + else + String.make leftPad ' ' + ^ string_after s (min attemptRemoveCount numLeadingSpaceForThisLine) + in + let lines = zero :: List.map padNonOpeningLine (one :: tl) in + makeList + ~inline:(true, true) + ~indent:0 + ~break:Always_rec + (List.map atom lines) + + let formatComment comment = + source_map ~loc:(Comment.location comment) (formatComment_ comment) + + let[@tail_mod_cons] rec append ?(space = false) txt = function + | Layout.SourceMap (loc, sub) -> + Layout.SourceMap (loc, append ~space txt sub) + | Sequence (config, l) when snd config.wrap <> "" -> + let sep = if space then " " else "" in + Sequence + ( { config with wrap = fst config.wrap, snd config.wrap ^ sep ^ txt } + , l ) + | Sequence (config, []) -> Sequence (config, [ atom txt ]) + | Sequence (({ sep = NoSep } as config), l) + | Sequence (({ sep = Sep "" } as config), l) -> + let sub = appendSub txt ~space l in + Sequence (config, sub) + | Label (formatter, left, right) -> + Label (formatter, left, append ~space txt right) + | Whitespace (info, sub) -> Whitespace (info, append ~space txt sub) + | layout -> (inline [@tailcall false]) ~postSpace:space layout (atom txt) + + and[@tail_mod_cons] appendSub txt ~space layouts = + match layouts with + | [] -> [] + | [ layout ] -> [ append ~space txt layout ] + | layout :: xs -> layout :: appendSub txt ~space xs + + let appendSep spaceBeforeSep sep layout = + append (if spaceBeforeSep then " " ^ sep else sep) layout + + let rec flattenCommentAndSep ?(spaceBeforeSep = false) ?sepStr = function + | Layout.SourceMap (loc, sub) -> + Layout.SourceMap (loc, flattenCommentAndSep ~spaceBeforeSep ?sepStr sub) + | Layout.Whitespace (info, sub) -> + Layout.Whitespace + (info, flattenCommentAndSep ~spaceBeforeSep ?sepStr sub) + | layout -> + (match sepStr with + | None -> layout + | Some sep -> appendSep spaceBeforeSep sep layout) + + let rec preOrderWalk f layout = + match f layout with + | Layout.Sequence (listConfig, sublayouts) -> + let newSublayouts = List.map (preOrderWalk f) sublayouts in + Layout.Sequence (listConfig, newSublayouts) + | Layout.Label (formatter, left, right) -> + let newLeftLayout = preOrderWalk f left in + let newRightLayout = preOrderWalk f right in + Layout.Label (formatter, newLeftLayout, newRightLayout) + | Layout.SourceMap (loc, sub) -> Layout.SourceMap (loc, preOrderWalk f sub) + | Layout.Easy _ as layout -> layout + | Layout.Whitespace (info, sub) -> + Layout.Whitespace (info, preOrderWalk f sub) + + (** Recursively unbreaks a layout to make sure they stay within the same + line *) + let unbreaklayout = + preOrderWalk (function + | Layout.Sequence (listConfig, sublayouts) -> + Layout.Sequence ({ listConfig with break = Layout.Never }, sublayouts) + | Layout.Label (formatter, left, right) -> + Layout.Label (unbreakLabelFormatter formatter, left, right) + | layout -> layout) + + (** [consolidateSeparator layout] walks the [layout], extract separators out + of each * list and insert them into PrintTree as separated items *) + let consolidateSeparator l = + preOrderWalk + (function + | Sequence (listConfig, sublayouts) + when listConfig.sep != NoSep && listConfig.sepLeft -> + (* TODO: Support !sepLeft, and this should apply to the *first* + separator if !sepLeft. *) + let[@tail_mod_cons] rec mapSublayout layouts = + match listConfig.sep, layouts with + | NoSep, _ -> + raise + (NotPossible + "We already covered this case. This shouldn't happen.") + | Sep _, [ layout ] -> [ layout ] + | (SepFinal (sepStr, _) | Sep sepStr), layout :: l2 :: xs -> + flattenCommentAndSep + ~spaceBeforeSep:listConfig.preSpace + ~sepStr + layout + :: mapSublayout (l2 :: xs) + | SepFinal (_, finalSepStr), [ layout ] -> + [ flattenCommentAndSep + ~spaceBeforeSep:listConfig.preSpace + ~sepStr:finalSepStr + layout + ] + | _, [] -> [] + in + let layoutsWithSepAndComment = mapSublayout sublayouts in + let sep = Layout.NoSep in + let preSpace = false in + Sequence + ({ listConfig with sep; preSpace }, layoutsWithSepAndComment) + | layout -> layout) + l + + (** [insertLinesAboveItems layout] walks the [layout] and insert empty lines *) + let insertLinesAboveItems items = + preOrderWalk + (function + | Whitespace (region, sub) -> + insertBlankLines (WhitespaceRegion.newlines region) sub + | layout -> layout) + items + + let insertCommentIntoWhitespaceRegion comment region subLayout = + let cl = Comment.location comment in + let range = WhitespaceRegion.range region in + (* append the comment to the list of inserted comments in the whitespace + region *) + let nextRegion = WhitespaceRegion.addComment region comment in + let formattedComment = formatComment comment in + match WhitespaceRegion.comments region with + (* the comment inserted into the whitespace region is the first in the + region *) + | [] -> (* * 1| let a = 1; - * 2| /* comment sits on the beginning of the region */ - * 3| /* previous comment */ - * 4| - * 5| let b = 2; + * 2| + * 3| /* comment at end of whitespace region */ + * 4| let b = 2; *) - if attachedToStartRegion then - (* we don't want a newline between `let a = 1` and the `comment sits - * on the beginning of the region` comment*) - WhitespaceRegion.modifyNewlines nextRegion 0 + if range.lnum_end = cl.loc_end.pos_lnum + then + let subLayout = breakline formattedComment subLayout in + Layout.Whitespace (nextRegion, subLayout) + (* + * 1| let a = 1; + * 2| /* comment at start of whitespace region */ + * 3| + * 4| let b = 2; + *) + else if range.lnum_start = cl.loc_start.pos_lnum + then + let subLayout = + breakline formattedComment (insertBlankLines 1 subLayout) + in + let nextRegion = WhitespaceRegion.modifyNewlines nextRegion 0 in + Whitespace (nextRegion, subLayout) + (* + * 1| let a = 1; + * 2| + * 3| /* comment floats in whitespace region */ + * 4| + * 5| let b = 2; + *) + else + let subLayout = + breakline formattedComment (insertBlankLines 1 subLayout) + in + Whitespace (nextRegion, subLayout) + (* The whitespace region contains already inserted comments *) + | prevComment :: _cs -> + let pcl = Comment.location prevComment in + (* check if the comment is attached to the start of the region *) + let attachedToStartRegion = cl.loc_start.pos_lnum = range.lnum_start in + let nextRegion = + (* + * 1| let a = 1; + * 2| /* comment sits on the beginning of the region */ + * 3| /* previous comment */ + * 4| + * 5| let b = 2; + *) + if attachedToStartRegion + then + (* we don't want a newline between `let a = 1` and the `comment sits + * on the beginning of the region` comment*) + WhitespaceRegion.modifyNewlines nextRegion 0 + (* + * 1| let a = 1; + * 2| + * 3| /* comment isn't located at the beginnin of a region*/ + * 4| /* previous comment */ + * 5| + * 6| let b = 2; + *) + else nextRegion + in (* * 1| let a = 1; - * 2| - * 3| /* comment isn't located at the beginnin of a region*/ + * 2| /* comment */ + * 3| --> whitespace between * 4| /* previous comment */ - * 5| - * 6| let b = 2; + * 5| let b = 1; *) + if Reason_location.hasSpaceBetween pcl cl + then + (* pcl.loc_start.pos_lnum - cl.loc_end.pos_lnum > 1 then *) + let subLayout = + breakline formattedComment (insertBlankLines 1 subLayout) + in + let withComment = Layout.Whitespace (nextRegion, subLayout) in + withComment + (* + * 1| let a = 1; + * 2| + * 3| /* comment */ | no whitespace between `comment` + * 4| /* previous comment */ | and `previous comment` + * 5| let b = 1; + *) else - nextRegion - in - (* - * 1| let a = 1; - * 2| /* comment */ - * 3| --> whitespace between - * 4| /* previous comment */ - * 5| let b = 1; - *) - if Reason_location.hasSpaceBetween pcl cl then - (* pcl.loc_start.pos_lnum - cl.loc_end.pos_lnum > 1 then *) - let subLayout = breakline formattedComment (insertBlankLines 1 subLayout) in - let withComment = Layout.Whitespace(nextRegion, subLayout) in - withComment - - (* - * 1| let a = 1; - * 2| - * 3| /* comment */ | no whitespace between `comment` - * 4| /* previous comment */ | and `previous comment` - * 5| let b = 1; - *) - else - let subLayout = breakline formattedComment subLayout in - let withComment = Layout.Whitespace(nextRegion, subLayout) in - withComment - -(** - * prependSingleLineComment inserts a single line comment right above layout - *) -let rec prependSingleLineComment comment layout = - match layout with - | Layout.SourceMap (loc, sub) -> - Layout.SourceMap (loc, prependSingleLineComment comment sub) - | Sequence (config, hd::tl) when config.break = Always_rec-> - Sequence(config, (prependSingleLineComment comment hd)::tl) - | Whitespace(info, sub) -> - insertCommentIntoWhitespaceRegion comment info sub - | layout -> - breakline (formatComment comment) layout - -(* breakAncestors break ancestors above node, but not comment attachment itself.*) -let appendComment ~breakAncestors layout comment = - let text = Comment.wrap comment in - let layout = match layout with - | Layout.Whitespace(info, sublayout) -> - Layout.Whitespace(info, makeList ~break:Layout.Never ~postSpace:true [sublayout; atom text]) - | layout -> - makeList ~break:Layout.Never ~postSpace:true [layout; atom text] - in - if breakAncestors then - makeList ~inline:(true, true) ~postSpace:false ~preSpace:true ~indent:0 - ~break:Always_rec [layout] - else - layout + let subLayout = breakline formattedComment subLayout in + let withComment = Layout.Whitespace (nextRegion, subLayout) in + withComment + + (** * prependSingleLineComment inserts a single line comment right above + layout *) + let rec prependSingleLineComment comment layout = + match layout with + | Layout.SourceMap (loc, sub) -> + Layout.SourceMap (loc, prependSingleLineComment comment sub) + | Sequence (config, hd :: tl) when config.break = Always_rec -> + Sequence (config, prependSingleLineComment comment hd :: tl) + | Whitespace (info, sub) -> + insertCommentIntoWhitespaceRegion comment info sub + | layout -> breakline (formatComment comment) layout -(** - * [looselyAttachComment layout comment] preorderly walks the layout and - * find a place where the comment can be loosely attached to - *) -let rec looselyAttachComment ~breakAncestors layout comment = - let location = Comment.location comment in - match layout with - | Layout.SourceMap (loc, sub) -> - Layout.SourceMap (loc, looselyAttachComment ~breakAncestors sub comment) - | Layout.Whitespace (info, sub) -> - Layout.Whitespace(info, looselyAttachComment ~breakAncestors sub comment) - | Easy _ -> - inline ~postSpace:true layout (formatComment comment) - | Sequence (listConfig, subLayouts) - when List.exists (Layout.contains_location ~location) subLayouts -> - (* If any of the subLayout strictly contains this comment, recurse into to it *) - let recurse_sublayout layout = - if Layout.contains_location layout ~location - then begin - looselyAttachComment ~breakAncestors layout comment - end + (* breakAncestors break ancestors above node, but not comment attachment + itself.*) + let appendComment ~breakAncestors layout comment = + let text = Comment.wrap comment in + let layout = + match layout with + | Layout.Whitespace (info, sublayout) -> + Layout.Whitespace + ( info + , makeList + ~break:Layout.Never + ~postSpace:true + [ sublayout; atom text ] ) + | layout -> + makeList ~break:Layout.Never ~postSpace:true [ layout; atom text ] + in + if breakAncestors + then + makeList + ~inline:(true, true) + ~postSpace:false + ~preSpace:true + ~indent:0 + ~break:Always_rec + [ layout ] else layout - in - Sequence (listConfig, List.map recurse_sublayout subLayouts) - | Sequence (listConfig, subLayouts) when subLayouts == [] -> - (* If there are no subLayouts (empty body), create a Sequence of just the comment *) - Sequence (listConfig, [formatComment comment]) - | Sequence (listConfig, subLayouts) -> - let (beforeComment, afterComment) = - Reason_syntax_util.pick_while (Layout.is_before ~location) subLayouts in - let newSubLayout = match List.rev beforeComment with - | [] -> - Reason_syntax_util.map_first (prependSingleLineComment comment) afterComment - | hd :: tl -> - List.rev_append - (appendComment ~breakAncestors hd comment :: tl) afterComment - in - Sequence (listConfig, newSubLayout) - | Label (formatter, left, right) -> - let newLeft, newRight = - match (Layout.get_location left, Layout.get_location right) with - | (None, None) -> - (left, looselyAttachComment ~breakAncestors right comment) - | (_, Some loc2) when Reason_syntax_util.location_contains loc2 location -> - (left, looselyAttachComment ~breakAncestors right comment) - | (Some loc1, _) when Reason_syntax_util.location_contains loc1 location -> - (looselyAttachComment ~breakAncestors left comment, right) - | (Some loc1, Some _) when Reason_syntax_util.location_is_before location loc1 -> - (prependSingleLineComment comment left, right) - | (Some _, Some loc2) when Reason_syntax_util.location_is_before location loc2 -> - (left, prependSingleLineComment comment right) - | _ -> (left, appendComment ~breakAncestors right comment) - in - Label (formatter, newLeft, newRight) -(** - * [insertSingleLineComment layout comment] preorderly walks the layout and - * find a place where the SingleLineComment can be fit into - *) -let rec insertSingleLineComment layout comment = - let location = Comment.location comment in - match layout with - | Layout.SourceMap (loc, sub) -> - Layout.SourceMap (loc, insertSingleLineComment sub comment) - | Layout.Whitespace (info, sub) -> - let range = WhitespaceRegion.range info in - if Range.containsLoc range location then - insertCommentIntoWhitespaceRegion comment info sub - else - Layout.Whitespace(info, insertSingleLineComment sub comment) - | Easy _ -> - prependSingleLineComment comment layout - | Sequence (listConfig, subLayouts) when subLayouts == [] -> - (* If there are no subLayouts (empty body), create a Sequence of just the - * comment. We need to be careful when the empty body contains a //-style - * comment. Example: - * let make = () => { - * // - * }; - * It is clear that the sequence needs to always break here, otherwise - * we get a parse error: let make = () => { // }; - * The closing brace and semicolon `};` would become part of the comment… + (** * [looselyAttachComment layout comment] preorderly walks the layout and + * find a place where the comment can be loosely attached to *) + let rec looselyAttachComment ~breakAncestors layout comment = + let location = Comment.location comment in + match layout with + | Layout.SourceMap (loc, sub) -> + Layout.SourceMap (loc, looselyAttachComment ~breakAncestors sub comment) + | Layout.Whitespace (info, sub) -> + Layout.Whitespace + (info, looselyAttachComment ~breakAncestors sub comment) + | Easy _ -> inline ~postSpace:true layout (formatComment comment) + | Sequence (listConfig, subLayouts) + when List.exists (Layout.contains_location ~location) subLayouts -> + (* If any of the subLayout strictly contains this comment, recurse into + to it *) + let recurse_sublayout layout = + if Layout.contains_location layout ~location + then looselyAttachComment ~breakAncestors layout comment + else layout + in + Sequence (listConfig, List.map recurse_sublayout subLayouts) + | Sequence (listConfig, subLayouts) when subLayouts == [] -> + (* If there are no subLayouts (empty body), create a Sequence of just + the comment *) + Sequence (listConfig, [ formatComment comment ]) + | Sequence (listConfig, subLayouts) -> + let beforeComment, afterComment = + Reason_syntax_util.pick_while (Layout.is_before ~location) subLayouts + in + let newSubLayout = + match List.rev beforeComment with + | [] -> + Reason_syntax_util.map_first + (prependSingleLineComment comment) + afterComment + | hd :: tl -> + List.rev_append + (appendComment ~breakAncestors hd comment :: tl) + afterComment + in + Sequence (listConfig, newSubLayout) + | Label (formatter, left, right) -> + let newLeft, newRight = + match Layout.get_location left, Layout.get_location right with + | None, None -> + left, looselyAttachComment ~breakAncestors right comment + | _, Some loc2 when Reason_syntax_util.location_contains loc2 location + -> + left, looselyAttachComment ~breakAncestors right comment + | Some loc1, _ when Reason_syntax_util.location_contains loc1 location + -> + looselyAttachComment ~breakAncestors left comment, right + | Some loc1, Some _ + when Reason_syntax_util.location_is_before location loc1 -> + prependSingleLineComment comment left, right + | Some _, Some loc2 + when Reason_syntax_util.location_is_before location loc2 -> + left, prependSingleLineComment comment right + | _ -> left, appendComment ~breakAncestors right comment + in + Label (formatter, newLeft, newRight) + + (** * [insertSingleLineComment layout comment] preorderly walks the layout + and * find a place where the SingleLineComment can be fit into *) + let rec insertSingleLineComment layout comment = + let location = Comment.location comment in + match layout with + | Layout.SourceMap (loc, sub) -> + Layout.SourceMap (loc, insertSingleLineComment sub comment) + | Layout.Whitespace (info, sub) -> + let range = WhitespaceRegion.range info in + if Range.containsLoc range location + then insertCommentIntoWhitespaceRegion comment info sub + else Layout.Whitespace (info, insertSingleLineComment sub comment) + | Easy _ -> prependSingleLineComment comment layout + | Sequence (listConfig, subLayouts) when subLayouts == [] -> + (* If there are no subLayouts (empty body), create a Sequence of just the + * comment. We need to be careful when the empty body contains a //-style + * comment. Example: + * let make = () => { + * // + * }; + * It is clear that the sequence needs to always break here, otherwise + * we get a parse error: let make = () => { // }; + * The closing brace and semicolon `};` would become part of the comment… + *) + let listConfig = + if Reason_comment.isLineComment comment + then { listConfig with break = Always_rec } + else listConfig + in + Sequence (listConfig, [ formatComment comment ]) + | Sequence (listConfig, subLayouts) -> + let beforeComment, afterComment = + Reason_syntax_util.pick_while (Layout.is_before ~location) subLayouts + in + (match afterComment with + (* Nothing in the list is after comment, attach comment to the statement + before the comment *) + | [] -> + let break sublayout = breakline sublayout (formatComment comment) in + Sequence (listConfig, Reason_syntax_util.map_last break beforeComment) + | hd :: tl -> + let afterComment = + match Layout.get_location hd with + | Some loc when Reason_syntax_util.location_contains loc location -> + insertSingleLineComment hd comment :: tl + | Some loc -> + Layout.SourceMap (loc, prependSingleLineComment comment hd) :: tl + | _ -> prependSingleLineComment comment hd :: tl + in + Sequence (listConfig, beforeComment @ afterComment)) + | Label (formatter, left, right) -> + let leftLoc = Layout.get_location left in + let rightLoc = Layout.get_location right in + let newLeft, newRight = + match leftLoc, rightLoc with + | None, None -> left, insertSingleLineComment right comment + | _, Some loc2 when Reason_syntax_util.location_contains loc2 location + -> + left, insertSingleLineComment right comment + | Some loc1, _ when Reason_syntax_util.location_contains loc1 location + -> + insertSingleLineComment left comment, right + | Some loc1, Some _ + when Reason_syntax_util.location_is_before location loc1 -> + prependSingleLineComment comment left, right + | Some _, Some loc2 + when Reason_syntax_util.location_is_before location loc2 -> + left, prependSingleLineComment comment right + | _ -> left, breakline right (formatComment comment) + in + Label (formatter, newLeft, newRight) + + let rec attachCommentToNodeRight layout comment = + match layout with + | Layout.Sequence (config, sub) when snd config.wrap <> "" -> + (* jwalke: This is quite the abuse of the "wrap" config *) + let lwrap, rwrap = config.wrap in + let rwrap = rwrap ^ " " ^ Comment.wrap comment in + Layout.Sequence ({ config with wrap = lwrap, rwrap }, sub) + | Layout.SourceMap (loc, sub) -> + Layout.SourceMap (loc, attachCommentToNodeRight sub comment) + | layout -> inline ~postSpace:true layout (formatComment comment) + + let rec attachCommentToNodeLeft comment layout = + match layout with + | Layout.Sequence (config, sub) when snd config.wrap <> "" -> + let lwrap, rwrap = config.wrap in + let lwrap = Comment.wrap comment ^ " " ^ lwrap in + Layout.Sequence ({ config with wrap = lwrap, rwrap }, sub) + | Layout.SourceMap (loc, sub) -> + Layout.SourceMap (loc, attachCommentToNodeLeft comment sub) + | layout -> Layout.Label (inlineLabel, formatComment comment, layout) + + (* [tryPerfectlyAttachComment layout comment] postorderly walk the [layout] and tries + * to perfectly attach a comment with a layout node. + * + * Perfectly attach here means a comment's start location is equal to the node's end location + * and vice versa. + * + * If the comment can be perfectly attached to any layout node, returns (newLayout, None), + * meaning the comment is consumed. Otherwise returns the (unchangedLayout, Some comment), + * meaning the comment is not consumed. + * + * "perfect attachment" doesn't make sense for end of line comments: + * + * { + * x: 0, + * y: 0 + * } + * + * One of these will be "perfectly attached" to the zero and the other won't. + * Why should the comma have such an influence? Trailing commas and semicolons + * may be inserted or removed, an we need end-of-line comments to never be + * impacted by that. Therefore, never try to "perfectly" attach EOL comments. *) - let listConfig = - if Reason_comment.isLineComment comment then - {listConfig with break = Always_rec} - else - listConfig - in - Sequence (listConfig, [formatComment comment]) - | Sequence (listConfig, subLayouts) -> - let (beforeComment, afterComment) = - Reason_syntax_util.pick_while (Layout.is_before ~location) subLayouts in - begin match afterComment with - (* Nothing in the list is after comment, attach comment to the statement before the comment *) - | [] -> - let break sublayout = breakline sublayout (formatComment comment) in - Sequence (listConfig, Reason_syntax_util.map_last break beforeComment) - | hd::tl -> - let afterComment = - match Layout.get_location hd with - | Some loc when Reason_syntax_util.location_contains loc location -> - insertSingleLineComment hd comment :: tl - | Some loc -> - Layout.SourceMap (loc, (prependSingleLineComment comment hd)) :: tl - | _ -> - prependSingleLineComment comment hd :: tl + let rec tryPerfectlyAttachComment layout = function + | None -> layout, None + | Some comment -> perfectlyAttachComment comment layout + + and perfectlyAttachComment comment = function + | Layout.Sequence (listConfig, subLayouts) -> + let distributeCommentIntoSubLayouts (i, processed, newComment) layout = + let layout, newComment = + tryPerfectlyAttachComment layout newComment + in + i + 1, layout :: processed, newComment in - Sequence (listConfig, beforeComment @ afterComment) - end - | Label (formatter, left, right) -> - let leftLoc = Layout.get_location left in - let rightLoc = Layout.get_location right in - let newLeft, newRight = match (leftLoc, rightLoc) with - | (None, None) -> - (left, insertSingleLineComment right comment) - | (_, Some loc2) when Reason_syntax_util.location_contains loc2 location -> - (left, insertSingleLineComment right comment) - | (Some loc1, _) when Reason_syntax_util.location_contains loc1 location -> - (insertSingleLineComment left comment, right) - | (Some loc1, Some _) when Reason_syntax_util.location_is_before location loc1 -> - (prependSingleLineComment comment left, right) - | (Some _, Some loc2) when Reason_syntax_util.location_is_before location loc2 -> - (left, prependSingleLineComment comment right) - | _ -> - (left, breakline right (formatComment comment)) - in - Label (formatter, newLeft, newRight) - -let rec attachCommentToNodeRight layout comment = - match layout with - | Layout.Sequence (config, sub) when snd config.wrap <> "" -> - (* jwalke: This is quite the abuse of the "wrap" config *) - let lwrap, rwrap = config.wrap in - let rwrap = rwrap ^ " " ^ Comment.wrap comment in - Layout.Sequence ({config with wrap=(lwrap, rwrap)}, sub) - | Layout.SourceMap (loc, sub) -> - Layout.SourceMap (loc, attachCommentToNodeRight sub comment) - | layout -> inline ~postSpace:true layout (formatComment comment) - -let rec attachCommentToNodeLeft comment layout = - match layout with - | Layout.Sequence (config, sub) when snd config.wrap <> "" -> - let lwrap, rwrap = config.wrap in - let lwrap = Comment.wrap comment ^ " " ^ lwrap in - Layout.Sequence ({config with wrap = (lwrap, rwrap)}, sub) - | Layout.SourceMap (loc, sub) -> - Layout.SourceMap (loc, attachCommentToNodeLeft comment sub ) - | layout -> - Layout.Label (inlineLabel, formatComment comment, layout) - -(** [tryPerfectlyAttachComment layout comment] postorderly walk the [layout] and tries - * to perfectly attach a comment with a layout node. - * - * Perfectly attach here means a comment's start location is equal to the node's end location - * and vice versa. - * - * If the comment can be perfectly attached to any layout node, returns (newLayout, None), - * meaning the comment is consumed. Otherwise returns the (unchangedLayout, Some comment), - * meaning the comment is not consumed. - * - * "perfect attachment" doesn't make sense for end of line comments: - * - * { - * x: 0, - * y: 0 - * } - * - * One of these will be "perfectly attached" to the zero and the other won't. - * Why should the comma have such an influence? Trailing commas and semicolons - * may be inserted or removed, an we need end-of-line comments to never be - * impacted by that. Therefore, never try to "perfectly" attach EOL comments. - *) -let rec tryPerfectlyAttachComment layout = function - | None -> (layout, None) - | Some comment -> perfectlyAttachComment comment layout - -and perfectlyAttachComment comment = function - | Layout.Sequence (listConfig, subLayouts) -> - let distributeCommentIntoSubLayouts (i, processed, newComment) layout = - let (layout, newComment) = - tryPerfectlyAttachComment layout newComment in - (i + 1, layout::processed, newComment) - in - let (_, processed, consumed) = - List.fold_left - distributeCommentIntoSubLayouts - (0, [], Some comment) (List.rev subLayouts) - in - Layout.Sequence (listConfig, processed), consumed - | Layout.Label (labelFormatter, left, right) -> - let (newRight, comment) = perfectlyAttachComment comment right in - let (newLeft, comment) = tryPerfectlyAttachComment left comment in - Layout.Label (labelFormatter, newLeft, newRight), comment - | Layout.SourceMap (loc, subLayout) -> - let commloc = Comment.location comment in - if loc.loc_end.Lexing.pos_lnum = loc.loc_start.Lexing.pos_lnum && - commloc.loc_start.Lexing.pos_cnum = loc.loc_end.Lexing.pos_cnum - then - (Layout.SourceMap (loc, makeList ~inline:(true, true) ~break:Always - [unbreaklayout (attachCommentToNodeRight subLayout comment)]), - None) - else - let (layout, comment) = perfectlyAttachComment comment subLayout in - begin match comment with - | None -> (Layout.SourceMap (loc, layout), None) - | Some comment -> - if commloc.loc_end.Lexing.pos_cnum = - loc.loc_start.Lexing.pos_cnum then - (Layout.SourceMap (loc, attachCommentToNodeLeft comment layout), None) - else if commloc.loc_start.Lexing.pos_cnum = loc.loc_end.Lexing.pos_cnum then - (Layout.SourceMap (loc, attachCommentToNodeRight layout comment), None) - else - (Layout.SourceMap (loc, layout), Some comment) - end - | Whitespace(info, subLayout) -> - begin match perfectlyAttachComment comment subLayout with - | (newLayout, None) -> (Whitespace(info, newLayout), None) - | (newLayout, Some c) -> (Whitespace(info, newLayout), Some c) - end - | layout -> (layout, Some comment) - -let insertRegularComment layout comment = - match perfectlyAttachComment comment layout with - | (layout, None) -> layout - | (layout, Some _) -> - looselyAttachComment ~breakAncestors:false layout comment - -let insertEndOfLineComment layout comment = - looselyAttachComment ~breakAncestors:true layout comment - -let rec partitionComments_ ((singleLines, endOfLines, regulars) as soFar) = function - | [] -> soFar - | com :: tl -> - match Comment.category com with - | Comment.EndOfLine -> - partitionComments_ (singleLines, (com :: endOfLines), regulars) tl - | Comment.SingleLine -> - partitionComments_ ((com :: singleLines), endOfLines, regulars) tl - | Comment.Regular -> - partitionComments_ (singleLines, endOfLines, (com :: regulars)) tl - -let partitionComments comments = - let (singleLines, endOfLines, regulars) = - partitionComments_ ([], [], []) comments in - (singleLines, List.rev endOfLines, regulars) - -(* - * Partition single line comments based on a location into two lists: - * - one contains the comments before/same height of that location - * - the other contains the comments after the location - *) -let partitionSingleLineComments loc singleLineComments = - let (before, after) = List.fold_left (fun (before, after) comment -> - let cl = Comment.location comment in - let isAfter = loc.loc_end.pos_lnum < cl.loc_start.pos_lnum in - if isAfter then - (before, comment::after) - else - (comment::before, after) - ) ([], []) singleLineComments - in (List.rev before, after) - -(* - * appends all [singleLineComments] after the [layout]. - * [loc] marks the end of [layout] - *) -let appendSingleLineCommentsToEnd loc layout singleLineComments = - let rec aux prevLoc layout i = function - | comment::cs -> - let loc = Comment.location comment in - let formattedComment = formatComment comment in - let commentLayout = if Reason_location.hasSpaceBetween loc prevLoc then - insertBlankLines 1 formattedComment - else - formattedComment + let _, processed, consumed = + List.fold_left + distributeCommentIntoSubLayouts + (0, [], Some comment) + (List.rev subLayouts) in - (* The initial layout breaks ugly with `breakline`, - * an inline list (that never breaks) fixes this *) - let newLayout = if i == 0 then - makeList ~inline:(true, true) ~break:Never [layout; commentLayout] + Layout.Sequence (listConfig, processed), consumed + | Layout.Label (labelFormatter, left, right) -> + let newRight, comment = perfectlyAttachComment comment right in + let newLeft, comment = tryPerfectlyAttachComment left comment in + Layout.Label (labelFormatter, newLeft, newRight), comment + | Layout.SourceMap (loc, subLayout) -> + let commloc = Comment.location comment in + if loc.loc_end.Lexing.pos_lnum = loc.loc_start.Lexing.pos_lnum + && commloc.loc_start.Lexing.pos_cnum = loc.loc_end.Lexing.pos_cnum + then + ( Layout.SourceMap + ( loc + , makeList + ~inline:(true, true) + ~break:Always + [ unbreaklayout (attachCommentToNodeRight subLayout comment) ] + ) + , None ) else - breakline layout commentLayout - in - aux loc newLayout (i + 1) cs - | [] -> layout - in - aux loc layout 0 singleLineComments + let layout, comment = perfectlyAttachComment comment subLayout in + (match comment with + | None -> Layout.SourceMap (loc, layout), None + | Some comment -> + if commloc.loc_end.Lexing.pos_cnum = loc.loc_start.Lexing.pos_cnum + then + ( Layout.SourceMap (loc, attachCommentToNodeLeft comment layout) + , None ) + else if commloc.loc_start.Lexing.pos_cnum + = loc.loc_end.Lexing.pos_cnum + then + ( Layout.SourceMap (loc, attachCommentToNodeRight layout comment) + , None ) + else Layout.SourceMap (loc, layout), Some comment) + | Whitespace (info, subLayout) -> + (match perfectlyAttachComment comment subLayout with + | newLayout, None -> Whitespace (info, newLayout), None + | newLayout, Some c -> Whitespace (info, newLayout), Some c) + | layout -> layout, Some comment + + let insertRegularComment layout comment = + match perfectlyAttachComment comment layout with + | layout, None -> layout + | layout, Some _ -> + looselyAttachComment ~breakAncestors:false layout comment + + let insertEndOfLineComment layout comment = + looselyAttachComment ~breakAncestors:true layout comment + + let rec partitionComments_ ((singleLines, endOfLines, regulars) as soFar) + = function + | [] -> soFar + | com :: tl -> + (match Comment.category com with + | Comment.EndOfLine -> + partitionComments_ (singleLines, com :: endOfLines, regulars) tl + | Comment.SingleLine -> + partitionComments_ (com :: singleLines, endOfLines, regulars) tl + | Comment.Regular -> + partitionComments_ (singleLines, endOfLines, com :: regulars) tl) + + let partitionComments comments = + let singleLines, endOfLines, regulars = + partitionComments_ ([], [], []) comments + in + singleLines, List.rev endOfLines, regulars -(* - * For simplicity, the formatting of comments happens in two parts in context of a source map: - * 1) insert the singleLineComments with the interleaving algorithm contained in - * `insertSingleLineComment` for all comments overlapping with the sourcemap. - * A `Layout.Whitespace` node signals an intent to preserve whitespace here. - * 2) SingleLineComments after the sourcemap, e.g. at the end of .re/.rei file, - * get attached with `appendSingleLineCommentsToEnd`. Due to the fact there - * aren't any real ocaml ast nodes anymore after the sourcemap (end of a - * file), the printing of the comments can be done in one pass with - * `appendSingleLineCommentsToEnd`. This is more performant and - * simplifies the implementation of comment attachment. - *) -let attachSingleLineComments singleLineComments = function - | Layout.SourceMap(loc, subLayout) -> - let (before, after) = partitionSingleLineComments loc singleLineComments in - let layout = List.fold_left insertSingleLineComment subLayout before in - appendSingleLineCommentsToEnd loc layout after - | layout -> - List.fold_left insertSingleLineComment layout singleLineComments - -let format_layout ?comments ppf layout = - let easy = match comments with - | None -> Layout.to_easy_format layout - | Some comments -> - let (singleLines, endOfLines, regulars) = partitionComments comments in - (* TODO: Stop generating multiple versions of the tree, and instead generate one new tree. *) - (* Layout.dump Format.std_formatter layout; *) - let layout = List.fold_left insertRegularComment layout regulars in - let layout = consolidateSeparator layout in - let layout = List.fold_left insertEndOfLineComment layout endOfLines in - (* Layout.dump Format.std_formatter layout; *) - let layout = attachSingleLineComments singleLines layout in - (* Layout.dump Format.std_formatter layout; *) - let layout = insertLinesAboveItems layout in - let layout = Layout.to_easy_format layout in - (* Layout.dump_easy Format.std_formatter layout; *) - layout - in - let buf = Buffer.create 1000 in - let fauxmatter = Format.formatter_of_buffer buf in - let _ = Format.pp_set_margin fauxmatter settings.width in - if debugWithHtml.contents then - Easy_format.Pretty.define_styles fauxmatter html_escape html_style; - let _ = Easy_format.Pretty.to_formatter fauxmatter easy in - let trimmed = Reason_syntax_util.processLineEndingsAndStarts (Buffer.contents buf) in - Format.fprintf ppf "%s\n" trimmed; - Format.pp_print_flush ppf () - -let rev_and_len xs = - let rec rev_and_len acc len xs = - match xs with - | [] -> (acc, len) - | x :: xs -> rev_and_len (x :: acc) (len + 1) xs - in - rev_and_len [] 0 xs - -let partitionFinalWrapping listTester wrapFinalItemSetting x = - let (rev, len) = rev_and_len x in - match (rev, wrapFinalItemSetting) with - | ([], _) -> raise (NotPossible "shouldnt be partitioning 0 label attachments") - | (_, NeverWrapFinalItem) -> None - | (last::revEverythingButLast, WrapFinalListyItemIfFewerThan max) -> - if not (listTester last) || len >= max then - None - else - Some (List.rev revEverythingButLast, last) - -let semiTerminated term = makeList [term; atom ";"] - -(* postSpace is so that when comments are interleaved, we still use spacing rules. *) -let makeLetSequence ?(wrap=("{", "}")) letItems = - makeList - ~break:Always_rec - ~inline:(true, false) - ~wrap - ~postSpace:true - ~sep:(SepFinal (";", ";")) - letItems - -let makeLetSequenceSingleLine ?(wrap=("{", "}")) letItems = - makeList - ~break:IfNeed - ~inline:(true, false) - ~wrap - ~preSpace:true - ~postSpace:true - ~sep:(Sep ";") - letItems - -(* postSpace is so that when comments are interleaved, we still use spacing rules. *) -let makeUnguardedLetSequence ?(sep=(Layout.SepFinal (";", ";"))) letItems = - makeList - ~break:Always_rec - ~inline:(true, true) - ~wrap:("", "") - ~indent:0 - ~postSpace:true - ~sep - letItems - -let formatSimpleAttributed x y = - makeList - ~wrap:("(", ")") - ~break:IfNeed - ~indent:0 - ~postSpace:true - (List.concat [y; [x]]) - -let formatAttributed ?(labelBreak=`Auto) x y = - label - ~break:labelBreak - ~indent:0 - ~space:true - (makeList ~inline:(true, true) ~postSpace:true y) - x - -(* For when the type constraint should be treated as a separate breakable line item itself - not docked to some value/pattern label. - fun x - y - : retType => blah; - *) -let formatJustTheTypeConstraint typ = - makeList ~postSpace:false ~sep:(Sep " ") [atom ":"; typ] + (* + * Partition single line comments based on a location into two lists: + * - one contains the comments before/same height of that location + * - the other contains the comments after the location + *) + let partitionSingleLineComments loc singleLineComments = + let before, after = + List.fold_left + (fun (before, after) comment -> + let cl = Comment.location comment in + let isAfter = loc.loc_end.pos_lnum < cl.loc_start.pos_lnum in + if isAfter + then before, comment :: after + else comment :: before, after) + ([], []) + singleLineComments + in + List.rev before, after -let formatTypeConstraint one two = - label ~space:true (makeList ~postSpace:false [one; atom ":"]) two + (* + * appends all [singleLineComments] after the [layout]. + * [loc] marks the end of [layout] + *) + let appendSingleLineCommentsToEnd loc layout singleLineComments = + let rec aux prevLoc layout i = function + | comment :: cs -> + let loc = Comment.location comment in + let formattedComment = formatComment comment in + let commentLayout = + if Reason_location.hasSpaceBetween loc prevLoc + then insertBlankLines 1 formattedComment + else formattedComment + in + (* The initial layout breaks ugly with `breakline`, + * an inline list (that never breaks) fixes this *) + let newLayout = + if i == 0 + then + makeList + ~inline:(true, true) + ~break:Never + [ layout; commentLayout ] + else breakline layout commentLayout + in + aux loc newLayout (i + 1) cs + | [] -> layout + in + aux loc layout 0 singleLineComments -let formatCoerce expr optType coerced = - match optType with - | None -> - label ~space:true (makeList ~postSpace:true [expr; atom ":>"]) coerced - | Some typ -> - label ~space:true (makeList ~postSpace:true [formatTypeConstraint expr typ; atom ":>"]) coerced + (* + * For simplicity, the formatting of comments happens in two parts in context of a source map: + * 1) insert the singleLineComments with the interleaving algorithm contained in + * `insertSingleLineComment` for all comments overlapping with the sourcemap. + * A `Layout.Whitespace` node signals an intent to preserve whitespace here. + * 2) SingleLineComments after the sourcemap, e.g. at the end of .re/.rei file, + * get attached with `appendSingleLineCommentsToEnd`. Due to the fact there + * aren't any real ocaml ast nodes anymore after the sourcemap (end of a + * file), the printing of the comments can be done in one pass with + * `appendSingleLineCommentsToEnd`. This is more performant and + * simplifies the implementation of comment attachment. + *) + let attachSingleLineComments singleLineComments = function + | Layout.SourceMap (loc, subLayout) -> + let before, after = + partitionSingleLineComments loc singleLineComments + in + let layout = List.fold_left insertSingleLineComment subLayout before in + appendSingleLineCommentsToEnd loc layout after + | layout -> + List.fold_left insertSingleLineComment layout singleLineComments + + let format_layout ?comments ppf layout = + let easy = + match comments with + | None -> Layout.to_easy_format layout + | Some comments -> + let singleLines, endOfLines, regulars = partitionComments comments in + (* TODO: Stop generating multiple versions of the tree, and instead + generate one new tree. *) + (* Layout.dump Format.std_formatter layout; *) + let layout = List.fold_left insertRegularComment layout regulars in + let layout = consolidateSeparator layout in + let layout = + List.fold_left insertEndOfLineComment layout endOfLines + in + (* Layout.dump Format.std_formatter layout; *) + let layout = attachSingleLineComments singleLines layout in + (* Layout.dump Format.std_formatter layout; *) + let layout = insertLinesAboveItems layout in + let layout = Layout.to_easy_format layout in + (* Layout.dump_easy Format.std_formatter layout; *) + layout + in + let buf = Buffer.create 1000 in + let fauxmatter = Format.formatter_of_buffer buf in + let _ = Format.pp_set_margin fauxmatter settings.width in + if debugWithHtml.contents + then Easy_format.Pretty.define_styles fauxmatter html_escape html_style; + let _ = Easy_format.Pretty.to_formatter fauxmatter easy in + let trimmed = + Reason_syntax_util.processLineEndingsAndStarts (Buffer.contents buf) + in + Format.fprintf ppf "%s\n" trimmed; + Format.pp_print_flush ppf () + + let rev_and_len xs = + let rec rev_and_len acc len xs = + match xs with + | [] -> acc, len + | x :: xs -> rev_and_len (x :: acc) (len + 1) xs + in + rev_and_len [] 0 xs + + let partitionFinalWrapping listTester wrapFinalItemSetting x = + let rev, len = rev_and_len x in + match rev, wrapFinalItemSetting with + | [], _ -> + raise (NotPossible "shouldnt be partitioning 0 label attachments") + | _, NeverWrapFinalItem -> None + | last :: revEverythingButLast, WrapFinalListyItemIfFewerThan max -> + if (not (listTester last)) || len >= max + then None + else Some (List.rev revEverythingButLast, last) + + let semiTerminated term = makeList [ term; atom ";" ] + + (* postSpace is so that when comments are interleaved, we still use spacing + rules. *) + let makeLetSequence ?(wrap = "{", "}") letItems = + makeList + ~break:Always_rec + ~inline:(true, false) + ~wrap + ~postSpace:true + ~sep:(SepFinal (";", ";")) + letItems + let makeLetSequenceSingleLine ?(wrap = "{", "}") letItems = + makeList + ~break:IfNeed + ~inline:(true, false) + ~wrap + ~preSpace:true + ~postSpace:true + ~sep:(Sep ";") + letItems -(* Standard function application style indentation - no special wrapping - * behavior. - * - * Formats like this: - * - * let result = - * someFunc - * (10, 20); - * - * - * Instead of this: - * - * let result = - * someFunc ( - * 10, - * 20 - * ); - * - * The outer list wrapping fixes #566: format should break the whole - * application before breaking arguments. - *) -let formatIndentedApplication headApplicationItem argApplicationItems = - makeList ~inline:(true, true) ~postSpace:true ~break:IfNeed [ - label - ~space:true - headApplicationItem - (makeAppList argApplicationItems) - ] + (* postSpace is so that when comments are interleaved, we still use spacing + rules. *) + let makeUnguardedLetSequence ?(sep = Layout.SepFinal (";", ";")) letItems = + makeList + ~break:Always_rec + ~inline:(true, true) + ~wrap:("", "") + ~indent:0 + ~postSpace:true + ~sep + letItems + + let formatSimpleAttributed x y = + makeList + ~wrap:("(", ")") + ~break:IfNeed + ~indent:0 + ~postSpace:true + (List.concat [ y; [ x ] ]) + + let formatAttributed ?(labelBreak = `Auto) x y = + label + ~break:labelBreak + ~indent:0 + ~space:true + (makeList ~inline:(true, true) ~postSpace:true y) + x + (* For when the type constraint should be treated as a separate breakable + line item itself not docked to some value/pattern label. fun x y : + retType => blah; *) + let formatJustTheTypeConstraint typ = + makeList ~postSpace:false ~sep:(Sep " ") [ atom ":"; typ ] -(* The loc, is an optional location or the returned app terms *) -let formatAttachmentApplication finalWrapping (attachTo: (bool * Layout.t) option) (appTermItems, loc) = - let partitioning = finalWrapping appTermItems in - match partitioning with - | None -> ( - match (appTermItems, attachTo) with - | ([], _) -> raise (NotPossible "No app terms") - | ([hd], None) -> source_map ?loc hd - | ([hd], (Some (useSpace, toThis))) -> label ~space:useSpace toThis (source_map ?loc hd) - | (hd::tl, None) -> - source_map ?loc (formatIndentedApplication hd tl) - | (hd::tl, (Some (useSpace, toThis))) -> - label - ~space:useSpace - toThis - (source_map ?loc (formatIndentedApplication hd tl)) - ) - | Some (attachedList, wrappedListy) -> ( - match (attachedList, attachTo) with - | ([], Some (useSpace, toThis)) -> + let formatTypeConstraint one two = + label ~space:true (makeList ~postSpace:false [ one; atom ":" ]) two + + let formatCoerce expr optType coerced = + match optType with + | None -> + label ~space:true (makeList ~postSpace:true [ expr; atom ":>" ]) coerced + | Some typ -> + label + ~space:true + (makeList + ~postSpace:true + [ formatTypeConstraint expr typ; atom ":>" ]) + coerced + + (* Standard function application style indentation - no special wrapping + * behavior. + * + * Formats like this: + * + * let result = + * someFunc + * (10, 20); + * + * + * Instead of this: + * + * let result = + * someFunc ( + * 10, + * 20 + * ); + * + * The outer list wrapping fixes #566: format should break the whole + * application before breaking arguments. + *) + let formatIndentedApplication headApplicationItem argApplicationItems = + makeList + ~inline:(true, true) + ~postSpace:true + ~break:IfNeed + [ label + ~space:true + headApplicationItem + (makeAppList argApplicationItems) + ] + + (* The loc, is an optional location or the returned app terms *) + let formatAttachmentApplication + finalWrapping + (attachTo : (bool * Layout.t) option) + (appTermItems, loc) + = + let partitioning = finalWrapping appTermItems in + match partitioning with + | None -> + (match appTermItems, attachTo with + | [], _ -> raise (NotPossible "No app terms") + | [ hd ], None -> source_map ?loc hd + | [ hd ], Some (useSpace, toThis) -> + label ~space:useSpace toThis (source_map ?loc hd) + | hd :: tl, None -> source_map ?loc (formatIndentedApplication hd tl) + | hd :: tl, Some (useSpace, toThis) -> + label + ~space:useSpace + toThis + (source_map ?loc (formatIndentedApplication hd tl))) + | Some (attachedList, wrappedListy) -> + (match attachedList, attachTo with + | [], Some (useSpace, toThis) -> label ~space:useSpace toThis (source_map ?loc wrappedListy) - | ([], None) -> + | [], None -> (* Not Sure when this would happen *) source_map ?loc wrappedListy - | (_::_, Some (useSpace, toThis)) -> + | _ :: _, Some (useSpace, toThis) -> (* TODO: Can't attach location to this - maybe rewrite anyways *) let attachedArgs = makeAppList attachedList in - label ~space:useSpace toThis + label + ~space:useSpace + toThis (label ~space:true attachedArgs wrappedListy) - | (_::_, None) -> + | _ :: _, None -> (* Args that are "attached to nothing" *) let appList = makeAppList attachedList in - source_map ?loc (label ~space:true appList wrappedListy) - ) - -(* - Preprocesses an expression term for the sake of label attachments ([letx = - expr]or record [field: expr]). Function application should have special - treatment when placed next to a label. (The invoked function term should - "stick" to the label in some cases). In others, the invoked function term - should become a new label for the remaining items to be indented under. - *) -let applicationFinalWrapping x = - partitionFinalWrapping isSequencey settings.funcApplicationLabelStyle x - -let curriedFunctionFinalWrapping x = - partitionFinalWrapping isSequencey settings.funcCurriedPatternStyle x - -let typeApplicationFinalWrapping typeApplicationItems = - partitionFinalWrapping isSequencey settings.funcApplicationLabelStyle typeApplicationItems - - -(* add parentheses to binders when they are in fact infix or prefix operators *) -let protectIdentifier txt = - let needs_parens = needs_parens txt in - let txt = - if Reason_syntax_util.is_andop txt || Reason_syntax_util.is_letop txt then - Reason_syntax_util.compress_letop_identifier txt - else - txt - in - if not needs_parens then atom txt - else if needs_spaces txt then makeList ~wrap:("(", ")") ~pad:(true, true) [atom txt] - else atom ("(" ^ txt ^ ")") - -let protectLongIdentifier longPrefix txt = - makeList [longPrefix; atom "."; protectIdentifier txt] - -let paren b fu ppf x = - if b - then Format.fprintf ppf "(%a)" fu x - else fu ppf x - -let constant_string_for_primitive ppf s = - let hasQuote = try String.index s '"' with Not_found -> -1 in - let hasNewline = try String.index s '\n' with Not_found -> -1 in - if hasQuote > -1 || hasNewline > -1 then - Format.fprintf ppf "{|%s|}" s - else Format.fprintf ppf "%S" s - -let tyvar ppf str = - Format.fprintf ppf "'%s" str - -(* In some places parens shouldn't be printed for readability: - * e.g. Some((-1)) should be printed as Some(-1) - * In `1 + (-1)` -1 should be wrapped in parens for readability - *) -let constant ?raw_literal ?(parens=true) ppf = function - | Pconst_char i -> - Format.fprintf ppf "%C" i - | Pconst_string (i, _, None) -> - begin match raw_literal with - | Some text -> - Format.fprintf ppf "\"%s\"" text - | None -> - Format.fprintf ppf "\"%s\"" (Reason_syntax_util.escape_string i) - end - | Pconst_string (i, _, Some delim) -> - Format.fprintf ppf "{%s|%s|%s}" delim i delim - | Pconst_integer (i, None) -> - paren (parens && i.[0] = '-') - (fun ppf -> Format.fprintf ppf "%s") ppf i - | Pconst_integer (i, Some m) -> - paren (parens && i.[0] = '-') - (fun ppf (i, m) -> Format.fprintf ppf "%s%c" i m) ppf (i,m) - | Pconst_float (i, None) -> - paren (parens && i.[0] = '-') - (fun ppf -> Format.fprintf ppf "%s") ppf i - | Pconst_float (i, Some m) -> - paren (parens && i.[0] = '-') - (fun ppf (i,m) -> Format.fprintf ppf "%s%c" i m) ppf (i,m) - -let is_punned_labelled_pattern_no_attrs p lbl = match p.ppat_attributes, p.ppat_desc with - | _::_, _ -> false - | [], Ppat_constraint ({ ppat_desc = Ppat_var { txt }; ppat_attributes=[]}, _) - | [], Ppat_var { txt } -> txt = lbl - | _ -> false + source_map ?loc (label ~space:true appList wrappedListy)) + + (* Preprocesses an expression term for the sake of label attachments ([letx + = expr]or record [field: expr]). Function application should have special + treatment when placed next to a label. (The invoked function term should + "stick" to the label in some cases). In others, the invoked function term + should become a new label for the remaining items to be indented + under. *) + let applicationFinalWrapping x = + partitionFinalWrapping isSequencey settings.funcApplicationLabelStyle x + + let curriedFunctionFinalWrapping x = + partitionFinalWrapping isSequencey settings.funcCurriedPatternStyle x + + let typeApplicationFinalWrapping typeApplicationItems = + partitionFinalWrapping + isSequencey + settings.funcApplicationLabelStyle + typeApplicationItems + + (* add parentheses to binders when they are in fact infix or prefix + operators *) + let protectIdentifier txt = + let needs_parens = needs_parens txt in + let txt = + if Reason_syntax_util.is_andop txt || Reason_syntax_util.is_letop txt + then Reason_syntax_util.compress_letop_identifier txt + else txt + in + if not needs_parens + then atom txt + else if needs_spaces txt + then makeList ~wrap:("(", ")") ~pad:(true, true) [ atom txt ] + else atom ("(" ^ txt ^ ")") + + let protectLongIdentifier longPrefix txt = + makeList [ longPrefix; atom "."; protectIdentifier txt ] + + let paren b fu ppf x = + if b then Format.fprintf ppf "(%a)" fu x else fu ppf x + + let constant_string_for_primitive ppf s = + let hasQuote = try String.index s '"' with Not_found -> -1 in + let hasNewline = try String.index s '\n' with Not_found -> -1 in + if hasQuote > -1 || hasNewline > -1 + then Format.fprintf ppf "{|%s|}" s + else Format.fprintf ppf "%S" s + + let tyvar ppf str = Format.fprintf ppf "'%s" str + + (* In some places parens shouldn't be printed for readability: + * e.g. Some((-1)) should be printed as Some(-1) + * In `1 + (-1)` -1 should be wrapped in parens for readability + *) + let constant ?raw_literal ?(parens = true) ppf = function + | Pconst_char i -> Format.fprintf ppf "%C" i + | Pconst_string (i, _, None) -> + (match raw_literal with + | Some text -> Format.fprintf ppf "\"%s\"" text + | None -> + Format.fprintf ppf "\"%s\"" (Reason_syntax_util.escape_string i)) + | Pconst_string (i, _, Some delim) -> + Format.fprintf ppf "{%s|%s|%s}" delim i delim + | Pconst_integer (i, None) -> + paren (parens && i.[0] = '-') (fun ppf -> Format.fprintf ppf "%s") ppf i + | Pconst_integer (i, Some m) -> + paren + (parens && i.[0] = '-') + (fun ppf (i, m) -> Format.fprintf ppf "%s%c" i m) + ppf + (i, m) + | Pconst_float (i, None) -> + paren (parens && i.[0] = '-') (fun ppf -> Format.fprintf ppf "%s") ppf i + | Pconst_float (i, Some m) -> + paren + (parens && i.[0] = '-') + (fun ppf (i, m) -> Format.fprintf ppf "%s%c" i m) + ppf + (i, m) + + let is_punned_labelled_pattern_no_attrs p lbl = + match p.ppat_attributes, p.ppat_desc with + | _ :: _, _ -> false + | ( [] + , Ppat_constraint + ({ ppat_desc = Ppat_var { txt }; ppat_attributes = [] }, _) ) + | [], Ppat_var { txt } -> + txt = lbl + | _ -> false -let isLongIdentWithDot = function - | Ldot _ -> true - | _ -> false + let isLongIdentWithDot = function Ldot _ -> true | _ -> false -(* Js.t -> useful for bucklescript sugar `Js.t({. foo: bar})` -> `{. "foo": bar}` *) -let isJsDotTLongIdent ident = match ident with - | Ldot (Lident "Js", "t") -> true - | _ -> false + (* Js.t -> useful for bucklescript sugar `Js.t({. foo: bar})` -> `{. "foo": + bar}` *) + let isJsDotTLongIdent ident = + match ident with Ldot (Lident "Js", "t") -> true | _ -> false -let recordRowIsPunned pld = + let recordRowIsPunned pld = let name = pld.pld_name.txt in - (match pld.pld_type with - | { ptyp_desc = ( - Ptyp_constr ( - { txt }, - (* don't pun parameterized types, e.g. {tag: tag 'props} *) - []) - ); - (* Don't pun types that have attributes attached, e.g. { foo: [@bar] foo } *) - ptyp_attributes = []; - _} - when - (Longident.last_exn txt = name - (* Don't pun types from other modules, e.g. type bar = {foo: Baz.foo}; *) - && isLongIdentWithDot txt == false) -> true - | _ -> false) + match pld.pld_type with + | { ptyp_desc = + Ptyp_constr + ( { txt } + , (* don't pun parameterized types, e.g. {tag: tag 'props} *) + [] ) + ; (* Don't pun types that have attributes attached, e.g. { foo: [@bar] + foo } *) + ptyp_attributes = [] + ; _ + } + when Longident.last_exn txt = name + (* Don't pun types from other modules, e.g. type bar = {foo: + Baz.foo}; *) + && isLongIdentWithDot txt == false -> + true + | _ -> false -let isPunnedJsxArg lbl ident = - not (isLongIdentWithDot ident.txt) && (Longident.last_exn ident.txt) = lbl + let isPunnedJsxArg lbl ident = + (not (isLongIdentWithDot ident.txt)) && Longident.last_exn ident.txt = lbl -let is_unit_pattern x = match x.ppat_desc with - | Ppat_construct ( {txt= Lident"()"}, None) -> true - | _ -> false + let is_unit_pattern x = + match x.ppat_desc with + | Ppat_construct ({ txt = Lident "()" }, None) -> true + | _ -> false -let is_ident_pattern x = match x.ppat_desc with - | Ppat_var _ -> true - | _ -> false + let is_ident_pattern x = + match x.ppat_desc with Ppat_var _ -> true | _ -> false -let is_any_pattern x = x.ppat_desc = Ppat_any + let is_any_pattern x = x.ppat_desc = Ppat_any -let is_direct_pattern x = x.ppat_attributes == [] && match x.ppat_desc with - | Ppat_construct ( {txt= Lident"()"}, None) -> true - | _ -> false + let is_direct_pattern x = + x.ppat_attributes == [] + && + match x.ppat_desc with + | Ppat_construct ({ txt = Lident "()" }, None) -> true + | _ -> false -let isJSXComponent expr = - match expr with - | ({pexp_desc= Pexp_apply ({pexp_desc=Pexp_ident _}, args); pexp_attributes}) - | ({pexp_desc= Pexp_apply ({pexp_desc=Pexp_letmodule(_,_,_)}, args); pexp_attributes}) -> - let {Reason_attributes.jsxAttrs} = Reason_attributes.partitionAttributes pexp_attributes in - let hasLabelledChildrenLiteral = List.exists (function - | (Labelled "children", _) -> true + let isJSXComponent expr = + match expr with + | { pexp_desc = Pexp_apply ({ pexp_desc = Pexp_ident _ }, args) + ; pexp_attributes + } + | { pexp_desc = Pexp_apply ({ pexp_desc = Pexp_letmodule (_, _, _) }, args) + ; pexp_attributes + } -> + let { Reason_attributes.jsxAttrs } = + Reason_attributes.partitionAttributes pexp_attributes + in + let hasLabelledChildrenLiteral = + List.exists + (function Labelled "children", _ -> true | _ -> false) + args + in + let rec hasSingleNonLabelledUnitAndIsAtTheEnd l = + match l with + | [] -> false + | (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, _) }) + :: [] -> + true + | (Nolabel, _) :: _ -> false + | _ :: rest -> hasSingleNonLabelledUnitAndIsAtTheEnd rest + in + if jsxAttrs != [] + && hasLabelledChildrenLiteral + && hasSingleNonLabelledUnitAndIsAtTheEnd args + then true + else false | _ -> false - ) args in - let rec hasSingleNonLabelledUnitAndIsAtTheEnd l = match l with - | [] -> false - | (Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}) :: [] -> true - | (Nolabel, _) :: _ -> false - | _ :: rest -> hasSingleNonLabelledUnitAndIsAtTheEnd rest - in - if jsxAttrs != [] - && hasLabelledChildrenLiteral - && hasSingleNonLabelledUnitAndIsAtTheEnd args - then - true - else - false - | _ -> false -(* Some cases require special formatting when there's a function application - * with a single argument containing some kind of structure with braces/parens/brackets. - * Example: `foo({a: 1, b: 2})` needs to be formatted as - * foo({ - * a: 1, - * b: 2 - * }) - * when the line length dictates breaking. Notice how `({` and `})` 'hug'. - * Also applies to (poly)variants because they can be seen as a form of "function application". - * This function says if a list of expressions fulfills the need to be formatted like - * the example above. *) -let isSingleArgParenApplication = function - | [{pexp_attributes = []; pexp_desc = Pexp_record _}] - | [{pexp_attributes = []; pexp_desc = Pexp_tuple _}] - | [{pexp_attributes = []; pexp_desc = Pexp_array _}] - | [{pexp_attributes = []; pexp_desc = Pexp_object _}] -> true - | [{pexp_attributes = []; pexp_desc = Pexp_extension (s, _)}] when s.txt = "mel.obj" -> true - | [({pexp_attributes = []} as exp)] when (is_simple_list_expr exp) -> true - | _ -> false + (* Some cases require special formatting when there's a function application + * with a single argument containing some kind of structure with braces/parens/brackets. + * Example: `foo({a: 1, b: 2})` needs to be formatted as + * foo({ + * a: 1, + * b: 2 + * }) + * when the line length dictates breaking. Notice how `({` and `})` 'hug'. + * Also applies to (poly)variants because they can be seen as a form of "function application". + * This function says if a list of expressions fulfills the need to be formatted like + * the example above. *) + let isSingleArgParenApplication = function + | [ { pexp_attributes = []; pexp_desc = Pexp_record _ } ] + | [ { pexp_attributes = []; pexp_desc = Pexp_tuple _ } ] + | [ { pexp_attributes = []; pexp_desc = Pexp_array _ } ] + | [ { pexp_attributes = []; pexp_desc = Pexp_object _ } ] -> + true + | [ { pexp_attributes = []; pexp_desc = Pexp_extension (s, _) } ] + when s.txt = "mel.obj" -> + true + | [ ({ pexp_attributes = [] } as exp) ] when is_simple_list_expr exp -> + true + | _ -> false -(* - * Determines if the arguments of a constructor pattern match need - * special printing. If there's one argument & they have some kind of wrapping, - * they're wrapping need to 'hug' the surrounding parens. - * Example: - * switch x { - * | Some({ - * a, - * b, - * }) => () - * } - * - * Notice how ({ and }) hug. - * This applies for records, arrays, tuples & lists. - * See `singleArgParenPattern` for the acutal formatting - *) -let isSingleArgParenPattern = function - | [{ppat_attributes = []; ppat_desc = Ppat_record _}] - | [{ppat_attributes = []; ppat_desc = Ppat_array _}] - | [{ppat_attributes = []; ppat_desc = Ppat_tuple _}] -> true - | [{ppat_attributes = []; ppat_desc = Ppat_construct (({txt=Lident "::"}), _)}] -> true - | _ -> false + (* + * Determines if the arguments of a constructor pattern match need + * special printing. If there's one argument & they have some kind of wrapping, + * they're wrapping need to 'hug' the surrounding parens. + * Example: + * switch x { + * | Some({ + * a, + * b, + * }) => () + * } + * + * Notice how ({ and }) hug. + * This applies for records, arrays, tuples & lists. + * See `singleArgParenPattern` for the acutal formatting + *) + let isSingleArgParenPattern = function + | [ { ppat_attributes = []; ppat_desc = Ppat_record _ } ] + | [ { ppat_attributes = []; ppat_desc = Ppat_array _ } ] + | [ { ppat_attributes = []; ppat_desc = Ppat_tuple _ } ] -> + true + | [ { ppat_attributes = [] + ; ppat_desc = Ppat_construct ({ txt = Lident "::" }, _) + } + ] -> + true + | _ -> false -(* Flattens a resolvedRule into a list of infixChain nodes. - * When foo |> f |> z gets parsed, we get the following tree: - * |> - * / \ - * foo |> - * / \ - * f z - * To format this recursive tree in a way that allows nice breaking - * & respects the print-width, we need some kind of flattened - * version of the above tree. `computeInfixChain` transforms the tree - * in a flattened version which allows flexible formatting. - * E.g. we get - * [LayoutNode foo; InfixToken |>; LayoutNode f; InfixToken |>; LayoutNode z] - *) -let rec computeInfixChain = function - | LayoutNode layoutNode -> [Layout layoutNode] - | InfixTree (op, leftResolvedRule, rightResolvedRule) -> - (computeInfixChain leftResolvedRule) @ [InfixToken op] @ (computeInfixChain rightResolvedRule) - -let equalityOperators = ["!="; "!=="; "==="; "=="; ">="; "<="; "<"; ">"] - -(* Formats a flattened list of infixChain nodes into a list of layoutNodes - * which allow smooth line-breaking - * e.g. [LayoutNode foo; InfixToken |>; LayoutNode f; InfixToken |>; LayoutNode z] - * becomes - * [ - * foo - * ; |> f --> label - * ; |> z --> label - * ] - * If you make a list out of this items, we get smooth line breaking - * foo |> f |> z - * becomes - * foo - * |> f - * |> z - * when the print-width forces line breaks. - *) -let formatComputedInfixChain infixChainList = - let layout_of_group group currentToken = - (* Represents the `foo` in - * foo - * |> f - * |> z *) - match group with - | [] | [ _ ] -> makeList ~inline:(true, true) ~sep:(Sep " ") group - | _ -> - (* Basic equality operators require special formatting, we can't give it - * 'classic' infix operator formatting, otherwise we would get - * let example = - * true - * != false - * && "a" - * == "b" - * *) - if List.mem currentToken equalityOperators then - let hd = List.hd group in - let tl = makeList ~inline:(true, true) ~sep:(Sep " ") (List.tl group) in - makeList ~inline:(true, true) ~sep:(Sep " ") ~break:IfNeed [hd; tl] - else if currentToken.[0] = '#' then - let isSharpEqual = currentToken = sharpOpEqualToken in - makeList ~postSpace:isSharpEqual group - else - (* Represents `|> f` in foo |> f - * We need a label here to indent possible closing parens - * on the same height as the infix operator - * e.g. - * >|= ( - * fun body => - * Printf.sprintf - * "okokok" uri meth headers body - * ) <-- notice how this closing paren is on the same height as >|= - *) - label ~break:`Never ~space:true (atom currentToken) (List.nth group 1) - in - let rec print acc group currentToken l = - match l with - | x::xs -> (match x with - | InfixToken t -> - (* = or := *) - if List.mem t requireIndentFor then - let groupNode = - makeList ~inline:(true, true) ~sep:(Sep " ") ((print [] group currentToken []) @ [atom t]) - in - let children = - makeList ~inline:(true, true) ~preSpace:true ~break:IfNeed - (print [] [] t xs) - in - print (acc @ [label ~space:true groupNode children]) [] t [] - (* Represents: - * List.map @@ - * List.length - * - * Notice how we want the `@@` on the first line. - * Extra indent puts pressure on the subsequent line lengths + (* Flattens a resolvedRule into a list of infixChain nodes. + * When foo |> f |> z gets parsed, we get the following tree: + * |> + * / \ + * foo |> + * / \ + * f z + * To format this recursive tree in a way that allows nice breaking + * & respects the print-width, we need some kind of flattened + * version of the above tree. `computeInfixChain` transforms the tree + * in a flattened version which allows flexible formatting. + * E.g. we get + * [LayoutNode foo; InfixToken |>; LayoutNode f; InfixToken |>; LayoutNode z] + *) + let rec computeInfixChain = function + | LayoutNode layoutNode -> [ Layout layoutNode ] + | InfixTree (op, leftResolvedRule, rightResolvedRule) -> + computeInfixChain leftResolvedRule + @ [ InfixToken op ] + @ computeInfixChain rightResolvedRule + + let equalityOperators = [ "!="; "!=="; "==="; "=="; ">="; "<="; "<"; ">" ] + + (* Formats a flattened list of infixChain nodes into a list of layoutNodes + * which allow smooth line-breaking + * e.g. [LayoutNode foo; InfixToken |>; LayoutNode f; InfixToken |>; LayoutNode z] + * becomes + * [ + * foo + * ; |> f --> label + * ; |> z --> label + * ] + * If you make a list out of this items, we get smooth line breaking + * foo |> f |> z + * becomes + * foo + * |> f + * |> z + * when the print-width forces line breaks. + *) + let formatComputedInfixChain infixChainList = + let layout_of_group group currentToken = + (* Represents the `foo` in + * foo + * |> f + * |> z *) + match group with + | [] | [ _ ] -> makeList ~inline:(true, true) ~sep:(Sep " ") group + | _ -> + (* Basic equality operators require special formatting, we can't give it + * 'classic' infix operator formatting, otherwise we would get + * let example = + * true + * != false + * && "a" + * == "b" * *) - else if t = "@@" then - let groupNode = - makeList ~inline:(true, true) ~sep:(Sep " ") (group @ [atom t]) + if List.mem currentToken equalityOperators + then + let hd = List.hd group in + let tl = + makeList ~inline:(true, true) ~sep:(Sep " ") (List.tl group) in - print (acc @ [groupNode]) [] t xs - (* != !== === == >= <= < > etc *) - else if List.mem t equalityOperators then - print acc ((print [] group currentToken []) @ [atom t]) t xs + makeList + ~inline:(true, true) + ~sep:(Sep " ") + ~break:IfNeed + [ hd; tl ] + else if currentToken.[0] = '#' + then + let isSharpEqual = currentToken = sharpOpEqualToken in + makeList ~postSpace:isSharpEqual group else - begin if requireNoSpaceFor t then - begin if (currentToken = "" || requireNoSpaceFor currentToken) then - print acc (group@[atom t]) t xs + (* Represents `|> f` in foo |> f + * We need a label here to indent possible closing parens + * on the same height as the infix operator + * e.g. + * >|= ( + * fun body => + * Printf.sprintf + * "okokok" uri meth headers body + * ) <-- notice how this closing paren is on the same height as >|= + *) + label + ~break:`Never + ~space:true + (atom currentToken) + (List.nth group 1) + in + let rec print acc group currentToken l = + match l with + | x :: xs -> + (match x with + | InfixToken t -> + (* = or := *) + if List.mem t requireIndentFor + then + let groupNode = + makeList + ~inline:(true, true) + ~sep:(Sep " ") + (print [] group currentToken [] @ [ atom t ]) + in + let children = + makeList + ~inline:(true, true) + ~preSpace:true + ~break:IfNeed + (print [] [] t xs) + in + print (acc @ [ label ~space:true groupNode children ]) [] t [] + (* Represents: + * List.map @@ + * List.length + * + * Notice how we want the `@@` on the first line. + * Extra indent puts pressure on the subsequent line lengths + * *) + else if t = "@@" + then + let groupNode = + makeList ~inline:(true, true) ~sep:(Sep " ") (group @ [ atom t ]) + in + print (acc @ [ groupNode ]) [] t xs + (* != !== === == >= <= < > etc *) + else if List.mem t equalityOperators + then print acc (print [] group currentToken [] @ [ atom t ]) t xs + else if requireNoSpaceFor t + then + if currentToken = "" || requireNoSpaceFor currentToken + then print acc (group @ [ atom t ]) t xs else (* a + b + foo##bar##baz * `foo` needs to be picked from the current group * and inserted into a new one. This way `foo` * gets the special "chained"-printing: * foo##bar##baz. *) - begin match List.rev group with - | hd::tl -> - let acc = - acc @ [layout_of_group (List.rev tl) currentToken] - in - print acc [hd; atom t] t xs - | [] -> print acc (group@[atom t]) t xs - end - end + match List.rev group with + | hd :: tl -> + let acc = + acc @ [ layout_of_group (List.rev tl) currentToken ] + in + print acc [ hd; atom t ] t xs + | [] -> print acc (group @ [ atom t ]) t xs else - print (acc @ [layout_of_group group currentToken]) [(atom t)] t xs - end - | Layout layoutNode -> print acc (group @ [layoutNode]) currentToken xs - ) - | [] -> - if List.mem currentToken requireIndentFor then - acc @ group - else - acc @ [layout_of_group group currentToken] - in - let l = print [] [] "" infixChainList in - makeList ~inline:(true, true) ~sep:(Sep " ") ~break:IfNeed l - -(** - * [groupAndPrint] will print every item in [items] according to the function [xf]. - * [getLoc] will extract the location from an item. Based on the difference - * between the location of two items, if there's whitespace between the two - * (taken possible comments into account), items get grouped. - * Every group designates a series of layout nodes "in need - * of whitespace above". A group gets decorated with a Whitespace node - * containing enough info to interleave whitespace at a later time during - * printing. - *) -let groupAndPrint ~xf ~getLoc ~comments items = - let rec group prevLoc curr acc = function - (* group items *) - | x::xs -> - let item = xf x in - let loc = getLoc x in - (* Get the range between the current and previous item - * Example: - * 1| let a = 1; - * 2| --> this is the range between the two - * 3| let b = 2; - * *) - let range = Range.makeRangeBetween prevLoc loc in - (* If there's whitespace interleaved, append the new layout node - * to a new group, otherwise keep it in the current group. - * Takes possible comments interleaved into account. + print + (acc @ [ layout_of_group group currentToken ]) + [ atom t ] + t + xs + | Layout layoutNode -> + print acc (group @ [ layoutNode ]) currentToken xs) + | [] -> + if List.mem currentToken requireIndentFor + then acc @ group + else acc @ [ layout_of_group group currentToken ] + in + let l = print [] [] "" infixChainList in + makeList ~inline:(true, true) ~sep:(Sep " ") ~break:IfNeed l + + (** * [groupAndPrint] will print every item in [items] according to the + function [xf]. * [getLoc] will extract the location from an item. Based + on the difference * between the location of two items, if there's + whitespace between the two * (taken possible comments into account), + items get grouped. * Every group designates a series of layout nodes "in + need * of whitespace above". A group gets decorated with a Whitespace + node * containing enough info to interleave whitespace at a later time + during * printing. *) + let groupAndPrint ~xf ~getLoc ~comments items = + let rec group prevLoc curr acc = function + (* group items *) + | x :: xs -> + let item = xf x in + let loc = getLoc x in + (* Get the range between the current and previous item + * Example: + * 1| let a = 1; + * 2| --> this is the range between the two + * 3| let b = 2; + * *) + let range = Range.makeRangeBetween prevLoc loc in + (* If there's whitespace interleaved, append the new layout node + * to a new group, otherwise keep it in the current group. + * Takes possible comments interleaved into account. + * + * Example: + * 1| let a = 1; + * 2| + * 3| let b = 2; + * 4| let c = 3; + * `let b = 2` will mark the start of a new group + * `let c = 3` will be added to the group containing `let b = 2` + *) + if Range.containsWhitespace ~range ~comments () + then group loc [ range, item ] (List.rev curr :: acc) xs + else group loc ((range, item) :: curr) acc xs + (* convert groups into "Layout.Whitespace" *) + | [] -> + let groups = List.rev (List.rev curr :: acc) in + List.mapi + (fun i group -> + match group with + | curr :: xs -> + let range, x = curr in + (* if this is the first group of all "items", the number of + * newlines interleaved should be 0, else we collapse all newlines + * to 1. + * + * Example: + * module Abc = { + * let a = 1; + * + * let b = 2; + * } + * `let a = 1` should be wrapped in a `Layout.Whitespace` because a + * user might put comments above the `let a = 1`. + * e.g. + * module Abc = { + * /* comment 1 */ + * + * /* comment 2 */ + * let a = 1; + * + * A Whitespace-node will automatically take care of the whitespace + * interleaving between the comments. + *) + let newlines = if i > 0 then 1 else 0 in + let region = WhitespaceRegion.make ~range ~newlines () in + let firstLayout = Layout.Whitespace (region, x) in + (* the first layout node of every group taks care of the + * whitespace above a group*) + firstLayout :: List.map snd xs + | [] -> []) + groups + in + match items with + | first :: rest -> + List.concat (group (getLoc first) [] [] (first :: rest)) + | [] -> [] + + let printer = + object (self : 'self) + val pipe = false + val semi = false + val inline_braces = false + val preserve_braces = true + + (* *Mutable state* in the printer to keep track of all comments + * Used when whitespace needs to be interleaved. + * The printing algorithm needs to take the comments into account in between + * two items, to correctly determine if there's whitespace between two items. + * The ast doesn't know if there are comments between two items, since + * comments are store separately. The location diff between two items + * might indicate whitespace between the two. While in reality there are + * comments filling that whitespace. The printer needs access to the comments + * for this reason. * * Example: * 1| let a = 1; * 2| - * 3| let b = 2; - * 4| let c = 3; - * `let b = 2` will mark the start of a new group - * `let c = 3` will be added to the group containing `let b = 2` + * 3| + * 4| let b = 2; + * -> here we can just diff the locations between `let a = 1` and `let b = 2` + * + * 1| let a = 1; + * 2| /* a comment */ + * 3| /* another comment */ + * 4| let b = 2; + * -> here the location diff will result into false info if we don't include + * the comments in the diffing *) - if Range.containsWhitespace ~range ~comments () then - group loc [(range, item)] ((List.rev curr)::acc) xs - else - group loc ((range, item)::curr) acc xs - (* convert groups into "Layout.Whitespace" *) - | [] -> - let groups = List.rev ((List.rev curr)::acc) in - List.mapi (fun i group -> match group with - | curr::xs -> - let (range, x) = curr in - (* if this is the first group of all "items", the number of - * newlines interleaved should be 0, else we collapse all newlines - * to 1. - * + val mutable comments = [] + method comments = comments + method trackComment comment = comments <- comment :: comments + + (* The test and first branch of ternaries must be guarded *) + method under_pipe = {} + method under_semi = {} + method reset_semi = {} + method reset_pipe = {} + method reset = {} + method inline_braces = {} + method dont_preserve_braces = {} + + method reset_request_braces = + {} + + method longident = + function + | Lident s -> protectIdentifier s + | Ldot (longPrefix, s) -> + protectLongIdentifier (self#longident longPrefix) s + | Lapply (y, s) -> + makeList [ self#longident y; atom "("; self#longident s; atom ")" ] + + (* This form allows applicative functors. *) + method longident_class_or_type_loc x = self#longident x.txt + + (* TODO: Fail if observing applicative functors for this form. *) + method longident_loc (x : Longident.t Location.loc) = + source_map ~loc:x.loc (self#longident x.txt) + + method constant ?raw_literal ?(parens = true) = + wrap (constant ?raw_literal ~parens) + + method constant_string_for_primitive = + wrap constant_string_for_primitive + + method tyvar = wrap tyvar + + (* c ['a,'b] *) + method class_params_def = + function [] -> atom "" | l -> makeTup (List.map self#type_param l) + + (* This will fall through to the simple version. *) + method non_arrowed_core_type x = self#non_arrowed_non_simple_core_type x + + method core_type2 x = + let { Reason_attributes.stdAttrs; uncurried } = + Reason_attributes.partitionAttributes x.ptyp_attributes + in + let uncurried = + uncurried + || + try Hashtbl.find uncurriedTable x.ptyp_loc with + | Not_found -> false + in + if stdAttrs != [] + then + formatAttributed + (self#non_arrowed_simple_core_type + { x with ptyp_attributes = [] }) + (self#attributes stdAttrs) + else + let x = if uncurried then { x with ptyp_attributes = [] } else x in + match x.ptyp_desc with + | Ptyp_arrow _ -> + let rec allArrowSegments ?(uncurried = false) acc = function + | { ptyp_desc = Ptyp_arrow (l, ct1, ct2); ptyp_attributes = [] } + -> + allArrowSegments + ~uncurried:false + ((l, ct1, false || uncurried) :: acc) + ct2 + | rhs -> + let rhs = self#core_type2 rhs in + let is_tuple typ = + match typ.ptyp_desc with Ptyp_tuple _ -> true | _ -> false + in + (match acc with + | [ (Nolabel, lhs, uncurried) ] when not (is_tuple lhs) -> + let t = self#non_arrowed_simple_core_type lhs in + let lhs = + if uncurried + then makeList ~wrap:("(. ", ")") ~postSpace:true [ t ] + else t + in + lhs, rhs + | acc -> + let params = List.rev_map self#type_with_label acc in + makeCommaBreakableListSurround "(" ")" params, rhs) + in + let lhs, rhs = allArrowSegments ~uncurried [] x in + let normalized = + makeList + ~preSpace:true + ~postSpace:true + ~inline:(true, true) + ~break:IfNeed + ~sep:(Sep "=>") + [ lhs; rhs ] + in + source_map ~loc:x.ptyp_loc normalized + | Ptyp_poly (sl, ct) -> + let ct = self#core_type ct in + let poly = + match sl with + | [] -> ct + | sl -> + makeList + ~break:IfNeed + ~postSpace:true + [ makeList + [ makeList + ~postSpace:true + (List.map (fun { txt } -> self#tyvar txt) sl) + ; atom "." + ] + ; ct + ] + in + source_map ~loc:x.ptyp_loc poly + | _ -> self#non_arrowed_core_type x + + (* Same as core_type2 but can be aliased *) + method core_type x = + let { Reason_attributes.stdAttrs; uncurried } = + Reason_attributes.partitionAttributes x.ptyp_attributes + in + let () = + if uncurried then Hashtbl.add uncurriedTable x.ptyp_loc true + in + if stdAttrs != [] + then + formatAttributed + (self#non_arrowed_simple_core_type + { x with ptyp_attributes = [] }) + (self#attributes stdAttrs) + else + match x.ptyp_desc with + | Ptyp_alias (ct, s) -> + source_map + ~loc:x.ptyp_loc + (label + ~space:true + (self#core_type ct) + (makeList ~postSpace:true [ atom "as"; atom ("'" ^ s) ])) + | _ -> self#core_type2 x + + method type_with_label (lbl, c, uncurried) = + let typ = self#core_type c in + let t = + match lbl with + | Nolabel -> typ + | Labelled lbl -> + label ~space:true (atom (namedArgSym ^ lbl ^ ":")) typ + | Optional lbl -> + label + ~space:true + (atom (namedArgSym ^ lbl ^ ":")) + (label typ (atom "=?")) + in + if uncurried then makeList ~postSpace:true [ atom "."; t ] else t + + method type_param (ct, (a, _)) = + makeList [ atom (type_variance a); self#core_type ct ] + + (* According to the parse rule [type_declaration], the "type declaration"'s + * physical location (as indicated by [td.ptype_loc]) begins with the + * identifier and includes the constraints. *) + method formatOneTypeDef + prepend + name + assignToken + ({ ptype_params; ptype_kind; ptype_loc } as td) = + let equalInitiatedSegments, constraints = + self#type_declaration_binding_segments td + in + let formattedTypeParams = List.map self#type_param ptype_params in + let binding = makeList ~postSpace:true [ prepend; name ] in + + (* + * /-----------everythingButConstraints-------------- | -constraints--\ + * /-innerL---| ------innerR--------------------------\ + * /binding\ /typeparams\ /--equalInitiatedSegments-\ + * type name 'v1 'v1 = foo = private bar constraint a = b + *) + let labelWithParams = + match formattedTypeParams with + | [] -> binding + | l -> label binding (makeTup l) + in + let everythingButConstraints = + let nameParamsEquals = + makeList ~postSpace:true [ labelWithParams; assignToken ] + in + match equalInitiatedSegments with + | [] -> labelWithParams + | _ :: _ :: _ :: _ -> + raise (NotPossible "More than two type segments.") + | hd :: [] -> + formatAttachmentApplication + typeApplicationFinalWrapping + (Some (true, nameParamsEquals)) + (hd, None) + | [ hd; hd2 ] -> + let first = + makeList + ~postSpace:true + ~break:IfNeed + ~inline:(true, true) + (hd @ [ atom "=" ]) + in + (* + * Because we want a record as a label with the opening brace on the same line + * and the closing brace indented at the beginning, we can't wrap it in a list here * Example: - * module Abc = { - * let a = 1; - * - * let b = 2; - * } - * `let a = 1` should be wrapped in a `Layout.Whitespace` because a - * user might put comments above the `let a = 1`. - * e.g. - * module Abc = { - * /* comment 1 */ - * - * /* comment 2 */ - * let a = 1; - * - * A Whitespace-node will automatically take care of the whitespace - * interleaving between the comments. + * type doubleEqualsRecord = + * myRecordWithReallyLongName = { <- opening brace on the same line + * xx: int, + * yy: int + * }; <- closing brace indentation *) - let newlines = if i > 0 then 1 else 0 in - let region = WhitespaceRegion.make ~range ~newlines () in - let firstLayout = Layout.Whitespace(region, x) in - (* the first layout node of every group taks care of the - * whitespace above a group*) - (firstLayout::(List.map snd xs)) - | [] -> [] - ) groups - in - match items with - | first::rest -> - List.concat (group (getLoc first) [] [] (first::rest)) - | [] -> [] - -let printer = object(self:'self) - val pipe = false - val semi = false - - val inline_braces = false - val preserve_braces = true - - (* *Mutable state* in the printer to keep track of all comments - * Used when whitespace needs to be interleaved. - * The printing algorithm needs to take the comments into account in between - * two items, to correctly determine if there's whitespace between two items. - * The ast doesn't know if there are comments between two items, since - * comments are store separately. The location diff between two items - * might indicate whitespace between the two. While in reality there are - * comments filling that whitespace. The printer needs access to the comments - * for this reason. - * - * Example: - * 1| let a = 1; - * 2| - * 3| - * 4| let b = 2; - * -> here we can just diff the locations between `let a = 1` and `let b = 2` - * - * 1| let a = 1; - * 2| /* a comment */ - * 3| /* another comment */ - * 4| let b = 2; - * -> here the location diff will result into false info if we don't include - * the comments in the diffing - *) - val mutable comments = [] - - method comments = comments - method trackComment comment = comments <- comment::comments - - (* The test and first branch of ternaries must be guarded *) - method under_pipe = {} - method under_semi = {} - method reset_semi = {} - method reset_pipe = {} - method reset = {} - - method inline_braces = {} - method dont_preserve_braces = {} - method reset_request_braces = {} - - - method longident = function - | Lident s -> (protectIdentifier s) - | Ldot(longPrefix, s) -> - (protectLongIdentifier (self#longident longPrefix) s) - | Lapply (y,s) -> makeList [self#longident y; atom "("; self#longident s; atom ")";] - - (* This form allows applicative functors. *) - method longident_class_or_type_loc x = self#longident x.txt - (* TODO: Fail if observing applicative functors for this form. *) - method longident_loc (x:Longident.t Location.loc) = - source_map ~loc:x.loc (self#longident x.txt) - - method constant ?raw_literal ?(parens=true) = - wrap (constant ?raw_literal ~parens) - - method constant_string_for_primitive = wrap constant_string_for_primitive - method tyvar = wrap tyvar - - (* c ['a,'b] *) - method class_params_def = function - | [] -> atom "" - | l -> makeTup (List.map self#type_param l) - - (* This will fall through to the simple version. *) - method non_arrowed_core_type x = self#non_arrowed_non_simple_core_type x - - method core_type2 x = - let {Reason_attributes.stdAttrs; uncurried} = Reason_attributes.partitionAttributes x.ptyp_attributes in - let uncurried = uncurried || try Hashtbl.find uncurriedTable x.ptyp_loc with | Not_found -> false in - if stdAttrs != [] then - formatAttributed - (self#non_arrowed_simple_core_type {x with ptyp_attributes = []}) - (self#attributes stdAttrs) - else - let x = if uncurried then { x with ptyp_attributes = [] } else x in - match x.ptyp_desc with - | Ptyp_arrow _ -> - let rec allArrowSegments ?(uncurried=false) acc = function - | { ptyp_desc = Ptyp_arrow (l, ct1, ct2); ptyp_attributes = []} -> - allArrowSegments ~uncurried:false - ((l,ct1, false || uncurried) :: acc) ct2 - | rhs -> - let rhs = self#core_type2 rhs in - let is_tuple typ = match typ.ptyp_desc with - | Ptyp_tuple _ -> true - | _ -> false + let second = + match ptype_kind with + | Ptype_record _ -> List.hd hd2 + | _ -> + makeList + ~postSpace:true + ~break:IfNeed + ~inline:(true, true) + hd2 in - match acc with - | [(Nolabel, lhs, uncurried )] when not (is_tuple lhs) -> - let t = self#non_arrowed_simple_core_type lhs in - let lhs = if uncurried then - makeList ~wrap:("(. ", ")") ~postSpace:true [t] - else t in - (lhs, rhs) - | acc -> - let params = List.rev_map self#type_with_label acc in - (makeCommaBreakableListSurround "(" ")" params, rhs) - in - let (lhs, rhs) = allArrowSegments ~uncurried [] x in - let normalized = makeList - ~preSpace:true ~postSpace:true ~inline:(true, true) - ~break:IfNeed ~sep:(Sep "=>") [lhs; rhs] - in source_map ~loc:x.ptyp_loc normalized - | Ptyp_poly (sl, ct) -> - let ct = self#core_type ct in - let poly = match sl with - | [] -> ct - | sl -> - makeList ~break:IfNeed ~postSpace:true [ - makeList [ - makeList ~postSpace:true (List.map (fun {txt} -> self#tyvar txt) sl); - atom "."; - ]; - ct + label + ~space:true + nameParamsEquals + (label ~space:true first second) + in + let everything = + match constraints with + | [] -> everythingButConstraints + | hd :: tl -> + makeList + ~break:IfNeed + ~postSpace:true + ~indent:0 + ~inline:(true, true) + (everythingButConstraints :: hd :: tl) + in + source_map ~loc:ptype_loc everything + + method formatOneTypeExt prepend name assignToken te = + let privateAtom = atom "pri" in + let privatize scope lst = + match scope with Public -> lst | Private -> privateAtom :: lst + in + let equalInitiatedSegments = + let segments = + List.map + self#type_extension_binding_segments + te.ptyext_constructors + in + let privatized_segments = privatize te.ptyext_private segments in + [ makeList + ~break:Always_rec + ~postSpace:true + ~inline:(true, true) + privatized_segments ] - in source_map ~loc:x.ptyp_loc poly - | _ -> self#non_arrowed_core_type x - - (* Same as core_type2 but can be aliased *) - method core_type x = - let {Reason_attributes.stdAttrs; uncurried} = Reason_attributes.partitionAttributes x.ptyp_attributes in - let () = if uncurried then Hashtbl.add uncurriedTable x.ptyp_loc true in - if stdAttrs != [] then - formatAttributed - (self#non_arrowed_simple_core_type {x with ptyp_attributes = []}) - (self#attributes stdAttrs) - else match x.ptyp_desc with - | (Ptyp_alias (ct, s)) -> - source_map ~loc:x.ptyp_loc - (label - ~space:true - (self#core_type ct) - (makeList ~postSpace:true [atom "as"; atom ("'" ^ s)])) - | _ -> self#core_type2 x - - method type_with_label (lbl, c, uncurried) = - let typ = self#core_type c in - let t = match lbl with - | Nolabel -> typ - | Labelled lbl -> - label ~space:true (atom (namedArgSym ^ lbl ^ ":")) typ - | Optional lbl -> - label - ~space:true - (atom (namedArgSym ^ lbl ^ ":")) - (label typ (atom "=?")) - in - if uncurried then - makeList ~postSpace:true [atom "."; t] - else t - - method type_param (ct, (a, _)) = - makeList [atom (type_variance a); self#core_type ct] - - (* According to the parse rule [type_declaration], the "type declaration"'s - * physical location (as indicated by [td.ptype_loc]) begins with the - * identifier and includes the constraints. *) - method formatOneTypeDef prepend name assignToken ({ptype_params; ptype_kind; ptype_loc} as td) = - let (equalInitiatedSegments, constraints) = (self#type_declaration_binding_segments td) in - let formattedTypeParams = List.map self#type_param ptype_params in - let binding = makeList ~postSpace:true [prepend;name] in - (* - /-----------everythingButConstraints-------------- | -constraints--\ - /-innerL---| ------innerR--------------------------\ - /binding\ /typeparams\ /--equalInitiatedSegments-\ - type name 'v1 'v1 = foo = private bar constraint a = b - *) - - let labelWithParams = match formattedTypeParams with - | [] -> binding - | l -> label binding (makeTup l) - in - let everythingButConstraints = - let nameParamsEquals = makeList ~postSpace:true [labelWithParams; assignToken] in - match equalInitiatedSegments with - | [] -> labelWithParams - | _::_::_::_ -> raise (NotPossible "More than two type segments.") - | hd::[] -> + in + let formattedTypeParams = List.map self#type_param te.ptyext_params in + let binding = makeList ~postSpace:true [ prepend; name ] in + let labelWithParams = + match formattedTypeParams with + | [] -> binding + | l -> label binding (makeTup l) + in + let everything = + let nameParamsEquals = + makeList ~postSpace:true [ labelWithParams; assignToken ] + in formatAttachmentApplication typeApplicationFinalWrapping (Some (true, nameParamsEquals)) - (hd, None) - | hd::hd2::[] -> - let first = makeList ~postSpace:true ~break:IfNeed ~inline:(true, true) (hd @ [atom "="]) in - (* - * Because we want a record as a label with the opening brace on the same line - * and the closing brace indented at the beginning, we can't wrap it in a list here - * Example: - * type doubleEqualsRecord = - * myRecordWithReallyLongName = { <- opening brace on the same line - * xx: int, - * yy: int - * }; <- closing brace indentation - *) - let second = match ptype_kind with - | Ptype_record _ -> List.hd hd2 - | _ -> makeList ~postSpace:true ~break:IfNeed ~inline:(true, true) hd2 + (equalInitiatedSegments, None) + in + source_map ~loc:te.ptyext_path.loc everything + + method type_extension_binding_segments + { pext_kind; pext_loc; pext_attributes; pext_name } = + let normalize lst = + match lst with + | [] -> raise (NotPossible "should not be called") + | [ hd ] -> hd + | _ :: _ -> makeList lst + in + let add_bar name attrs args = + let lbl = + match args with None -> name | Some args -> label name args in - label ~space:true nameParamsEquals ( - label ~space:true first second - ) - in - let everything = - match constraints with - | [] -> everythingButConstraints - | hd::tl -> makeList ~break:IfNeed ~postSpace:true ~indent:0 ~inline:(true, true) (everythingButConstraints::hd::tl) - in - source_map ~loc:ptype_loc everything - - method formatOneTypeExt prepend name assignToken te = - let privateAtom = (atom "pri") in - let privatize scope lst = match scope with - | Public -> lst - | Private -> privateAtom::lst in - let equalInitiatedSegments = - let segments = List.map self#type_extension_binding_segments te.ptyext_constructors in - let privatized_segments = privatize te.ptyext_private segments in - [makeList ~break:Always_rec ~postSpace:true ~inline:(true, true) privatized_segments] in - let formattedTypeParams = List.map self#type_param te.ptyext_params in - let binding = makeList ~postSpace:true (prepend::name::[]) in - let labelWithParams = match formattedTypeParams with - | [] -> binding - | l -> label binding (makeTup l) - in - let everything = - let nameParamsEquals = makeList ~postSpace:true [labelWithParams; assignToken] in - formatAttachmentApplication - typeApplicationFinalWrapping - (Some (true, nameParamsEquals)) - (equalInitiatedSegments, None) - in - source_map ~loc:te.ptyext_path.loc everything - - method type_extension_binding_segments {pext_kind; pext_loc; pext_attributes; pext_name} = - let normalize lst = match lst with - | [] -> raise (NotPossible "should not be called") - | [hd] -> hd - | _::_ -> makeList lst - in - let add_bar name attrs args = - let lbl = begin match args with - | None -> name - | Some args -> label name args - end in - if attrs != [] then - label ~space:true - (makeList - ~postSpace:true - [ - atom "|"; - makeList - ~postSpace:true - ~break:Layout.IfNeed - ~inline:(true, true) - (self#attributes attrs) - ] - ) - lbl - else - makeList ~postSpace:true [atom "|"; lbl] - in - let sourceMappedName = atom ~loc:pext_name.loc pext_name.txt in - let resolved = match pext_kind with - | Pext_decl (_, ctor_args, gadt) -> - let formattedArgs = match ctor_args with - | Pcstr_tuple [] -> [] - | Pcstr_tuple args -> [makeTup (List.map self#non_arrowed_non_simple_core_type args)] - | Pcstr_record r -> [self#record_declaration ~wrap:("({", "})") r] - in - let formattedGadt = match gadt with - | None -> None - | Some x -> Some ( - makeList [ - formatJustTheTypeConstraint (self#core_type x) - ] - ) - in - (formattedArgs, formattedGadt) - (* type bar += Foo = Attr.Foo *) - | Pext_rebind rebind -> - let r = self#longident_loc rebind in - (* we put an empty space before the '=': we don't have access to the fact - * that we need a space because of the Pext_rebind later *) - let prepend = (atom " =") in - ([makeList ~postSpace:true [prepend; r]], None) - in - (* - The first element of the tuple represents constructor arguments, - the second an optional formatted gadt. - - Case 1: No constructor arguments, neither a gadt - type attr = ..; - type attr += | Str - - Case 2: No constructor arguments, is a gadt - type attr = ..; - type attr += | Str :attr - - Case 3: Has Constructor args, not a gadt - type attr = ..; - type attr += | Str(string); - type attr += | Point(int, int); - - Case 4: Has Constructor args & is a gadt - type attr = ..; - type attr += | Point(int, int) :attr; - *) - let everything = match resolved with - | ([], None) -> add_bar sourceMappedName pext_attributes None - | ([], Some gadt) -> add_bar sourceMappedName pext_attributes (Some gadt) - | (ctorArgs, None) -> add_bar sourceMappedName pext_attributes (Some (normalize ctorArgs)) - | (ctorArgs, Some gadt) -> add_bar sourceMappedName pext_attributes (Some (normalize (ctorArgs@[gadt]))) - in - source_map ~loc:pext_loc everything - - (* shared by [Pstr_type,Psig_type]*) - method type_def_list ?(eq_symbol="=") (rf, l) = - (* As oposed to used in type substitution. *) - let formatOneTypeDefStandard prepend td = - let itm = - self#formatOneTypeDef - prepend - (atom ~loc:td.ptype_name.loc td.ptype_name.txt) - (atom eq_symbol) - td - in - let {Reason_attributes.stdAttrs; docAttrs} = Reason_attributes.partitionAttributes ~partDoc:true td.ptype_attributes in - let layout = self#attach_std_item_attrs stdAttrs itm in - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:td.ptype_loc - ~layout - () - in - - match l with - | [] -> raise (NotPossible "asking for type list of nothing") - | hd::tl -> - let first = - match rf with - | Recursive -> formatOneTypeDefStandard (atom "type") hd - | Nonrecursive -> - formatOneTypeDefStandard (atom "type nonrec") hd + if attrs != [] + then + label + ~space:true + (makeList + ~postSpace:true + [ atom "|" + ; makeList + ~postSpace:true + ~break:Layout.IfNeed + ~inline:(true, true) + (self#attributes attrs) + ]) + lbl + else makeList ~postSpace:true [ atom "|"; lbl ] + in + let sourceMappedName = atom ~loc:pext_name.loc pext_name.txt in + let resolved = + match pext_kind with + | Pext_decl (_, ctor_args, gadt) -> + let formattedArgs = + match ctor_args with + | Pcstr_tuple [] -> [] + | Pcstr_tuple args -> + [ makeTup + (List.map self#non_arrowed_non_simple_core_type args) + ] + | Pcstr_record r -> + [ self#record_declaration ~wrap:("({", "})") r ] + in + let formattedGadt = + match gadt with + | None -> None + | Some x -> + Some + (makeList + [ formatJustTheTypeConstraint (self#core_type x) ]) + in + formattedArgs, formattedGadt + (* type bar += Foo = Attr.Foo *) + | Pext_rebind rebind -> + let r = self#longident_loc rebind in + (* we put an empty space before the '=': we don't have access to the fact + * that we need a space because of the Pext_rebind later *) + let prepend = atom " =" in + [ makeList ~postSpace:true [ prepend; r ] ], None + in + (* + * The first element of the tuple represents constructor arguments, + * the second an optional formatted gadt. + * + * Case 1: No constructor arguments, neither a gadt + * type attr = ..; + * type attr += | Str + * + * Case 2: No constructor arguments, is a gadt + * type attr = ..; + * type attr += | Str :attr + * + * Case 3: Has Constructor args, not a gadt + * type attr = ..; + * type attr += | Str(string); + * type attr += | Point(int, int); + * + * Case 4: Has Constructor args & is a gadt + * type attr = ..; + * type attr += | Point(int, int) :attr; + *) + let everything = + match resolved with + | [], None -> add_bar sourceMappedName pext_attributes None + | [], Some gadt -> + add_bar sourceMappedName pext_attributes (Some gadt) + | ctorArgs, None -> + add_bar + sourceMappedName + pext_attributes + (Some (normalize ctorArgs)) + | ctorArgs, Some gadt -> + add_bar + sourceMappedName + pext_attributes + (Some (normalize (ctorArgs @ [ gadt ]))) + in + source_map ~loc:pext_loc everything + + (* shared by [Pstr_type,Psig_type]*) + method type_def_list ?(eq_symbol = "=") (rf, l) = + (* As oposed to used in type substitution. *) + let formatOneTypeDefStandard prepend td = + let itm = + self#formatOneTypeDef + prepend + (atom ~loc:td.ptype_name.loc td.ptype_name.txt) + (atom eq_symbol) + td + in + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + td.ptype_attributes + in + let layout = self#attach_std_item_attrs stdAttrs itm in + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:td.ptype_loc + ~layout + () in - match tl with + + match l with + | [] -> raise (NotPossible "asking for type list of nothing") + | hd :: tl -> + let first = + match rf with + | Recursive -> formatOneTypeDefStandard (atom "type") hd + | Nonrecursive -> formatOneTypeDefStandard (atom "type nonrec") hd + in + (match tl with (* Exactly one type *) | [] -> first - | _::_ as typeList -> - let items = (hd.ptype_loc, first)::(List.map (fun ptyp -> - (ptyp.ptype_loc, formatOneTypeDefStandard (atom "and") ptyp) - ) typeList - ) in - makeList ~indent:0 ~inline:(true, true) ~break:Always_rec ( - groupAndPrint - ~xf:snd - ~getLoc:fst - ~comments:self#comments - items - ) - - method type_variant_list lst = - match lst with - | [] -> [atom "|"] - | _ -> List.map (fun x -> self#type_variant_leaf x) lst - - method type_variant_leaf ?opt_ampersand:(a=false) ?polymorphic:(p=false) = self#type_variant_leaf1 a p true - method type_variant_leaf_nobar ?opt_ampersand:(a=false) ?polymorphic:(p=false) = self#type_variant_leaf1 a p false - - (* TODOATTRIBUTES: Attributes on the entire variant leaf are likely - * not parsed or printed correctly. *) - method type_variant_leaf1 opt_ampersand polymorphic print_bar x = - let {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = x in - let {Reason_attributes.stdAttrs; docAttrs} = Reason_attributes.partitionAttributes ~partDoc:true pcd_attributes in - let ampersand_helper i arg = - let ct = self#core_type arg in - let ct = match arg.ptyp_desc with - | Ptyp_tuple _ -> ct - | _ -> makeTup [ct] - in - if i == 0 && not opt_ampersand then - ct - else - label (atom "&") ct - in - let args = match pcd_args with - | Pcstr_record r -> - [self#record_declaration ~wrap:("({", "})") r] - | Pcstr_tuple [] -> [] - | Pcstr_tuple l when polymorphic -> List.mapi ampersand_helper l - (* Here's why this works. With the new syntax, all the args, are already inside of - a safely guarded place like Constructor(here, andHere). Compare that to the - previous syntax Constructor here andHere. In the previous syntax, we needed to - require that we print "non-arrowed" types for here, and andHere to avoid - something like Constructor a=>b c=>d. In the new syntax, we don't care if here - and andHere have unguarded arrow types like a=>b because they're safely - separated by commas. - *) - | Pcstr_tuple l -> [makeTup (List.map self#core_type l)] - in - let gadtRes = match pcd_res with - | None -> None - | Some x -> Some ( - formatJustTheTypeConstraint (self#core_type x) - ) - in - let normalize lst = match lst with - | [] -> raise (NotPossible "should not be called") - | [hd] -> hd - | _::_ -> makeList ~inline:(true, true) ~break:IfNeed ~postSpace:true lst - in - let add_bar constructor = - makeList ~postSpace:true (if print_bar then [atom "|"; constructor] else [constructor]) - in - (* In some cases (e.g. inline records) we want the label with bar & the gadt resolution - * as a list. - * | If { - * pred: expr bool, - * true_branch: expr 'a, - * false_branch: expr 'a - * } ==> end of label - * :expr 'a; ==> gadt res - * The label & the gadt res form two separate units combined into a list. - * This is necessary to properly align the closing '}' on the same height as the 'If'. - *) - let add_bar_2 ?gadt name args = - let lbl = label name args in - let fullLbl = match gadt with - | Some g -> makeList ~inline:(true, true) ~break:IfNeed [lbl; g] - | None -> lbl - in - add_bar fullLbl - in - - let prefix = if polymorphic then "`" else "" in - let sourceMappedName = atom ~loc:pcd_name.loc (prefix ^ pcd_name.txt) in - let sourceMappedNameWithAttributes = - let layout = match stdAttrs with - | [] -> sourceMappedName - | stdAttrs -> - formatAttributed sourceMappedName (self#attributes stdAttrs) - in - match docAttrs with - | [] -> layout - | docAttrs -> - makeList ~break:Always ~inline:(true, true) [ - makeList (self#attributes docAttrs); - layout - ] - in - let constructorName = makeList ~postSpace:true [sourceMappedNameWithAttributes] in - let everything = match (args, gadtRes) with - | ([], None) -> add_bar sourceMappedNameWithAttributes - | ([], Some gadt) -> add_bar_2 sourceMappedNameWithAttributes gadt - | (_::_, None) -> add_bar_2 constructorName (normalize args) - | (_::_, Some gadt) -> - (match pcd_args with - | Pcstr_record _ -> add_bar_2 ~gadt constructorName (normalize args) - | _ -> add_bar_2 constructorName ~gadt (normalize args)) - in - source_map ~loc:pcd_loc everything - - method record_declaration ?(wrap=("{", "}")) ?assumeRecordLoc lbls = - let recordRow pld = - let hasPunning = recordRowIsPunned pld in - let name = - if hasPunning - then [atom pld.pld_name.txt] - else [atom pld.pld_name.txt; atom ":"] - in - let name = source_map ~loc:pld.pld_name.loc (makeList name) in - let withMutable = - match pld.pld_mutable with - | Immutable -> name - | Mutable -> makeList ~postSpace:true [atom "mutable"; name] - in - let recordRow = if hasPunning then - label withMutable (atom "") - else - label ~space:true withMutable (self#core_type pld.pld_type) - in - let recordRow = match pld.pld_attributes with - | [] -> recordRow - | attrs -> - let {Reason_attributes.stdAttrs; docAttrs} = Reason_attributes.partitionAttributes ~partDoc:true attrs in - let stdAttrsLayout = - makeList ~inline:(true, true) ~postSpace:true (self#attributes stdAttrs) - in - let docAttrsLayout = makeList ~inline:(true, true) (self#attributes docAttrs) in - let children = match (docAttrs, stdAttrs) with - | [], [] -> [recordRow] - | _, [] -> [docAttrsLayout; recordRow] - | [], _ -> [stdAttrsLayout; recordRow] - | _, _ -> - [docAttrsLayout; stdAttrsLayout; recordRow] - in - makeList ~inline:(true, true) ~break:Always_rec children - in - source_map ~loc:pld.pld_loc recordRow - in - let rows = List.map recordRow lbls in - (* if a record type has more than 1 row, always break *) - let break = - match rows with - | [] | [ _ ] -> Layout.IfNeed - | _ -> Layout.Always_rec - in - source_map ?loc:assumeRecordLoc - (makeList ~wrap ~sep:commaTrail ~postSpace:true ~break rows) - - (* Returns the type declaration partitioned into three segments - one - suitable for appending to a label, the actual type manifest - and the list of constraints. *) - method type_declaration_binding_segments x = - (* Segments of the type binding (occuring after the type keyword) that - should begin with "=". Zero to two total sections. - This is just a straightforward reverse mapping from the original parser: - type_kind: - /*empty*/ - { (Ptype_abstract, Public, None) } - | EQUAL core_type - { (Ptype_abstract, Public, Some $2) } - | EQUAL PRIVATE core_type - { (Ptype_abstract, Private, Some $3) } - | EQUAL constructor_declarations - { (Ptype_variant(List.rev $2), Public, None) } - | EQUAL PRIVATE constructor_declarations - { (Ptype_variant(List.rev $3), Private, None) } - | EQUAL private_flag BAR constructor_declarations - { (Ptype_variant(List.rev $4), $2, None) } - | EQUAL DOTDOT - { (Ptype_open, Public, None) } - | EQUAL private_flag LBRACE label_declarations opt_comma RBRACE - { (Ptype_record(List.rev $4), $2, None) } - | EQUAL core_type EQUAL private_flag opt_bar constructor_declarations - { (Ptype_variant(List.rev $6), $4, Some $2) } - | EQUAL core_type EQUAL DOTDOT - { (Ptype_open, Public, Some $2) } - | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_comma RBRACE - { (Ptype_record(List.rev $6), $4, Some $2) } - *) - let privateAtom = (atom "pri") in - let privatize scope lst = match scope with - | Public -> lst - | Private -> privateAtom::lst in - - let estimateRecordOpenBracePoint () = - match x.ptype_params with - | [] -> x.ptype_name.loc.loc_end - | _ -> - (fst (List.nth x.ptype_params (List.length x.ptype_params - 1))).ptyp_loc.loc_end - in + | _ :: _ as typeList -> + let items = + (hd.ptype_loc, first) + :: List.map + (fun ptyp -> + ( ptyp.ptype_loc + , formatOneTypeDefStandard (atom "and") ptyp )) + typeList + in + makeList + ~indent:0 + ~inline:(true, true) + ~break:Always_rec + (groupAndPrint + ~xf:snd + ~getLoc:fst + ~comments:self#comments + items)) + + method type_variant_list lst = + match lst with + | [] -> [ atom "|" ] + | _ -> List.map (fun x -> self#type_variant_leaf x) lst + + method type_variant_leaf + ?opt_ampersand:(a = false) + ?polymorphic:(p = false) = + self#type_variant_leaf1 a p true + + method type_variant_leaf_nobar + ?opt_ampersand:(a = false) + ?polymorphic:(p = false) = + self#type_variant_leaf1 a p false + + (* TODOATTRIBUTES: Attributes on the entire variant leaf are likely + * not parsed or printed correctly. *) + method type_variant_leaf1 opt_ampersand polymorphic print_bar x = + let { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } = x in + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes ~partDoc:true pcd_attributes + in + let ampersand_helper i arg = + let ct = self#core_type arg in + let ct = + match arg.ptyp_desc with + | Ptyp_tuple _ -> ct + | _ -> makeTup [ ct ] + in + if i == 0 && not opt_ampersand then ct else label (atom "&") ct + in + let args = + match pcd_args with + | Pcstr_record r -> [ self#record_declaration ~wrap:("({", "})") r ] + | Pcstr_tuple [] -> [] + | Pcstr_tuple l when polymorphic -> List.mapi ampersand_helper l + (* Here's why this works. With the new syntax, all the args, are + already inside of a safely guarded place like Constructor(here, + andHere). Compare that to the previous syntax Constructor here + andHere. In the previous syntax, we needed to require that we + print "non-arrowed" types for here, and andHere to avoid + something like Constructor a=>b c=>d. In the new syntax, we don't + care if here and andHere have unguarded arrow types like a=>b + because they're safely separated by commas. *) + | Pcstr_tuple l -> [ makeTup (List.map self#core_type l) ] + in + let gadtRes = + match pcd_res with + | None -> None + | Some x -> Some (formatJustTheTypeConstraint (self#core_type x)) + in + let normalize lst = + match lst with + | [] -> raise (NotPossible "should not be called") + | [ hd ] -> hd + | _ :: _ -> + makeList ~inline:(true, true) ~break:IfNeed ~postSpace:true lst + in + let add_bar constructor = + makeList + ~postSpace:true + (if print_bar then [ atom "|"; constructor ] else [ constructor ]) + in + (* In some cases (e.g. inline records) we want the label with bar & the gadt resolution + * as a list. + * | If { + * pred: expr bool, + * true_branch: expr 'a, + * false_branch: expr 'a + * } ==> end of label + * :expr 'a; ==> gadt res + * The label & the gadt res form two separate units combined into a list. + * This is necessary to properly align the closing '}' on the same height as the 'If'. + *) + let add_bar_2 ?gadt name args = + let lbl = label name args in + let fullLbl = + match gadt with + | Some g -> makeList ~inline:(true, true) ~break:IfNeed [ lbl; g ] + | None -> lbl + in + add_bar fullLbl + in - let equalInitiatedSegments = match (x.ptype_kind, x.ptype_private, x.ptype_manifest) with - (* /*empty*/ {(Ptype_abstract, Public, None)} *) - | (Ptype_abstract, Public, None) -> [ + let prefix = if polymorphic then "`" else "" in + let sourceMappedName = + atom ~loc:pcd_name.loc (prefix ^ pcd_name.txt) + in + let sourceMappedNameWithAttributes = + let layout = + match stdAttrs with + | [] -> sourceMappedName + | stdAttrs -> + formatAttributed sourceMappedName (self#attributes stdAttrs) + in + match docAttrs with + | [] -> layout + | docAttrs -> + makeList + ~break:Always + ~inline:(true, true) + [ makeList (self#attributes docAttrs); layout ] + in + let constructorName = + makeList ~postSpace:true [ sourceMappedNameWithAttributes ] + in + let everything = + match args, gadtRes with + | [], None -> add_bar sourceMappedNameWithAttributes + | [], Some gadt -> add_bar_2 sourceMappedNameWithAttributes gadt + | _ :: _, None -> add_bar_2 constructorName (normalize args) + | _ :: _, Some gadt -> + (match pcd_args with + | Pcstr_record _ -> + add_bar_2 ~gadt constructorName (normalize args) + | _ -> add_bar_2 constructorName ~gadt (normalize args)) + in + source_map ~loc:pcd_loc everything + + method record_declaration ?(wrap = "{", "}") ?assumeRecordLoc lbls = + let recordRow pld = + let hasPunning = recordRowIsPunned pld in + let name = + if hasPunning + then [ atom pld.pld_name.txt ] + else [ atom pld.pld_name.txt; atom ":" ] + in + let name = source_map ~loc:pld.pld_name.loc (makeList name) in + let withMutable = + match pld.pld_mutable with + | Immutable -> name + | Mutable -> makeList ~postSpace:true [ atom "mutable"; name ] + in + let recordRow = + if hasPunning + then label withMutable (atom "") + else label ~space:true withMutable (self#core_type pld.pld_type) + in + let recordRow = + match pld.pld_attributes with + | [] -> recordRow + | attrs -> + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes ~partDoc:true attrs + in + let stdAttrsLayout = + makeList + ~inline:(true, true) + ~postSpace:true + (self#attributes stdAttrs) + in + let docAttrsLayout = + makeList ~inline:(true, true) (self#attributes docAttrs) + in + let children = + match docAttrs, stdAttrs with + | [], [] -> [ recordRow ] + | _, [] -> [ docAttrsLayout; recordRow ] + | [], _ -> [ stdAttrsLayout; recordRow ] + | _, _ -> [ docAttrsLayout; stdAttrsLayout; recordRow ] + in + makeList ~inline:(true, true) ~break:Always_rec children + in + source_map ~loc:pld.pld_loc recordRow + in + let rows = List.map recordRow lbls in + (* if a record type has more than 1 row, always break *) + let break = + match rows with + | [] | [ _ ] -> Layout.IfNeed + | _ -> Layout.Always_rec + in + source_map + ?loc:assumeRecordLoc + (makeList ~wrap ~sep:commaTrail ~postSpace:true ~break rows) + + (* Returns the type declaration partitioned into three segments - one + suitable for appending to a label, the actual type manifest and the + list of constraints. *) + method type_declaration_binding_segments x = + (* Segments of the type binding (occuring after the type keyword) that + * should begin with "=". Zero to two total sections. + * This is just a straightforward reverse mapping from the original parser: + * type_kind: + * /*empty*/ + * { (Ptype_abstract, Public, None) } + * | EQUAL core_type + * { (Ptype_abstract, Public, Some $2) } + * | EQUAL PRIVATE core_type + * { (Ptype_abstract, Private, Some $3) } + * | EQUAL constructor_declarations + * { (Ptype_variant(List.rev $2), Public, None) } + * | EQUAL PRIVATE constructor_declarations + * { (Ptype_variant(List.rev $3), Private, None) } + * | EQUAL private_flag BAR constructor_declarations + * { (Ptype_variant(List.rev $4), $2, None) } + * | EQUAL DOTDOT + * { (Ptype_open, Public, None) } + * | EQUAL private_flag LBRACE label_declarations opt_comma RBRACE + * { (Ptype_record(List.rev $4), $2, None) } + * | EQUAL core_type EQUAL private_flag opt_bar constructor_declarations + * { (Ptype_variant(List.rev $6), $4, Some $2) } + * | EQUAL core_type EQUAL DOTDOT + * { (Ptype_open, Public, Some $2) } + * | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_comma RBRACE + * { (Ptype_record(List.rev $6), $4, Some $2) } + *) + let privateAtom = atom "pri" in + let privatize scope lst = + match scope with Public -> lst | Private -> privateAtom :: lst + in - ] - (* EQUAL core_type {(Ptype_abstract, Public, Some _)} *) - | (Ptype_abstract, Public, Some y) -> [ - [self#core_type y] - ] - (* EQUAL PRIVATE core_type {(Ptype_abstract, Private, Some $3)} *) - | (Ptype_abstract, Private, Some y) -> [ - [privateAtom; self#core_type y] - ] - (* EQUAL constructor_declarations {(Ptype_variant _., Public, None)} *) - (* This case is redundant *) - (* | (Ptype_variant lst, Public, None) -> [ *) - (* [makeSpacedBreakableInlineList (List.map type_variant_leaf lst)] *) - (* ] *) - (* EQUAL PRIVATE constructor_declarations {(Ptype_variant _, Private, None)} *) - | (Ptype_variant lst, Private, None) -> [ - [privateAtom; makeList ~break:IfNeed ~postSpace:true ~inline:(true, true) (self#type_variant_list lst)] - ] - (* EQUAL private_flag BAR constructor_declarations {(Ptype_variant _, $2, None)} *) - | (Ptype_variant lst, scope, None) -> [ - privatize scope - [makeList - ~break:Always_rec - ~postSpace:true - ~inline:(true, true) - (self#type_variant_list lst)] - ] - (* EQUAL DOTDOT {(Ptype_open, Public, None)} *) - | (Ptype_open, Public, None) -> [ - [atom ".."] - ] - | (Ptype_open, Private, None) -> [ - [privateAtom; atom ".."] - ] - (* Super confusing how record/variants' manifest is not actually the - description of the structure. What's in the manifest in that case is - the *second* EQUALS asignment. *) - - (* EQUAL private_flag LBRACE label_declarations opt_comma RBRACE {(Ptype_record _, $2, None)} *) - | (Ptype_record lst, scope, None) -> - let assumeRecordLoc = {loc_start = estimateRecordOpenBracePoint(); loc_end = x.ptype_loc.loc_end; loc_ghost = false} in - [privatize scope [self#record_declaration ~assumeRecordLoc lst]] - (* And now all of the forms involving *TWO* equals *) - (* Again, super confusing how manifests of variants/records represent the - structure after the second equals. *) - (* ================================================*) - - - (* EQUAL core_type EQUAL private_flag opt_bar constructor_declarations { - (Ptype_variant _, _, Some _)} *) - | (Ptype_variant lst, scope, Some mani) -> [ - [self#core_type mani]; - let variant = makeList ~break:IfNeed ~postSpace:true ~inline:(true, true) (self#type_variant_list lst) in - privatize scope [variant]; - ] + let estimateRecordOpenBracePoint () = + match x.ptype_params with + | [] -> x.ptype_name.loc.loc_end + | _ -> + (fst (List.nth x.ptype_params (List.length x.ptype_params - 1))) + .ptyp_loc + .loc_end + in - (* EQUAL core_type EQUAL DOTDOT {(Ptype_open, Public, Some $2)} *) - | (Ptype_open, Public, Some mani) -> [ - [self#core_type mani]; - [atom ".."]; - ] - (* EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_comma RBRACE - {(Ptype_record _, $4, Some $2)} *) - | (Ptype_record lst, scope, Some mani) -> - let declaration = self#record_declaration lst in - let record = match scope with - | Public -> [declaration] - | Private -> [label ~space:true privateAtom declaration] + let equalInitiatedSegments = + match x.ptype_kind, x.ptype_private, x.ptype_manifest with + (* /*empty*/ {(Ptype_abstract, Public, None)} *) + | Ptype_abstract, Public, None -> [] + (* EQUAL core_type {(Ptype_abstract, Public, Some _)} *) + | Ptype_abstract, Public, Some y -> [ [ self#core_type y ] ] + (* EQUAL PRIVATE core_type {(Ptype_abstract, Private, Some $3)} *) + | Ptype_abstract, Private, Some y -> + [ [ privateAtom; self#core_type y ] ] + (* EQUAL constructor_declarations {(Ptype_variant _., Public, None)} *) + (* This case is redundant *) + (* | (Ptype_variant lst, Public, None) -> [ *) + (* [makeSpacedBreakableInlineList (List.map type_variant_leaf lst)] *) + (* ] *) + (* EQUAL PRIVATE constructor_declarations {(Ptype_variant _, Private, None)} *) + | Ptype_variant lst, Private, None -> + [ [ privateAtom + ; makeList + ~break:IfNeed + ~postSpace:true + ~inline:(true, true) + (self#type_variant_list lst) + ] + ] + (* EQUAL private_flag BAR constructor_declarations {(Ptype_variant + _, $2, None)} *) + | Ptype_variant lst, scope, None -> + [ privatize + scope + [ makeList + ~break:Always_rec + ~postSpace:true + ~inline:(true, true) + (self#type_variant_list lst) + ] + ] + (* EQUAL DOTDOT {(Ptype_open, Public, None)} *) + | Ptype_open, Public, None -> [ [ atom ".." ] ] + | Ptype_open, Private, None -> [ [ privateAtom; atom ".." ] ] + (* Super confusing how record/variants' manifest is not actually the + description of the structure. What's in the manifest in that case + is the *second* EQUALS asignment. *) + (* EQUAL private_flag LBRACE label_declarations opt_comma RBRACE + {(Ptype_record _, $2, None)} *) + | Ptype_record lst, scope, None -> + let assumeRecordLoc = + { loc_start = estimateRecordOpenBracePoint () + ; loc_end = x.ptype_loc.loc_end + ; loc_ghost = false + } + in + [ privatize scope [ self#record_declaration ~assumeRecordLoc lst ] + ] + (* And now all of the forms involving *TWO* equals *) + (* Again, super confusing how manifests of variants/records + represent the structure after the second equals. *) + (* ================================================*) + + (* EQUAL core_type EQUAL private_flag opt_bar + constructor_declarations { (Ptype_variant _, _, Some _)} *) + | Ptype_variant lst, scope, Some mani -> + [ [ self#core_type mani ] + ; (let variant = + makeList + ~break:IfNeed + ~postSpace:true + ~inline:(true, true) + (self#type_variant_list lst) + in + privatize scope [ variant ]) + ] + (* EQUAL core_type EQUAL DOTDOT {(Ptype_open, Public, Some $2)} *) + | Ptype_open, Public, Some mani -> + [ [ self#core_type mani ]; [ atom ".." ] ] + (* EQUAL core_type EQUAL private_flag LBRACE label_declarations + opt_comma RBRACE {(Ptype_record _, $4, Some $2)} *) + | Ptype_record lst, scope, Some mani -> + let declaration = self#record_declaration lst in + let record = + match scope with + | Public -> [ declaration ] + | Private -> [ label ~space:true privateAtom declaration ] + in + [ [ self#core_type mani ]; record ] + (* Everything else is impossible *) + (* ================================================*) + | _, _, _ -> + raise (NotPossible "Encountered impossible type specification") in - [ [self#core_type mani]; record ] - (* Everything else is impossible *) - (* ================================================*) + let makeConstraint (ct1, ct2, _) = + let constraintEq = + makeList + ~postSpace:true + [ atom "constraint"; self#core_type ct1; atom "=" ] + in + label ~space:true constraintEq (self#core_type ct2) + in + let constraints = List.map makeConstraint x.ptype_cstrs in + equalInitiatedSegments, constraints - | (_, _, _ ) -> raise (NotPossible "Encountered impossible type specification") - in + (* "non-arrowed" means "a type where all arrows are inside at least one level of parens" + * + * z => z: not a "non-arrowed" type. + * (a, b): a "non-arrowed" type. + * (z=>z): a "non-arrowed" type because the arrows are guarded by parens. + * + * A "non arrowed, non simple" type would be one that is not-arrowed, and also + * not "simple". Simple means it is "clearly one unit" like (a, b), identifier, + * "hello", None. + *) + method non_arrowed_non_simple_core_type x = + let { Reason_attributes.stdAttrs } = + Reason_attributes.partitionAttributes x.ptyp_attributes + in + if stdAttrs != [] + then + formatAttributed + (self#non_arrowed_simple_core_type + { x with ptyp_attributes = [] }) + (self#attributes stdAttrs) + else + match x.ptyp_desc with + (* This significantly differs from the standard OCaml + printer/parser: Type constructors are no longer simple *) + | _ -> self#non_arrowed_simple_core_type x + + method type_param_list_element = + function + | { ptyp_attributes = []; ptyp_desc = Ptyp_package (lid, cstrs) } -> + self#typ_package ~mod_prefix:true lid cstrs + | t -> self#core_type t + + method non_arrowed_simple_core_type x = + let { Reason_attributes.stdAttrs } = + Reason_attributes.partitionAttributes x.ptyp_attributes + in + if stdAttrs != [] + then + formatSimpleAttributed + (self#non_arrowed_simple_core_type + { x with ptyp_attributes = [] }) + (self#attributes stdAttrs) + else + let result = + match x.ptyp_desc with + (* LPAREN core_type_comma_list RPAREN %prec below_NEWDOT *) + (* { match $2 with *) + (* | [] -> raise Parse_error *) + (* | one::[] -> one *) + (* | moreThanOne -> mktyp(Ptyp_tuple(List.rev moreThanOne)) } *) + | Ptyp_tuple l -> + makeTup (List.map self#type_param_list_element l) + | Ptyp_object (l, o) -> self#unparseObject l o + | Ptyp_package (lid, cstrs) -> + self#typ_package ~protect:true ~mod_prefix:true lid cstrs + (* | QUOTE ident *) + (* { mktyp(Ptyp_var $2) } *) + | Ptyp_var s -> ensureSingleTokenSticksToLabel (self#tyvar s) + (* | UNDERSCORE *) + (* { mktyp(Ptyp_any) } *) + | Ptyp_any -> ensureSingleTokenSticksToLabel (atom "_") + (* | type_longident *) + (* { mktyp(Ptyp_constr(mkrhs $1 1, [])) } *) + | Ptyp_constr (li, []) -> + (* [ensureSingleTokenSticksToLabel] loses location information + which is important when you are embedded inside a list and + comments are to be interleaved around you. Therefore, we wrap + the result in the correct [SourceMap]. *) + source_map + ~loc:li.loc + (ensureSingleTokenSticksToLabel (self#longident_loc li)) + | Ptyp_constr (li, l) -> + (match l with + | [ { ptyp_desc = Ptyp_object ((_ :: _ as l), o) } ] + when isJsDotTLongIdent li.txt -> + (* should have one or more rows, Js.t({..}) should print as Js.t({..}) + * {..} has a totally different meaning than Js.t({..}) *) + self#unparseObject ~withStringKeys:true l o + | [ { ptyp_desc = Ptyp_object (l, o) } ] + when not (isJsDotTLongIdent li.txt) -> + label + (self#longident_loc li) + (self#unparseObject ~wrap:("(", ")") l o) + | [ { ptyp_desc = + Ptyp_constr + ( lii + , [ { ptyp_desc = Ptyp_object ((_ :: _ as ll), o) } ] + ) + } + ] + when isJsDotTLongIdent lii.txt -> + label + (self#longident_loc li) + (self#unparseObject + ~withStringKeys:true + ~wrap:("(", ")") + ll + o) + | _ -> + (* small guidance: in `type foo = bar`, we're now at the `bar` + part *) + + (* The single identifier has to be wrapped in a + [ensureSingleTokenSticksToLabel] to avoid (@see + @avoidSingleTokenWrapping): *) + label + (self#longident_loc li) + (makeTup (List.map self#type_param_list_element l))) + | Ptyp_variant (l, closed, low) -> + let pcd_attributes = x.ptyp_attributes in + let pcd_res = None in + let variant_helper i rf = + match rf.prf_desc with + | Rtag (label, opt_ampersand, ctl) -> + let pcd_args = Pcstr_tuple ctl in + let all_attrs = + List.concat [ pcd_attributes; rf.prf_attributes ] + in + self#type_variant_leaf + ~opt_ampersand + ~polymorphic:true + { pcd_name = label + ; pcd_args + ; pcd_res + ; pcd_loc = label.loc + ; pcd_attributes = all_attrs + ; pcd_vars = [] + } + | Rinherit ct -> + (* '| type' is required if the Rinherit is not the first + row_field in the list *) + if i = 0 + then self#core_type ct + else + makeList ~postSpace:true [ atom "|"; self#core_type ct ] + in + let designator, tl = + match closed, low with + | Closed, None -> "", [] + | Closed, Some tl -> "<", tl + | Open, _ -> ">", [] + in + let node_list = List.mapi variant_helper l in + let ll = List.map (fun t -> atom ("`" ^ t)) tl in + let tag_list = + makeList ~postSpace:true ~break:IfNeed (atom ">" :: ll) + in + let type_list = + if tl != [] then node_list @ [ tag_list ] else node_list + in + let break = + match type_list with + | _ :: _ :: _ -> Layout.Always_rec + | [] | _ :: [] -> IfNeed + in + makeList + ~wrap:("[" ^ designator, "]") + ~pad:(true, false) + ~postSpace:true + ~break + type_list + | Ptyp_class (li, []) -> + makeList [ atom "#"; self#longident_loc li ] + | Ptyp_class (li, l) -> + label + (makeList [ atom "#"; self#longident_loc li ]) + (makeTup (List.map self#core_type l)) + | Ptyp_extension e -> self#extension e + | Ptyp_arrow (_, _, _) | Ptyp_alias (_, _) | Ptyp_poly (_, _) -> + makeList ~wrap:("(", ")") ~break:IfNeed [ self#core_type x ] + in + source_map ~loc:x.ptyp_loc result + (* TODO: ensure that we have a form of desugaring that protects *) + (* when final argument of curried pattern is a type constraint: *) + (* | COLON non_arrowed_core_type EQUALGREATER expr { mkexp_constraint $4 + (Some $2, None) } *) + (* \----/ \--/ + * constraint coerce + * + * Creates a ghost expression: + * mkexp_constraint | Some t, None -> ghexp(Pexp_constraint(e, t)) + *) - let makeConstraint (ct1, ct2, _) = - let constraintEq = makeList ~postSpace:true [ - atom "constraint"; - self#core_type ct1; - atom "="; - ] in - label ~space:true constraintEq (self#core_type ct2) in - let constraints = List.map makeConstraint x.ptype_cstrs in - (equalInitiatedSegments, constraints) - - (* "non-arrowed" means "a type where all arrows are inside at least one level of parens" - - z => z: not a "non-arrowed" type. - (a, b): a "non-arrowed" type. - (z=>z): a "non-arrowed" type because the arrows are guarded by parens. - - A "non arrowed, non simple" type would be one that is not-arrowed, and also - not "simple". Simple means it is "clearly one unit" like (a, b), identifier, - "hello", None. - *) - method non_arrowed_non_simple_core_type x = - let {Reason_attributes.stdAttrs} = Reason_attributes.partitionAttributes x.ptyp_attributes in - if stdAttrs != [] then - formatAttributed - (self#non_arrowed_simple_core_type {x with ptyp_attributes=[]}) - (self#attributes stdAttrs) - else - match x.ptyp_desc with - (* This significantly differs from the standard OCaml printer/parser: - Type constructors are no longer simple *) - | _ -> self#non_arrowed_simple_core_type x - - method type_param_list_element = function - | {ptyp_attributes = []; ptyp_desc = Ptyp_package(lid,cstrs)} -> - self#typ_package ~mod_prefix:true lid cstrs - | t -> self#core_type t - - method non_arrowed_simple_core_type x = - let {Reason_attributes.stdAttrs} = Reason_attributes.partitionAttributes x.ptyp_attributes in - if stdAttrs != [] then - formatSimpleAttributed - (self#non_arrowed_simple_core_type {x with ptyp_attributes=[]}) - (self#attributes stdAttrs) - else - let result = - match x.ptyp_desc with - (* LPAREN core_type_comma_list RPAREN %prec below_NEWDOT *) - (* { match $2 with *) - (* | [] -> raise Parse_error *) - (* | one::[] -> one *) - (* | moreThanOne -> mktyp(Ptyp_tuple(List.rev moreThanOne)) } *) - | Ptyp_tuple l -> makeTup (List.map self#type_param_list_element l) - | Ptyp_object (l, o) -> self#unparseObject l o - | Ptyp_package (lid, cstrs) -> - self#typ_package ~protect:true ~mod_prefix:true lid cstrs - (* | QUOTE ident *) - (* { mktyp(Ptyp_var $2) } *) - | Ptyp_var s -> ensureSingleTokenSticksToLabel (self#tyvar s) - (* | UNDERSCORE *) - (* { mktyp(Ptyp_any) } *) - | Ptyp_any -> ensureSingleTokenSticksToLabel (atom "_") - (* | type_longident *) - (* { mktyp(Ptyp_constr(mkrhs $1 1, [])) } *) - | Ptyp_constr (li, []) -> - (* [ensureSingleTokenSticksToLabel] loses location information which is important - when you are embedded inside a list and comments are to be interleaved around you. - Therefore, we wrap the result in the correct [SourceMap]. *) - source_map ~loc:li.loc - (ensureSingleTokenSticksToLabel (self#longident_loc li)) - | Ptyp_constr (li, l) -> - (match l with - | [{ptyp_desc = Ptyp_object (_::_ as l, o) }] when isJsDotTLongIdent li.txt -> - (* should have one or more rows, Js.t({..}) should print as Js.t({..}) - * {..} has a totally different meaning than Js.t({..}) *) - self#unparseObject ~withStringKeys:true l o - | [{ptyp_desc = Ptyp_object (l, o) }] when not (isJsDotTLongIdent li.txt) -> - label (self#longident_loc li) - (self#unparseObject ~wrap:("(",")") l o) - | [{ptyp_desc = Ptyp_constr(lii, [{ ptyp_desc = Ptyp_object (_::_ as ll, o)}])}] - when isJsDotTLongIdent lii.txt -> - label (self#longident_loc li) - (self#unparseObject ~withStringKeys:true ~wrap:("(",")") ll o) - | _ -> - (* small guidance: in `type foo = bar`, we're now at the `bar` part *) + method pattern_list_split_cons acc = + function + | { ppat_desc = + Ppat_construct + ( { txt = Lident "::" } + , Some ([], { ppat_desc = Ppat_tuple [ pat1; pat2 ] }) ) + } -> + self#pattern_list_split_cons (pat1 :: acc) pat2 + | p -> List.rev acc, p - (* The single identifier has to be wrapped in a [ensureSingleTokenSticksToLabel] to - avoid (@see @avoidSingleTokenWrapping): *) - label - (self#longident_loc li) - (makeTup ( - List.map self#type_param_list_element l - )) - ) - | Ptyp_variant (l, closed, low) -> - let pcd_attributes = x.ptyp_attributes in - let pcd_res = None in - let variant_helper i rf = - match rf.prf_desc with - | Rtag (label, opt_ampersand, ctl) -> - let pcd_args = Pcstr_tuple ctl in - let all_attrs = List.concat [pcd_attributes; rf.prf_attributes] in - self#type_variant_leaf - ~opt_ampersand - ~polymorphic:true - {pcd_name = label; pcd_args; pcd_res; pcd_loc = label.loc; pcd_attributes = all_attrs; pcd_vars = []} - | Rinherit ct -> - (* '| type' is required if the Rinherit is not the first - row_field in the list - *) - if i = 0 then - self#core_type ct - else - makeList ~postSpace:true [atom "|"; self#core_type ct] in - let (designator, tl) = - match (closed,low) with - | (Closed,None) -> ("", []) - | (Closed,Some tl) -> ("<", tl) - | (Open,_) -> (">", []) in - let node_list = List.mapi variant_helper l in - let ll = (List.map (fun t -> atom ("`" ^ t)) tl) in - let tag_list = makeList ~postSpace:true ~break:IfNeed ((atom ">")::ll) in - let type_list = if tl != [] then node_list@[tag_list] else node_list in - let break = match type_list with - | _ :: _ :: _ -> Layout.Always_rec - | [] | _ :: [] -> IfNeed - in - makeList ~wrap:("[" ^ designator,"]") ~pad:(true, false) ~postSpace:true ~break type_list - | Ptyp_class (li, []) -> makeList [atom "#"; self#longident_loc li] - | Ptyp_class (li, l) -> - label - (makeList [atom "#"; self#longident_loc li]) - (makeTup (List.map self#core_type l)) - | Ptyp_extension e -> self#extension e - | Ptyp_arrow (_, _, _) - | Ptyp_alias (_, _) - | Ptyp_poly (_, _) -> - makeList ~wrap:("(",")") ~break:IfNeed [self#core_type x] - in - source_map ~loc:x.ptyp_loc result - (* TODO: ensure that we have a form of desugaring that protects *) - (* when final argument of curried pattern is a type constraint: *) - (* | COLON non_arrowed_core_type EQUALGREATER expr - { mkexp_constraint $4 (Some $2, None) } *) - (* \----/ \--/ - constraint coerce - - Creates a ghost expression: - mkexp_constraint | Some t, None -> ghexp(Pexp_constraint(e, t)) - *) - - method pattern_list_split_cons acc = function - | { - ppat_desc = Ppat_construct ( - { txt = Lident("::")}, - Some ([], {ppat_desc = Ppat_tuple ([pat1; pat2])}) - ) } -> - self#pattern_list_split_cons (pat1::acc) pat2 - | p -> (List.rev acc), p - - (* - * Adds parens to the right sub-tree when it is not a single node: - * - * A | B is formatted as A | B - * A | (B | C) is formatted as A | (B | C) - * - * Also, adds parens to both sub-trees when both of them - * are not a single node: - * (A | B) | (C | D) is formatted as A | B | (C | D) - * A | B | (C | D) is formatted as A | B | (C | D) - * (A | B) | C is formatted as A | B | C - * A | B | C is formatted as A | B | C - * - *) - method or_pattern p1 p2 = - let (p1_raw, p2_raw) = (self#pattern p1, self#pattern p2) in - let (left, right) = - match p2.ppat_desc with - | Ppat_or _ -> (p1_raw, formatPrecedence p2_raw) - | _ -> (p1_raw, p2_raw) - in - makeList - ~break:IfNeed - ~inline:(true, true) - ~sep:(Sep "|") - ~postSpace:true - ~preSpace:true - [left; right] - - (* - * Renders level 3 or simpler patterns: - * - * Simpler - * ^ ----------- - * | 1. [ ], { }, X.{ }, ident, (any-other-pattern-with-parens-around) - * | 2. F(args), lazy(foo), [@attr] 1-2 - * | 3. pat as alias, pat | pat - * | 4. 1-3 : typ - * v ------------ - * Complex - * - * Assumes visually rendered attributes have already been rendered. - *) - method pattern_at_least_as_simple_as_alias_or_or x = - let {Reason_attributes.arityAttrs=_; stdAttrs} = Reason_attributes.partitionAttributes x.ppat_attributes in - match stdAttrs, x.ppat_desc with - | [], Ppat_or (p1, p2) -> - self#or_pattern p1 p2 - | [], Ppat_alias (p, s) -> - let raw_pattern = (self#pattern p) in - let pattern_with_precedence = match p.ppat_desc with - | Ppat_or (p1, p2) -> formatPrecedence (self#or_pattern p1 p2) - | Ppat_constraint _ -> makeList ~wrap:("(", ")") [ raw_pattern ] - | _ -> raw_pattern - in - label ~space:true - (source_map ~loc:p.ppat_loc pattern_with_precedence) - (makeList ~postSpace:true [ - atom "as"; - (source_map ~loc:s.loc (protectIdentifier s.txt)) - ]) (* RA*) - | _ -> self#pattern_at_least_as_simple_as_application x - - (* Formats a pattern that is a least as "simple" as function application - * style syntax. Produces formatting that is as simple as either 1 or 2. - * - * Simpler - * ^ ----------- - * | 1. [ ], { }, X.{ }, ident, (any-other-pattern-with-parens-around) - * | 2. F(args), lazy(foo), [@attr] 1-2 - * | 3. pat as alias, pat | pat - * | 4. 1-3 : typ - * v ------------ - * Complex - * - * - * 1. and 2. do not need parens around them in order to apply attributes to - * them. 3. does need parens around it to apply attributes to the whole - * pattern. - * - * Assumes visually rendered attributes have already been rendered. - *) - method pattern_at_least_as_simple_as_application x = - (* TODOATTRIBUTES: Handle the stdAttrs here *) - let {Reason_attributes.stdAttrs; arityAttrs} = Reason_attributes.partitionAttributes x.ppat_attributes in - let formattedPattern = - match x.ppat_desc with - | Ppat_variant (l, Some p) -> - if arityAttrs != [] then - raise (NotPossible "Should never see embedded attributes on poly variant") - else - source_map ~loc:x.ppat_loc - (self#constructor_pattern (atom ("`" ^ l)) p - ~polyVariant:true ~arityIsClear:true) - | Ppat_lazy p -> label (atom "lazy") (formatPrecedence (self#simple_pattern p)) - | Ppat_construct (({txt} as li), po) when not (txt = Lident "::")-> (* FIXME The third field always false *) - let formattedConstruction = match po with - (* TODO: Check the explicit_arity field on the pattern/constructor - attributes to determine if should desugar to an *actual* tuple. *) - (* | Some ({ *) - (* ppat_desc=Ppat_tuple l; *) - (* ppat_attributes=[{txt="explicit_arity"; loc}] *) - (* }) -> *) - (* label ~space:true (self#longident_loc li) (makeSpacedBreakableInlineList (List.map self#simple_pattern l)) *) - | Some (_, pattern) -> + (* + * Adds parens to the right sub-tree when it is not a single node: + * + * A | B is formatted as A | B + * A | (B | C) is formatted as A | (B | C) + * + * Also, adds parens to both sub-trees when both of them + * are not a single node: + * (A | B) | (C | D) is formatted as A | B | (C | D) + * A | B | (C | D) is formatted as A | B | (C | D) + * (A | B) | C is formatted as A | B | C + * A | B | C is formatted as A | B | C + * + *) + method or_pattern p1 p2 = + let p1_raw, p2_raw = self#pattern p1, self#pattern p2 in + let left, right = + match p2.ppat_desc with + | Ppat_or _ -> p1_raw, formatPrecedence p2_raw + | _ -> p1_raw, p2_raw + in + makeList + ~break:IfNeed + ~inline:(true, true) + ~sep:(Sep "|") + ~postSpace:true + ~preSpace:true + [ left; right ] + + (* + * Renders level 3 or simpler patterns: + * + * Simpler + * ^ ----------- + * | 1. [ ], { }, X.{ }, ident, (any-other-pattern-with-parens-around) + * | 2. F(args), lazy(foo), [@attr] 1-2 + * | 3. pat as alias, pat | pat + * | 4. 1-3 : typ + * v ------------ + * Complex + * + * Assumes visually rendered attributes have already been rendered. + *) + method pattern_at_least_as_simple_as_alias_or_or x = + let { Reason_attributes.arityAttrs = _; stdAttrs } = + Reason_attributes.partitionAttributes x.ppat_attributes + in + match stdAttrs, x.ppat_desc with + | [], Ppat_or (p1, p2) -> self#or_pattern p1 p2 + | [], Ppat_alias (p, s) -> + let raw_pattern = self#pattern p in + let pattern_with_precedence = + match p.ppat_desc with + | Ppat_or (p1, p2) -> formatPrecedence (self#or_pattern p1 p2) + | Ppat_constraint _ -> makeList ~wrap:("(", ")") [ raw_pattern ] + | _ -> raw_pattern + in + label + ~space:true + (source_map ~loc:p.ppat_loc pattern_with_precedence) + (makeList + ~postSpace:true + [ atom "as"; source_map ~loc:s.loc (protectIdentifier s.txt) ]) + (* RA*) + | _ -> self#pattern_at_least_as_simple_as_application x + + (* Formats a pattern that is a least as "simple" as function application + * style syntax. Produces formatting that is as simple as either 1 or 2. + * + * Simpler + * ^ ----------- + * | 1. [ ], { }, X.{ }, ident, (any-other-pattern-with-parens-around) + * | 2. F(args), lazy(foo), [@attr] 1-2 + * | 3. pat as alias, pat | pat + * | 4. 1-3 : typ + * v ------------ + * Complex + * + * + * 1. and 2. do not need parens around them in order to apply attributes to + * them. 3. does need parens around it to apply attributes to the whole + * pattern. + * + * Assumes visually rendered attributes have already been rendered. + *) + method pattern_at_least_as_simple_as_application x = + (* TODOATTRIBUTES: Handle the stdAttrs here *) + let { Reason_attributes.stdAttrs; arityAttrs } = + Reason_attributes.partitionAttributes x.ppat_attributes + in + let formattedPattern = + match x.ppat_desc with + | Ppat_variant (l, Some p) -> + if arityAttrs != [] + then + raise + (NotPossible + "Should never see embedded attributes on poly variant") + else + source_map + ~loc:x.ppat_loc + (self#constructor_pattern + (atom ("`" ^ l)) + p + ~polyVariant:true + ~arityIsClear:true) + | Ppat_lazy p -> + label (atom "lazy") (formatPrecedence (self#simple_pattern p)) + | Ppat_construct (({ txt } as li), po) when not (txt = Lident "::") + -> + (* FIXME The third field always false *) + let formattedConstruction = + match po with + (* TODO: Check the explicit_arity field on the + pattern/constructor attributes to determine if should desugar + to an *actual* tuple. *) + (* | Some ({ *) + (* ppat_desc=Ppat_tuple l; *) + (* ppat_attributes=[{txt="explicit_arity"; loc}] *) + (* }) -> *) + (* label ~space:true (self#longident_loc li) + (makeSpacedBreakableInlineList (List.map self#simple_pattern + l)) *) + | Some (_, pattern) -> let arityIsClear = isArityClear arityAttrs in - self#constructor_pattern ~arityIsClear (self#longident_loc li) pattern - | None -> - self#longident_loc li + self#constructor_pattern + ~arityIsClear + (self#longident_loc li) + pattern + | None -> self#longident_loc li + in + source_map ~loc:x.ppat_loc formattedConstruction + | _ -> self#simple_pattern { x with ppat_attributes = arityAttrs } + in + if stdAttrs != [] + then formatAttributed formattedPattern (self#attributes stdAttrs) + else formattedPattern + + (* Format a pattern with no particular requirements of simplicity. For example when + * formatting a pattern *inside* one tuple position: + * | + * v + * let (x : int, foo) = .. + * + * + * Renders level 3 or simpler patterns: + * + * Simpler + * ^ ----------- + * | 1. [ ], { }, X.{ }, ident, (any-other-pattern-with-parens-around) + * | 2. F(args), lazy(foo), [@attr] 1-2 + * | 3. pat as alias, pat | pat + * | 4. 1-3 : typ + * v ------------ + * Complex + * + * Assumes visually rendered attributes have already been rendered. + *) + method pattern x = + let { Reason_attributes.arityAttrs = _; stdAttrs } = + Reason_attributes.partitionAttributes x.ppat_attributes + in + match stdAttrs, x.ppat_desc with + | [], Ppat_constraint (p, ct) -> + let pat, typ = + match p, ct with + | ( { ppat_desc = Ppat_unpack unpack } + , { ptyp_desc = Ptyp_package (lid, cstrs) } ) -> + let unpack = + match unpack.txt with None -> "_" | Some unpack -> unpack + in + ( makeList ~postSpace:true [ atom "module"; atom unpack ] + , self#typ_package ~mod_prefix:false lid cstrs ) + | _ -> + (* Have to call pattern_at_least_as_simple_as_alias_or_or because + * we don't want to allow *another* nested type annotation without + * first adding parens *) + ( self#pattern_at_least_as_simple_as_alias_or_or p + , self#core_type ct ) in - source_map ~loc:x.ppat_loc formattedConstruction - | _ -> self#simple_pattern {x with ppat_attributes=arityAttrs} - in - if stdAttrs != [] then - formatAttributed formattedPattern (self#attributes stdAttrs) - else formattedPattern - - (* Format a pattern with no particular requirements of simplicity. For example when - * formatting a pattern *inside* one tuple position: - * | - * v - * let (x : int, foo) = .. - * - * - * Renders level 3 or simpler patterns: - * - * Simpler - * ^ ----------- - * | 1. [ ], { }, X.{ }, ident, (any-other-pattern-with-parens-around) - * | 2. F(args), lazy(foo), [@attr] 1-2 - * | 3. pat as alias, pat | pat - * | 4. 1-3 : typ - * v ------------ - * Complex - * - * Assumes visually rendered attributes have already been rendered. - *) - method pattern x = - let {Reason_attributes.arityAttrs=_; stdAttrs} = Reason_attributes.partitionAttributes x.ppat_attributes in - match stdAttrs, x.ppat_desc with - | [], Ppat_constraint (p, ct) -> - let (pat, typ) = begin match (p, ct) with - | ( - {ppat_desc = Ppat_unpack(unpack)}, - {ptyp_desc = Ptyp_package (lid, cstrs)} - ) -> - let unpack = match unpack.txt with - | None -> "_" - | Some unpack -> unpack in - (makeList ~postSpace:true [atom "module"; atom unpack], - self#typ_package ~mod_prefix:false lid cstrs) + formatTypeConstraint pat typ + | _ -> self#pattern_at_least_as_simple_as_alias_or_or x + + method patternList ?(wrap = "", "") pat = + let pat_list, pat_last = self#pattern_list_split_cons [] pat in + let pat_list = List.map self#pattern pat_list in + match pat_last with + | { ppat_desc = Ppat_construct ({ txt = Lident "[]" }, _) } -> + (* [x,y,z] *) + let lwrap, rwrap = wrap in + makeList + pat_list + ~break:Layout.IfNeed + ~sep:commaTrail + ~postSpace:true + ~wrap:(lwrap ^ "[", "]" ^ rwrap) | _ -> - (* Have to call pattern_at_least_as_simple_as_alias_or_or because - * we don't want to allow *another* nested type annotation without - * first adding parens *) - (self#pattern_at_least_as_simple_as_alias_or_or p, self#core_type ct) - end in - formatTypeConstraint pat typ - | _ -> self#pattern_at_least_as_simple_as_alias_or_or x - - method patternList ?(wrap=("","")) pat = - let pat_list, pat_last = self#pattern_list_split_cons [] pat in - let pat_list = List.map self#pattern pat_list in - match pat_last with - | {ppat_desc = Ppat_construct ({txt=Lident "[]"},_)} -> (* [x,y,z] *) - let (lwrap, rwrap) = wrap in - makeList pat_list - ~break:Layout.IfNeed ~sep:commaTrail ~postSpace:true - ~wrap:(lwrap ^ "[", "]" ^ rwrap) - | _ -> (* x::y *) - makeES6List pat_list (self#pattern pat_last) ~wrap - - (* In some contexts the Ptyp_package needs to be protected by parens, or - * the `module` keyword needs to be added. - * Example: let f = (module Add: S.Z, x) => Add.add(x); - * It's clear that `S.Z` is a module because it constraints the - * `module Add` pattern. No need to add "module" before `S.Z`. - * - * Example2: - * type t = (module Console); - * In this case the "module" keyword needs to be printed to indicate - * usage of a first-class-module. - *) - method typ_package ?(protect=false) ?(mod_prefix=true) lid cstrs = - let packageIdent = - let packageIdent = self#longident_loc lid in - if mod_prefix then - makeList ~postSpace:true [atom "module"; packageIdent] - else packageIdent - in - let unwrapped_layout = match cstrs with - | [] -> packageIdent - | cstrs -> - label ~space:true - (makeList ~postSpace:true [packageIdent; atom "with"]) - (makeList - ~inline:(true, true) - ~break:IfNeed - ~sep:(Sep " and ") - (List.map (fun (s, ct) -> - label ~space:true + (* x::y *) + makeES6List pat_list (self#pattern pat_last) ~wrap + + (* In some contexts the Ptyp_package needs to be protected by parens, or + * the `module` keyword needs to be added. + * Example: let f = (module Add: S.Z, x) => Add.add(x); + * It's clear that `S.Z` is a module because it constraints the + * `module Add` pattern. No need to add "module" before `S.Z`. + * + * Example2: + * type t = (module Console); + * In this case the "module" keyword needs to be printed to indicate + * usage of a first-class-module. + *) + method typ_package ?(protect = false) ?(mod_prefix = true) lid cstrs = + let packageIdent = + let packageIdent = self#longident_loc lid in + if mod_prefix + then makeList ~postSpace:true [ atom "module"; packageIdent ] + else packageIdent + in + let unwrapped_layout = + match cstrs with + | [] -> packageIdent + | cstrs -> + label + ~space:true + (makeList ~postSpace:true [ packageIdent; atom "with" ]) (makeList - ~break:IfNeed ~postSpace:true - [atom "type"; self#longident_loc s; atom "="]) - (self#core_type ct) - ) cstrs)) - in - if protect then - makeList ~postSpace:true ~wrap:("(", ")") [unwrapped_layout ] - else unwrapped_layout - - method simple_pattern x = - let {Reason_attributes.arityAttrs; stdAttrs} = Reason_attributes.partitionAttributes x.ppat_attributes in - if stdAttrs != [] then - formatSimpleAttributed - (self#simple_pattern {x with ppat_attributes=arityAttrs}) - (self#attributes stdAttrs) - else - let itm = - match x.ppat_desc with - | Ppat_construct (({loc; txt=Lident ("()"|"[]" as x)}), _) -> - (* Patterns' locations might include a leading bar depending on the - * context it was parsed in. Therefore, we need to include further - * information about the contents of the pattern such as tokens etc, - * in order to get comments to be distributed correctly.*) - atom ~loc x - | Ppat_construct (({txt=Lident "::"}), _) -> - self#patternList x (* LIST PATTERN *) - | Ppat_construct (li, None) -> - source_map ~loc:x.ppat_loc (self#longident_loc li) - | Ppat_any -> atom "_" - | Ppat_var ({loc; txt = txt}) -> - (* - To prevent this: - - let oneArgShouldWrapToAlignWith - theFunctionNameBinding => theFunctionNameBinding; + ~inline:(true, true) + ~break:IfNeed + ~sep:(Sep " and ") + (List.map + (fun (s, ct) -> + label + ~space:true + (makeList + ~break:IfNeed + ~postSpace:true + [ atom "type"; self#longident_loc s; atom "=" ]) + (self#core_type ct)) + cstrs)) + in + if protect + then makeList ~postSpace:true ~wrap:("(", ")") [ unwrapped_layout ] + else unwrapped_layout - And instead do: + method simple_pattern x = + let { Reason_attributes.arityAttrs; stdAttrs } = + Reason_attributes.partitionAttributes x.ppat_attributes + in + if stdAttrs != [] + then + formatSimpleAttributed + (self#simple_pattern { x with ppat_attributes = arityAttrs }) + (self#attributes stdAttrs) + else + let itm = + match x.ppat_desc with + | Ppat_construct ({ loc; txt = Lident (("()" | "[]") as x) }, _) + -> + (* Patterns' locations might include a leading bar depending on the + * context it was parsed in. Therefore, we need to include further + * information about the contents of the pattern such as tokens etc, + * in order to get comments to be distributed correctly.*) + atom ~loc x + | Ppat_construct ({ txt = Lident "::" }, _) -> + self#patternList x (* LIST PATTERN *) + | Ppat_construct (li, None) -> + source_map ~loc:x.ppat_loc (self#longident_loc li) + | Ppat_any -> atom "_" + | Ppat_var { loc; txt } -> + (* + * To prevent this: + * + * let oneArgShouldWrapToAlignWith + * theFunctionNameBinding => theFunctionNameBinding; + * + * And instead do: + * + * let oneArgShouldWrapToAlignWith + * theFunctionNameBinding => theFunctionNameBinding; + * + * We have to do something to the non "listy" patterns. Non listy + * patterns don't indent the same amount as listy patterns when docked + * to a label. + * + * If wrapping the non-listy pattern in [ensureSingleTokenSticksToLabel] + * you'll get the following (even though it should wrap) + * + * let oneArgShouldWrapToAlignWith theFunctionNameBinding => theFunctionNameBinding; + *) + source_map ~loc (protectIdentifier txt) + | Ppat_array l -> self#patternArray l + | Ppat_unpack s -> + let s = match s.txt with None -> "_" | Some s -> s in + makeList + ~wrap:("(", ")") + ~break:IfNeed + ~postSpace:true + [ atom "module"; atom s ] + | Ppat_open (lid, pat) -> + (* let someFn Qualified.{ record } = ... *) + let needsParens = + match pat.ppat_desc with + | Ppat_exception _ -> true + | _ -> false + in + let pat = self#simple_pattern pat in + label + (label (self#longident_loc lid) (atom ".")) + (if needsParens then formatPrecedence pat else pat) + | Ppat_type li -> makeList [ atom "#"; self#longident_loc li ] + | Ppat_record (l, closed) -> self#patternRecord l closed + | Ppat_tuple l -> self#patternTuple l + | Ppat_constant c -> + let raw_literal, _ = + Reason_attributes.extract_raw_literal x.ppat_attributes + in + self#constant ?raw_literal c + | Ppat_interval (c1, c2) -> + makeList + ~postSpace:true + [ self#constant c1; atom ".."; self#constant c2 ] + | Ppat_variant (l, None) -> makeList [ atom "`"; atom l ] + | Ppat_constraint _ -> formatPrecedence (self#pattern x) + | Ppat_lazy p -> + formatPrecedence + (label + (atom "lazy") + (formatPrecedence (self#simple_pattern p))) + | Ppat_extension e -> self#extension e + | Ppat_exception p -> + (* + * An exception pattern with an alias should be wrapped in (...) + * The rules for what goes to the right of the exception are a little (too) nuanced. + * It accepts "non simple" parameters, except in the case of `as`. + * Here we consistently apply "simplification" to the exception argument. + * Example: + * | exception (Sys_error _ as exc) => raise exc + * parses correctly while + * | Sys_error _ as exc => raise exc + * results in incorrect parsing with type error otherwise. + *) + makeList + ~postSpace:true + [ atom "exception"; self#simple_pattern p ] + | _ -> formatPrecedence (self#pattern x) + (* May have a redundant sourcemap *) + in + source_map ~loc:x.ppat_loc itm + + method label_exp lbl opt pat = + let term = self#pattern pat in + let param = + match lbl with + | Nolabel -> term + | (Labelled lbl | Optional lbl) + when is_punned_labelled_pattern_no_attrs pat lbl -> + makeList [ atom namedArgSym; term ] + | Labelled lbl | Optional lbl -> + let lblLayout = + makeList + ~sep:(Sep " ") + ~break:Layout.Never + [ atom (namedArgSym ^ lbl); atom "as" ] + in + label lblLayout ~space:true term + in + match opt, lbl with + | None, Optional _ -> makeList [ param; atom "=?" ] + | None, _ -> param + | Some o, _ -> + makeList + [ param; atom "="; self#unparseProtectedExpr ~forceParens:true o ] - let oneArgShouldWrapToAlignWith - theFunctionNameBinding => theFunctionNameBinding; + method access op cls e1 e2 = + makeList + [ (* Important that this be not breaking - at least to preserve same + behavior as stock desugarer. It might even be required (double + check in parser.mly) *) + e1 + ; atom op + ; e2 + ; atom cls + ] - We have to do something to the non "listy" patterns. Non listy - patterns don't indent the same amount as listy patterns when docked - to a label. + method simple_get_application x = + let { Reason_attributes.stdAttrs; jsxAttrs } = + Reason_attributes.partitionAttributes x.pexp_attributes + in + match x.pexp_desc, stdAttrs, jsxAttrs with + | _, _ :: _, [] -> None (* Has some printed attributes - not simple *) + | Pexp_apply ({ pexp_desc = Pexp_ident loc }, l), [], _jsx :: _ -> + (* TODO: Soon, we will allow the final argument to be an identifier + which represents the entire list. This would be written as + `...list`. If you imagine there being an implicit [] + inside the tag, then it would be consistent with array spread: + [...list] evaluates to the thing as list. *) + let hasLabelledChildrenLiteral = + List.exists + (function Labelled "children", _ -> true | _ -> false) + l + in + let rec hasSingleNonLabelledUnitAndIsAtTheEnd l = + match l with + | [] -> false + | ( Nolabel + , { pexp_desc = Pexp_construct ({ txt = Lident "()" }, _) } ) + :: [] -> + true + | (Nolabel, _) :: _ -> false + | _ :: rest -> hasSingleNonLabelledUnitAndIsAtTheEnd rest + in + if hasLabelledChildrenLiteral + && hasSingleNonLabelledUnitAndIsAtTheEnd l + then + match loc.txt with + | Ldot (moduleLid, "createElement") -> + Some + (self#formatJSXComponent + (String.concat "." (Longident.flatten_exn moduleLid)) + l) + | lid -> + Some + (self#formatJSXComponent + (String.concat "." (Longident.flatten_exn lid)) + l) + else None + | ( Pexp_apply + ( { pexp_desc = + Pexp_letmodule + ( _ + , ({ pmod_desc = Pmod_apply _ } as app) + , { pexp_desc = Pexp_ident loc } ) + } + , l ) + , [] + , _jsx :: _ ) -> + (* TODO: Soon, we will allow the final argument to be an identifier + which represents the entire list. This would be written as + `...list`. If you imagine there being an implicit [] + inside the tag, then it would be consistent with array spread: + [...list] evaluates to the thing as list. *) + let rec extract_apps args = function + | { pmod_desc = Pmod_apply (m1, { pmod_desc = Pmod_ident loc }) } + -> + let arg = String.concat "." (Longident.flatten_exn loc.txt) in + extract_apps (arg :: args) m1 + | { pmod_desc = Pmod_ident loc } -> + String.concat "." (Longident.flatten_exn loc.txt) :: args + | _ -> + failwith + "Functors in JSX tags support only module names as parameters" + in + let hasLabelledChildrenLiteral = + List.exists + (function Labelled "children", _ -> true | _ -> false) + l + in + let rec hasSingleNonLabelledUnitAndIsAtTheEnd l = + match l with + | [] -> false + | ( Nolabel + , { pexp_desc = Pexp_construct ({ txt = Lident "()" }, _) } ) + :: [] -> + true + | (Nolabel, _) :: _ -> false + | _ :: rest -> hasSingleNonLabelledUnitAndIsAtTheEnd rest + in + if hasLabelledChildrenLiteral + && hasSingleNonLabelledUnitAndIsAtTheEnd l + then + match Longident.flatten_exn loc.txt with + | [] | [ _ ] -> + Some (self#formatJSXComponent (Longident.last_exn loc.txt) l) + | _ -> + if Longident.last_exn loc.txt = "createElement" + then + match extract_apps [] app with + | ftor :: args -> + let applied = ftor ^ "(" ^ String.concat ", " args ^ ")" in + Some + (self#formatJSXComponent + ~closeComponentName:ftor + applied + l) + | _ -> None + else None + else None + | _ -> None - If wrapping the non-listy pattern in [ensureSingleTokenSticksToLabel] - you'll get the following (even though it should wrap) + method sugar_set_expr_parts e = + if e.pexp_attributes != [] + then None (* should also check attributes underneath *) + else + match e.pexp_desc with + | Pexp_apply + ( { pexp_desc = Pexp_ident { txt = Ldot (Lident "Array", "set") } + } + , [ (_, e1); (_, e2); (_, e3) ] ) -> + let prec = Custom "prec_lbracket" in + let lhs = + self#unparseResolvedRule + (self#ensureExpression ~reducesOnToken:prec e1) + in + Some (self#access "[" "]" lhs (self#unparseExpr e2), e3) + | Pexp_apply + ( { pexp_desc = + Pexp_ident { txt = Ldot (Lident "String", "set") } + } + , [ (_, e1); (_, e2); (_, e3) ] ) -> + let prec = Custom "prec_lbracket" in + let lhs = + self#unparseResolvedRule + (self#ensureExpression ~reducesOnToken:prec e1) + in + Some (self#access ".[" "]" lhs (self#unparseExpr e2), e3) + | Pexp_apply + ( { pexp_desc = + Pexp_ident + { txt = Ldot (Ldot (Lident "Bigarray", array), "set") } + } + , label_exprs ) -> + (match array with + | "Genarray" -> + (match label_exprs with + | [ (_, a); (_, { pexp_desc = Pexp_array ls }); (_, c) ] -> + let formattedList = List.map self#unparseExpr ls in + let lhs = + makeList + [ self#simple_enough_to_be_lhs_dot_send a; atom "." ] + in + let rhs = + makeList + ~break:IfNeed + ~postSpace:true + ~sep:commaSep + ~wrap:("{", "}") + formattedList + in + Some (label lhs rhs, c) + | _ -> None) + | "Array1" | "Array2" | "Array3" -> + (match label_exprs with + | (_, a) :: rest -> + (match List.rev rest with + | (_, v) :: rest -> + let args = List.map snd (List.rev rest) in + let formattedList = List.map self#unparseExpr args in + let lhs = + makeList + [ self#simple_enough_to_be_lhs_dot_send a; atom "." ] + in + let rhs = + makeList + ~break:IfNeed + ~postSpace:true + ~sep:commaSep + ~wrap:("{", "}") + formattedList + in + Some (label lhs rhs, v) + | _ -> assert false) + | _ -> assert false) + | _ -> None) + | _ -> None + (** Detects "sugar expressions" (sugar for array/string setters) and + returns their separate parts. *) - let oneArgShouldWrapToAlignWith theFunctionNameBinding => theFunctionNameBinding; + (* + * + * How would we know not to print the sequence without { }; protecting the let a? + * + * let a + * | + * sequence + * / \ + * let a print a + * alert a + * let res = { + * let a = something(); + * { \ + * alert(a); | portion to be parsed as a sequence() + * let a = 20; | The final ; print(a) causes the entire + * alert(a); | portion to be parsed as a sequence() + * }; | + * print (a); / + * } + * + * ****************************************************************** + * Any time the First expression of a sequence is another sequence, or (as in + * this case) a let, wrapping the first sequence expression in { } is + * required. + * ****************************************************************** + *) - *) - source_map ~loc (protectIdentifier txt) - | Ppat_array l -> - self#patternArray l - | Ppat_unpack s -> - let s = match s.txt with | None -> "_" | Some s -> s in - makeList ~wrap:("(", ")") ~break:IfNeed ~postSpace:true [atom "module"; atom s] - | Ppat_open (lid, pat) -> - (* let someFn Qualified.{ record } = ... *) - let needsParens = match pat.ppat_desc with - | Ppat_exception _ -> true - | _ -> false + (** TODO: Configure the optional ability to print the *minimum* number + of parens. It's simply a matter of changing [higherPrecedenceThan] + to [higherOrEqualPrecedenceThan]. *) + + (* The point of the function is to ensure that + ~reducesAfterRight:rightExpr will reduce at the proper time when it + is reparsed, possibly wrapping it in parenthesis if needed. It + ensures a rule doesn't reduce until *after* `reducesAfterRight` gets + a chance to reduce. Example: The addition rule which has precedence + of rightmost token "+", in `x + a * b` should not reduce until after + the a * b gets a chance to reduce. This function would determine the + minimum parens to ensure that. *) + method ensureContainingRule ~withPrecedence ~reducesAfterRight () = + match self#unparseExprRecurse reducesAfterRight with + | SpecificInfixPrecedence ({ shiftPrecedence }, rightRecurse) -> + if higherPrecedenceThan shiftPrecedence withPrecedence + then rightRecurse + else if higherPrecedenceThan withPrecedence shiftPrecedence + then + LayoutNode + (formatPrecedence + ~loc:reducesAfterRight.pexp_loc + (self#unparseResolvedRule rightRecurse)) + else if isRightAssociative ~prec:withPrecedence + then rightRecurse + else + LayoutNode + (formatPrecedence + ~loc:reducesAfterRight.pexp_loc + (self#unparseResolvedRule rightRecurse)) + | FunctionApplication itms -> + let funApplExpr = + formatAttachmentApplication + applicationFinalWrapping + None + (itms, Some reducesAfterRight.pexp_loc) in - let pat = self#simple_pattern pat in - label - (label (self#longident_loc lid) (atom ("."))) - (if needsParens then formatPrecedence pat else pat) - | Ppat_type li -> - makeList [atom "#"; self#longident_loc li] - | Ppat_record (l, closed) -> - self#patternRecord l closed - | Ppat_tuple l -> - self#patternTuple l - | Ppat_constant c -> - let raw_literal, _ = Reason_attributes.extract_raw_literal x.ppat_attributes in - (self#constant ?raw_literal c) - | Ppat_interval (c1, c2) -> - makeList ~postSpace:true [self#constant c1; atom ".."; self#constant c2] - | Ppat_variant (l, None) -> makeList[atom "`"; atom l] - | Ppat_constraint _ -> - formatPrecedence (self#pattern x) - | Ppat_lazy p -> - formatPrecedence (label (atom "lazy") (formatPrecedence (self#simple_pattern p))) - | Ppat_extension e -> self#extension e - | Ppat_exception p -> - (* - An exception pattern with an alias should be wrapped in (...) - The rules for what goes to the right of the exception are a little (too) nuanced. - It accepts "non simple" parameters, except in the case of `as`. - Here we consistently apply "simplification" to the exception argument. - Example: - | exception (Sys_error _ as exc) => raise exc - parses correctly while - | Sys_error _ as exc => raise exc - results in incorrect parsing with type error otherwise. - *) - (makeList ~postSpace:true [atom "exception"; self#simple_pattern p]) - | _ -> formatPrecedence (self#pattern x) (* May have a redundant sourcemap *) - in - source_map ~loc:x.ppat_loc itm - - method label_exp lbl opt pat = - let term = self#pattern pat in - let param = match lbl with - | Nolabel -> term - | Labelled lbl | Optional lbl when is_punned_labelled_pattern_no_attrs pat lbl -> - makeList [atom namedArgSym; term] - | Labelled lbl | Optional lbl -> - let lblLayout= - makeList ~sep:(Sep " ") ~break:Layout.Never - [atom (namedArgSym ^ lbl); atom "as"] - in - label lblLayout ~space:true term - in - match opt, lbl with - | None, Optional _ -> makeList [param; atom "=?"] - | None, _ -> param - | Some o, _ -> makeList [param; atom "="; (self#unparseProtectedExpr ~forceParens:true o)] - - method access op cls e1 e2 = makeList [ - (* Important that this be not breaking - at least to preserve same - behavior as stock desugarer. It might even be required (double check - in parser.mly) *) - e1; - atom op; - e2; - atom cls; - ] + (* Little hack: need to print parens for the `bar` application in + e.g. `foo->other##(bar(baz))` or `foo->other->(bar(baz))`. *) + if higherPrecedenceThan withPrecedence (Custom "prec_functionAppl") + then + LayoutNode + (formatPrecedence ~loc:reducesAfterRight.pexp_loc funApplExpr) + else LayoutNode funApplExpr + | PotentiallyLowPrecedence itm -> + LayoutNode (formatPrecedence ~loc:reducesAfterRight.pexp_loc itm) + | Simple itm -> LayoutNode itm + + method ensureExpression ~reducesOnToken expr = + match self#unparseExprRecurse expr with + | SpecificInfixPrecedence ({ reducePrecedence }, leftRecurse) -> + if higherPrecedenceThan reducePrecedence reducesOnToken + then leftRecurse + else if higherPrecedenceThan reducesOnToken reducePrecedence + then + LayoutNode + (formatPrecedence + ~loc:expr.pexp_loc + (self#unparseResolvedRule leftRecurse)) + else if isLeftAssociative ~prec:reducesOnToken + then leftRecurse + else + LayoutNode + (formatPrecedence + ~loc:expr.pexp_loc + (self#unparseResolvedRule leftRecurse)) + | FunctionApplication itms -> + LayoutNode + (formatAttachmentApplication + applicationFinalWrapping + None + (itms, Some expr.pexp_loc)) + | PotentiallyLowPrecedence itm -> + LayoutNode (formatPrecedence ~loc:expr.pexp_loc itm) + | Simple itm -> LayoutNode itm + + method unparseExpr x = + match self#unparseExprRecurse x with + | SpecificInfixPrecedence (_, resolvedRule) -> + self#unparseResolvedRule resolvedRule + | FunctionApplication itms -> + formatAttachmentApplication + applicationFinalWrapping + None + (itms, Some x.pexp_loc) + | PotentiallyLowPrecedence itm -> itm + | Simple itm -> itm + (** Attempts to unparse: The beginning of a more general printing + algorithm, that determines how to print based on precedence of + tokens and rules. The end goal is that this should be completely + auto-generated from the Menhir parsing tables. We could move more + and more into this function. + + You could always just call self#expression, but `unparseExpr` will + render infix/prefix/unary/terary fixities in their beautiful forms + while minimizing parenthesis. *) + + (* This method may not even be needed *) + method unparseUnattributedExpr x = + match Reason_attributes.partitionAttributes x.pexp_attributes with + | { docAttrs = []; stdAttrs = [] } -> self#unparseExpr x + | _ -> makeList ~wrap:("(", ")") [ self#unparseExpr x ] + + (* ensureExpr ensures that the expression is wrapped in parens + * e.g. is necessary in cases like: + * let display = (:message=("hello": string)) => 1; + * but not in cases like: + * let f = (a: bool) => 1; + * TODO: in the future we should probably use the type ruleCategory + * to 'automatically' ensure the validity of a constraint expr with parens... + *) + method unparseProtectedExpr ?(forceParens = false) e = + let itm = + match e with + | { pexp_attributes = []; pexp_desc = Pexp_constraint (x, ct) } -> + let x = self#unparseExpr x in + let children = + [ x; label ~space:true (atom ":") (self#core_type ct) ] + in + if forceParens + then makeList ~wrap:("(", ")") children + else makeList children + | { pexp_attributes; pexp_desc = Pexp_constant c } -> + (* When we have Some(-1) or someFunction(-1, -2), the arguments -1 and -2 + * pass through this case. In this context they don't need to be wrapped in extra parens + * Some((-1)) should be printed as Some(-1). This is in contrast with + * 1 + (-1) where we print the parens for readability. *) + let raw_literal, pexp_attributes = + Reason_attributes.extract_raw_literal pexp_attributes + in + let constant = self#constant ?raw_literal ~parens:forceParens c in + (match pexp_attributes with + | [] -> constant + | attrs -> + let formattedAttrs = + makeSpacedBreakableInlineList + (List.map self#item_attribute attrs) + in + makeSpacedBreakableInlineList [ formattedAttrs; constant ]) + | { pexp_desc = Pexp_fun _ } -> self#formatPexpFun e + | x -> self#unparseExpr x + in + source_map ~loc:e.pexp_loc itm + + method simplifyUnparseExpr + ?(inline = false) + ?(even_wrap_simple = false) + ?(wrap = "(", ")") + x = + match self#unparseExprRecurse x, even_wrap_simple with + | SpecificInfixPrecedence (_, itm), _ -> + formatPrecedence + ~inline + ~wrap + ~loc:x.pexp_loc + (self#unparseResolvedRule itm) + | FunctionApplication itms, _ -> + formatPrecedence + ~inline + ~wrap + ~loc:x.pexp_loc + (formatAttachmentApplication + applicationFinalWrapping + None + (itms, Some x.pexp_loc)) + | PotentiallyLowPrecedence itm, _ | Simple itm, true -> + formatPrecedence ~inline ~wrap ~loc:x.pexp_loc itm + | Simple itm, false -> itm + + method unparseResolvedRule = + function + | LayoutNode layoutNode -> layoutNode + | InfixTree _ as infixTree -> + formatComputedInfixChain (computeInfixChain infixTree) + + method unparseExprApplicationItems x = + match self#unparseExprRecurse x with + | SpecificInfixPrecedence (_, wrappedRule) -> + let itm = self#unparseResolvedRule wrappedRule in + [ itm ], Some x.pexp_loc + | FunctionApplication itms -> itms, Some x.pexp_loc + | PotentiallyLowPrecedence itm -> [ itm ], Some x.pexp_loc + | Simple itm -> [ itm ], Some x.pexp_loc + + (* Provides beautiful printing for pipe first sugar: + * foo + * ->f(a, b) + * ->g(c, d) + *) + method formatPipeFirst e = + let module PipeFirstTree = struct + type exp = Parsetree.expression + type flatNode = + | Exp of exp + | ExpU of exp (* uncurried *) + | Args of (Asttypes.arg_label * exp) list - method simple_get_application x = - let {Reason_attributes.stdAttrs; jsxAttrs} = Reason_attributes.partitionAttributes x.pexp_attributes in - match (x.pexp_desc, stdAttrs, jsxAttrs) with - | (_, _::_, []) -> None (* Has some printed attributes - not simple *) - | (Pexp_apply ({pexp_desc=Pexp_ident loc}, l), [], _jsx::_) -> ( - (* TODO: Soon, we will allow the final argument to be an identifier which - represents the entire list. This would be written as - `...list`. If you imagine there being an implicit [] inside - the tag, then it would be consistent with array spread: - [...list] evaluates to the thing as list. - *) - let hasLabelledChildrenLiteral = List.exists (function - | (Labelled "children", _) -> true - | _ -> false - ) l in - let rec hasSingleNonLabelledUnitAndIsAtTheEnd l = match l with - | [] -> false - | (Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}) :: [] -> true - | (Nolabel, _) :: _ -> false - | _ :: rest -> hasSingleNonLabelledUnitAndIsAtTheEnd rest - in - if hasLabelledChildrenLiteral && hasSingleNonLabelledUnitAndIsAtTheEnd l then - match loc.txt with - | Ldot (moduleLid, "createElement") -> - Some (self#formatJSXComponent - (String.concat "." (Longident.flatten_exn moduleLid)) l) - | lid -> - Some (self#formatJSXComponent - (String.concat "." (Longident.flatten_exn lid)) l) - else None - ) - | (Pexp_apply ( - {pexp_desc= - Pexp_letmodule(_, - ({pmod_desc=Pmod_apply _} as app), - {pexp_desc=Pexp_ident loc} - )}, l), [], _jsx::_) -> ( - (* TODO: Soon, we will allow the final argument to be an identifier which - represents the entire list. This would be written as - `...list`. If you imagine there being an implicit [] inside - the tag, then it would be consistent with array spread: - [...list] evaluates to the thing as list. - *) - let rec extract_apps args = function - | { pmod_desc = Pmod_apply (m1, {pmod_desc=Pmod_ident loc}) } -> - let arg = String.concat "." (Longident.flatten_exn loc.txt) in - extract_apps (arg :: args) m1 - | { pmod_desc=Pmod_ident loc } -> (String.concat "." (Longident.flatten_exn loc.txt))::args - | _ -> failwith "Functors in JSX tags support only module names as parameters" in - let hasLabelledChildrenLiteral = List.exists (function - | (Labelled "children", _) -> true - | _ -> false - ) l in - let rec hasSingleNonLabelledUnitAndIsAtTheEnd l = match l with - | [] -> false - | (Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}) :: [] -> true - | (Nolabel, _) :: _ -> false - | _ :: rest -> hasSingleNonLabelledUnitAndIsAtTheEnd rest - in - if hasLabelledChildrenLiteral && hasSingleNonLabelledUnitAndIsAtTheEnd l then - match Longident.flatten_exn loc.txt with - | [] | [ _ ] -> - Some (self#formatJSXComponent (Longident.last_exn loc.txt) l) - | _ -> - if Longident.last_exn loc.txt = "createElement" then - begin match extract_apps [] app with - | ftor::args -> - let applied = ftor ^ "(" ^ String.concat ", " args ^ ")" in - Some (self#formatJSXComponent ~closeComponentName:ftor applied l) - | _ -> None - end - else None - else None - ) - | _ -> None + type flatT = flatNode list + + type node = + { exp : exp + ; args : (Asttypes.arg_label * exp) list + ; uncurried : bool + } + + type t = node list - (** Detects "sugar expressions" (sugar for array/string setters) and returns their separate - parts. *) - method sugar_set_expr_parts e = - if e.pexp_attributes != [] then None - (* should also check attributes underneath *) - else match e.pexp_desc with - | Pexp_apply ({pexp_desc=Pexp_ident{txt=Ldot (Lident ("Array"), "set")}}, [(_,e1);(_,e2);(_,e3)]) -> - let prec = Custom "prec_lbracket" in - let lhs = self#unparseResolvedRule ( - self#ensureExpression ~reducesOnToken:prec e1 - ) in - Some (self#access "[" "]" lhs (self#unparseExpr e2), e3) - | Pexp_apply ({pexp_desc=Pexp_ident {txt=Ldot (Lident "String", "set")}}, [(_,e1);(_,e2);(_,e3)]) -> - let prec = Custom "prec_lbracket" in - let lhs = self#unparseResolvedRule ( - self#ensureExpression ~reducesOnToken:prec e1 - ) in - Some ((self#access ".[" "]" lhs (self#unparseExpr e2)), e3) - | Pexp_apply ( - {pexp_desc=Pexp_ident {txt = Ldot (Ldot (Lident "Bigarray", array), "set")}}, - label_exprs - ) -> ( - match array with - | "Genarray" -> ( - match label_exprs with - | [(_,a);(_,{pexp_desc=Pexp_array ls});(_,c)] -> - let formattedList = List.map self#unparseExpr ls in - let lhs = makeList [self#simple_enough_to_be_lhs_dot_send a; atom "."] in - let rhs = makeList ~break:IfNeed ~postSpace:true ~sep:commaSep ~wrap:("{", "}") formattedList + let formatNode ?prefix ?(first = false) { exp; args; uncurried } = + let formatLayout expr = + let formatted = + if first + then + self#ensureExpression + ~reducesOnToken:(Token pipeFirstToken) + expr + else + match expr with + (* a->foo(x, _) and a->(foo(x, _)) are equivalent under pipe first + * (a->foo)(x, _) is unnatural and desugars to + * (__x) => (a |. foo)(x, __x) + * Under `->`, it makes more sense to desugar into + * a |. (__x => foo(x, __x)) + * + * Hence we don't need parens in this case. + *) + | expr when Reason_heuristics.isUnderscoreApplication expr + -> + LayoutNode (self#unparseExpr expr) + | _ -> + self#ensureContainingRule + ~withPrecedence:(Token pipeFirstToken) + ~reducesAfterRight:expr + () + in + self#unparseResolvedRule formatted in - Some (label lhs rhs, c) - | _ -> None - ) - | ("Array1"|"Array2"|"Array3") -> ( - match label_exprs with - | (_,a)::rest -> ( - match List.rev rest with - | (_,v)::rest -> - let args = List.map snd (List.rev rest) in - let formattedList = List.map self#unparseExpr args in - let lhs = makeList [self#simple_enough_to_be_lhs_dot_send a; atom "."] in - let rhs = makeList ~break:IfNeed ~postSpace:true ~sep:commaSep ~wrap:("{", "}") formattedList in - Some (label lhs rhs, v) - | _ -> assert false - ) - | _ -> assert false - ) - | _ -> None - ) - | _ -> None - - (* - - How would we know not to print the sequence without { }; protecting the let a? - - let a - | - sequence - / \ - let a print a - alert a - let res = { - let a = something(); - { \ - alert(a); | portion to be parsed as a sequence() - let a = 20; | The final ; print(a) causes the entire - alert(a); | portion to be parsed as a sequence() - }; | - print (a); / - } - - ****************************************************************** - Any time the First expression of a sequence is another sequence, or (as in - this case) a let, wrapping the first sequence expression in { } is - required. - ****************************************************************** - *) - - (** - TODO: Configure the optional ability to print the *minimum* number of - parens. It's simply a matter of changing [higherPrecedenceThan] to - [higherOrEqualPrecedenceThan]. - *) - - (* The point of the function is to ensure that ~reducesAfterRight:rightExpr will reduce - at the proper time when it is reparsed, possibly wrapping it - in parenthesis if needed. It ensures a rule doesn't reduce - until *after* `reducesAfterRight` gets a chance to reduce. - Example: The addition rule which has precedence of rightmost - token "+", in `x + a * b` should not reduce until after the a * b gets - a chance to reduce. This function would determine the minimum parens to - ensure that. *) - method ensureContainingRule ~withPrecedence ~reducesAfterRight () = - match self#unparseExprRecurse reducesAfterRight with - | SpecificInfixPrecedence ({shiftPrecedence}, rightRecurse) -> - if higherPrecedenceThan shiftPrecedence withPrecedence then rightRecurse - else if (higherPrecedenceThan withPrecedence shiftPrecedence) then - LayoutNode (formatPrecedence ~loc:reducesAfterRight.pexp_loc (self#unparseResolvedRule rightRecurse)) - else ( - if isRightAssociative ~prec:withPrecedence then - rightRecurse - else - LayoutNode (formatPrecedence ~loc:reducesAfterRight.pexp_loc (self#unparseResolvedRule rightRecurse)) - ) - | FunctionApplication itms -> - let funApplExpr = formatAttachmentApplication applicationFinalWrapping None (itms, Some reducesAfterRight.pexp_loc) - in - (* Little hack: need to print parens for the `bar` application in e.g. - `foo->other##(bar(baz))` or `foo->other->(bar(baz))`. *) - if higherPrecedenceThan withPrecedence (Custom "prec_functionAppl") - then LayoutNode (formatPrecedence ~loc:reducesAfterRight.pexp_loc funApplExpr) - else LayoutNode funApplExpr - | PotentiallyLowPrecedence itm -> LayoutNode (formatPrecedence ~loc:reducesAfterRight.pexp_loc itm) - | Simple itm -> LayoutNode itm - - method ensureExpression ~reducesOnToken expr = - match self#unparseExprRecurse expr with - | SpecificInfixPrecedence ({reducePrecedence}, leftRecurse) -> - if higherPrecedenceThan reducePrecedence reducesOnToken then leftRecurse - else if higherPrecedenceThan reducesOnToken reducePrecedence then - LayoutNode (formatPrecedence ~loc:expr.pexp_loc (self#unparseResolvedRule leftRecurse)) - else ( - if isLeftAssociative ~prec:reducesOnToken then - leftRecurse - else - LayoutNode (formatPrecedence ~loc:expr.pexp_loc (self#unparseResolvedRule leftRecurse)) - ) - | FunctionApplication itms -> LayoutNode (formatAttachmentApplication applicationFinalWrapping None (itms, Some expr.pexp_loc)) - | PotentiallyLowPrecedence itm -> LayoutNode (formatPrecedence ~loc:expr.pexp_loc itm) - | Simple itm -> LayoutNode itm - - (** Attempts to unparse: The beginning of a more general printing algorithm, - that determines how to print based on precedence of tokens and rules. - The end goal is that this should be completely auto-generated from the - Menhir parsing tables. We could move more and more into this function. - - You could always just call self#expression, but `unparseExpr` will render - infix/prefix/unary/terary fixities in their beautiful forms while - minimizing parenthesis. - *) - method unparseExpr x = - match self#unparseExprRecurse x with - | SpecificInfixPrecedence (_, resolvedRule) -> - self#unparseResolvedRule resolvedRule - | FunctionApplication itms -> - formatAttachmentApplication applicationFinalWrapping None (itms, Some x.pexp_loc) - | PotentiallyLowPrecedence itm -> itm - | Simple itm -> itm - - (* This method may not even be needed *) - method unparseUnattributedExpr x = - match Reason_attributes.partitionAttributes x.pexp_attributes with - | {docAttrs = []; stdAttrs = []} -> self#unparseExpr x - | _ -> makeList ~wrap:("(",")") [self#unparseExpr x] - - (* ensureExpr ensures that the expression is wrapped in parens - * e.g. is necessary in cases like: - * let display = (:message=("hello": string)) => 1; - * but not in cases like: - * let f = (a: bool) => 1; - * TODO: in the future we should probably use the type ruleCategory - * to 'automatically' ensure the validity of a constraint expr with parens... - *) - method unparseProtectedExpr ?(forceParens=false) e = - let itm = - match e with - | { pexp_attributes = []; pexp_desc = Pexp_constraint (x, ct)} -> - let x = self#unparseExpr x in - let children = [x; label ~space:true (atom ":") (self#core_type ct)] in - if forceParens then - makeList ~wrap:("(", ")") children - else makeList children - | { pexp_attributes; pexp_desc = Pexp_constant c } -> - (* When we have Some(-1) or someFunction(-1, -2), the arguments -1 and -2 - * pass through this case. In this context they don't need to be wrapped in extra parens - * Some((-1)) should be printed as Some(-1). This is in contrast with - * 1 + (-1) where we print the parens for readability. *) - let raw_literal, pexp_attributes = - Reason_attributes.extract_raw_literal pexp_attributes - in - let constant = self#constant ?raw_literal ~parens:forceParens c in - begin match pexp_attributes with - | [] -> constant - | attrs -> - let formattedAttrs = makeSpacedBreakableInlineList (List.map self#item_attribute attrs) in - makeSpacedBreakableInlineList [formattedAttrs; constant] + let parens = + match exp.pexp_desc with + | Pexp_apply (e, _) -> + printedStringAndFixityExpr e = UnaryPostfix "^" + | _ -> false + in + let layout = + match args with + | [] -> + let e = formatLayout exp in + (match prefix with Some l -> makeList [ l; e ] | None -> e) + | args -> + let args = + List.map + (fun (label, arg) -> + label, self#process_underscore_application arg) + args + in + let fakeApplExp = + let loc_end = + match List.rev args with + | (_, e) :: _ -> e.pexp_loc.loc_end + | _ -> exp.pexp_loc.loc_end + in + { exp with pexp_loc = { exp.pexp_loc with loc_end } } + in + makeList + (self#formatFunAppl + ?prefix + ~jsxAttrs:[] + ~args + ~funExpr:exp + ~applicationExpr:fakeApplExp + ~uncurried + ()) + in + if parens then formatPrecedence layout else layout end - | {pexp_desc = Pexp_fun _ } -> self#formatPexpFun e - | x -> self#unparseExpr x - in - source_map ~loc:e.pexp_loc itm - - method simplifyUnparseExpr ?(inline=false) ?(even_wrap_simple=false) ?(wrap=("(", ")")) x = - match self#unparseExprRecurse x, even_wrap_simple with - | SpecificInfixPrecedence (_, itm), _ -> - formatPrecedence - ~inline - ~wrap - ~loc:x.pexp_loc - (self#unparseResolvedRule itm) - | FunctionApplication itms, _ -> - formatPrecedence - ~inline - ~wrap - ~loc:x.pexp_loc - (formatAttachmentApplication applicationFinalWrapping None (itms, Some x.pexp_loc)) - | PotentiallyLowPrecedence itm, _ - | Simple itm, true -> - formatPrecedence - ~inline - ~wrap - ~loc:x.pexp_loc - itm - | Simple itm, false -> itm - - - method unparseResolvedRule = function - | LayoutNode layoutNode -> layoutNode - | InfixTree _ as infixTree -> - formatComputedInfixChain (computeInfixChain infixTree) - - method unparseExprApplicationItems x = - match self#unparseExprRecurse x with - | SpecificInfixPrecedence (_, wrappedRule) -> - let itm = self#unparseResolvedRule wrappedRule in - ([itm], Some x.pexp_loc) - | FunctionApplication itms -> (itms, Some x.pexp_loc) - | PotentiallyLowPrecedence itm -> ([itm], Some x.pexp_loc) - | Simple itm -> ([itm], Some x.pexp_loc) - - - (* Provides beautiful printing for pipe first sugar: - * foo - * ->f(a, b) - * ->g(c, d) - *) - method formatPipeFirst e = - let module PipeFirstTree = struct - type exp = Parsetree.expression - - type flatNode = - | Exp of exp - | ExpU of exp (* uncurried *) - | Args of (Asttypes.arg_label * exp) list - type flatT = flatNode list - - type node = { - exp: exp; - args: (Asttypes.arg_label *exp) list; - uncurried: bool; - } - type t = node list - - let formatNode ?prefix ?(first=false) {exp; args; uncurried} = - let formatLayout expr = - let formatted = if first then - self#ensureExpression ~reducesOnToken:(Token pipeFirstToken) expr - else - match expr with - (* a->foo(x, _) and a->(foo(x, _)) are equivalent under pipe first - * (a->foo)(x, _) is unnatural and desugars to - * (__x) => (a |. foo)(x, __x) - * Under `->`, it makes more sense to desugar into - * a |. (__x => foo(x, __x)) + in + (* Imagine: foo->f(a, b)->g(c,d) + * The corresponding parsetree looks more like: + * (((foo->f)(a,b))->g)(c, d) + * The extra Pexp_apply nodes, e.g. (foo->f), result into a + * nested/recursive ast which is pretty inconvenient in terms of printing. + * For printing purposes we actually want something more like: + * foo->|f(a,b)|->|g(c, d)| + * in order to provide to following printing: + * foo + * ->f(a, b) + * ->g(c, d) + * The job of "flatten" is to turn the inconvenient, nested ast + * (((foo->f)(a,b))->g)(c, d) + * into + * [Exp foo; Exp f; Args [a; b]; Exp g; Args [c; d]] + * which can be processed for printing purposes. + *) + let rec flatten ?(uncurried = false) acc = function + | { pexp_desc = + Pexp_apply + ( { pexp_desc = Pexp_ident { txt = Longident.Lident "|." } } + , [ (Nolabel, arg1); (Nolabel, arg2) ] ) + } -> + flatten (PipeFirstTree.Exp arg2 :: acc) arg1 + | { pexp_attributes + ; pexp_desc = + Pexp_apply + ( { pexp_desc = + Pexp_apply + ( { pexp_desc = + Pexp_ident { txt = Longident.Lident "|." } + } + , [ (Nolabel, arg1); (Nolabel, arg2) ] ) + } + , args ) + } as e -> + let args = PipeFirstTree.Args args in + (match pexp_attributes with + | [ { attr_name = { txt = "u" | "bs" }; attr_payload = PStr [] } ] + -> + flatten (PipeFirstTree.ExpU arg2 :: args :: acc) arg1 + | [] -> + (* the uncurried attribute might sit on the Pstr_eval + * enclosing the Pexp_apply*) + if uncurried + then flatten (PipeFirstTree.ExpU arg2 :: args :: acc) arg1 + else flatten (PipeFirstTree.Exp arg2 :: args :: acc) arg1 + | _ -> PipeFirstTree.Exp e :: acc) + | { pexp_desc = Pexp_ident { txt = Longident.Lident "|." } } -> acc + | arg -> PipeFirstTree.Exp arg :: acc + in + (* Given: foo->f(a, b)->g(c, d) + * We get the following PipeFirstTree.flatNode list: + * [Exp foo; Exp f; Args [a; b]; Exp g; Args [c; d]] + * The job of `parse` is to turn the "flat representation" + * (a.k.a. PipeFirstTree.flastNode list) into a more convenient structure + * that allows us to express the segments: "foo" "f(a, b)" "g(c, d)". + * PipeFirstTree.t expresses those segments. + * [{exp = foo; args = []}; {exp = f; args = [a; b]}; {exp = g; args = [c; d]}] + *) + let rec parse acc = function + | PipeFirstTree.Exp e :: PipeFirstTree.Args args :: xs -> + parse + (PipeFirstTree.{ exp = e; args; uncurried = false } :: acc) + xs + | PipeFirstTree.ExpU e :: PipeFirstTree.Args args :: xs -> + parse + (PipeFirstTree.{ exp = e; args; uncurried = true } :: acc) + xs + | PipeFirstTree.Exp e :: xs -> + parse + (PipeFirstTree.{ exp = e; args = []; uncurried = false } :: acc) + xs + | _ -> List.rev acc + in + (* Given: foo->f(. a,b); + * The uncurried attribute doesn't sit on the Pexp_apply, but sits on + * the top level Pstr_eval. We don't have access to top-level context here, + * hence the lookup in the global uncurriedTable to correctly determine + * if we need to print uncurried. *) + let uncurried = + try Hashtbl.find uncurriedTable e.pexp_loc with Not_found -> false + in + (* Turn + * foo->f(a, b)->g(c, d) + * into + * [Exp foo; Exp f; Args [a; b]; Exp g; Args [c; d]] + *) + let (flatNodes : PipeFirstTree.flatT) = flatten ~uncurried [] e in + (* Turn + * [Exp foo; Exp f; Args [a; b]; Exp g; Args [c; d]] + * into + * [{exp = foo; args = []}; {exp = f; args = [a; b]}; {exp = g; args = [c; d]}] + *) + let (pipetree : PipeFirstTree.t) = parse [] flatNodes in + (* Turn + * [{exp = foo; args = []}; {exp = f; args = [a; b]}; {exp = g; args = [c; d]}] + * into + * [foo; ->f(a, b); ->g(c, d)] + *) + let pipeSegments = + match pipetree with + (* Special case printing of + * foo->bar( + * aa, + * bb, + * ) * - * Hence we don't need parens in this case. + * We don't want + * foo + * ->bar( + * aa, + * bb + * ) + * + * Notice how `foo->bar` shouldn't break, it wastes space and is + * inconsistent with + * foo.bar( + * aa, + * bb, + * ) *) - | expr when Reason_heuristics.isUnderscoreApplication expr -> - LayoutNode (self#unparseExpr expr) - | _ -> - self#ensureContainingRule - ~withPrecedence:(Token pipeFirstToken) ~reducesAfterRight:expr () + | [ ({ exp = { pexp_desc = Pexp_ident _ } } as hd); last ] -> + let prefix = + Some + (makeList + [ PipeFirstTree.formatNode ~first:true hd; atom "->" ]) + in + [ PipeFirstTree.formatNode ?prefix last ] + | hd :: tl -> + let hd = PipeFirstTree.formatNode ~first:true hd in + let tl = + List.map + (fun node -> + makeList [ atom "->"; PipeFirstTree.formatNode node ]) + tl + in + hd :: tl + | [] -> [] in - self#unparseResolvedRule formatted - in - let parens = match (exp.pexp_desc) with - | Pexp_apply (e,_) -> printedStringAndFixityExpr e = UnaryPostfix "^" - | _ -> false - in - let layout = match args with - | [] -> - let e = formatLayout exp in - (match prefix with - | Some l -> makeList [l; e] - | None -> e) - | args -> - let args = List.map - (fun (label, arg) -> - label, self#process_underscore_application arg) - args + (* Provide nice breaking for: [foo; ->f(a, b); ->g(c, d)] + * foo + * ->f(a, b) + * ->g(c, d) + *) + makeList ~break:IfNeed ~inline:(true, true) pipeSegments + + (* + * Replace (__x) => foo(__x) with foo(_) + *) + method process_underscore_application x = + let process_application expr = + let process_arg (l, e) = + match e.pexp_desc with + | Pexp_ident ({ txt = Lident "__x" } as id) -> + let pexp_desc = Pexp_ident { id with txt = Lident "_" } in + l, { e with pexp_desc } + | _ -> l, e in - let fakeApplExp = - let loc_end = match List.rev args with - | (_, e)::_ -> e.pexp_loc.loc_end - | _ -> exp.pexp_loc.loc_end - in - {exp with pexp_loc = { exp.pexp_loc with loc_end = loc_end } } + match expr.pexp_desc with + | Pexp_apply (e_fun, args) -> + let pexp_desc = Pexp_apply (e_fun, List.map process_arg args) in + { expr with pexp_desc } + | _ -> expr + in + match x.pexp_desc with + | Pexp_fun + ( Nolabel + , None + , { ppat_desc = Ppat_var { txt = "__x" } } + , ({ pexp_desc = Pexp_apply _ } as e) ) -> + process_application e + | Pexp_fun (l, eo, p, e) -> + let e_processed = self#process_underscore_application e in + if e == e_processed + then x + else { x with pexp_desc = Pexp_fun (l, eo, p, e_processed) } + | _ -> x + + method unparseExprRecurse x = + let x = self#process_underscore_application x in + + (* If there are any attributes, render unary like `(~-) x [@ppx]`, and + infix like `(+) x y [@attr]` *) + let { Reason_attributes.arityAttrs + ; stdAttrs + ; jsxAttrs + ; stylisticAttrs + ; uncurried + } + = + Reason_attributes.partitionAttributes + ~allowUncurry:(Reason_heuristics.bsExprCanBeUncurried x) + x.pexp_attributes + in + let stylisticAttrs = + Reason_attributes.maybe_remove_stylistic_attrs + stylisticAttrs + ~should_preserve:preserve_braces + in + let () = + if uncurried then Hashtbl.add uncurriedTable x.pexp_loc true + in + let x = + { x with + pexp_attributes = + stylisticAttrs @ arityAttrs @ stdAttrs @ jsxAttrs + } + in + (* If there's any attributes, recurse without them, then apply them to + the ends of functions, or simplify infix printings then append. *) + match stdAttrs, x.pexp_desc with + | _, Pexp_letop _ -> + (* `Pexp_letop` is a bit different than `let` bindings because the + attributes are in `Pexp_letop` rather than the `value_binding` + type (check https://github.com/ocaml/ocaml/issues/9301 too), so + we must treat it a bit differently if we want to print the + attributes inside the braces. *) + FunctionApplication [ makeLetSequence (self#letList x) ] + | _ :: _, _ -> + let withoutVisibleAttrs = + { x with + pexp_attributes = stylisticAttrs @ arityAttrs @ jsxAttrs + } in - makeList ( - self#formatFunAppl - ?prefix - ~jsxAttrs:[] - ~args - ~funExpr:exp - ~applicationExpr:fakeApplExp - ~uncurried - () - ) - in - if parens then - formatPrecedence layout - else layout - end in - (* Imagine: foo->f(a, b)->g(c,d) - * The corresponding parsetree looks more like: - * (((foo->f)(a,b))->g)(c, d) - * The extra Pexp_apply nodes, e.g. (foo->f), result into a - * nested/recursive ast which is pretty inconvenient in terms of printing. - * For printing purposes we actually want something more like: - * foo->|f(a,b)|->|g(c, d)| - * in order to provide to following printing: - * foo - * ->f(a, b) - * ->g(c, d) - * The job of "flatten" is to turn the inconvenient, nested ast - * (((foo->f)(a,b))->g)(c, d) - * into - * [Exp foo; Exp f; Args [a; b]; Exp g; Args [c; d]] - * which can be processed for printing purposes. - *) - let rec flatten ?(uncurried=false) acc = function - | {pexp_desc = Pexp_apply( - {pexp_desc = Pexp_ident({txt = Longident.Lident("|.")})}, - [Nolabel, arg1; Nolabel, arg2] - )} -> - flatten ((PipeFirstTree.Exp arg2)::acc) arg1 - | {pexp_attributes; - pexp_desc = Pexp_apply( - {pexp_desc = Pexp_apply( - {pexp_desc = Pexp_ident({txt = Longident.Lident("|.")})}, - [Nolabel, arg1; Nolabel, arg2] - )}, - args - )} as e -> - let args = PipeFirstTree.Args args in - begin match pexp_attributes with - | [{ attr_name = {txt = "u" | "bs"}; attr_payload = PStr []}] -> - flatten ((PipeFirstTree.ExpU arg2)::args::acc) arg1 - | [] -> - (* the uncurried attribute might sit on the Pstr_eval - * enclosing the Pexp_apply*) - if uncurried then - flatten ((PipeFirstTree.ExpU arg2)::args::acc) arg1 - else - flatten ((PipeFirstTree.Exp arg2)::args::acc) arg1 - | _ -> - (PipeFirstTree.Exp e)::acc - end - | {pexp_desc = Pexp_ident({txt = Longident.Lident("|.")})} -> acc - | arg -> ((PipeFirstTree.Exp arg)::acc) - in - (* Given: foo->f(a, b)->g(c, d) - * We get the following PipeFirstTree.flatNode list: - * [Exp foo; Exp f; Args [a; b]; Exp g; Args [c; d]] - * The job of `parse` is to turn the "flat representation" - * (a.k.a. PipeFirstTree.flastNode list) into a more convenient structure - * that allows us to express the segments: "foo" "f(a, b)" "g(c, d)". - * PipeFirstTree.t expresses those segments. - * [{exp = foo; args = []}; {exp = f; args = [a; b]}; {exp = g; args = [c; d]}] - *) - let rec parse acc = function - | (PipeFirstTree.Exp e)::(PipeFirstTree.Args args)::xs -> - parse ((PipeFirstTree.{exp = e; args; uncurried = false})::acc) xs - | (PipeFirstTree.ExpU e)::(PipeFirstTree.Args args)::xs -> - parse ((PipeFirstTree.{exp = e; args; uncurried = true})::acc) xs - | (PipeFirstTree.Exp e)::xs -> - parse ((PipeFirstTree.{exp = e; args = []; uncurried = false})::acc) xs - | _ -> List.rev acc - in - (* Given: foo->f(. a,b); - * The uncurried attribute doesn't sit on the Pexp_apply, but sits on - * the top level Pstr_eval. We don't have access to top-level context here, - * hence the lookup in the global uncurriedTable to correctly determine - * if we need to print uncurried. *) - let uncurried = try Hashtbl.find uncurriedTable e.pexp_loc with - | Not_found -> false - in - (* Turn - * foo->f(a, b)->g(c, d) - * into - * [Exp foo; Exp f; Args [a; b]; Exp g; Args [c; d]] - *) - let (flatNodes : PipeFirstTree.flatT) = flatten ~uncurried [] e in - (* Turn - * [Exp foo; Exp f; Args [a; b]; Exp g; Args [c; d]] - * into - * [{exp = foo; args = []}; {exp = f; args = [a; b]}; {exp = g; args = [c; d]}] - *) - let (pipetree : PipeFirstTree.t) = parse [] flatNodes in - (* Turn - * [{exp = foo; args = []}; {exp = f; args = [a; b]}; {exp = g; args = [c; d]}] - * into - * [foo; ->f(a, b); ->g(c, d)] - *) - let pipeSegments = match pipetree with - (* Special case printing of - * foo->bar( - * aa, - * bb, - * ) - * - * We don't want - * foo - * ->bar( - * aa, - * bb - * ) - * - * Notice how `foo->bar` shouldn't break, it wastes space and is - * inconsistent with - * foo.bar( - * aa, - * bb, - * ) - *) - | [({exp = {pexp_desc = Pexp_ident _ }} as hd); last] -> - let prefix = Some ( - makeList [PipeFirstTree.formatNode ~first:true hd; atom "->"] - ) in - [PipeFirstTree.formatNode ?prefix last] - | hd::tl -> - let hd = PipeFirstTree.formatNode ~first:true hd in - let tl = List.map (fun node -> - makeList [atom "->"; PipeFirstTree.formatNode node] - ) tl in - hd::tl - | [] -> [] - in - (* Provide nice breaking for: [foo; ->f(a, b); ->g(c, d)] - * foo - * ->f(a, b) - * ->g(c, d) - *) - makeList ~break:IfNeed ~inline:(true, true) pipeSegments - - (* - * Replace (__x) => foo(__x) with foo(_) - *) - method process_underscore_application x = - let process_application expr = - let process_arg (l,e) = match e.pexp_desc with - | Pexp_ident ({ txt = Lident "__x"} as id) -> - let pexp_desc = Pexp_ident {id with txt = Lident "_"} in - (l, {e with pexp_desc}) - | _ -> - (l,e) in - match expr.pexp_desc with - | Pexp_apply (e_fun, args) -> - let pexp_desc = Pexp_apply (e_fun, List.map process_arg args) in - {expr with pexp_desc} - | _ -> - expr in - match x.pexp_desc with - | Pexp_fun (Nolabel, None, {ppat_desc = Ppat_var {txt="__x"}}, - ({pexp_desc = Pexp_apply _} as e)) -> - process_application e - | Pexp_fun (l, eo, p, e) -> - let e_processed = self#process_underscore_application e in - if e == e_processed then - x - else - {x with pexp_desc = Pexp_fun (l, eo, p, e_processed)} - | _ -> - x - - method unparseExprRecurse x = - let x = self#process_underscore_application x in - (* If there are any attributes, render unary like `(~-) x [@ppx]`, and infix like `(+) x y [@attr]` *) - - let {Reason_attributes.arityAttrs; stdAttrs; jsxAttrs; stylisticAttrs; uncurried} = - Reason_attributes.partitionAttributes ~allowUncurry:(Reason_heuristics.bsExprCanBeUncurried x) x.pexp_attributes - in - let stylisticAttrs = - Reason_attributes.maybe_remove_stylistic_attrs - stylisticAttrs - ~should_preserve:preserve_braces - in - let () = if uncurried then Hashtbl.add uncurriedTable x.pexp_loc true in - let x = {x with pexp_attributes = (stylisticAttrs @ arityAttrs @ stdAttrs @ jsxAttrs) } in - (* If there's any attributes, recurse without them, then apply them to - the ends of functions, or simplify infix printings then append. *) - match stdAttrs, x.pexp_desc with - | _, Pexp_letop _ -> - (* `Pexp_letop` is a bit different than `let` bindings because the - attributes are in `Pexp_letop` rather than the `value_binding` type - (check https://github.com/ocaml/ocaml/issues/9301 too), so we must - treat it a bit differently if we want to print the attributes inside - the braces. *) - FunctionApplication [ makeLetSequence (self#letList x) ] - | _ :: _, _ -> - let withoutVisibleAttrs = {x with pexp_attributes=(stylisticAttrs @ arityAttrs @ jsxAttrs)} in - let attributesAsList = List.map self#attribute stdAttrs in - let itms = match self#unparseExprRecurse withoutVisibleAttrs with - | SpecificInfixPrecedence ({reducePrecedence}, wrappedRule) -> - let itm = self#unparseResolvedRule wrappedRule in - (match reducePrecedence with - (* doesn't need wrapping; we know how to parse *) - | Custom "prec_lbracket" | Token "." -> [itm] - | _ -> [formatPrecedence ~loc:x.pexp_loc itm]) - | FunctionApplication itms -> itms - | PotentiallyLowPrecedence itm -> [formatPrecedence ~loc:x.pexp_loc itm] - | Simple itm -> [itm] - in - FunctionApplication [ - makeList - ~break:IfNeed - ~inline:(true, true) - ~indent:0 - ~postSpace:true - (List.concat [attributesAsList; itms]) - ] - | [], _ -> - match self#simplest_expression x with - | Some se -> Simple se - | None -> - let self = self#reset_request_braces in - match x.pexp_desc with - | Pexp_apply (e, ls) -> ( - let ls = List.map (fun (l,expr) -> (l, self#process_underscore_application expr)) ls in - match (e, ls) with - | (e, _) when Reason_heuristics.isPipeFirst e -> - let prec = Token pipeFirstToken in - SpecificInfixPrecedence - ({reducePrecedence=prec; shiftPrecedence=prec}, LayoutNode (self#formatPipeFirst x)) - | ({pexp_desc = Pexp_ident {txt = Ldot (Lident ("Array"),"get")}}, [(_,e1);(_,e2)]) -> - begin match e1.pexp_desc with - | Pexp_ident ({txt = Lident "_"}) -> - let k = atom "Array.get" in - let v = makeList ~postSpace:true ~sep:(Layout.Sep ",") ~wrap:("(", ")") - [atom "_"; self#unparseExpr e2] + let attributesAsList = List.map self#attribute stdAttrs in + let itms = + match self#unparseExprRecurse withoutVisibleAttrs with + | SpecificInfixPrecedence ({ reducePrecedence }, wrappedRule) -> + let itm = self#unparseResolvedRule wrappedRule in + (match reducePrecedence with + (* doesn't need wrapping; we know how to parse *) + | Custom "prec_lbracket" | Token "." -> [ itm ] + | _ -> [ formatPrecedence ~loc:x.pexp_loc itm ]) + | FunctionApplication itms -> itms + | PotentiallyLowPrecedence itm -> + [ formatPrecedence ~loc:x.pexp_loc itm ] + | Simple itm -> [ itm ] in - Simple (label k v) + FunctionApplication + [ makeList + ~break:IfNeed + ~inline:(true, true) + ~indent:0 + ~postSpace:true + (List.concat [ attributesAsList; itms ]) + ] + | [], _ -> + (match self#simplest_expression x with + | Some se -> Simple se + | None -> + let self = self#reset_request_braces in + (match x.pexp_desc with + | Pexp_apply (e, ls) -> + let ls = + List.map + (fun (l, expr) -> + l, self#process_underscore_application expr) + ls + in + (match e, ls with + | e, _ when Reason_heuristics.isPipeFirst e -> + let prec = Token pipeFirstToken in + SpecificInfixPrecedence + ( { reducePrecedence = prec; shiftPrecedence = prec } + , LayoutNode (self#formatPipeFirst x) ) + | ( { pexp_desc = + Pexp_ident { txt = Ldot (Lident "Array", "get") } + } + , [ (_, e1); (_, e2) ] ) -> + (match e1.pexp_desc with + | Pexp_ident { txt = Lident "_" } -> + let k = atom "Array.get" in + let v = + makeList + ~postSpace:true + ~sep:(Layout.Sep ",") + ~wrap:("(", ")") + [ atom "_"; self#unparseExpr e2 ] + in + Simple (label k v) + | _ -> + let prec = Custom "prec_lbracket" in + let lhs = + self#unparseResolvedRule + (self#ensureExpression ~reducesOnToken:prec e1) + in + let rhs = self#unparseExpr e2 in + SpecificInfixPrecedence + ( { reducePrecedence = prec; shiftPrecedence = prec } + , LayoutNode (self#access "[" "]" lhs rhs) )) + | ( { pexp_desc = + Pexp_ident { txt = Ldot (Lident "String", "get") } + } + , [ (_, e1); (_, e2) ] ) -> + if Reason_heuristics.isUnderscoreIdent e1 + then + let k = atom "String.get" in + let v = + makeList + ~postSpace:true + ~sep:(Layout.Sep ",") + ~wrap:("(", ")") + [ atom "_"; self#unparseExpr e2 ] + in + Simple (label k v) + else + let prec = Custom "prec_lbracket" in + let lhs = + self#unparseResolvedRule + (self#ensureExpression ~reducesOnToken:prec e1) + in + let rhs = self#unparseExpr e2 in + SpecificInfixPrecedence + ( { reducePrecedence = prec; shiftPrecedence = prec } + , LayoutNode (self#access ".[" "]" lhs rhs) ) + | ( { pexp_desc = + Pexp_ident + { txt = + Ldot (Ldot (Lident "Bigarray", "Genarray"), "get") + } + } + , [ (_, e1); (_, ({ pexp_desc = Pexp_array ls } as e2)) ] ) -> + if Reason_heuristics.isUnderscoreIdent e1 + then + let k = atom "Bigarray.Genarray.get" in + let v = + makeList + ~postSpace:true + ~sep:(Layout.Sep ",") + ~wrap:("(", ")") + [ atom "_"; self#unparseExpr e2 ] + in + Simple (label k v) + else + let formattedList = List.map self#unparseExpr ls in + let lhs = + makeList + [ self#simple_enough_to_be_lhs_dot_send e1; atom "." ] + in + let rhs = + makeList + ~break:IfNeed + ~postSpace:true + ~sep:commaSep + ~wrap:("{", "}") + formattedList + in + let prec = Custom "prec_lbracket" in + SpecificInfixPrecedence + ( { reducePrecedence = prec; shiftPrecedence = prec } + , LayoutNode (label lhs rhs) ) + | ( { pexp_desc = + Pexp_ident + { txt = + Ldot + ( Ldot + ( Lident "Bigarray" + , (("Array1" | "Array2" | "Array3") as + arrayIdent) ) + , "get" ) + } + } + , (_, e1) :: rest ) -> + if Reason_heuristics.isUnderscoreIdent e1 + then + let k = atom ("Bigarray." ^ arrayIdent ^ ".get") in + let v = + makeList + ~postSpace:true + ~sep:(Layout.Sep ",") + ~wrap:("(", ")") + (atom "_" + :: List.map (fun (_, e) -> self#unparseExpr e) rest) + in + Simple (label k v) + else + let formattedList = + List.map self#unparseExpr (List.map snd rest) + in + let lhs = + makeList + [ self#simple_enough_to_be_lhs_dot_send e1; atom "." ] + in + let rhs = + makeList + ~break:IfNeed + ~postSpace:true + ~sep:commaSep + ~wrap:("{", "}") + formattedList + in + let prec = Custom "prec_lbracket" in + SpecificInfixPrecedence + ( { reducePrecedence = prec; shiftPrecedence = prec } + , LayoutNode (label lhs rhs) ) + | _ -> + (match self#sugar_set_expr_parts x with + (* Returns None if there's attributes - would render as regular function *) + (* Format as if it were an infix function application with identifier "=" *) + | Some (simplyFormatedLeftItm, rightExpr) -> + let tokenPrec = Token updateToken in + let rightItm = + self#ensureContainingRule + ~withPrecedence:tokenPrec + ~reducesAfterRight:rightExpr + () + in + let leftWithOp = + makeList + ~postSpace:true + [ simplyFormatedLeftItm; atom updateToken ] + in + let expr = + label + ~space:true + leftWithOp + (self#unparseResolvedRule rightItm) + in + SpecificInfixPrecedence + ( { reducePrecedence = tokenPrec + ; shiftPrecedence = tokenPrec + } + , LayoutNode expr ) + | None -> + (match printedStringAndFixityExpr e, ls with + (* We must take care not to print two subsequent prefix + operators without spaces between them (`! !` could become + `!!` which is totally different). *) + | AlmostSimplePrefix prefixStr, [ (Nolabel, rightExpr) ] -> + let forceSpace = + match rightExpr.pexp_desc with + | Pexp_apply (ee, _) -> + (match printedStringAndFixityExpr ee with + | AlmostSimplePrefix _ -> true + | _ -> false) + | _ -> false + in + let prec = Token prefixStr in + let rightItm = + self#unparseResolvedRule + (self#ensureContainingRule + ~withPrecedence:prec + ~reducesAfterRight:rightExpr + ()) + in + SpecificInfixPrecedence + ( { reducePrecedence = prec; shiftPrecedence = prec } + , LayoutNode + (label ~space:forceSpace (atom prefixStr) rightItm) + ) + | UnaryPostfix postfixStr, [ (Nolabel, leftExpr) ] -> + let forceSpace = + match leftExpr.pexp_desc with + | Pexp_apply (ee, _) -> + (match printedStringAndFixityExpr ee with + | UnaryPostfix "^" | AlmostSimplePrefix _ -> true + | _ -> false) + | _ -> false + in + let leftItm = + match leftExpr.pexp_desc with + | Pexp_apply (e, _) -> + (match printedStringAndFixityExpr e with + | Infix printedIdent + when requireNoSpaceFor printedIdent + || Reason_heuristics.isPipeFirst e -> + self#unparseExpr leftExpr + | _ -> self#simplifyUnparseExpr leftExpr) + | Pexp_field _ -> self#unparseExpr leftExpr + | _ -> self#simplifyUnparseExpr leftExpr + in + Simple (label ~space:forceSpace leftItm (atom postfixStr)) + | ( Infix printedIdent + , [ (Nolabel, leftExpr); (Nolabel, rightExpr) ] ) -> + let infixToken = Token printedIdent in + let rightItm = + self#ensureContainingRule + ~withPrecedence:infixToken + ~reducesAfterRight:rightExpr + () + in + let leftItm = + self#ensureExpression + ~reducesOnToken:infixToken + leftExpr + in + (* Left exprs of infix tokens which we don't print spaces + for (e.g. `##`) need to be wrapped in parens in the + case of postfix `^`. Otherwise, printing will be + ambiguous as `^` is also a valid start of an infix + operator. *) + let formattedLeftItm = + match leftItm with + | LayoutNode x -> + (match leftExpr.pexp_desc with + | Pexp_apply (e, _) -> + (match printedStringAndFixityExpr e with + | UnaryPostfix "^" + when requireNoSpaceFor printedIdent -> + LayoutNode + (formatPrecedence ~loc:leftExpr.pexp_loc x) + | _ -> leftItm) + | _ -> leftItm) + | InfixTree _ -> leftItm + in + let infixTree = + InfixTree (printedIdent, formattedLeftItm, rightItm) + in + SpecificInfixPrecedence + ( { reducePrecedence = infixToken + ; shiftPrecedence = infixToken + } + , infixTree ) + (* Will be rendered as `(+) a b c` which is parsed with + higher precedence than all the other forms unparsed + here.*) + | UnaryPlusPrefix printedIdent, [ (Nolabel, rightExpr) ] -> + let prec = Custom "prec_unary" in + let rightItm = + self#unparseResolvedRule + (self#ensureContainingRule + ~withPrecedence:prec + ~reducesAfterRight:rightExpr + ()) + in + let expr = + label ~space:true (atom printedIdent) rightItm + in + SpecificInfixPrecedence + ( { reducePrecedence = prec + ; shiftPrecedence = Token printedIdent + } + , LayoutNode expr ) + | ( (UnaryMinusPrefix printedIdent as x) + , [ (Nolabel, rightExpr) ] ) + | ( (UnaryNotPrefix printedIdent as x) + , [ (Nolabel, rightExpr) ] ) -> + let forceSpace = + match x with + | UnaryMinusPrefix _ -> true + | _ -> + (match rightExpr.pexp_desc with + | Pexp_apply + ({ pexp_desc = Pexp_ident { txt = Lident s } }, _) + -> + isSimplePrefixToken s + | _ -> false) + in + let prec = Custom "prec_unary" in + let rightItm = + self#unparseResolvedRule + (self#ensureContainingRule + ~withPrecedence:prec + ~reducesAfterRight:rightExpr + ()) + in + let expr = + label ~space:forceSpace (atom printedIdent) rightItm + in + SpecificInfixPrecedence + ( { reducePrecedence = prec + ; shiftPrecedence = Token printedIdent + } + , LayoutNode expr ) + (* Will need to be rendered in self#expression as (~-) x y + z. *) + | _, _ -> + (* This case will happen when there is something like + * + * Bar.createElement a::1 b::2 [] [@bla] [@JSX] + * + * At this point the bla will be stripped (because it's a visible + * attribute) but the JSX will still be there. + *) + + (* this case also happens when we have something like: + * List.map((a) => a + 1, numbers); + * We got two "List.map" as Pexp_ident & a list of arguments: + * [`(a) => a + 1`; `numbers`] + * + * Another possible case is: + * describe("App", () => + * test("math", () => + * Expect.expect(1 + 2) |> toBe(3))); + *) + let uncurried = + try Hashtbl.find uncurriedTable x.pexp_loc with + | Not_found -> false + in + FunctionApplication + (self#formatFunAppl + ~uncurried + ~jsxAttrs + ~args:ls + ~applicationExpr:x + ~funExpr:e + ())))) + | Pexp_field (e, li) -> + let prec = Token "." in + let leftItm = + self#unparseResolvedRule + (self#ensureExpression ~reducesOnToken:prec e) + in + let { Reason_attributes.stdAttrs } = + Reason_attributes.partitionAttributes e.pexp_attributes + in + let formattedLeftItm = + if stdAttrs == [] + then leftItm + else formatPrecedence ~loc:e.pexp_loc leftItm + in + let layout = + label + (makeList [ formattedLeftItm; atom "." ]) + (self#longident_loc li) + in + SpecificInfixPrecedence + ( { reducePrecedence = prec; shiftPrecedence = prec } + , LayoutNode layout ) + | Pexp_construct (li, Some eo) + when not (is_simple_construct (view_expr x)) -> + (match view_expr x with + (* TODO: Explicit arity *) + | `normal -> + let arityIsClear = isArityClear arityAttrs in + FunctionApplication + [ self#constructor_expression + ~arityIsClear + stdAttrs + (self#longident_loc li) + eo + ] + | _ -> assert false) + | Pexp_variant (l, Some eo) -> + if arityAttrs != [] + then + raise + (NotPossible + "Should never see embedded attributes on poly variant") + else + FunctionApplication + [ self#constructor_expression + ~polyVariant:true + ~arityIsClear:true + stdAttrs + (atom ("`" ^ l)) + eo + ] + (* TODO: Should protect this identifier *) + | Pexp_setinstvar (s, rightExpr) -> + let rightItm = + self#unparseResolvedRule + (self#ensureContainingRule + ~withPrecedence:(Token updateToken) + ~reducesAfterRight:rightExpr + ()) + in + let expr = + label + ~space:true + (makeList + ~postSpace:true + [ protectIdentifier s.txt; atom updateToken ]) + rightItm + in + SpecificInfixPrecedence + ( { reducePrecedence = Token updateToken + ; shiftPrecedence = Token updateToken + } + , LayoutNode expr ) + | Pexp_setfield (leftExpr, li, rightExpr) -> + let rightItm = + self#unparseResolvedRule + (self#ensureContainingRule + ~withPrecedence:(Token updateToken) + ~reducesAfterRight:rightExpr + ()) + in + let leftItm = + self#unparseResolvedRule + (self#ensureExpression ~reducesOnToken:(Token ".") leftExpr) + in + let leftLbl = + label (makeList [ leftItm; atom "." ]) (self#longident_loc li) + in + let expr = + label + ~space:true + (makeList ~postSpace:true [ leftLbl; atom updateToken ]) + rightItm + in + SpecificInfixPrecedence + ( { reducePrecedence = Token updateToken + ; shiftPrecedence = Token updateToken + } + , LayoutNode expr ) + | Pexp_match (e, l) when detectTernary l != None -> + (match detectTernary l with + | None -> raise (Invalid_argument "Impossible") + | Some (tt, ff) -> + let ifTrue = self#reset_request_braces#unparseExpr tt in + let testItem = + self#unparseResolvedRule + (self#reset_request_braces#ensureExpression + e + ~reducesOnToken:(Token "?")) + in + let ifFalse = + self#unparseResolvedRule + (self#reset_request_braces#ensureContainingRule + ~withPrecedence:(Token ":") + ~reducesAfterRight:ff + ()) + in + let trueBranch = + label ~space:true ~break:`Never (atom "?") ifTrue + in + let falseBranch = + label ~space:true ~break:`Never (atom ":") ifFalse + in + let expr = + label + ~space:true + testItem + (makeList + ~break:IfNeed + ~sep:(Sep " ") + ~inline:(true, true) + [ trueBranch; falseBranch ]) + in + SpecificInfixPrecedence + ( { reducePrecedence = Token ":" + ; shiftPrecedence = Token "?" + } + , LayoutNode expr )) + | _ -> + (match self#expression_requiring_parens_in_infix x with + | Some e -> e + | None -> + raise (Invalid_argument "No match for unparsing expression")))) + + method formatNonSequencyExpression ?parent e = + (* + * Instead of printing: + * let result = { open Fmt; strf(foo);} + * + * We format as: + * let result = Fmt.(strf(foo)) + * + * (Also see https://github.com/facebook/Reason/issues/114) + *) + match e.pexp_attributes, e.pexp_desc with + | [], Pexp_record _ (* syntax sugar for M.{x:1} *) + | [], Pexp_tuple _ (* syntax sugar for M.(a, b) *) + | [], Pexp_object { pcstr_fields = [] } (* syntax sugar for M.{} *) + | [], Pexp_construct ({ txt = Lident "::" }, Some _) + | [], Pexp_construct ({ txt = Lident "[]" }, _) + | [], Pexp_extension ({ txt = "mel.obj" }, _) -> + self#simplifyUnparseExpr e (* syntax sugar for M.[x,y] *) + (* syntax sugar for the rest, wrap with parens to avoid ambiguity. + * E.g., avoid M.(M2.v) being printed as M.M2.v + * Or ReasonReact.(<> {string("Test")} ); + *) | _ -> - let prec = Custom "prec_lbracket" in - let lhs = self#unparseResolvedRule ( - self#ensureExpression ~reducesOnToken:prec e1 - ) in - let rhs = self#unparseExpr e2 in - SpecificInfixPrecedence - ({reducePrecedence=prec; shiftPrecedence=prec}, LayoutNode (self#access "[" "]" lhs rhs)) - end - | ({pexp_desc = Pexp_ident {txt = Ldot (Lident ("String"),"get")}}, [(_,e1);(_,e2)]) -> - if Reason_heuristics.isUnderscoreIdent e1 then - let k = atom "String.get" in - let v = makeList ~postSpace:true ~sep:(Layout.Sep ",") ~wrap:("(", ")") - [atom "_"; self#unparseExpr e2] - in - Simple (label k v) - else - let prec = Custom "prec_lbracket" in - let lhs = self#unparseResolvedRule ( - self#ensureExpression ~reducesOnToken:prec e1 - ) in - let rhs = self#unparseExpr e2 in - SpecificInfixPrecedence - ({reducePrecedence=prec; shiftPrecedence=prec}, LayoutNode (self#access ".[" "]" lhs rhs)) - | ( - {pexp_desc= Pexp_ident {txt=Ldot (Ldot (Lident "Bigarray", "Genarray" ), "get")}}, - [(_,e1); (_,({pexp_desc=Pexp_array ls} as e2))] - ) -> - if (Reason_heuristics.isUnderscoreIdent e1) then - let k = atom "Bigarray.Genarray.get" in - let v = makeList ~postSpace:true ~sep:(Layout.Sep ",") ~wrap:("(", ")") - [atom "_"; self#unparseExpr e2] - in - Simple (label k v) - else - let formattedList = List.map self#unparseExpr ls in - let lhs = makeList [(self#simple_enough_to_be_lhs_dot_send e1); atom "."] in - let rhs = makeList ~break:IfNeed ~postSpace:true ~sep:commaSep ~wrap:("{", "}") formattedList in - let prec = Custom "prec_lbracket" in - SpecificInfixPrecedence ({reducePrecedence=prec; shiftPrecedence=prec}, LayoutNode (label lhs rhs)) - | ( - {pexp_desc= Pexp_ident {txt= - Ldot (Ldot (Lident "Bigarray", (("Array1"|"Array2"|"Array3") as arrayIdent)), "get")} - }, - (_,e1)::rest - ) -> - if Reason_heuristics.isUnderscoreIdent e1 then - let k = atom("Bigarray." ^ arrayIdent ^ ".get") in - let v = makeList ~postSpace:true ~sep:(Layout.Sep ",") ~wrap:("(", ")") - ((atom "_")::(List.map (fun (_, e) -> self#unparseExpr e) rest)) - in - Simple (label k v) - else - let formattedList = List.map self#unparseExpr (List.map snd rest) in - let lhs = makeList [(self#simple_enough_to_be_lhs_dot_send e1); atom "."] in - let rhs = makeList ~break:IfNeed ~postSpace:true ~sep:commaSep ~wrap:("{", "}") formattedList in - let prec = Custom "prec_lbracket" in - SpecificInfixPrecedence ({reducePrecedence=prec; shiftPrecedence=prec}, LayoutNode (label lhs rhs)) - | _ -> ( - - match (self#sugar_set_expr_parts x) with - (* Returns None if there's attributes - would render as regular function *) - (* Format as if it were an infix function application with identifier "=" *) - | Some (simplyFormatedLeftItm, rightExpr) -> ( - let tokenPrec = Token updateToken in - let rightItm = self#ensureContainingRule ~withPrecedence:tokenPrec ~reducesAfterRight:rightExpr () in - let leftWithOp = makeList ~postSpace:true [simplyFormatedLeftItm; atom updateToken] in - let expr = label ~space:true leftWithOp (self#unparseResolvedRule rightItm) in - SpecificInfixPrecedence ({reducePrecedence=tokenPrec; shiftPrecedence=tokenPrec}, LayoutNode expr) - ) - | None -> ( - match (printedStringAndFixityExpr e, ls) with - (* We must take care not to print two subsequent prefix operators without - spaces between them (`! !` could become `!!` which is totally - different). *) - | (AlmostSimplePrefix prefixStr, [(Nolabel, rightExpr)]) -> - let forceSpace = match rightExpr.pexp_desc with - | Pexp_apply (ee, _) -> - (match printedStringAndFixityExpr ee with | AlmostSimplePrefix _ -> true | _ -> false) - | _ -> false - in - let prec = Token prefixStr in - let rightItm = self#unparseResolvedRule ( - self#ensureContainingRule ~withPrecedence:prec ~reducesAfterRight:rightExpr () - ) in - SpecificInfixPrecedence - ({reducePrecedence=prec; shiftPrecedence = prec}, LayoutNode (label ~space:forceSpace (atom prefixStr) rightItm)) - | (UnaryPostfix postfixStr, [(Nolabel, leftExpr)]) -> - let forceSpace = match leftExpr.pexp_desc with - | Pexp_apply (ee, _) -> - (match printedStringAndFixityExpr ee with - | UnaryPostfix "^" | AlmostSimplePrefix _ -> true - | _ -> false) - | _ -> false - in - let leftItm = (match leftExpr.pexp_desc with - | Pexp_apply (e,_) -> - (match printedStringAndFixityExpr e with - | Infix printedIdent - when requireNoSpaceFor printedIdent || - Reason_heuristics.isPipeFirst e -> - self#unparseExpr leftExpr - | _ -> self#simplifyUnparseExpr leftExpr) - | Pexp_field _ -> self#unparseExpr leftExpr - | _ -> self#simplifyUnparseExpr leftExpr - ) - in - Simple (label ~space:forceSpace leftItm (atom postfixStr)) - | (Infix printedIdent, [(Nolabel, leftExpr); (Nolabel, rightExpr)]) -> - let infixToken = Token printedIdent in - let rightItm = self#ensureContainingRule ~withPrecedence:infixToken ~reducesAfterRight:rightExpr () in - let leftItm = self#ensureExpression ~reducesOnToken:infixToken leftExpr in - (* Left exprs of infix tokens which we don't print spaces for (e.g. `##`) - need to be wrapped in parens in the case of postfix `^`. Otherwise, - printing will be ambiguous as `^` is also a valid start of an infix - operator. *) - let formattedLeftItm = (match leftItm with - | LayoutNode x -> begin match leftExpr.pexp_desc with - | Pexp_apply (e,_) -> - (match printedStringAndFixityExpr e with - | UnaryPostfix "^" when requireNoSpaceFor printedIdent -> - LayoutNode (formatPrecedence ~loc:leftExpr.pexp_loc x) - | _ -> leftItm) - | _ -> leftItm - end - | InfixTree _ -> leftItm - ) in - let infixTree = InfixTree (printedIdent, formattedLeftItm, rightItm) in - SpecificInfixPrecedence ({reducePrecedence=infixToken; shiftPrecedence=infixToken}, infixTree) - (* Will be rendered as `(+) a b c` which is parsed with higher precedence than all - the other forms unparsed here.*) - | (UnaryPlusPrefix printedIdent, [(Nolabel, rightExpr)]) -> - let prec = Custom "prec_unary" in - let rightItm = self#unparseResolvedRule ( - self#ensureContainingRule ~withPrecedence:prec ~reducesAfterRight:rightExpr () - ) in - let expr = label ~space:true (atom printedIdent) rightItm in - SpecificInfixPrecedence ({reducePrecedence=prec; shiftPrecedence=Token printedIdent}, LayoutNode expr) - | (UnaryMinusPrefix printedIdent as x, [(Nolabel, rightExpr)]) - | (UnaryNotPrefix printedIdent as x, [(Nolabel, rightExpr)]) -> - let forceSpace = (match x with - | UnaryMinusPrefix _ -> true - | _ -> begin match rightExpr.pexp_desc with - | Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident s}}, _) -> - isSimplePrefixToken s - | _ -> false - end) in - let prec = Custom "prec_unary" in - let rightItm = self#unparseResolvedRule ( - self#ensureContainingRule ~withPrecedence:prec ~reducesAfterRight:rightExpr () - ) in - let expr = label ~space:forceSpace (atom printedIdent) rightItm in - SpecificInfixPrecedence ({reducePrecedence=prec; shiftPrecedence=Token printedIdent}, LayoutNode expr) - (* Will need to be rendered in self#expression as (~-) x y z. *) - | (_, _) -> - (* This case will happen when there is something like - - Bar.createElement a::1 b::2 [] [@bla] [@JSX] - - At this point the bla will be stripped (because it's a visible - attribute) but the JSX will still be there. - *) + (match parent with + | Some parent + when Reason_attributes.has_open_notation_attr + parent.pexp_attributes -> + makeList + ~break:IfNeed + ~inline:(true, false) + ~postSpace:true + ~wrap:("(", ")") + ~sep:(SepFinal (";", "")) + (self#letList e) + | Some _ | None -> + makeList ~wrap:("(", ")") ~break:IfNeed [ self#unparseExpr e ]) - (* this case also happens when we have something like: - * List.map((a) => a + 1, numbers); - * We got two "List.map" as Pexp_ident & a list of arguments: - * [`(a) => a + 1`; `numbers`] + (* + * It's not enough to only check if precedence of an infix left/right is + * greater than the infix itself. We also should likely pay attention to + * left/right associativity. So how do we render the minimum number of + * parenthesis? + * + * The intuition is that sequential right associative operators will + * naturally build up deep trees on the right side (left builds up left-deep + * trees). So by default, we add parens to model the tree structure that + * we're rendering except when the parser will *naturally* parse the tree + * structure that the parens assert. + * + * Sequential identical infix operators: + * ------------------------------------ + * So if we see a nested infix operator of precedence Y, as one side of + * another infix operator that has the same precedence (Y), that is S + * associative on the S side of the function application, we don't need to + * wrap in parens. In more detail: + * + * -Add parens around infix binary function application + * Exception 1: Unless we are a left-assoc operator of precedence X in the left branch of an operator w/ precedence X. + * Exception 2: Unless we are a right-assoc operator of precedence X in the right branch of an operator w/ precedence X. + * Exception 3: Unless we are a _any_-assoc X operator in the _any_ branch of an Y operator where X has greater precedence than Y. + * + * Note that the exceptions do not specify any special cases for mixing + * left/right associativity. Precedence is what determines necessity of + * parens for operators with non-identical precedences. Associativity + * only determines necessity of parens for identically precedented operators. + * + * PLUS is left assoc: + * - So this one *shouldn't* expand into two consecutive infix +: + * + * + * [Pexp_apply] + * / \ + * first + [Pexp_apply] + * / \ + * second + third + * + * + * - This one *should*: + * + * [Pexp_apply] + * / \ + * [ Pexp_apply ] + third + * / \ + * first + second + * + * + * COLONCOLON is right assoc, so + * - This one *should* expand into two consecutive infix :: : + * + * [Pexp_apply] + * / \ + * first :: [Pexp_apply] + * / \ + * second :: third + * + * + * - This one *shouldn't*: + * + * [Pexp_apply] + * / \ + * [ Pexp_apply ] :: third + * / \ + * first :: second + * + * + * Sequential differing infix operators: + * ------------------------------------ + * + * Neither of the following require paren grouping because of rule 3. + * + * + * [Pexp_apply] + * / \ + * first + [Pexp_apply] + * / \ + * second * third + * + * + * [Pexp_apply] + * / \ + * [Pexp_apply + third + * / \ + * first * second + * + * The previous has nothing to do with the fact that + and * have the same + * associativity. Exception 3 applies to the following where :: is right assoc + * and + is left. + has higher precedence than :: + * + * - so parens aren't required to group + when it is in a branch of a + * lower precedence :: + * + * [Pexp_apply] + * / \ + * first :: [Pexp_apply] + * / \ + * second + third + * * - * Another possible case is: - * describe("App", () => - * test("math", () => - * Expect.expect(1 + 2) |> toBe(3))); + * - Whereas there is no Exception that applies in this case (Exception 3 + * doesn't apply) so parens are required around the :: in this case. + * + * [Pexp_apply] + * / \ + * [ Pexp_apply ] + third + * / \ + * first :: second *) - let uncurried = try Hashtbl.find uncurriedTable x.pexp_loc with | Not_found -> false in - FunctionApplication ( - self#formatFunAppl - ~uncurried - ~jsxAttrs - ~args:ls - ~applicationExpr:x - ~funExpr:e - () - ) - ) - ) - ) - | Pexp_field (e, li) -> - let prec = Token "." in - let leftItm = self#unparseResolvedRule ( - self#ensureExpression ~reducesOnToken:prec e - ) in - let {Reason_attributes.stdAttrs} = Reason_attributes.partitionAttributes e.pexp_attributes in - let formattedLeftItm = if stdAttrs == [] then - leftItm - else - formatPrecedence ~loc:e.pexp_loc leftItm - in - let layout = label (makeList [formattedLeftItm; atom "."]) (self#longident_loc li) in - SpecificInfixPrecedence ({reducePrecedence=prec; shiftPrecedence=prec}, LayoutNode layout) - | Pexp_construct (li, Some eo) when not (is_simple_construct (view_expr x)) -> ( - match view_expr x with - (* TODO: Explicit arity *) - | `normal -> - let arityIsClear = isArityClear arityAttrs in - FunctionApplication [self#constructor_expression ~arityIsClear stdAttrs (self#longident_loc li) eo] - | _ -> assert false - ) - | Pexp_variant (l, Some eo) -> - if arityAttrs != [] then - raise (NotPossible "Should never see embedded attributes on poly variant") - else - FunctionApplication [self#constructor_expression ~polyVariant:true ~arityIsClear:true stdAttrs (atom ("`" ^ l)) eo] - (* TODO: Should protect this identifier *) - | Pexp_setinstvar (s, rightExpr) -> - let rightItm = self#unparseResolvedRule ( - self#ensureContainingRule ~withPrecedence:(Token updateToken) ~reducesAfterRight:rightExpr () - ) in - let expr = label ~space:true (makeList ~postSpace:true [(protectIdentifier s.txt); atom updateToken]) rightItm in - SpecificInfixPrecedence ({reducePrecedence=(Token updateToken); shiftPrecedence=(Token updateToken)}, LayoutNode expr) - | Pexp_setfield (leftExpr, li, rightExpr) -> - let rightItm = self#unparseResolvedRule ( - self#ensureContainingRule ~withPrecedence:(Token updateToken) ~reducesAfterRight:rightExpr () - ) in - let leftItm = self#unparseResolvedRule ( - self#ensureExpression ~reducesOnToken:(Token ".") leftExpr - ) in - let leftLbl = - label - (makeList [leftItm; atom "."]) - (self#longident_loc li) in - let expr = label ~space:true (makeList ~postSpace:true [leftLbl; atom updateToken]) rightItm in - SpecificInfixPrecedence ({reducePrecedence=(Token updateToken); shiftPrecedence=(Token updateToken)}, LayoutNode expr) - | Pexp_match (e, l) when detectTernary l != None -> ( - match detectTernary l with - | None -> raise (Invalid_argument "Impossible") - | Some (tt, ff) -> - let ifTrue = self#reset_request_braces#unparseExpr tt in - let testItem = self#unparseResolvedRule ( - self#reset_request_braces#ensureExpression e ~reducesOnToken:(Token "?") - ) in - let ifFalse = self#unparseResolvedRule ( - self#reset_request_braces#ensureContainingRule ~withPrecedence:(Token ":") ~reducesAfterRight:ff () - ) in - let trueBranch = label ~space:true ~break:`Never (atom "?") ifTrue - in - let falseBranch = label ~space:true ~break:`Never (atom ":") ifFalse - in - let expr = label ~space:true testItem (makeList ~break:IfNeed ~sep:(Sep " ") ~inline:(true, true) [trueBranch; falseBranch]) - in - SpecificInfixPrecedence ({reducePrecedence=Token ":"; shiftPrecedence=Token "?"}, LayoutNode expr) - ) - | _ -> ( - match self#expression_requiring_parens_in_infix x with - | Some e -> e - | None -> raise (Invalid_argument "No match for unparsing expression") - ) - - method formatNonSequencyExpression ?parent e = - (* - * Instead of printing: - * let result = { open Fmt; strf(foo);} - * - * We format as: - * let result = Fmt.(strf(foo)) - * - * (Also see https://github.com/facebook/Reason/issues/114) - *) - match e.pexp_attributes, e.pexp_desc with - | [], Pexp_record _ (* syntax sugar for M.{x:1} *) - | [], Pexp_tuple _ (* syntax sugar for M.(a, b) *) - | [], Pexp_object {pcstr_fields = []} (* syntax sugar for M.{} *) - | [], Pexp_construct ( {txt= Lident"::"},Some _) - | [], Pexp_construct ( {txt= Lident"[]"},_) - | [], Pexp_extension ( {txt = "mel.obj"}, _ ) -> - self#simplifyUnparseExpr e (* syntax sugar for M.[x,y] *) - (* syntax sugar for the rest, wrap with parens to avoid ambiguity. - * E.g., avoid M.(M2.v) being printed as M.M2.v - * Or ReasonReact.(<> {string("Test")} ); - *) - | _ -> ( - match parent with - | Some parent when Reason_attributes.has_open_notation_attr parent.pexp_attributes -> - makeList - ~break:IfNeed - ~inline:(true, false) - ~postSpace:true - ~wrap:("(",")") - ~sep:(SepFinal (";", "")) - (self#letList e) - | Some _ | None -> makeList ~wrap:("(",")") ~break:IfNeed [self#unparseExpr e] - ) - - (* - It's not enough to only check if precedence of an infix left/right is - greater than the infix itself. We also should likely pay attention to - left/right associativity. So how do we render the minimum number of - parenthesis? - - The intuition is that sequential right associative operators will - naturally build up deep trees on the right side (left builds up left-deep - trees). So by default, we add parens to model the tree structure that - we're rendering except when the parser will *naturally* parse the tree - structure that the parens assert. - - Sequential identical infix operators: - ------------------------------------ - So if we see a nested infix operator of precedence Y, as one side of - another infix operator that has the same precedence (Y), that is S - associative on the S side of the function application, we don't need to - wrap in parens. In more detail: - - -Add parens around infix binary function application - Exception 1: Unless we are a left-assoc operator of precedence X in the left branch of an operator w/ precedence X. - Exception 2: Unless we are a right-assoc operator of precedence X in the right branch of an operator w/ precedence X. - Exception 3: Unless we are a _any_-assoc X operator in the _any_ branch of an Y operator where X has greater precedence than Y. - - Note that the exceptions do not specify any special cases for mixing - left/right associativity. Precedence is what determines necessity of - parens for operators with non-identical precedences. Associativity - only determines necessity of parens for identically precedented operators. - - PLUS is left assoc: - - So this one *shouldn't* expand into two consecutive infix +: + method classExpressionToFormattedApplicationItems = + function + | { pcl_desc = Pcl_apply (ce, l) } -> + [ label + (self#simple_class_expr ce) + (self#label_x_expression_params l) + ] + | x -> [ self#class_expr x ] + + method dotdotdotChild expr = + let self = self#inline_braces in + match expr with + | { pexp_desc = Pexp_apply (funExpr, args) } + when printedStringAndFixityExpr funExpr == Normal + && Reason_attributes.without_stylistic_attrs + expr.pexp_attributes + == [] -> + (match + self#formatFunAppl + ~prefix:(atom "...") + ~wrap:("{", "}") + ~jsxAttrs:[] + ~args + ~funExpr + ~applicationExpr:expr + () + with + | [ x ] -> x + | xs -> makeList xs) + | { pexp_desc = Pexp_fun _ } -> + self#formatPexpFun ~prefix:(atom "...") ~wrap:("{", "}") expr + | _ -> + (* Currently spreading a list must be wrapped in { }. + * You can remove the entire even_wrap_simple arg when that is fixed. *) + let even_wrap_simple = + match expr with + | { pexp_desc = + Pexp_construct + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) + } -> + not (Reason_attributes.has_jsx_attributes expr.pexp_attributes) + | _ -> false + in + let childLayout = + self#dont_preserve_braces#simplifyUnparseExpr + ~even_wrap_simple + ~wrap:("{", "}") + expr + in + makeList ~break:Never [ atom "..."; childLayout ] - [Pexp_apply] - / \ - first + [Pexp_apply] - / \ - second + third + (* + * How JSX is formatted/wrapped. We want the attributes to wrap independently + * of children. + * + * + * child + * child + * child + * + * + * +-------------------------------+ + * | left right (list of attrs) | + * | / \ / \ | + * | + * | +---------+ + * +--| | > + * +---------+ + * + * + *) + method formatJSXComponent componentName ?closeComponentName args = + let self = self#inline_braces in + let rec processArguments arguments processedAttrs children = + match arguments with + | (Labelled "children", { pexp_desc = Pexp_construct (_, None) }) + :: tail -> + processArguments tail processedAttrs None + | ( Labelled "children" + , ({ pexp_desc = + Pexp_construct + ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) + } as arg) ) + :: tail -> + (match self#formatJsxChildrenNonSpread arg [] with + (* Back out of the standard jsx child formatting *) + | None -> + processArguments + tail + processedAttrs + (Some [ self#dotdotdotChild arg ]) + | Some chldn -> processArguments tail processedAttrs (Some chldn)) + | (Labelled "children", expr) :: tail -> + processArguments + tail + processedAttrs + (Some [ self#dotdotdotChild expr ]) + | (Optional lbl, expression) :: tail -> + let { Reason_attributes.jsxAttrs; _ } = + Reason_attributes.partitionAttributes expression.pexp_attributes + in + let value_has_jsx = jsxAttrs != [] in + let nextAttr = + match expression.pexp_desc with + | Pexp_ident ident when isPunnedJsxArg lbl ident -> + makeList ~break:Layout.Never [ atom "?"; atom lbl ] + | Pexp_construct _ when value_has_jsx -> + label + (makeList ~break:Layout.Never [ atom lbl; atom "=?" ]) + (self#simplifyUnparseExpr ~wrap:("{", "}") expression) + | _ -> + label + (makeList ~break:Layout.Never [ atom lbl; atom "=?" ]) + (self#dont_preserve_braces#simplifyUnparseExpr + ~wrap:("{", "}") + expression) + in + processArguments tail (nextAttr :: processedAttrs) children + | (Labelled lbl, expression) :: tail -> + let { Reason_attributes.jsxAttrs; _ } = + Reason_attributes.partitionAttributes expression.pexp_attributes + in + let value_has_jsx = jsxAttrs != [] in + let nextAttr = + match expression.pexp_desc with + | Pexp_ident ident when isPunnedJsxArg lbl ident -> atom lbl + | _ when isJSXComponent expression -> + label + (atom (lbl ^ "=")) + (makeList + ~break:IfNeed + ~wrap:("{", "}") + [ self#dont_preserve_braces#simplifyUnparseExpr + expression + ]) + | Pexp_open (me, e) + when self#isSeriesOfOpensFollowedByNonSequencyExpression + expression -> + label + (makeList + [ atom lbl + ; atom "=" + ; label + (self#moduleExpressionToFormattedApplicationItems + me.popen_expr) + (atom ".") + ]) + (self#formatNonSequencyExpression e) + | Pexp_apply (({ pexp_desc = Pexp_ident _ } as funExpr), args) + when printedStringAndFixityExpr funExpr == Normal + && Reason_attributes.without_stylistic_attrs + expression.pexp_attributes + == [] -> + let lhs = makeList [ atom lbl; atom "=" ] in + (match + self#formatFunAppl + ~prefix:lhs + ~wrap:("{", "}") + ~jsxAttrs:[] + ~args + ~funExpr + ~applicationExpr:expression + () + with + | [ x ] -> x + | xs -> makeList xs) + | Pexp_apply (eFun, _) -> + let lhs = makeList [ atom lbl; atom "=" ] in + let rhs = + match printedStringAndFixityExpr eFun with + | Infix str when requireNoSpaceFor str -> + self#unparseExpr expression + | _ -> + self#dont_preserve_braces#simplifyUnparseExpr + ~wrap:("{", "}") + expression + in + label lhs rhs + | Pexp_construct _ when value_has_jsx -> + label + (makeList [ atom lbl; atom "=" ]) + (self#simplifyUnparseExpr ~wrap:("{", "}") expression) + | Pexp_record _ | Pexp_construct _ | Pexp_array _ | Pexp_tuple _ + | Pexp_match _ | Pexp_extension _ | Pexp_function _ -> + label + (makeList [ atom lbl; atom "=" ]) + (self#dont_preserve_braces#simplifyUnparseExpr + ~wrap:("{", "}") + expression) + | Pexp_fun _ -> + let propName = makeList [ atom lbl; atom "=" ] in + self#formatPexpFun + ~wrap:("{", "}") + ~prefix:propName + expression + | _ -> + makeList + [ atom lbl + ; atom "=" + ; self#dont_preserve_braces#simplifyUnparseExpr + ~wrap:("{", "}") + expression + ] + in + processArguments tail (nextAttr :: processedAttrs) children + | [] -> processedAttrs, children + | _ :: tail -> processArguments tail processedAttrs children + in + let reversedAttributes, children = processArguments args [] None in + match children with + | None -> + makeList + ~break:IfNeed + ~wrap:("<" ^ componentName, "/>") + ~pad:(true, true) + ~inline:(false, false) + ~postSpace:true + (List.rev reversedAttributes) + | Some renderedChildren -> + let openTagAndAttrs = + match reversedAttributes with + | [] -> atom ("<" ^ componentName ^ ">") + | revAttrHd :: revAttrTl -> + let finalAttrList = + List.rev + (makeList ~break:Layout.Never [ revAttrHd; atom ">" ] + :: revAttrTl) + in + let renderedAttrList = + makeList + ~inline:(true, true) + ~break:IfNeed + ~pad:(false, false) + ~preSpace:true + finalAttrList + in + label ~space:true (atom ("<" ^ componentName)) renderedAttrList + in + label + openTagAndAttrs + (makeList + ~wrap: + ( "" + , " componentName + | Some close -> close) + ^ ">" ) + ~inline:(true, false) + ~break:IfNeed + ~pad:(true, true) + ~postSpace:true + renderedChildren) + (* + * Format Pexp_fun expression: (a, b) => a + b; + * Example: the `onClick` prop with Pexp_fun in + *
{ + * Js.log(event); + * handleChange(event); + * }} + * />; + * + * The arguments of the callback (Pexp_fun) should be inlined as much as + * possible on the same line as `onClick={`. + * Also notice the brace-hugging `}}` at the end. + * + * ~prefix -> prefixes the Pexp_fun layout, example `onClick=` + * ~wrap -> wraps the `Pexp_fun` in the tuple passed to wrap, e.g. `{` and + * `}` for jsx + *) + method formatPexpFun ?(prefix = atom "") ?(wrap = "", "") expression = + let lwrap, rwrap = wrap in + let { Reason_attributes.stdAttrs; uncurried } = + Reason_attributes.partitionAttributes expression.pexp_attributes + in + if uncurried then Hashtbl.add uncurriedTable expression.pexp_loc true; - - This one *should*: + let args, ret = + (* omit attributes here, we're formatting them manually *) + self#curriedPatternsAndReturnVal + { expression with pexp_attributes = [] } + in + (* Format `onClick={` *) + let propName = makeList ~wrap:("", lwrap) [ prefix ] in + let argsList = + let args = + match args with [ argsList ] -> argsList | args -> makeList args + in + match stdAttrs with + | [] -> args + | attrs -> + (* attach attributes to the args of the Pexp_fun: `[@attr] + (event)` *) + let attrList = + makeList + ~inline:(true, true) + ~break:IfNeed + ~postSpace:true + (List.map self#attribute attrs) + in + let all = [ attrList; args ] in + makeList ~break:IfNeed ~inline:(true, true) ~postSpace:true all + in + (* Format `onClick={(event)` *) + let propNameWithArgs = label propName argsList in + (* Pick constraints: (a, b) :string => ... + * :string is the constraint here *) + let return, optConstr = + match ret.pexp_desc with + | Pexp_constraint (e, ct) -> e, Some (self#non_arrowed_core_type ct) + | _ -> ret, None + in + let returnExpr, leftWrap = + match self#letList return with + | [ x ] -> + (* Format `handleChange(event)}` or + * handleChange(event) + * } + * + * If the closing rwrap is empty, we need it to be inline, otherwise + * we get a empty newline when the layout breaks: + * ``` + * handleChange(event) + * + * ``` + * (Notice to nonsense newline) + *) + let shouldPreserveBraces = + self#should_preserve_requested_braces return + in + let rwrap = if shouldPreserveBraces then "}" ^ rwrap else rwrap in + let inlineClosing = rwrap = "" in + let layout = + makeList + ~break:IfNeed + ~inline:(true, inlineClosing) + ~wrap:("", rwrap) + [ x ] + in + layout, if shouldPreserveBraces then "{" else "" + | xs -> + (* Format `Js.log(event)` and `handleChange(event)` as + * { + * Js.log(event); + * handleChange(event); + * }} + *) + let layout = + makeList + ~break:Always_rec + ~sep:(SepFinal (";", ";")) + ~wrap:("{", "}" ^ rwrap) + xs + in + layout, "" + in + match optConstr with + | Some typeConstraint -> + let upToConstraint = + label + ~space:true + (makeList ~wrap:("", ":") [ propNameWithArgs ]) + typeConstraint + in + label + (makeList ~wrap:("", " => " ^ leftWrap) [ upToConstraint ]) + returnExpr + | None -> + label + (makeList ~wrap:("", " => " ^ leftWrap) [ propNameWithArgs ]) + returnExpr + + (* Creates a list of simple module expressions corresponding to module + expression or functor application. *) + method moduleExpressionToFormattedApplicationItems ?(prefix = "") x = + match x with + (* are we formatting a functor application with a module structure as arg? + * YourLib.Make({ + * type t = int; + * type s = string; + * }); + * + * We should "hug" the parens here: ({ & }) should stick together. + *) + | { pmod_desc = + Pmod_apply + ( ({ pmod_desc = Pmod_ident _ } as m1) + , ({ pmod_desc = Pmod_structure _ } as m2) ) + } -> + let modIdent = + source_map ~loc:m1.pmod_loc (self#simple_module_expr m1) + in + let name = + if prefix <> "" + then makeList ~postSpace:true [ atom prefix; modIdent ] + else modIdent + in + let arg = + source_map ~loc:m2.pmod_loc (self#simple_module_expr ~hug:true m2) + in + label name arg + | _ -> + let rec extract_apps args = function + | { pmod_desc = Pmod_apply (me1, me2) } -> + let arg = + source_map ~loc:me2.pmod_loc (self#simple_module_expr me2) + in + extract_apps (arg :: args) me1 + | me -> + let head = source_map ~loc:me.pmod_loc (self#module_expr me) in + if args == [] then head else label head (makeTup args) + in + let functor_application = extract_apps [] x in + if prefix <> "" + then makeList ~postSpace:true [ atom prefix; functor_application ] + else functor_application - [Pexp_apply] - / \ - [ Pexp_apply ] + third - / \ - first + second + (* + * Watch out, if you see something like below (sixteenTuple getting put on a + * newline), yet a paren-wrapped list wouldn't have had an extra newlin, you + * might need to wrap the single token (sixteenTuple) in [ensureSingleTokenSticksToLabel]. + * let ( + * axx, + * oxx, + * pxx + * ): + * sixteenTuple = echoTuple ( + * 0, + * 0, + * 0 + * ); + *) + method formatSimplePatternBinding + labelOpener + layoutPattern + typeConstraint + appTerms = + let letPattern = + label ~break:`Never ~space:true (atom labelOpener) layoutPattern + in + let upUntilEqual = + match typeConstraint with + | None -> letPattern + | Some tc -> formatTypeConstraint letPattern tc + in + let includingEqual = + makeList ~postSpace:true [ upUntilEqual; atom "=" ] + in + formatAttachmentApplication + applicationFinalWrapping + (Some (true, includingEqual)) + appTerms - - COLONCOLON is right assoc, so - - This one *should* expand into two consecutive infix :: : - - [Pexp_apply] - / \ - first :: [Pexp_apply] - / \ - second :: third - - - - This one *shouldn't*: - - [Pexp_apply] - / \ - [ Pexp_apply ] :: third - / \ - first :: second - - - - - Sequential differing infix operators: - ------------------------------------ - - Neither of the following require paren grouping because of rule 3. - - - [Pexp_apply] - / \ - first + [Pexp_apply] - / \ - second * third - - - [Pexp_apply] - / \ - [Pexp_apply + third - / \ - first * second - - The previous has nothing to do with the fact that + and * have the same - associativity. Exception 3 applies to the following where :: is right assoc - and + is left. + has higher precedence than :: - - - so parens aren't required to group + when it is in a branch of a - lower precedence :: - - [Pexp_apply] - / \ - first :: [Pexp_apply] - / \ - second + third - - - - Whereas there is no Exception that applies in this case (Exception 3 - doesn't apply) so parens are required around the :: in this case. - - [Pexp_apply] - / \ - [ Pexp_apply ] + third - / \ - first :: second - - *) - - method classExpressionToFormattedApplicationItems = function - | { pcl_desc = Pcl_apply (ce, l) } -> - [label (self#simple_class_expr ce) (self#label_x_expression_params l)] - | x -> [self#class_expr x] - - - method dotdotdotChild expr = - let self = self#inline_braces in - match expr with - | {pexp_desc = Pexp_apply (funExpr, args)} - when printedStringAndFixityExpr funExpr == Normal && - Reason_attributes.without_stylistic_attrs expr.pexp_attributes == [] -> - begin match (self#formatFunAppl ~prefix:(atom "...") ~wrap:("{", "}") ~jsxAttrs:[] ~args ~funExpr ~applicationExpr:expr ()) with - | [x] -> x - | xs -> makeList xs - end - | {pexp_desc = Pexp_fun _ } -> - self#formatPexpFun ~prefix:(atom "...") ~wrap:("{", "}") expr - | _ -> - (* Currently spreading a list must be wrapped in { }. - * You can remove the entire even_wrap_simple arg when that is fixed. *) - let even_wrap_simple = match expr with - | {pexp_desc = Pexp_construct ({txt = Lident"::"}, Some {pexp_desc = Pexp_tuple _})} -> - not (Reason_attributes.has_jsx_attributes expr.pexp_attributes) - | _ -> false - in - let childLayout = - self#dont_preserve_braces#simplifyUnparseExpr - ~even_wrap_simple - ~wrap:("{", "}") - expr - in - makeList ~break:Never [atom "..."; childLayout] - (* - How JSX is formatted/wrapped. We want the attributes to wrap independently - of children. - - - child - child - child - - - +-------------------------------+ - | left right (list of attrs) | - | / \ / \ | - | - | +---------+ - +--| | > - +---------+ - - *) - method formatJSXComponent componentName ?closeComponentName args = - let self = self#inline_braces in - let rec processArguments arguments processedAttrs children = - match arguments with - | (Labelled "children", {pexp_desc = Pexp_construct (_, None)}) :: tail -> - processArguments tail processedAttrs None - | (Labelled "children", ( - {pexp_desc = Pexp_construct ({txt = Lident"::"}, Some {pexp_desc = Pexp_tuple _})} as arg - ) - ) :: tail -> - (match self#formatJsxChildrenNonSpread arg [] with - (* Back out of the standard jsx child formatting *) - | None -> processArguments tail processedAttrs (Some [self#dotdotdotChild arg]) - | Some chldn -> processArguments tail processedAttrs (Some chldn)) - | (Labelled "children", expr) :: tail -> - processArguments tail processedAttrs (Some [self#dotdotdotChild expr]) - | (Optional lbl, expression) :: tail -> - let {Reason_attributes.jsxAttrs; _} = Reason_attributes.partitionAttributes expression.pexp_attributes in - let value_has_jsx = jsxAttrs != [] in - let nextAttr = - match expression.pexp_desc with - | Pexp_ident ident when isPunnedJsxArg lbl ident -> - makeList ~break:Layout.Never [atom "?"; atom lbl] - | Pexp_construct _ when value_has_jsx -> - label - (makeList ~break:Layout.Never [atom lbl; atom "=?"]) - (self#simplifyUnparseExpr ~wrap:("{","}") expression) - | _ -> - label - (makeList ~break:Layout.Never [atom lbl; atom "=?"]) - (self#dont_preserve_braces#simplifyUnparseExpr ~wrap:("{","}") expression) in - processArguments tail (nextAttr :: processedAttrs) children - | (Labelled lbl, expression) :: tail -> - let {Reason_attributes.jsxAttrs; _} = Reason_attributes.partitionAttributes expression.pexp_attributes in - let value_has_jsx = jsxAttrs != [] in - let nextAttr = - match expression.pexp_desc with - | Pexp_ident ident when isPunnedJsxArg lbl ident -> atom lbl - | _ when isJSXComponent expression -> - label (atom (lbl ^ "=")) - (makeList ~break:IfNeed ~wrap:("{", "}") - [self#dont_preserve_braces#simplifyUnparseExpr expression]) - | Pexp_open (me, e) - when self#isSeriesOfOpensFollowedByNonSequencyExpression expression -> - label (makeList [atom lbl; - atom "="; - (label (self#moduleExpressionToFormattedApplicationItems me.popen_expr) (atom "."))]) - (self#formatNonSequencyExpression e) - | Pexp_apply ({pexp_desc = Pexp_ident _} as funExpr, args) - when printedStringAndFixityExpr funExpr == Normal && - Reason_attributes.without_stylistic_attrs expression.pexp_attributes == [] -> - let lhs = makeList [atom lbl; atom "="] in - begin match ( - self#formatFunAppl - ~prefix:lhs - ~wrap:("{", "}") - ~jsxAttrs:[] - ~args - ~funExpr - ~applicationExpr:expression - ()) - with - | [x] -> x - | xs -> makeList xs - end - | Pexp_apply (eFun, _) -> - let lhs = makeList [atom lbl; atom "="] in - let rhs = (match printedStringAndFixityExpr eFun with - | Infix str when requireNoSpaceFor str -> self#unparseExpr expression - | _ -> self#dont_preserve_braces#simplifyUnparseExpr ~wrap:("{","}") expression) - in label lhs rhs - | Pexp_construct _ when value_has_jsx -> - label - (makeList [atom lbl; atom "="]) - (self#simplifyUnparseExpr ~wrap:("{","}") expression) - | Pexp_record _ - | Pexp_construct _ - | Pexp_array _ - | Pexp_tuple _ - | Pexp_match _ - | Pexp_extension _ - | Pexp_function _ -> - label - (makeList [atom lbl; atom "="]) - (self#dont_preserve_braces#simplifyUnparseExpr ~wrap:("{","}") expression) - | Pexp_fun _ -> - let propName = makeList [atom lbl; atom "="] in - self#formatPexpFun ~wrap:("{", "}") ~prefix:propName expression - | _ -> makeList [ - atom lbl; - atom "="; - self#dont_preserve_braces#simplifyUnparseExpr ~wrap:("{","}") expression - ] - in - processArguments tail (nextAttr :: processedAttrs) children - | [] -> (processedAttrs, children) - | _ :: tail -> processArguments tail processedAttrs children - in - let (reversedAttributes, children) = processArguments args [] None in - match children with - | None -> - makeList - ~break:IfNeed - ~wrap:("<" ^ componentName, "/>") - ~pad:(true, true) - ~inline:(false, false) - ~postSpace:true - (List.rev reversedAttributes) - | Some renderedChildren -> - let openTagAndAttrs = - match reversedAttributes with - | [] -> (atom ("<" ^ componentName ^ ">")) - | revAttrHd::revAttrTl -> - let finalAttrList = (List.rev (makeList ~break:Layout.Never [revAttrHd; atom ">"] :: revAttrTl)) in - let renderedAttrList = (makeList ~inline:(true, true) ~break:IfNeed ~pad:(false, false) ~preSpace:true finalAttrList) in - label - ~space:true - (atom ("<" ^ componentName)) - renderedAttrList - in - label - openTagAndAttrs - (makeList - ~wrap:("", " componentName | Some close -> close) ^ ">") - ~inline:(true, false) - ~break:IfNeed - ~pad:(true, true) - ~postSpace:true - renderedChildren) - - (* - * Format Pexp_fun expression: (a, b) => a + b; - * Example: the `onClick` prop with Pexp_fun in - *
{ - * Js.log(event); - * handleChange(event); - * }} - * />; - * - * The arguments of the callback (Pexp_fun) should be inlined as much as - * possible on the same line as `onClick={`. - * Also notice the brace-hugging `}}` at the end. - * - * ~prefix -> prefixes the Pexp_fun layout, example `onClick=` - * ~wrap -> wraps the `Pexp_fun` in the tuple passed to wrap, e.g. `{` and - * `}` for jsx - *) - method formatPexpFun ?(prefix=(atom "")) ?(wrap=("","")) expression = - let (lwrap, rwrap) = wrap in - let {Reason_attributes.stdAttrs; uncurried} = Reason_attributes.partitionAttributes expression.pexp_attributes in - if uncurried then Hashtbl.add uncurriedTable expression.pexp_loc true; - - let (args, ret) = - (* omit attributes here, we're formatting them manually *) - self#curriedPatternsAndReturnVal {expression with pexp_attributes = [] } - in - (* Format `onClick={` *) - let propName = makeList ~wrap:("", lwrap) [prefix] in - let argsList = - let args = match args with - | [argsList] -> argsList - | args -> makeList args - in - match stdAttrs with - | [] -> args - | attrs -> - (* attach attributes to the args of the Pexp_fun: `[@attr] (event)` *) - let attrList = - makeList ~inline:(true, true) ~break:IfNeed ~postSpace:true - (List.map self#attribute attrs) - in - let all = [attrList; args] in - makeList ~break:IfNeed ~inline:(true, true) ~postSpace:true all - in - (* Format `onClick={(event)` *) - let propNameWithArgs = label propName argsList in - (* Pick constraints: (a, b) :string => ... - * :string is the constraint here *) - let (return, optConstr) = match ret.pexp_desc with - | Pexp_constraint (e, ct) -> (e, Some (self#non_arrowed_core_type ct)) - | _ -> (ret, None) - in - let returnExpr, leftWrap = match (self#letList return) with - | [x] -> - (* Format `handleChange(event)}` or - * handleChange(event) - * } - * - * If the closing rwrap is empty, we need it to be inline, otherwise - * we get a empty newline when the layout breaks: - * ``` - * handleChange(event) - * - * ``` - * (Notice to nonsense newline) - *) - let shouldPreserveBraces = self#should_preserve_requested_braces return in - let rwrap = if shouldPreserveBraces then - "}" ^ rwrap - else - rwrap - in - let inlineClosing = rwrap = "" in - let layout = - makeList ~break:IfNeed ~inline:(true, inlineClosing) ~wrap:("", rwrap) [x] - in - layout, if shouldPreserveBraces then "{" else "" - | xs -> - (* Format `Js.log(event)` and `handleChange(event)` as - * { - * Js.log(event); - * handleChange(event); - * }} - *) - let layout = makeList - ~break:Always_rec ~sep:(SepFinal (";", ";")) ~wrap:("{", "}" ^ rwrap) - xs - in - layout, "" - in - match optConstr with - | Some typeConstraint -> - let upToConstraint = - label ~space:true - (makeList ~wrap:("", ":") [propNameWithArgs]) - typeConstraint - in - label - (makeList ~wrap:("", " => " ^ leftWrap) [upToConstraint]) - returnExpr - | None -> - label - (makeList ~wrap:("", " => " ^ leftWrap) [propNameWithArgs]) - returnExpr - - (* Creates a list of simple module expressions corresponding to module - expression or functor application. *) - method moduleExpressionToFormattedApplicationItems ?(prefix="") x = - match x with - (* are we formatting a functor application with a module structure as arg? - * YourLib.Make({ - * type t = int; - * type s = string; - * }); - * - * We should "hug" the parens here: ({ & }) should stick together. - *) - | { pmod_desc = Pmod_apply ( - ({pmod_desc = Pmod_ident _} as m1), - ({pmod_desc = Pmod_structure _} as m2) - ) - } -> - let modIdent = source_map ~loc:m1.pmod_loc (self#simple_module_expr m1) in - let name = if prefix <> "" then - makeList ~postSpace:true [atom prefix; modIdent] - else modIdent - in - let arg = source_map ~loc:m2.pmod_loc (self#simple_module_expr ~hug:true m2) in - label name arg - | _ -> - let rec extract_apps args = function - | { pmod_desc = Pmod_apply (me1, me2) } -> - let arg = source_map ~loc:me2.pmod_loc (self#simple_module_expr me2) in - extract_apps (arg :: args) me1 - | me -> - let head = source_map ~loc:me.pmod_loc (self#module_expr me) in - if args == [] then head else label head (makeTup args) - in - let functor_application = extract_apps [] x in - if prefix <> "" then - makeList ~postSpace:true [atom prefix; functor_application] - else - functor_application - - (* - - Watch out, if you see something like below (sixteenTuple getting put on a - newline), yet a paren-wrapped list wouldn't have had an extra newlin, you - might need to wrap the single token (sixteenTuple) in [ensureSingleTokenSticksToLabel]. - let ( - axx, - oxx, - pxx - ): - sixteenTuple = echoTuple ( - 0, - 0, - 0 - ); - *) - - method formatSimplePatternBinding labelOpener layoutPattern typeConstraint appTerms = - let letPattern = label ~break:`Never ~space:true (atom labelOpener) layoutPattern in - let upUntilEqual = - match typeConstraint with - | None -> letPattern - | Some tc -> formatTypeConstraint letPattern tc - in - let includingEqual = makeList ~postSpace:true [upUntilEqual; atom "="] in - formatAttachmentApplication applicationFinalWrapping (Some (true, includingEqual)) appTerms - - (* - The [bindingLabel] is either the function name (if let binding) or first - arg (if lambda). - - For defining layout of the following form: - - lbl one - two - constraint => { - ... - } - - If using "=" as the arrow, can also be used for: - - met private - myMethod - constraint = fun ... - - *) - method wrapCurriedFunctionBinding - ?attachTo - ~arrow - ?(sweet=false) - ?(spaceBeforeArrow=true) - prefixText - bindingLabel - patternList - returnedAppTerms = - let allPatterns = bindingLabel::patternList in - let partitioning = curriedFunctionFinalWrapping allPatterns in - let everythingButReturnVal = - (* - Because align_closing is set to false, you get: - - (Brackets[] inserted to show boundaries between open/close of pattern list) - let[firstThing - secondThing - thirdThing] - - It only wraps to indent four by coincidence: If the "opening" token was - longer, you'd get: - - letReallyLong[firstThing - secondThing - thirdThing] - - For curried let bindings, we stick the arrow in the *last* pattern: - let[firstThing - secondThing - thirdThing =>] - - But it could have just as easily been the "closing" token corresponding to - "let". This works because we have [align_closing = false]. The benefit of - shoving it in the last pattern, is that we can turn [align_closing = true] - and still have the arrow stuck to the last pattern (which is usually what we - want) (See modeTwo below). - *) - match partitioning with - | None when sweet -> - makeList - ~pad:(false, spaceBeforeArrow) - ~wrap:("", arrow) - ~indent:(settings.space * settings.indentWrappedPatternArgs) - ~postSpace:true - ~inline:(true, true) - ~break:IfNeed - allPatterns - | None -> - (* We want the binding label to break *with* the arguments. Again, - there's no apparent way to add additional indenting for the - args with this setting. *) - + (* + * The [bindingLabel] is either the function name (if let binding) or first + * arg (if lambda). + * + * For defining layout of the following form: + * + * lbl one + * two + * constraint => { + * ... + * } + * + * If using "=" as the arrow, can also be used for: + * + * met private + * myMethod + * constraint = fun ... + * + *) + method wrapCurriedFunctionBinding + ?attachTo + ~arrow + ?(sweet = false) + ?(spaceBeforeArrow = true) + prefixText + bindingLabel + patternList + returnedAppTerms = + let allPatterns = bindingLabel :: patternList in + let partitioning = curriedFunctionFinalWrapping allPatterns in + let everythingButReturnVal = (* - Formats lambdas by treating the first pattern as the - "bindingLabel" which is kind of strange in some cases (when - you only have one arg that wraps)... - - echoTheEchoer ( - fun ( - a, - p - ) => ( - a, - b - ) - - But it makes sense in others (where you have multiple args): - - echoTheEchoer ( - fun ( - a, - p - ) - mySecondArg - myThirdArg => ( - a, - b - ) - - Try any other convention for wrapping that first arg and it - won't look as balanced when adding multiple args. + * Because align_closing is set to false, you get: + * + * (Brackets[] inserted to show boundaries between open/close of pattern list) + * let[firstThing + * secondThing + * thirdThing] + * + * It only wraps to indent four by coincidence: If the "opening" token was + * longer, you'd get: + * + * letReallyLong[firstThing + * secondThing + * thirdThing] + * + * For curried let bindings, we stick the arrow in the *last* pattern: + * let[firstThing + * secondThing + * thirdThing =>] + * + * But it could have just as easily been the "closing" token corresponding to + * "let". This works because we have [align_closing = false]. The benefit of + * shoving it in the last pattern, is that we can turn [align_closing = true] + * and still have the arrow stuck to the last pattern (which is usually what we + * want) (See modeTwo below). + *) + match partitioning with + | None when sweet -> + makeList + ~pad:(false, spaceBeforeArrow) + ~wrap:("", arrow) + ~indent:(settings.space * settings.indentWrappedPatternArgs) + ~postSpace:true + ~inline:(true, true) + ~break:IfNeed + allPatterns + | None -> + (* We want the binding label to break *with* the arguments. Again, + there's no apparent way to add additional indenting for the + args with this setting. *) - *) - makeList - ~pad:(true, spaceBeforeArrow) - ~wrap:(prefixText, arrow) - ~indent:(settings.space * settings.indentWrappedPatternArgs) - ~postSpace:true - ~inline:(true, true) - ~break:IfNeed - allPatterns - | Some (attachedList, wrappedListy) -> - (* To get *only* the final argument to "break", while not - necessarily breaking the prior arguments, we dock everything - but the last item to a created label *) - label - ~space:true - ( + (* + * Formats lambdas by treating the first pattern as the + * "bindingLabel" which is kind of strange in some cases (when + * you only have one arg that wraps)... + * + * echoTheEchoer ( + * fun ( + * a, + * p + * ) => ( + * a, + * b + * ) + * + * But it makes sense in others (where you have multiple args): + * + * echoTheEchoer ( + * fun ( + * a, + * p + * ) + * mySecondArg + * myThirdArg => ( + * a, + * b + * ) + * + * Try any other convention for wrapping that first arg and it + * won't look as balanced when adding multiple args. + *) makeList ~pad:(true, spaceBeforeArrow) ~wrap:(prefixText, arrow) @@ -5015,3555 +5810,4330 @@ let printer = object(self:'self) ~postSpace:true ~inline:(true, true) ~break:IfNeed - attachedList - ) - wrappedListy - in - - let everythingButAppTerms = match attachTo with - | None -> everythingButReturnVal - | Some toThis -> label ~space:true toThis everythingButReturnVal - in - formatAttachmentApplication - applicationFinalWrapping - (Some (true, everythingButAppTerms)) - returnedAppTerms - - method leadingCurriedAbstractTypes x = - let rec argsAndReturn xx = - match xx.pexp_desc with - | Pexp_newtype (str,e) -> - let (nextArgs, return) = argsAndReturn e in - (str::nextArgs, return) - | _ -> ([], xx.pexp_desc) - in argsAndReturn x - - method curriedConstructorPatternsAndReturnVal cl = - let rec argsAndReturn args = function - | { pcl_desc = Pcl_fun (label, eo, p, e); pcl_attributes = [] } -> - let arg = source_map ~loc:p.ppat_loc (self#label_exp label eo p) in - argsAndReturn (arg :: args) e - | xx -> - if args == [] then (None, xx) else (Some (makeTup (List.rev args)), xx) - in - argsAndReturn [] cl - - - (* - Returns the arguments list (if any, that occur before the =>), and the - final expression (that is either returned from the function (after =>) or - that is bound to the value (if there are no arguments, and this is just a - let pattern binding)). - *) - method curriedPatternsAndReturnVal x = - let uncurried = try Hashtbl.find uncurriedTable x.pexp_loc with | Not_found -> false in - let rec extract_args xx = - let {Reason_attributes.stdAttrs} = Reason_attributes.partitionAttributes ~allowUncurry:false xx.pexp_attributes in - if stdAttrs != [] then - ([], xx) - else match xx.pexp_desc with - (* label * expression option * pattern * expression *) - | Pexp_fun (l, eo, p, e) -> - let args, ret = extract_args e in - (`Value (l,eo,p) :: args, ret) - | Pexp_newtype (newtype,e) -> - let args, ret = extract_args e in - (`Type newtype :: args, ret) - | Pexp_constraint _ -> ([], xx) - | _ -> ([], xx) - in - let prepare_arg = function - | `Value (l,eo,p) -> source_map ~loc:p.ppat_loc (self#label_exp l eo p) - | `Type nt -> atom ("type " ^ nt.txt) - in - let single_argument_no_parens p ret = - if uncurried then false - else - let isUnitPat = is_unit_pattern p in - let isAnyPat = is_any_pattern p in - begin match ret.pexp_desc with - (* (event) :ReasonReact.event => {...} - * The above Pexp_fun with constraint ReasonReact.event requires parens - * surrounding the single argument `event`.*) - | Pexp_constraint _ when not isUnitPat && not isAnyPat -> false - | _ -> isUnitPat || isAnyPat || is_ident_pattern p - end - in - match extract_args x with - | ([], ret) -> ([], ret) - | ([`Value (Nolabel, None, p) ], ret) when is_unit_pattern p && uncurried -> - ( [atom "(.)"], ret) - | ([`Value (Nolabel, None, p) as arg], ret) when single_argument_no_parens p ret -> - ([prepare_arg arg], ret) - | (args, ret) -> - ([makeTup ~uncurried (List.map prepare_arg args)], ret) - - (* Returns the (curriedModule, returnStructure) for a functor *) - method curriedFunctorPatternsAndReturnStruct = function - (* string loc * module_type option * module_expr *) - | { pmod_desc = Pmod_functor(fp, me2) } -> - let firstOne = - match fp with - | Unit -> atom "" - | Named (s, mt') -> - let s = moduleIdent s in - self#module_type (makeList [atom s; atom ":"]) mt' - in - let (functorArgsRecurse, returnStructure) = (self#curriedFunctorPatternsAndReturnStruct me2) in - (firstOne::functorArgsRecurse, returnStructure) - | me -> ([], me) - - method isRenderableAsPolymorphicAbstractTypes - typeVars - polyType - leadingAbstractVars - nonVarifiedType = - same_ast_modulo_varification_and_extensions polyType nonVarifiedType && - for_all2' string_loc_equal typeVars leadingAbstractVars - - (* Reinterpret this as a pattern constraint since we don't currently have a - way to disambiguate. There is currently a way to disambiguate a parsing - from Ppat_constraint vs. Pexp_constraint. Currently (and consistent with - OCaml standard parser): - - let (x: typ) = blah; - Becomes Ppat_constraint - let x:poly . type = blah; - Becomes Ppat_constraint - let x:typ = blah; - Becomes Pexp_constraint(ghost) - let x = (blah:typ); - Becomes Pexp_constraint(ghost) - - How are double constraints represented? - let (x:typ) = (blah:typ); - If currently both constraints are parsed into a single Pexp_constraint, - then something must be lost, and how could you fail type checking on: - let x:int = (10:string) ?? Answer: It probably parses into a nested - Pexp_constraint. - - Proposal: - - let (x: typ) = blah; - Becomes Ppat_constraint (still) - let x:poly . type = blah; - Becomes Ppat_constraint (still) - let x:typ = blah; - Becomes Ppat_constraint - let x = blah:typ; - Becomes Pexp_constraint - - - Reasoning: Allows parsing of any of the currently valid ML forms, but - combines the two most similar into one form. The only lossyness is the - unnecessary parens, which there is already precedence for dropping in - expressions. In the existing approach, preserving a paren-constrained - expression is *impossible* because it becomes pretty printed as - let x:t =.... In the proposal, it is not impossible - it is only - impossible to preserve unnecessary parenthesis around the let binding. - - The one downside is that integrating with existing code that uses [let x = - (blah:typ)] in standard OCaml will be parsed as a Pexp_constraint. There - might be some lossiness (beyond parens) that occurs in the original OCaml - parser. - *) - - method locallyAbstractPolymorphicFunctionBinding prefixText layoutPattern funWithNewTypes absVars bodyType = - let appTerms = self#unparseExprApplicationItems funWithNewTypes in - let locallyAbstractTypes = (List.map (fun x -> atom x.txt) absVars) in - let typeLayout = - source_map ~loc:bodyType.ptyp_loc (self#core_type bodyType) - in - let polyType = - label - ~space:true - (* TODO: This isn't a correct use of sep! It ruins how - * comments are interleaved. *) - (makeList [makeList ~sep:(Sep " ") (atom "type"::locallyAbstractTypes); atom "."]) - typeLayout - in - self#formatSimplePatternBinding - prefixText - layoutPattern - (Some polyType) - appTerms - - (** - Intelligently switches between: - Curried function binding w/ constraint on return expr: - lbl patt - pattAux - arg - :constraint => { - ... - } - - Constrained: - lbl patt - pattAux... - :constraint = { - ... - } - *) - method wrappedBinding prefixText ~arrow pattern patternAux expr = - let expr = self#process_underscore_application expr in - let (argsList, return) = self#curriedPatternsAndReturnVal expr in - let patternList = match patternAux with - | [] -> pattern - | _::_ -> makeList ~postSpace:true ~inline:(true, true) ~break:IfNeed (pattern::patternAux) - in - match (argsList, return.pexp_desc) with - | ([], Pexp_constraint (e, ct)) -> - let typeLayout = - source_map ~loc:ct.ptyp_loc - begin match ct.ptyp_desc with - | Ptyp_package (li, cstrs) -> - self#typ_package li cstrs - | _ -> - self#core_type ct - end - in - let appTerms = self#unparseExprApplicationItems e in - self#formatSimplePatternBinding prefixText patternList (Some typeLayout) appTerms - | ([], _) -> - (* simple let binding, e.g. `let number = 5` *) - (* let f = (. a, b) => a + b; *) - let appTerms = self#unparseExprApplicationItems expr in - self#formatSimplePatternBinding prefixText patternList None appTerms - | (_::_, _) -> - let (argsWithConstraint, actualReturn) = self#normalizeFunctionArgsConstraint argsList return in - let fauxArgs = - List.concat [patternAux; argsWithConstraint] in - let returnedAppTerms = self#unparseExprApplicationItems actualReturn in - (* Attaches the `=` to `f` to recreate javascript function syntax in - * let f = (a, b) => a + b; *) - let lbl = makeList ~sep:(Sep " ") ~break:Layout.Never [pattern; atom "="] in - self#wrapCurriedFunctionBinding prefixText ~arrow lbl fauxArgs returnedAppTerms - - (* Similar to the above method. *) - method wrappedClassBinding prefixText pattern patternAux expr = - let (args, return) = self#curriedConstructorPatternsAndReturnVal expr in - let patternList = - match patternAux with - | [] -> pattern - | _::_ -> makeList ~postSpace:true ~inline:(true, true) ~break:IfNeed (pattern::patternAux) - in - match (args, return.pcl_desc) with - | (None, Pcl_constraint (e, ct)) -> - let typeLayout = source_map ~loc:ct.pcty_loc (self#class_constructor_type ct) in - self#formatSimplePatternBinding prefixText patternList (Some typeLayout) - (self#classExpressionToFormattedApplicationItems e, None) - | (None, _) -> - self#formatSimplePatternBinding prefixText patternList None - (self#classExpressionToFormattedApplicationItems expr, None) - | (Some args, _) -> - let (argsWithConstraint, actualReturn) = - self#normalizeConstructorArgsConstraint [args] return in - let fauxArgs = - List.concat [patternAux; argsWithConstraint] in - self#wrapCurriedFunctionBinding prefixText ~arrow:"=" pattern fauxArgs - (self#classExpressionToFormattedApplicationItems actualReturn, None) - - (* Attaches doc comments to a layout, with whitespace preserved - * Example: - * /** Doc comment */ - * - * /* another random comment */ - * let a = 1; - *) - method attachDocAttrsToLayout - (* all std attributes attached on the ast node backing the layout *) - ~stdAttrs:(stdAttrs : Parsetree.attributes) - (* all doc comments attached on the ast node backing the layout *) - ~docAttrs:(docAttrs : Parsetree.attributes) - (* location of the layout *) - ~loc - (* layout to attach the doc comments to *) - ~layout () = - (* - * compute the correct location of layout - * Example: - * 1| /** doc-comment */ - * 2| - * 3| [@attribute] - * 4| let a = 1; - * - * The location might indicate a start of line 4 for the ast-node - * representing `let a = 1`. The reality is that `[@attribute]` should be - * included (start of line 3), to represent the correct start location - * of the whole layout. - *) - let loc = match stdAttrs with - | { attr_name = astLoc; _}::_ -> astLoc.loc - | [] -> loc - in - let rec aux prevLoc layout = function - | ({ attr_name = x; _} as attr : Parsetree.attribute)::xs -> - let newLayout = - let range = Range.makeRangeBetween x.loc prevLoc in - let layout = - if Range.containsWhitespace ~range ~comments:self#comments () then - let region = WhitespaceRegion.make ~range ~newlines:1 () in - Layout.Whitespace(region, layout) - else layout - in - makeList ~inline:(true, true) ~break:Always [ - self#attribute attr; - layout - ] - in aux x.loc newLayout xs - | [] -> layout - in - aux loc layout (List.rev docAttrs) - - method value_binding prefixText { pvb_pat; pvb_attributes; pvb_loc; pvb_expr } = - self#binding prefixText ~attrs:pvb_attributes ~loc:pvb_loc ~pat:pvb_pat pvb_expr - - method binding_op prefixText { pbop_pat; pbop_loc; pbop_exp } = - self#binding (Reason_syntax_util.escape_stars_slashes prefixText) ~loc:pbop_loc ~pat:pbop_pat pbop_exp + allPatterns + | Some (attachedList, wrappedListy) -> + (* To get *only* the final argument to "break", while not + necessarily breaking the prior arguments, we dock everything + but the last item to a created label *) + label + ~space:true + (makeList + ~pad:(true, spaceBeforeArrow) + ~wrap:(prefixText, arrow) + ~indent:(settings.space * settings.indentWrappedPatternArgs) + ~postSpace:true + ~inline:(true, true) + ~break:IfNeed + attachedList) + wrappedListy + in - method binding prefixText ?(attrs=[]) ~loc ~pat expr = (* TODO: print attributes *) - let body = match pat.ppat_attributes, pat.ppat_desc with - | [], (Ppat_var _) -> - self#wrappedBinding prefixText ~arrow:"=>" - (source_map ~loc:pat.ppat_loc (self#simple_pattern pat)) - [] expr - (* - Ppat_constraint is used in bindings of the form + let everythingButAppTerms = + match attachTo with + | None -> everythingButReturnVal + | Some toThis -> label ~space:true toThis everythingButReturnVal + in + formatAttachmentApplication + applicationFinalWrapping + (Some (true, everythingButAppTerms)) + returnedAppTerms + + method leadingCurriedAbstractTypes x = + let rec argsAndReturn xx = + match xx.pexp_desc with + | Pexp_newtype (str, e) -> + let nextArgs, return = argsAndReturn e in + str :: nextArgs, return + | _ -> [], xx.pexp_desc + in + argsAndReturn x - let (inParenVar:typ) = ... + method curriedConstructorPatternsAndReturnVal cl = + let rec argsAndReturn args = function + | { pcl_desc = Pcl_fun (label, eo, p, e); pcl_attributes = [] } -> + let arg = + source_map ~loc:p.ppat_loc (self#label_exp label eo p) + in + argsAndReturn (arg :: args) e + | xx -> + if args == [] + then None, xx + else Some (makeTup (List.rev args)), xx + in + argsAndReturn [] cl + + (* Returns the arguments list (if any, that occur before the =>), and + the final expression (that is either returned from the function + (after =>) or that is bound to the value (if there are no arguments, + and this is just a let pattern binding)). *) + method curriedPatternsAndReturnVal x = + let uncurried = + try Hashtbl.find uncurriedTable x.pexp_loc with Not_found -> false + in + let rec extract_args xx = + let { Reason_attributes.stdAttrs } = + Reason_attributes.partitionAttributes + ~allowUncurry:false + xx.pexp_attributes + in + if stdAttrs != [] + then [], xx + else + match xx.pexp_desc with + (* label * expression option * pattern * expression *) + | Pexp_fun (l, eo, p, e) -> + let args, ret = extract_args e in + `Value (l, eo, p) :: args, ret + | Pexp_newtype (newtype, e) -> + let args, ret = extract_args e in + `Type newtype :: args, ret + | Pexp_constraint _ -> [], xx + | _ -> [], xx + in + let prepare_arg = function + | `Value (l, eo, p) -> + source_map ~loc:p.ppat_loc (self#label_exp l eo p) + | `Type nt -> atom ("type " ^ nt.txt) + in + let single_argument_no_parens p ret = + if uncurried + then false + else + let isUnitPat = is_unit_pattern p in + let isAnyPat = is_any_pattern p in + match ret.pexp_desc with + (* (event) :ReasonReact.event => {...} + * The above Pexp_fun with constraint ReasonReact.event requires parens + * surrounding the single argument `event`.*) + | Pexp_constraint _ when (not isUnitPat) && not isAnyPat -> false + | _ -> isUnitPat || isAnyPat || is_ident_pattern p + in + match extract_args x with + | [], ret -> [], ret + | [ `Value (Nolabel, None, p) ], ret + when is_unit_pattern p && uncurried -> + [ atom "(.)" ], ret + | [ (`Value (Nolabel, None, p) as arg) ], ret + when single_argument_no_parens p ret -> + [ prepare_arg arg ], ret + | args, ret -> [ makeTup ~uncurried (List.map prepare_arg args) ], ret + + (* Returns the (curriedModule, returnStructure) for a functor *) + method curriedFunctorPatternsAndReturnStruct = + function + (* string loc * module_type option * module_expr *) + | { pmod_desc = Pmod_functor (fp, me2) } -> + let firstOne = + match fp with + | Unit -> atom "" + | Named (s, mt') -> + let s = moduleIdent s in + self#module_type (makeList [ atom s; atom ":" ]) mt' + in + let functorArgsRecurse, returnStructure = + self#curriedFunctorPatternsAndReturnStruct me2 + in + firstOne :: functorArgsRecurse, returnStructure + | me -> [], me + + method isRenderableAsPolymorphicAbstractTypes + typeVars + polyType + leadingAbstractVars + nonVarifiedType = + same_ast_modulo_varification_and_extensions polyType nonVarifiedType + && for_all2' string_loc_equal typeVars leadingAbstractVars + + (* Reinterpret this as a pattern constraint since we don't currently have a + * way to disambiguate. There is currently a way to disambiguate a parsing + * from Ppat_constraint vs. Pexp_constraint. Currently (and consistent with + * OCaml standard parser): + + * let (x: typ) = blah; + * Becomes Ppat_constraint + * let x:poly . type = blah; + * Becomes Ppat_constraint + * let x:typ = blah; + * Becomes Pexp_constraint(ghost) + * let x = (blah:typ); + * Becomes Pexp_constraint(ghost) + * + * How are double constraints represented? + * let (x:typ) = (blah:typ); + * If currently both constraints are parsed into a single Pexp_constraint, + * then something must be lost, and how could you fail type checking on: + * let x:int = (10:string) ?? Answer: It probably parses into a nested + * Pexp_constraint. + * + * Proposal: + * + * let (x: typ) = blah; + * Becomes Ppat_constraint (still) + * let x:poly . type = blah; + * Becomes Ppat_constraint (still) + * let x:typ = blah; + * Becomes Ppat_constraint + * let x = blah:typ; + * Becomes Pexp_constraint + * + * + * Reasoning: Allows parsing of any of the currently valid ML forms, but + * combines the two most similar into one form. The only lossyness is the + * unnecessary parens, which there is already precedence for dropping in + * expressions. In the existing approach, preserving a paren-constrained + * expression is *impossible* because it becomes pretty printed as + * let x:t =.... In the proposal, it is not impossible - it is only + * impossible to preserve unnecessary parenthesis around the let binding. + * + * The one downside is that integrating with existing code that uses [let x = + * (blah:typ)] in standard OCaml will be parsed as a Pexp_constraint. There + * might be some lossiness (beyond parens) that occurs in the original OCaml + * parser. + *) - And in the case of let bindings for explicitly polymorphic type - annotations (see parser for more details). + method locallyAbstractPolymorphicFunctionBinding + prefixText + layoutPattern + funWithNewTypes + absVars + bodyType = + let appTerms = self#unparseExprApplicationItems funWithNewTypes in + let locallyAbstractTypes = List.map (fun x -> atom x.txt) absVars in + let typeLayout = + source_map ~loc:bodyType.ptyp_loc (self#core_type bodyType) + in + let polyType = + label + ~space:true + (* TODO: This isn't a correct use of sep! It ruins how + * comments are interleaved. *) + (makeList + [ makeList ~sep:(Sep " ") (atom "type" :: locallyAbstractTypes) + ; atom "." + ]) + typeLayout + in + self#formatSimplePatternBinding + prefixText + layoutPattern + (Some polyType) + appTerms - See reason_parser.mly for explanation of how we encode the two primary - forms of explicit polymorphic annotations in the parse tree, and how - we must recover them here. - *) - | [], (Ppat_open (lid, {ppat_desc = Ppat_record(l, closed); _})) -> (* - Special case handling for: - - let Foo.{ - destruct1, - destruct2, - destruct3, - destruct4, - destruct5, - } = bar; - *) - - let upUntilEqual = - let pat = self#patternRecord l closed in - label - (label ~space:true - (atom prefixText) - (label - (self#longident_loc lid) - (atom (".")) - ) - ) - pat - in - let appTerms = self#unparseExprApplicationItems expr in - let includingEqual = makeList ~postSpace:true [upUntilEqual; atom "="] in - formatAttachmentApplication applicationFinalWrapping (Some (true, includingEqual)) appTerms - | [], (Ppat_constraint(p, ty)) -> ( - (* Locally abstract forall types are *seriously* mangled by the parsing - stage, and we have to be very smart about how to recover it. - - let df_locallyAbstractFuncAnnotated: - type a b. - a => - b => - (inputEchoRecord a, inputEchoRecord b) = - fun (input: a) (input2: b) => ( - {inputIs: input}, - {inputIs: input2} - ); - - becomes: - - let df_locallyAbstractFuncAnnotatedTwo: - 'a 'b . - 'a => 'b => (inputEchoRecord 'a, inputEchoRecord 'b) - = - fun (type a) (type b) => ( - fun (input: a) (input2: b) => ({inputIs: input}, {inputIs:input2}): - a => b => (inputEchoRecord a, inputEchoRecord b) - ); - *) - let layoutPattern = - source_map ~loc:pat.ppat_loc (self#simple_pattern p) - in - let leadingAbsTypesAndExpr = self#leadingCurriedAbstractTypes expr in - match (p.ppat_desc, ty.ptyp_desc, leadingAbsTypesAndExpr) with - | (Ppat_var _, - Ptyp_poly (typeVars, varifiedPolyType), - (_::_ as absVars, Pexp_constraint(funWithNewTypes, nonVarifiedExprType))) - when self#isRenderableAsPolymorphicAbstractTypes - typeVars - (* If even artificially varified - don't know until returns*) - varifiedPolyType - absVars - nonVarifiedExprType -> - (* - We assume was the case whenever we see this pattern in the - AST, it was because the parser parsed the polymorphic locally - abstract type sugar. - - Ppat_var..Ptyp_poly...Pexp_constraint: - - let x: 'a 'b . 'a => 'b => 'b = - fun (type a) (type b) => - (fun aVal bVal => bVal : a => b => b); - - We need to be careful not to accidentally detect similar - forms, that cannot be printed as sugar. - - let x: 'a 'b . 'a => 'b => 'b = - fun (type a) (type b) => - (fun aVal bVal => bVal : int => int => int); - - Should *NOT* be formatted as: - - let x: type a b. int => int => int = fun aVal bVal => bVal; - - The helper function - [same_ast_modulo_varification_and_extensions] was created to - help compare the varified constraint pattern body, and the - non-varified expression constraint type. - - The second requirement that we check before assuming that the - sugar form is correct, is to make sure the list of type vars - corresponds to a leading prefix of the Pexp_newtype variables. - *) - self#locallyAbstractPolymorphicFunctionBinding + * Intelligently switches between: + * Curried function binding w/ constraint on return expr: + * lbl patt + * pattAux + * arg + * :constraint => { + * ... + * } + * + * Constrained: + * lbl patt + * pattAux... + * :constraint = { + * ... + * } + *) + method wrappedBinding prefixText ~arrow pattern patternAux expr = + let expr = self#process_underscore_application expr in + let argsList, return = self#curriedPatternsAndReturnVal expr in + let patternList = + match patternAux with + | [] -> pattern + | _ :: _ -> + makeList + ~postSpace:true + ~inline:(true, true) + ~break:IfNeed + (pattern :: patternAux) + in + match argsList, return.pexp_desc with + | [], Pexp_constraint (e, ct) -> + let typeLayout = + source_map + ~loc:ct.ptyp_loc + (match ct.ptyp_desc with + | Ptyp_package (li, cstrs) -> self#typ_package li cstrs + | _ -> self#core_type ct) + in + let appTerms = self#unparseExprApplicationItems e in + self#formatSimplePatternBinding + prefixText + patternList + (Some typeLayout) + appTerms + | [], _ -> + (* simple let binding, e.g. `let number = 5` *) + (* let f = (. a, b) => a + b; *) + let appTerms = self#unparseExprApplicationItems expr in + self#formatSimplePatternBinding prefixText patternList None appTerms + | _ :: _, _ -> + let argsWithConstraint, actualReturn = + self#normalizeFunctionArgsConstraint argsList return + in + let fauxArgs = List.concat [ patternAux; argsWithConstraint ] in + let returnedAppTerms = + self#unparseExprApplicationItems actualReturn + in + (* Attaches the `=` to `f` to recreate javascript function syntax in + * let f = (a, b) => a + b; *) + let lbl = + makeList ~sep:(Sep " ") ~break:Layout.Never [ pattern; atom "=" ] + in + self#wrapCurriedFunctionBinding + prefixText + ~arrow + lbl + fauxArgs + returnedAppTerms + + (* Similar to the above method. *) + method wrappedClassBinding prefixText pattern patternAux expr = + let args, return = self#curriedConstructorPatternsAndReturnVal expr in + let patternList = + match patternAux with + | [] -> pattern + | _ :: _ -> + makeList + ~postSpace:true + ~inline:(true, true) + ~break:IfNeed + (pattern :: patternAux) + in + match args, return.pcl_desc with + | None, Pcl_constraint (e, ct) -> + let typeLayout = + source_map ~loc:ct.pcty_loc (self#class_constructor_type ct) + in + self#formatSimplePatternBinding + prefixText + patternList + (Some typeLayout) + (self#classExpressionToFormattedApplicationItems e, None) + | None, _ -> + self#formatSimplePatternBinding + prefixText + patternList + None + (self#classExpressionToFormattedApplicationItems expr, None) + | Some args, _ -> + let argsWithConstraint, actualReturn = + self#normalizeConstructorArgsConstraint [ args ] return + in + let fauxArgs = List.concat [ patternAux; argsWithConstraint ] in + self#wrapCurriedFunctionBinding + prefixText + ~arrow:"=" + pattern + fauxArgs + ( self#classExpressionToFormattedApplicationItems actualReturn + , None ) + + (* Attaches doc comments to a layout, with whitespace preserved + * Example: + * /** Doc comment */ + * + * /* another random comment */ + * let a = 1; + *) + method attachDocAttrsToLayout + ~(* all std attributes attached on the ast node backing the + layout *) + (stdAttrs : Parsetree.attributes) + ~(* all doc comments attached on the ast node backing the layout *) + (docAttrs : Parsetree.attributes) + ~(* location of the layout *) + loc + ~(* layout to attach the doc comments to *) + layout + () = + (* + * compute the correct location of layout + * Example: + * 1| /** doc-comment */ + * 2| + * 3| [@attribute] + * 4| let a = 1; + * + * The location might indicate a start of line 4 for the ast-node + * representing `let a = 1`. The reality is that `[@attribute]` should be + * included (start of line 3), to represent the correct start location + * of the whole layout. + *) + let loc = + match stdAttrs with + | { attr_name = astLoc; _ } :: _ -> astLoc.loc + | [] -> loc + in + let rec aux prevLoc layout = function + | ({ attr_name = x; _ } as attr : Parsetree.attribute) :: xs -> + let newLayout = + let range = Range.makeRangeBetween x.loc prevLoc in + let layout = + if Range.containsWhitespace ~range ~comments:self#comments () + then + let region = WhitespaceRegion.make ~range ~newlines:1 () in + Layout.Whitespace (region, layout) + else layout + in + makeList + ~inline:(true, true) + ~break:Always + [ self#attribute attr; layout ] + in + aux x.loc newLayout xs + | [] -> layout + in + aux loc layout (List.rev docAttrs) + + method value_binding + prefixText + { pvb_pat; pvb_attributes; pvb_loc; pvb_expr } = + self#binding + prefixText + ~attrs:pvb_attributes + ~loc:pvb_loc + ~pat:pvb_pat + pvb_expr + + method binding_op prefixText { pbop_pat; pbop_loc; pbop_exp } = + self#binding + (Reason_syntax_util.escape_stars_slashes prefixText) + ~loc:pbop_loc + ~pat:pbop_pat + pbop_exp + + method binding prefixText ?(attrs = []) ~loc ~pat expr = + (* TODO: print attributes *) + let body = + match pat.ppat_attributes, pat.ppat_desc with + | [], Ppat_var _ -> + self#wrappedBinding prefixText - layoutPattern - funWithNewTypes - absVars - nonVarifiedExprType + ~arrow:"=>" + (source_map ~loc:pat.ppat_loc (self#simple_pattern pat)) + [] + expr + (* + * Ppat_constraint is used in bindings of the form + * + * let (inParenVar:typ) = ... + * + * And in the case of let bindings for explicitly polymorphic type + * annotations (see parser for more details). + * + * See reason_parser.mly for explanation of how we encode the two primary + * forms of explicit polymorphic annotations in the parse tree, and how + * we must recover them here. + *) + | [], Ppat_open (lid, { ppat_desc = Ppat_record (l, closed); _ }) -> + (* + * Special case handling for: + * + * let Foo.{ + * destruct1, + * destruct2, + * destruct3, + * destruct4, + * destruct5, + * } = bar; + *) + let upUntilEqual = + let pat = self#patternRecord l closed in + label + (label + ~space:true + (atom prefixText) + (label (self#longident_loc lid) (atom "."))) + pat + in + let appTerms = self#unparseExprApplicationItems expr in + let includingEqual = + makeList ~postSpace:true [ upUntilEqual; atom "=" ] + in + formatAttachmentApplication + applicationFinalWrapping + (Some (true, includingEqual)) + appTerms + | [], Ppat_constraint (p, ty) -> + (* Locally abstract forall types are *seriously* mangled by the parsing + * stage, and we have to be very smart about how to recover it. + * + * let df_locallyAbstractFuncAnnotated: + * type a b. + * a => + * b => + * (inputEchoRecord a, inputEchoRecord b) = + * fun (input: a) (input2: b) => ( + * {inputIs: input}, + * {inputIs: input2} + * ); + * + * becomes: + * + * let df_locallyAbstractFuncAnnotatedTwo: + * 'a 'b . + * 'a => 'b => (inputEchoRecord 'a, inputEchoRecord 'b) + * = + * fun (type a) (type b) => ( + * fun (input: a) (input2: b) => ({inputIs: input}, {inputIs:input2}): + * a => b => (inputEchoRecord a, inputEchoRecord b) + * ); + *) + let layoutPattern = + source_map ~loc:pat.ppat_loc (self#simple_pattern p) + in + let leadingAbsTypesAndExpr = + self#leadingCurriedAbstractTypes expr + in + (match p.ppat_desc, ty.ptyp_desc, leadingAbsTypesAndExpr with + | ( Ppat_var _ + , Ptyp_poly (typeVars, varifiedPolyType) + , ( (_ :: _ as absVars) + , Pexp_constraint (funWithNewTypes, nonVarifiedExprType) ) ) + when self#isRenderableAsPolymorphicAbstractTypes + typeVars + (* If even artificially varified - don't know until + returns*) + varifiedPolyType + absVars + nonVarifiedExprType -> + (* + * We assume was the case whenever we see this pattern in the + * AST, it was because the parser parsed the polymorphic locally + * abstract type sugar. + * + * Ppat_var..Ptyp_poly...Pexp_constraint: + * + * let x: 'a 'b . 'a => 'b => 'b = + * fun (type a) (type b) => + * (fun aVal bVal => bVal : a => b => b); + * + * We need to be careful not to accidentally detect similar + * forms, that cannot be printed as sugar. + * + * let x: 'a 'b . 'a => 'b => 'b = + * fun (type a) (type b) => + * (fun aVal bVal => bVal : int => int => int); + * + * Should *NOT* be formatted as: + * + * let x: type a b. int => int => int = fun aVal bVal => bVal; + * + * The helper function + * [same_ast_modulo_varification_and_extensions] was created to + * help compare the varified constraint pattern body, and the + * non-varified expression constraint type. + * + * The second requirement that we check before assuming that the + * sugar form is correct, is to make sure the list of type vars + * corresponds to a leading prefix of the Pexp_newtype variables. + *) + self#locallyAbstractPolymorphicFunctionBinding + prefixText + layoutPattern + funWithNewTypes + absVars + nonVarifiedExprType + | _ -> + let typeLayout = + source_map ~loc:ty.ptyp_loc (self#core_type ty) + in + let appTerms = self#unparseExprApplicationItems expr in + self#formatSimplePatternBinding + prefixText + layoutPattern + (Some typeLayout) + appTerms) | _ -> - let typeLayout = source_map ~loc:ty.ptyp_loc (self#core_type ty) in + let layoutPattern = + source_map ~loc:pat.ppat_loc (self#pattern pat) + in let appTerms = self#unparseExprApplicationItems expr in self#formatSimplePatternBinding prefixText layoutPattern - (Some typeLayout) + None appTerms - ) - | _ -> - let layoutPattern = - source_map ~loc:pat.ppat_loc (self#pattern pat) - in - let appTerms = self#unparseExprApplicationItems expr in - self#formatSimplePatternBinding prefixText layoutPattern None appTerms - in - let {Reason_attributes.stdAttrs; docAttrs} = Reason_attributes.partitionAttributes ~partDoc:true attrs in - let body = makeList ~inline:(true, true) [body] in - let layout = self#attach_std_item_attrs stdAttrs (source_map ~loc:loc body) in - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:pat.ppat_loc - ~layout - () - - (* Ensures that the constraint is formatted properly for sake of function - binding (formatted without arrows) - let x y z : no_unguarded_arrows_allowed_here => ret; - *) - method normalizeFunctionArgsConstraint argsList return = - match return.pexp_desc with - | Pexp_constraint (e, ct) -> - let typeLayout = - source_map ~loc:ct.ptyp_loc - (self#non_arrowed_non_simple_core_type ct) - in - ([makeList - ~break:IfNeed - ~inline:(true, true) - (argsList@[formatJustTheTypeConstraint typeLayout])], e) - | _ -> (argsList, return) - - method normalizeConstructorArgsConstraint argsList return = - match return.pcl_desc with - | Pcl_constraint (e, ct) when return.pcl_attributes == [] -> - let typeLayout = - source_map ~loc:ct.pcty_loc - (self#non_arrowed_class_constructor_type ct) - in - (argsList@[formatJustTheTypeConstraint typeLayout], e) - | _ -> (argsList, return) - - method bindingsLocationRange ?extension l = - let len = List.length l in - let fstLoc = match extension with - | Some ({pexp_loc = {loc_ghost = false}} as ext) -> ext.pexp_loc - | _ -> (List.nth l 0).pvb_loc - in - let lstLoc = (List.nth l (len - 1)).pvb_loc in - { - loc_start = fstLoc.loc_start; - loc_end = lstLoc.loc_end; - loc_ghost = false - } - - method bindingOpsLocationRange { let_; ands; _ } = - let fstLoc = let_.pbop_loc in - let lstLoc = match ands with - | [] -> fstLoc - | xs -> - let len = List.length xs in - (List.nth xs (len - 1)).pbop_loc in - { - loc_start = fstLoc.loc_start; - loc_end = lstLoc.loc_end; - loc_ghost = false - } - - method bindings ?extension (rf, l) = - let label = add_extension_sugar "let" extension in - let label = match rf with - | Nonrecursive -> label - | Recursive -> label ^ " rec" - in - match l with - | [x] -> self#value_binding label x - | l -> - let items = List.mapi (fun i x -> - let loc = extractLocValBinding x in - let layout = self#value_binding (if i == 0 then label else "and") x in - (loc, layout) - ) l - in - let itemsLayout = groupAndPrint - ~xf:(fun (_, layout) -> layout) - ~getLoc:(fun (loc, _) -> loc) - ~comments:self#comments - items - in - makeList - ~postSpace:true - ~break:Always - ~indent:0 - ~inline:(true, true) - itemsLayout - - method letop_bindings { let_; ands } = - let label = Reason_syntax_util.compress_letop_identifier (let_.pbop_op.txt) in - let let_item = self#binding_op label let_ in - match ands with - | [] -> let_item - | l -> - let and_items = List.map (fun x -> - let loc = extractLocBindingOp x in - let layout = self#binding_op (Reason_syntax_util.compress_letop_identifier x.pbop_op.txt) x in - (loc, layout) - ) l - in - let itemsLayout = groupAndPrint - ~xf:(fun (_, layout) -> layout) - ~getLoc:(fun (loc, _) -> loc) - ~comments:self#comments - ((extractLocBindingOp let_, let_item) :: and_items) - in - makeList - ~postSpace:true - ~break:Always - ~indent:0 - ~inline:(true, true) - itemsLayout + in + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes ~partDoc:true attrs + in + let body = makeList ~inline:(true, true) [ body ] in + let layout = + self#attach_std_item_attrs stdAttrs (source_map ~loc body) + in + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:pat.ppat_loc + ~layout + () - method pexp_open ~attrs ?extension expr me = - let openLayout = label ~space:true - (atom (add_open_extension_sugar ~override:me.popen_override extension)) - (self#moduleExpressionToFormattedApplicationItems me.popen_expr) - in - let attrsOnOpen = - makeList ~inline:(true, true) ~postSpace:true ~break:Always - ((self#attributes attrs)@[openLayout]) - in - (* Just like the bindings, have to synthesize a location since the - * Pexp location is parsed (potentially) beginning with the open - * brace {} in the let sequence. *) - let layout = source_map ~loc:me.popen_loc attrsOnOpen in - let loc = { - me.popen_loc with - loc_start = { - me.popen_loc.loc_start with - pos_lnum = expr.pexp_loc.loc_start.pos_lnum - } - } - in - loc, layout - - method letList expr = - let letModuleBinding ?extension s me = - let prefixText = add_extension_sugar "module" extension in - let bindingName = atom ~loc:s.loc (moduleIdent s) in - let moduleExpr = me in - let letModuleLayout = - (self#let_module_binding prefixText bindingName moduleExpr) in - let letModuleLoc = { - loc_start = s.loc.loc_start; - loc_end = me.pmod_loc.loc_end; - loc_ghost = false - } in - (* Just like the bindings, have to synthesize a location since the - * Pexp location is parsed (potentially) beginning with the open - * brace {} in the let sequence. *) - let layout = source_map ~loc:letModuleLoc letModuleLayout in - let (_, return) = self#curriedFunctorPatternsAndReturnStruct moduleExpr in - let loc = { - letModuleLoc with - loc_end = return.pmod_loc.loc_end - } in - (loc, layout) - in - (* Recursively transform a nested ast of "let-items", into a flat - * list containing the location indicating start/end of the "let-item" and - * its layout. *) - let rec processLetList acc expr = - let {Reason_attributes.stdAttrs; arityAttrs; jsxAttrs; stylisticAttrs} = - Reason_attributes.partitionAttributes ~allowUncurry:false expr.pexp_attributes - in - match (stdAttrs, expr.pexp_desc) with - | ([], Pexp_let (rf, l, e)) -> - (* For "letList" bindings, the start/end isn't as simple as with - * module value bindings. For "let lists", the sequences were formed - * within braces {}. The parser relocates the first let binding to the - * first brace. *) - let bindingsLayout = self#bindings (rf, l) in - let bindingsLoc = self#bindingsLocationRange l in - let layout = source_map ~loc:bindingsLoc bindingsLayout in - processLetList ((bindingsLoc, layout)::acc) e - | (attrs, Pexp_letop ( {body; _} as op)) -> - (* For "letList" bindings, the start/end isn't as simple as with - * module value bindings. For "let lists", the sequences were formed - * within braces {}. The parser relocates the first let binding to the - * first brace. *) - let bindingsLayout = self#letop_bindings op in - let bindingsLoc = self#bindingOpsLocationRange op in - let bindingsLayout = + (* Ensures that the constraint is formatted properly for sake of + function binding (formatted without arrows) let x y z : + no_unguarded_arrows_allowed_here => ret; *) + method normalizeFunctionArgsConstraint argsList return = + match return.pexp_desc with + | Pexp_constraint (e, ct) -> + let typeLayout = + source_map + ~loc:ct.ptyp_loc + (self#non_arrowed_non_simple_core_type ct) + in + ( [ makeList + ~break:IfNeed + ~inline:(true, true) + (argsList @ [ formatJustTheTypeConstraint typeLayout ]) + ] + , e ) + | _ -> argsList, return + + method normalizeConstructorArgsConstraint argsList return = + match return.pcl_desc with + | Pcl_constraint (e, ct) when return.pcl_attributes == [] -> + let typeLayout = + source_map + ~loc:ct.pcty_loc + (self#non_arrowed_class_constructor_type ct) + in + argsList @ [ formatJustTheTypeConstraint typeLayout ], e + | _ -> argsList, return + + method bindingsLocationRange ?extension l = + let len = List.length l in + let fstLoc = + match extension with + | Some ({ pexp_loc = { loc_ghost = false } } as ext) -> ext.pexp_loc + | _ -> (List.nth l 0).pvb_loc + in + let lstLoc = (List.nth l (len - 1)).pvb_loc in + { loc_start = fstLoc.loc_start + ; loc_end = lstLoc.loc_end + ; loc_ghost = false + } + + method bindingOpsLocationRange { let_; ands; _ } = + let fstLoc = let_.pbop_loc in + let lstLoc = + match ands with + | [] -> fstLoc + | xs -> + let len = List.length xs in + (List.nth xs (len - 1)).pbop_loc + in + { loc_start = fstLoc.loc_start + ; loc_end = lstLoc.loc_end + ; loc_ghost = false + } + + method bindings ?extension (rf, l) = + let label = add_extension_sugar "let" extension in + let label = + match rf with Nonrecursive -> label | Recursive -> label ^ " rec" + in + match l with + | [ x ] -> self#value_binding label x + | l -> + let items = + List.mapi + (fun i x -> + let loc = extractLocValBinding x in + let layout = + self#value_binding (if i == 0 then label else "and") x + in + loc, layout) + l + in + let itemsLayout = + groupAndPrint + ~xf:(fun (_, layout) -> layout) + ~getLoc:(fun (loc, _) -> loc) + ~comments:self#comments + items + in + makeList + ~postSpace:true + ~break:Always + ~indent:0 + ~inline:(true, true) + itemsLayout + + method letop_bindings { let_; ands } = + let label = + Reason_syntax_util.compress_letop_identifier let_.pbop_op.txt + in + let let_item = self#binding_op label let_ in + match ands with + | [] -> let_item + | l -> + let and_items = + List.map + (fun x -> + let loc = extractLocBindingOp x in + let layout = + self#binding_op + (Reason_syntax_util.compress_letop_identifier + x.pbop_op.txt) + x + in + loc, layout) + l + in + let itemsLayout = + groupAndPrint + ~xf:(fun (_, layout) -> layout) + ~getLoc:(fun (loc, _) -> loc) + ~comments:self#comments + ((extractLocBindingOp let_, let_item) :: and_items) + in + makeList + ~postSpace:true + ~break:Always + ~indent:0 + ~inline:(true, true) + itemsLayout + + method pexp_open ~attrs ?extension expr me = + let openLayout = + label + ~space:true + (atom + (add_open_extension_sugar + ~override:me.popen_override + extension)) + (self#moduleExpressionToFormattedApplicationItems me.popen_expr) + in + let attrsOnOpen = makeList - ~break:IfNeed ~inline:(true, true) ~postSpace:true - ((self#attributes attrs) @ [ bindingsLayout ]) - in - let layout = source_map ~loc:bindingsLoc bindingsLayout in - processLetList ((bindingsLoc, layout)::acc) body - | (attrs, Pexp_open (me, e)) - (* Add this when check to make sure these are handled as regular "simple expressions" *) - when not (self#isSeriesOfOpensFollowedByNonSequencyExpression {expr with pexp_attributes = []}) -> - if (Reason_attributes.has_open_notation_attr stylisticAttrs) then ( - (Location.none, label - (label - (self#moduleExpressionToFormattedApplicationItems me.popen_expr) - (atom ("."))) - (makeLetSequence ~wrap:("(", ")") (self#letList e))) :: acc - ) - else ( - let loc, layout = self#pexp_open ~attrs expr me in - processLetList ((loc, layout)::acc) e - ) - | ([], Pexp_letmodule (s, me, e)) -> - let loc, layout = letModuleBinding s me in - processLetList ((loc, layout)::acc) e - | ([], Pexp_letexception (extensionConstructor, expr)) -> - let exc = self#exception_declaration extensionConstructor in - let layout = source_map ~loc:extensionConstructor.pext_loc exc in - processLetList ((extensionConstructor.pext_loc, layout)::acc) expr - | ([], Pexp_sequence (({pexp_desc=Pexp_sequence _ }) as e1, e2)) - | ([], Pexp_sequence (({pexp_desc=Pexp_let _ }) as e1, e2)) - | ([], Pexp_sequence (({pexp_desc=Pexp_open _ }) as e1, e2)) - | ([], Pexp_sequence (({pexp_desc=Pexp_letmodule _}) as e1, e2)) - | ([], Pexp_sequence (e1, e2)) -> - let e1Layout = match expression_not_immediate_extension_sugar e1 with + ~break:Always + (self#attributes attrs @ [ openLayout ]) + in + (* Just like the bindings, have to synthesize a location since the * + Pexp location is parsed (potentially) beginning with the open * + brace {} in the let sequence. *) + let layout = source_map ~loc:me.popen_loc attrsOnOpen in + let loc = + { me.popen_loc with + loc_start = + { me.popen_loc.loc_start with + pos_lnum = expr.pexp_loc.loc_start.pos_lnum + } + } + in + loc, layout + + method letList expr = + let letModuleBinding ?extension s me = + let prefixText = add_extension_sugar "module" extension in + let bindingName = atom ~loc:s.loc (moduleIdent s) in + let moduleExpr = me in + let letModuleLayout = + self#let_module_binding prefixText bindingName moduleExpr + in + let letModuleLoc = + { loc_start = s.loc.loc_start + ; loc_end = me.pmod_loc.loc_end + ; loc_ghost = false + } + in + (* Just like the bindings, have to synthesize a location since the + * Pexp location is parsed (potentially) beginning with the open + * brace {} in the let sequence. *) + let layout = source_map ~loc:letModuleLoc letModuleLayout in + let _, return = + self#curriedFunctorPatternsAndReturnStruct moduleExpr + in + let loc = { letModuleLoc with loc_end = return.pmod_loc.loc_end } in + loc, layout + in + (* Recursively transform a nested ast of "let-items", into a flat + * list containing the location indicating start/end of the "let-item" and + * its layout. *) + let rec processLetList acc expr = + let { Reason_attributes.stdAttrs + ; arityAttrs + ; jsxAttrs + ; stylisticAttrs + } + = + Reason_attributes.partitionAttributes + ~allowUncurry:false + expr.pexp_attributes + in + match stdAttrs, expr.pexp_desc with + | [], Pexp_let (rf, l, e) -> + (* For "letList" bindings, the start/end isn't as simple as with + * module value bindings. For "let lists", the sequences were formed + * within braces {}. The parser relocates the first let binding to the + * first brace. *) + let bindingsLayout = self#bindings (rf, l) in + let bindingsLoc = self#bindingsLocationRange l in + let layout = source_map ~loc:bindingsLoc bindingsLayout in + processLetList ((bindingsLoc, layout) :: acc) e + | attrs, Pexp_letop ({ body; _ } as op) -> + (* For "letList" bindings, the start/end isn't as simple as with + * module value bindings. For "let lists", the sequences were formed + * within braces {}. The parser relocates the first let binding to the + * first brace. *) + let bindingsLayout = self#letop_bindings op in + let bindingsLoc = self#bindingOpsLocationRange op in + let bindingsLayout = + makeList + ~break:IfNeed + ~inline:(true, true) + ~postSpace:true + (self#attributes attrs @ [ bindingsLayout ]) + in + let layout = source_map ~loc:bindingsLoc bindingsLayout in + processLetList ((bindingsLoc, layout) :: acc) body + | attrs, Pexp_open (me, e) + (* Add this when check to make sure these are handled as regular + "simple expressions" *) + when not + (self#isSeriesOfOpensFollowedByNonSequencyExpression + { expr with pexp_attributes = [] }) -> + if Reason_attributes.has_open_notation_attr stylisticAttrs + then + ( Location.none + , label + (label + (self#moduleExpressionToFormattedApplicationItems + me.popen_expr) + (atom ".")) + (makeLetSequence ~wrap:("(", ")") (self#letList e)) ) + :: acc + else + let loc, layout = self#pexp_open ~attrs expr me in + processLetList ((loc, layout) :: acc) e + | [], Pexp_letmodule (s, me, e) -> + let loc, layout = letModuleBinding s me in + processLetList ((loc, layout) :: acc) e + | [], Pexp_letexception (extensionConstructor, expr) -> + let exc = self#exception_declaration extensionConstructor in + let layout = source_map ~loc:extensionConstructor.pext_loc exc in + processLetList + ((extensionConstructor.pext_loc, layout) :: acc) + expr + | [], Pexp_sequence (({ pexp_desc = Pexp_sequence _ } as e1), e2) + | [], Pexp_sequence (({ pexp_desc = Pexp_let _ } as e1), e2) + | [], Pexp_sequence (({ pexp_desc = Pexp_open _ } as e1), e2) + | [], Pexp_sequence (({ pexp_desc = Pexp_letmodule _ } as e1), e2) + | [], Pexp_sequence (e1, e2) -> + let e1Layout = + match expression_not_immediate_extension_sugar e1 with + | Some (extension, e) -> + self#attach_std_item_attrs ~extension [] (self#unparseExpr e) + | None -> self#unparseExpr e1 + in + let loc = e1.pexp_loc in + let layout = source_map ~loc e1Layout in + processLetList ((loc, layout) :: acc) e2 + | _ -> + let expr = + { expr with pexp_attributes = arityAttrs @ stdAttrs @ jsxAttrs } + in + (match expression_not_immediate_extension_sugar expr with + | Some + ( extension + , { pexp_attributes = []; pexp_desc = Pexp_let (rf, l, e) } ) + -> + let bindingsLayout = self#bindings ~extension (rf, l) in + let bindingsLoc = + self#bindingsLocationRange ~extension:expr l + in + let layout = source_map ~loc:bindingsLoc bindingsLayout in + processLetList + ((extractLocationFromValBindList expr l, layout) :: acc) + e + | Some + ( extension + , { pexp_attributes = [] + ; pexp_desc = Pexp_letmodule (s, me, e) + } ) -> + let loc, layout = letModuleBinding ~extension s me in + processLetList ((loc, layout) :: acc) e + | Some + ( extension + , { pexp_attributes = attrs; pexp_desc = Pexp_open (me, e) } + ) -> + let loc, layout = self#pexp_open ~attrs ~extension expr me in + processLetList ((loc, layout) :: acc) e | Some (extension, e) -> - self#attach_std_item_attrs ~extension [] (self#unparseExpr e) + let layout = + self#attach_std_item_attrs ~extension [] (self#unparseExpr e) + in + (expr.pexp_loc, layout) :: acc | None -> - self#unparseExpr e1 + (* Should really do something to prevent infinite loops here. + Never allowing a top level call into letList to recurse back + to self#unparseExpr- top level calls into letList *must* be + one of the special forms above whereas lower level recursive + calls may be of any form. *) + let layout = + source_map ~loc:expr.pexp_loc (self#unparseExpr expr) + in + (expr.pexp_loc, layout) :: acc) + in + let es = processLetList [] expr in + (* Interleave whitespace between the "let-items" when appropriate *) + groupAndPrint + ~xf:(fun (_, layout) -> layout) + ~getLoc:(fun (loc, _) -> loc) + ~comments:self#comments + (List.rev es) + + method constructor_expression + ?(polyVariant = false) + ~arityIsClear + stdAttrs + ctor + eo = + let implicit_arity, arguments = + match eo.pexp_desc with + | Pexp_construct ({ txt = Lident "()" }, _) -> + (* `foo() is a polymorphic variant that contains a single unit construct as expression + * This requires special formatting: `foo(()) -> `foo() *) + false, atom "()" + (* special printing: MyConstructor(()) -> MyConstructor() *) + | Pexp_tuple l when is_single_unit_construct l -> false, atom "()" + | Pexp_tuple l when polyVariant == true -> + false, self#unparseSequence ~wrap:("(", ")") ~construct:`Tuple l + | Pexp_tuple l -> + (* There is no ambiguity when the number of tuple components is 1. + We don't need put implicit_arity in that case *) + (match l with + | exprList when isSingleArgParenApplication exprList -> + false, self#singleArgParenApplication exprList + | _ -> + not arityIsClear, makeTup (List.map self#unparseProtectedExpr l)) + | _ when isSingleArgParenApplication [ eo ] -> + false, self#singleArgParenApplication [ eo ] + | _ -> false, makeTup [ self#unparseProtectedExpr eo ] + in + let arguments = source_map ~loc:eo.pexp_loc arguments in + let construction = + label + ctor + (if isSequencey arguments + then arguments + else ensureSingleTokenSticksToLabel arguments) + in + let attrs = + if implicit_arity && not polyVariant + then + { attr_name = { txt = "implicit_arity"; loc = eo.pexp_loc } + ; attr_payload = PStr [] + ; attr_loc = eo.pexp_loc + } + :: stdAttrs + else stdAttrs + in + match attrs with + | [] -> construction + | _ :: _ -> formatAttributed construction (self#attributes attrs) + + (* TODOATTRIBUTES: Handle stdAttrs here (merge with implicit_arity) *) + method constructor_pattern ?(polyVariant = false) ~arityIsClear ctor po + = + let implicit_arity, arguments = + match po.ppat_desc with + (* There is no ambiguity when the number of tuple components is 1. + We don't need put implicit_arity in that case *) + | Ppat_tuple (([] | _ :: []) as l) -> false, l + | Ppat_tuple l -> not arityIsClear, l + | _ -> false, [ po ] + in + let space, arguments = + match arguments with + | [ x ] when is_direct_pattern x -> true, self#simple_pattern x + | xs when isSingleArgParenPattern xs -> + false, self#singleArgParenPattern xs + (* Optimize the case when it's a variant holding a shot variable - + avoid trailing*) + | [ ({ ppat_desc = Ppat_constant (Pconst_string (s, _, None)) } as x) + ] + | [ ({ ppat_desc = Ppat_construct ({ txt = Lident s }, None) } as x) + ] + | [ ({ ppat_desc = Ppat_var { txt = s } } as x) ] + when Reason_heuristics.singleTokenPatternOmmitTrail s -> + let layout = makeTup ~trailComma:false [ self#pattern x ] in + false, source_map ~loc:po.ppat_loc layout + | [ ({ ppat_desc = Ppat_any } as x) ] + | [ ({ ppat_desc = Ppat_constant (Pconst_char _) } as x) ] + | [ ({ ppat_desc = Ppat_constant (Pconst_integer _) } as x) ] -> + let layout = makeTup ~trailComma:false [ self#pattern x ] in + false, source_map ~loc:po.ppat_loc layout + | xs -> + let layout = makeTup (List.map self#pattern xs) in + false, source_map ~loc:po.ppat_loc layout + in + let construction = label ~space ctor arguments in + if implicit_arity && not polyVariant + then + formatAttributed + construction + (self#attributes + [ { attr_name = { txt = "implicit_arity"; loc = po.ppat_loc } + ; attr_payload = PStr [] + ; attr_loc = po.ppat_loc + } + ]) + else construction + + (* + * Provides special printing for constructor arguments: + * iff there's one argument & they have some kind of wrapping, + * they're wrapping need to 'hug' the surrounding parens. + * Example: + * switch x { + * | Some({ + * a, + * b, + * }) => () + * } + * + * Notice how ({ and }) hug. + * This applies for records, arrays, tuples & lists. + * Also see `isSingleArgParenPattern` to determine if this kind of wrapping applies. + *) + method singleArgParenPattern = + function + | [ { ppat_desc = Ppat_record (l, closed); ppat_loc = loc } ] -> + source_map ~loc (self#patternRecord ~wrap:("(", ")") l closed) + | [ { ppat_desc = Ppat_array l; ppat_loc = loc } ] -> + source_map ~loc (self#patternArray ~wrap:("(", ")") l) + | [ { ppat_desc = Ppat_tuple l; ppat_loc = loc } ] -> + source_map ~loc (self#patternTuple ~wrap:("(", ")") l) + | [ ({ ppat_desc = Ppat_construct ({ txt = Lident "::" }, _) + ; ppat_loc + } as listPattern) + ] -> + source_map + ~loc:ppat_loc + (self#patternList ~wrap:("(", ")") listPattern) + | _ -> assert false + + (* TODO: Similar to tuples, do not print parens around type constraints + (same for lists) *) + method patternArray ?(wrap = "", "") l = + let left, right = wrap in + let wrap = left ^ "[|", "|]" ^ right in + makeList + ~wrap + ~break:IfNeed + ~postSpace:true + ~sep:commaTrail + (List.map self#pattern l) + + method patternTuple ?(wrap = "", "") l = + let left, right = wrap in + let wrap = left ^ "(", ")" ^ right in + makeList + ~wrap + ~sep:commaTrail + ~postSpace:true + ~break:IfNeed + (List.map self#pattern l) + + method patternRecord ?(wrap = "", "") l closed = + let longident_x_pattern (li, p) = + match li, p.ppat_desc with + | { txt = ident }, Ppat_var { txt } + when Longident.last_exn ident = txt -> + (* record field punning when destructuring. {x: x, y: y} becomes {x, y} *) + (* works with module prefix too: {MyModule.x: x, y: y} becomes {MyModule.x, y} *) + self#longident_loc li + | ( { txt = ident } + , Ppat_alias + ( { ppat_desc = Ppat_var { txt = ident2 } } + , { txt = aliasIdent } ) ) + when Longident.last_exn ident = ident2 -> + (* record field punning when destructuring with renaming. {state: + state as prevState} becomes {state as prevState *) + (* works with module prefix too: {ReasonReact.state: state as + prevState} becomes {ReasonReact.state as prevState *) + makeList + ~sep:(Sep " ") + [ self#longident_loc li; atom "as"; atom aliasIdent ] + | _ -> + let pattern = + let formatted = self#pattern p in + let wrap = + match p.ppat_desc with + | Ppat_constraint (_, _) -> Some ("(", ")") + | _ -> None + in + makeList ~inline:(true, true) ?wrap [ formatted ] + in + label + ~space:true + (makeList [ self#longident_loc li; atom ":" ]) + pattern + in + let rows = + List.map longident_x_pattern l + @ match closed with Closed -> [] | _ -> [ atom "_" ] + in + let left, right = wrap in + let wrap = left ^ "{", "}" ^ right in + makeList ~wrap ~break:IfNeed ~sep:commaTrail ~postSpace:true rows + + method patternFunction ?extension loc l = + let estimatedFunLocation = + { loc_start = loc.loc_start + ; loc_end = + { loc.loc_start with + pos_cnum = loc.loc_start.Lexing.pos_cnum + 3 + } + ; loc_ghost = false + } + in + makeList + ~postSpace:true + ~break:IfNeed + ~inline:(true, true) + ~pad:(false, false) + (atom + ~loc:estimatedFunLocation + (add_extension_sugar funToken extension) + :: self#case_list l) + + method parenthesized_expr ?break expr = + let result = self#unparseExpr expr in + match expr.pexp_attributes, expr.pexp_desc with + | [], (Pexp_tuple _ | Pexp_construct ({ txt = Lident "()" }, None)) -> + result + | _ -> makeList ~wrap:("(", ")") ?break [ self#unparseExpr expr ] + + (* Expressions requiring parens, in most contexts such as separated by + infix *) + method expression_requiring_parens_in_infix x = + let { Reason_attributes.stdAttrs } = + Reason_attributes.partitionAttributes x.pexp_attributes + in + assert (stdAttrs == []); + (* keep the incoming expression around, an expr with + * immediate extension sugar might contain less than perfect location + * info in its children (used for comment interleaving), the expression passed to + * 'expression_requiring_parens_in_infix' contains the correct location *) + let originalExpr = x in + let extension, x = expression_immediate_extension_sugar x in + match x.pexp_desc with + (* The only reason Pexp_fun must also be wrapped in parens when under + pipe, is that its => token will be confused with the match token. + Simple expression will also invoke `#reset`. *) + | Pexp_function _ when pipe || semi -> + None (* Would be rendered as simplest_expression *) + (* Pexp_function, on the other hand, doesn't need wrapping in parens + in most cases anymore, since `fun` is not ambiguous anymore (we + print Pexp_fun as ES6 functions). *) + | Pexp_function l -> + let prec = Custom funToken in + let expr = self#patternFunction ?extension x.pexp_loc l in + Some + (SpecificInfixPrecedence + ( { reducePrecedence = prec; shiftPrecedence = prec } + , LayoutNode expr )) + | _ -> + (* The Pexp_function cases above don't use location because comment + printing breaks for them. *) + let itm = + match x.pexp_desc with + | Pexp_fun _ | Pexp_newtype _ -> + (* let uncurried = *) + let args, ret = self#curriedPatternsAndReturnVal x in + (match args with + | [] -> raise (NotPossible "no arrow args in unparse ") + | firstArg :: tl -> + (* Suboptimal printing of parens: + * + * something >>= fun x => x + 1; + * + * Will be printed as: + * + * something >>= (fun x => x + 1); + * + * Because the arrow has lower precedence than >>=, but it wasn't + * needed because + * + * (something >>= fun x) => x + 1; + * + * Is not a valid parse. Parens around the `=>` weren't needed to + * prevent reducing instead of shifting. To optimize this part, we need + * a much deeper encoding of the parse rules to print parens only when + * needed, testing which rules will be reduced. It really should be + * integrated deeply with Menhir. + * + * One question is, if it's this difficult to describe when parens are + * needed, should we even print them with the minimum amount? We can + * instead model everything as "infix" with ranked precedences. + *) + let retValUnparsed = self#unparseExprApplicationItems ret in + Some + (self#wrapCurriedFunctionBinding + ~sweet:(extension = None) + (add_extension_sugar funToken extension) + ~arrow:"=>" + firstArg + tl + retValUnparsed)) + | Pexp_try (e, l) -> + let estimatedBracePoint = + { loc_start = e.pexp_loc.loc_end + ; loc_end = x.pexp_loc.loc_end + ; loc_ghost = false + } + in + let cases = + self#case_list ~allowUnguardedSequenceBodies:true l + in + let switchWith = + self#dont_preserve_braces#formatSingleArgLabelApplication + (atom (add_extension_sugar "try" extension)) + e + in + Some + (label + ~space:true + switchWith + (source_map + ~loc:estimatedBracePoint + (makeList + ~indent:settings.trySwitchIndent + ~wrap:("{", "}") + ~break:Always_rec + ~postSpace:true + cases))) + (* These should have already been handled and we should never + havgotten this far. *) + | Pexp_setinstvar _ -> + raise + (Invalid_argument + "Cannot handle setinstvar here - call unparseExpr") + | Pexp_setfield (_, _, _) -> + raise + (Invalid_argument + "Cannot handle setfield here - call unparseExpr") + | Pexp_apply _ -> + raise + (Invalid_argument + "Cannot handle apply here - call unparseExpr") + | Pexp_match (e, l) -> + let estimatedBracePoint = + { loc_start = e.pexp_loc.loc_end + ; (* See originalExpr binding, for more info. + * It contains the correct location under immediate extension sugar *) + loc_end = originalExpr.pexp_loc.loc_end + ; loc_ghost = false + } + in + let cases = + self#case_list ~allowUnguardedSequenceBodies:true l + in + let switchWith = + label + ~space:true + (atom (add_extension_sugar "switch" extension)) + (self#parenthesized_expr ~break:IfNeed e) + in + let lbl = + label + ~space:true + switchWith + (source_map + ~loc:estimatedBracePoint + (makeList + ~indent:settings.trySwitchIndent + ~wrap:("{", "}") + ~break:Always_rec + ~postSpace:true + cases)) + in + Some lbl + | Pexp_ifthenelse (e1, e2, eo) -> + let blocks, finalExpression = sequentialIfBlocks eo in + let rec singleExpression exp = + match exp.pexp_desc with + | Pexp_ident _ -> true + | Pexp_constant _ -> true + | Pexp_construct (_, arg) -> + (match arg with + | None -> true + | Some x -> singleExpression x) + | _ -> false + in + let singleLineIf = + singleExpression e1 + && singleExpression e2 + && + match eo with + | Some expr -> singleExpression expr + | None -> true + in + let makeLetSequence = + if singleLineIf + then makeLetSequenceSingleLine + else makeLetSequence + in + let rec sequence soFar remaining = + match remaining, finalExpression with + | [], None -> soFar + | [], Some e -> + let soFarWithElseAppended = + makeList ~postSpace:true [ soFar; atom "else" ] + in + label + ~space:true + soFarWithElseAppended + (source_map + ~loc:e.pexp_loc + (makeLetSequence (self#letList e))) + | hd :: tl, _ -> + let e1, e2 = hd in + let soFarWithElseIfAppended = + label + ~space:true + (makeList ~postSpace:true [ soFar; atom "else if" ]) + (makeList ~wrap:("(", ")") [ self#unparseExpr e1 ]) + in + let nextSoFar = + label + ~space:true + soFarWithElseIfAppended + (source_map + ~loc:e2.pexp_loc + (makeLetSequence (self#letList e2))) + in + sequence nextSoFar tl + in + let init = + let if_ = atom (add_extension_sugar "if" extension) in + let cond = self#parenthesized_expr e1 in + label + ~space:true + (source_map ~loc:e1.pexp_loc (label ~space:true if_ cond)) + (source_map + ~loc:e2.pexp_loc + (makeLetSequence (self#letList e2))) + in + Some (sequence init blocks) + | Pexp_while (e1, e2) -> + let lbl = + let while_ = atom (add_extension_sugar "while" extension) in + let cond = self#parenthesized_expr e1 in + label + ~space:true + (label ~space:true while_ cond) + (source_map + ~loc:e2.pexp_loc + (makeLetSequence (self#letList e2))) + in + Some lbl + | Pexp_for (s, e1, e2, df, e3) -> + (* + * for longIdentifier in + * (longInit expr) to + * (longEnd expr) { + * print_int longIdentifier; + * }; + *) + let identifierIn = + makeList ~postSpace:true [ self#pattern s; atom "in" ] + in + let dockedToFor = + makeList + ~break:IfNeed + ~postSpace:true + ~inline:(true, true) + ~wrap:("(", ")") + [ identifierIn + ; makeList + ~postSpace:true + [ self#unparseExpr e1; self#direction_flag df ] + ; self#unparseExpr e2 + ] + in + let upToBody = + makeList + ~inline:(true, true) + ~postSpace:true + [ atom (add_extension_sugar "for" extension); dockedToFor ] + in + Some + (label + ~space:true + upToBody + (source_map + ~loc:e3.pexp_loc + (makeLetSequence (self#letList e3)))) + | Pexp_new li -> + Some + (label + ~space:true + (atom "new") + (self#longident_class_or_type_loc li)) + | Pexp_assert e -> + Some (label (atom "assert") (makeTup [ self#unparseExpr e ])) + | Pexp_lazy e -> + Some (self#formatSingleArgLabelApplication (atom "lazy") e) + | Pexp_poly _ -> + failwith + ("This version of the pretty printer assumes it is \ + impossible to " + ^ "construct a Pexp_poly outside of a method definition - \ + yet it sees one.") + | _ -> None + in + (match itm with + | None -> None + | Some i -> + Some (PotentiallyLowPrecedence (source_map ~loc:x.pexp_loc i))) + + method potentiallyConstrainedExpr x = + match x.pexp_desc with + | Pexp_constraint (e, ct) -> + formatTypeConstraint (self#unparseExpr e) (self#core_type ct) + | _ -> self#unparseExpr x + + (* + * Because the rule BANG simple_expr was given %prec below_DOT_AND_SHARP, + * !x.y.z will parse as !(x.y.z) and not (!x).y.z. + * + * !x.y.z == !((x.y).z) + * !x#y#z == !((x#y)#z) + * + * So the intuition is: In general, any simple expression can exist to the + * left of a `.`, except `BANG simple_expr`, which has special precedence, + * and must be guarded in this one case. + * + * TODO: Instead of special casing this here, we should continue to extend + * unparseExpr to also unparse simple expressions, (by encoding the + * rules precedence below_DOT_AND_SHARP). + * + * TODO: + * Some would even have the prefix application be parsed with lower + * precedence function *application*. In the case of !, where ! means not, + * it makes a lot of sense because (!identifier)(arg) would be meaningless. + * + * !callTheFunction(1, 2, 3)(andEvenCurriedArgs) + * + * Only problem is that it could then not appear anywhere simple expressions + * would appear. + * + * We could make a special case for ! followed by one simple expression, and + * consider the result simple. + * + * Alternatively, we can figure out a way to not require simple expressions + * in the most common locations such as if/while tests. This is really hard + * (impossible w/ grammars Menhir supports?) + * + * if ! myFunc argOne argTwo { + * + * } else { + * + * }; + * + *) + method simple_enough_to_be_lhs_dot_send x = + match x.pexp_desc with + | Pexp_apply (eFun, _) -> + (match printedStringAndFixityExpr eFun with + | AlmostSimplePrefix _ | UnaryPlusPrefix _ | UnaryMinusPrefix _ + | UnaryNotPrefix _ | UnaryPostfix _ | Infix _ -> + self#simplifyUnparseExpr x + | Letop _ | Andop _ | Normal -> + if x.pexp_attributes == [] + then + (* `let a = foo().bar` instead of `let a = (foo()).bar *) + (* same for foo()##bar, foo()#=bar, etc. *) + self#unparseExpr x + else self#simplifyUnparseExpr x) + | _ -> self#simplifyUnparseExpr x + + method unparseRecord + ?wrap:(lwrap, rwrap = "", "") + ?(withStringKeys = false) + ?(allowPunning = true) + ?(forceBreak = false) + l + eo = + (* forceBreak is a ref which can be set to always break the record rows. + * Example, when we have a row which contains a nested record, + * this ref can be set to true from inside the printing of that row, + * which forces breaks for the outer record structure. *) + let forceBreak = ref forceBreak in + let quote = atom "\"" in + let maybeQuoteFirstElem fst rest = + if withStringKeys + then + match fst.txt with + | Lident s -> quote :: atom s :: quote :: rest + | Ldot _ | Lapply _ -> assert false + else self#longident_loc fst :: rest + in + let makeRow (li, e) shouldPun = + let totalRowLoc = + { loc_start = li.Asttypes.loc.loc_start + ; loc_end = e.pexp_loc.loc_end + ; loc_ghost = false + } + in + let theRow = + match e.pexp_desc, shouldPun, allowPunning with + (* record value punning. Turns {foo: foo, bar: 1} into {foo, bar: 1} *) + (* also turns {Foo.bar: bar, baz: 1} into {Foo.bar, baz: 1} *) + (* don't turn {bar: Foo.bar, baz: 1} into {bar, baz: 1}, naturally *) + | Pexp_ident { txt = Lident value }, true, true + when Longident.last_exn li.txt = value -> + makeList (maybeQuoteFirstElem li []) + (* Force breaks for nested records or mel.obj sugar + * Example: + * let person = {name: {first: "Bob", last: "Zhmith"}, age: 32}; + * is a lot less readable than + * let person = { + * "name": { + * "first": "Bob", + * "last": "Zhmith" + * }, + * "age": 32 + * }; + *) + | Pexp_record (recordRows, optionalGadt), _, _ -> + forceBreak := true; + let keyWithColon = + makeList (maybeQuoteFirstElem li [ atom ":" ]) + in + let value = + self#unparseRecord ~forceBreak:true recordRows optionalGadt + in + label ~space:true keyWithColon value + | Pexp_extension (s, p), _, _ when s.txt = "mel.obj" -> + forceBreak := true; + let keyWithColon = + makeList (maybeQuoteFirstElem li [ atom ":" ]) + in + let value = self#formatBsObjExtensionSugar ~forceBreak:true p in + label ~space:true keyWithColon value + | Pexp_object classStructure, _, _ -> + forceBreak := true; + let keyWithColon = + makeList (maybeQuoteFirstElem li [ atom ":" ]) + in + let value = + self#classStructure ~forceBreak:true classStructure + in + label ~space:true keyWithColon value + | _ -> + let argsList, return = self#curriedPatternsAndReturnVal e in + (match argsList with + | [] -> + let appTerms = self#unparseExprApplicationItems e in + let upToColon = + makeList (maybeQuoteFirstElem li [ atom ":" ]) + in + formatAttachmentApplication + applicationFinalWrapping + (Some (true, upToColon)) + appTerms + | firstArg :: tl -> + let upToColon = + makeList (maybeQuoteFirstElem li [ atom ":" ]) + in + let returnedAppTerms = + self#unparseExprApplicationItems return + in + self#wrapCurriedFunctionBinding + ~sweet:true + ~attachTo:upToColon + funToken + ~arrow:"=>" + firstArg + tl + returnedAppTerms) + in + source_map ~loc:totalRowLoc theRow, totalRowLoc + in + let rec getRows l = + match l with + | [] -> [] + | hd :: [] -> [ makeRow hd true ] + | hd :: hd2 :: tl -> makeRow hd true :: getRows (hd2 :: tl) + in + + let allRows = + match eo with + | None -> + (match l with + (* No punning (or comma) for records with only a single field. + It's ambiguous with an expression in a scope *) + (* See comment in parser.mly for + lbl_expr_list_with_at_least_one_non_punned_field *) + | [ hd ] -> [ makeRow hd false ] + | _ -> getRows l) + (* This case represents a "spread" being present -> {...x, a: 1, b: + 2} *) + | Some withRecord -> + let firstRow = + let row = + (* Unclear why "sugar_expr" was special cased hre. *) + let appTerms = self#unparseExprApplicationItems withRecord in + formatAttachmentApplication + applicationFinalWrapping + (Some (false, atom "...")) + appTerms + in + source_map ~loc:withRecord.pexp_loc row, withRecord.pexp_loc + in + firstRow :: getRows l + in + let break = + (* if a record has more than 1 row, always break *) + match !forceBreak, allRows with + | false, ([] | [ _ ]) -> Layout.IfNeed + | _ -> Layout.Always_rec + in + makeList + ~wrap:(lwrap ^ "{", "}" ^ rwrap) + ~break + ~sep:commaTrail + ~postSpace:true + (groupAndPrint ~xf:fst ~getLoc:snd ~comments:self#comments allRows) + + method isSeriesOfOpensFollowedByNonSequencyExpression expr = + match expr.pexp_attributes, expr.pexp_desc with + | [], Pexp_let _ -> false + | [], Pexp_letop _ -> false + | [], Pexp_sequence _ -> false + | [], Pexp_letmodule _ -> false + | ( [] + , Pexp_open + ( { popen_override + ; popen_expr = { pmod_desc = Pmod_ident _; _ } + ; _ + } + , e ) ) -> + popen_override == Fresh + && self#isSeriesOfOpensFollowedByNonSequencyExpression e + | [], Pexp_open _ -> false + | [], Pexp_letexception _ -> false + | [], Pexp_extension ({ txt }, _) -> txt = "mel.obj" + | _ -> true + + method unparseObject + ?wrap:(lwrap, rwrap = "", "") + ?(withStringKeys = false) + l + o = + let core_field_type { pof_desc; pof_attributes; _ } = + match pof_desc with + | Otag ({ txt }, ct) -> + let l = Reason_attributes.extractStdAttrs pof_attributes in + let row = + let rowKey = + if withStringKeys + then makeList ~wrap:("\"", "\"") [ atom txt ] + else atom txt + in + label + ~space:true + (makeList ~break:Layout.Never [ rowKey; atom ":" ]) + (self#core_type ct) + in + (match l with + | [] -> row + | _ :: _ -> + makeList + ~postSpace:true + ~break:IfNeed + ~inline:(true, true) + (List.concat [ self#attributes pof_attributes; [ row ] ])) + | Oinherit ct -> + makeList ~break:Layout.Never [ atom "..."; self#core_type ct ] + in + let rows = List.map core_field_type l in + let openness = + match o with Closed -> atom "." | Open -> atom ".." + in + (* if an object has more than 2 rows, always break for readability *) + let rows_layout = + let break = + match rows with + | [] | [ _ ] -> Layout.IfNeed + | _ -> Layout.Always_rec + in + makeList + ~break + ~inline:(true, true) + ~postSpace:true + ~sep:commaTrail + rows + in + makeList + ~break:Layout.IfNeed + ~preSpace:(rows != []) + ~wrap:(lwrap ^ "{", "}" ^ rwrap) + (openness :: [ rows_layout ]) + + method unparseSequence ?(wrap = "", "") ~construct l = + match construct with + | `ES6List -> + let seq, ext = + match List.rev l with + | ext :: seq_rev -> List.rev seq_rev, ext + | [] -> assert false + in + makeES6List + ~wrap + (List.map self#unparseExpr seq) + (self#unparseExpr ext) + | _ -> + let left, right = wrap in + let xf, (leftDelim, rightDelim) = + match construct with + | `List -> self#unparseExpr, ("[", "]") + | `Array -> self#unparseExpr, ("[|", "|]") + | `Tuple -> self#potentiallyConstrainedExpr, ("(", ")") + | `ES6List -> assert false + in + let wrap = left ^ leftDelim, rightDelim ^ right in + makeList + ~wrap + ~sep:commaTrail + ~break:IfNeed + ~postSpace:true + (List.map xf l) + + method formatBsObjExtensionSugar + ?(wrap = "", "") + ?(forceBreak = false) + payload = + match payload with + | PStr [ itm ] -> + (match itm with + | { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (l, eo) }, []) + } -> + self#unparseRecord + ~forceBreak + ~wrap + ~withStringKeys:true + ~allowPunning:false + l + eo + | { pstr_desc = + Pstr_eval + ( { pexp_desc = Pexp_extension ({ txt = "mel.obj" }, payload) + } + , [] ) + } -> + (* some folks write `[%mel.obj [%mel.obj {foo: bar}]]`. This looks + improbable but it happens often if you use the sugared version: + `[%mel.obj {"foo": bar}]`. We're gonna be lenient here and + treat it as if they wanted to just write `{"foo": bar}`. + BuckleScript does the same relaxation when parsing mel.obj *) + self#formatBsObjExtensionSugar ~wrap ~forceBreak payload + | _ -> + raise + (Invalid_argument + "mel.obj only accepts a record. You've passed something else")) + | _ -> assert false + + method should_preserve_requested_braces expr = + let { Reason_attributes.stylisticAttrs } = + Reason_attributes.partitionAttributes expr.pexp_attributes + in + match expr.pexp_desc with + | Pexp_ifthenelse _ | Pexp_try _ -> false + | Pexp_sequence _ -> + (* `let ... in` should _always_ preserve braces *) + true + | _ -> + preserve_braces + && Reason_attributes.has_preserve_braces_attrs stylisticAttrs + + method simplest_expression x = + let { Reason_attributes.stdAttrs + ; jsxAttrs + ; stylisticAttrs + ; arityAttrs + } + = + Reason_attributes.partitionAttributes x.pexp_attributes + in + let hasJsxAttribute = jsxAttrs != [] in + if stdAttrs != [] + then None + else if self#should_preserve_requested_braces x + then + let layout = + makeList + ~break:(if inline_braces then Always else Always_rec) + ~inline:(true, inline_braces) + ~wrap:("{", "}") + ~postSpace:true + ~sep:(if inline_braces then Sep ";" else SepFinal (";", ";")) + (self#letList x) + in + Some layout + else + let item = + match x.pexp_desc with + (* The only reason Pexp_fun must also be wrapped in parens is that + its => token will be confused with the match token. *) + | Pexp_fun _ when pipe || semi -> + Some (self#reset#simplifyUnparseExpr x) + | Pexp_function l when pipe || semi -> + Some + (formatPrecedence + ~loc:x.pexp_loc + (self#reset#patternFunction x.pexp_loc l)) + | Pexp_apply _ -> + (match self#simple_get_application x with + (* If it's the simple form of application. *) + | Some simpleGet -> Some simpleGet + | None -> None) + | Pexp_object cs -> Some (self#classStructure cs) + | Pexp_override l -> + (* FIXME *) + let string_x_expression (s, e) = + label ~space:true (atom (s.txt ^ ":")) (self#unparseExpr e) + in + Some + (makeList + ~postSpace:true + ~wrap:("{<", ">}") + ~sep:(Sep ",") + (List.map string_x_expression l)) + | Pexp_construct ({ txt = Lident "[]" }, _) when hasJsxAttribute + -> + Some (atom "<> ") + | Pexp_construct ({ txt = Lident "::" }, Some _) + when hasJsxAttribute -> + (match self#formatJsxChildrenNonSpread x [] with + | None -> + (* Back out of the standard jsx child formatting *) + (* This is actually not a useful construct to have written: + * <> ... x + * Is the same as: + * x + * There is also a bug in the parser where a space is needed + * between <> and ..., but no one would write the ... form of + * <> anyways. *) + let withoutJsxAttributes = + { x with pexp_attributes = stylisticAttrs @ arityAttrs } + in + self#simplest_expression withoutJsxAttributes + | Some chldn -> + Some + (makeList + ~break:IfNeed + ~inline:(false, false) + ~postSpace:true + ~wrap:("<>", "") + ~pad:(true, true) + chldn)) + | Pexp_construct _ when is_simple_construct (view_expr x) -> + Some + (match view_expr x with + | `nil -> atom "[]" + | `tuple -> atom "()" + | `list xs -> + (* LIST EXPRESSION *) + self#unparseSequence ~construct:`List xs + | `cons xs -> self#unparseSequence ~construct:`ES6List xs + | `simple x -> self#longident x + | _ -> assert false) + | Pexp_ident li -> + (* Lone identifiers shouldn't break when to the right of a + label *) + Some (ensureSingleTokenSticksToLabel (self#longident_loc li)) + | Pexp_constant c -> + (* Constants shouldn't break when to the right of a label *) + let raw_literal, _ = + Reason_attributes.extract_raw_literal x.pexp_attributes + in + Some + (ensureSingleTokenSticksToLabel + (self#constant ?raw_literal c)) + | Pexp_pack me -> + Some + (makeList + ~break:IfNeed + ~postSpace:true + ~wrap:("(", ")") + ~inline:(true, true) + [ atom "module"; self#module_expr me ]) + | Pexp_tuple l -> + (* TODO: These may be simple, non-simple, or type constrained + non-simple expressions *) + Some (self#unparseSequence ~construct:`Tuple l) + | Pexp_constraint (e, ct) -> + Some + (makeList + ~break:IfNeed + ~wrap:("(", ")") + [ formatTypeConstraint + (self#unparseExpr e) + (self#core_type ct) + ]) + | Pexp_coerce (e, cto1, ct) -> + let optFormattedType = + match cto1 with + | None -> None + | Some typ -> Some (self#core_type typ) + in + Some + (makeList + ~break:IfNeed + ~wrap:("(", ")") + [ formatCoerce + (self#unparseExpr e) + optFormattedType + (self#core_type ct) + ]) + | Pexp_variant (l, None) -> + Some (ensureSingleTokenSticksToLabel (atom ("`" ^ l))) + | Pexp_record (l, eo) -> Some (self#unparseRecord l eo) + | Pexp_array l -> Some (self#unparseSequence ~construct:`Array l) + | Pexp_let _ | Pexp_sequence _ | Pexp_letmodule _ + | Pexp_letexception _ | Pexp_letop _ -> + Some (makeLetSequence (self#letList x)) + | Pexp_extension e -> + (match expression_immediate_extension_sugar x with + | Some _, _ -> None + | None, _ -> + (match expression_extension_sugar x with + | None -> Some (self#extension e) + | Some (_, x') -> + (match x'.pexp_desc with + | Pexp_let _ | Pexp_letop _ | Pexp_letmodule _ -> + Some (makeLetSequence (self#letList x)) + | _ -> Some (self#extension e)))) + | Pexp_open (me, e) -> + if self#isSeriesOfOpensFollowedByNonSequencyExpression x + then + Some + (label + (label + (self#moduleExpressionToFormattedApplicationItems + me.popen_expr) + (atom ".")) + (self#formatNonSequencyExpression ~parent:x e)) + else Some (makeLetSequence (self#letList x)) + | Pexp_send (e, s) -> + let needparens = + match e.pexp_desc with + | Pexp_apply (ee, _) -> + (match printedStringAndFixityExpr ee with + | UnaryPostfix "^" -> true + | _ -> false) + | _ -> false + in + let lhs = self#simple_enough_to_be_lhs_dot_send e in + let lhs = + if needparens then makeList ~wrap:("(", ")") [ lhs ] else lhs + in + Some (label (makeList [ lhs; atom "#" ]) (atom s.txt)) + | Pexp_unreachable -> Some (atom ".") + | _ -> None + in + match item with + | None -> None + | Some i -> Some (source_map ~loc:x.pexp_loc i) + + (* Renders jsx children. Returns None if it is not a valid JSX child + * structure and must be rendered as spread. You cannot render any list of + * JSX children in Reason unless it is nil-terminated. Otherwise you must use + * spread. *) + method formatJsxChildrenNonSpread expr processedRev = + let formatJsxChild x = + match x with + | { pexp_desc = Pexp_apply _ } as e -> + (* Pipe first behaves differently according to the expression on the + * right. In example (1) below, it's a `SpecificInfixPrecedence`; in + * (2), however, it's `Simple` and doesn't need to be wrapped in parens. + * + * (1).
{items->Belt.Array.map(ReasonReact.string)->ReasonReact.array}
; + * (2). (title === "" ? [1, 2, 3] : blocks)->Foo.toString ; *) + if Reason_heuristics.isPipeFirst e + && not (Reason_heuristics.isPipeFirstWithNonSimpleJSXChild e) + then self#formatPipeFirst e + else + self#inline_braces#simplifyUnparseExpr + ~inline:true + ~wrap:("{", "}") + e + (* No braces - very simple *) + | { pexp_desc = Pexp_ident li } -> self#longident_loc li + | { pexp_desc = Pexp_constant constant } as x -> + let raw_literal, _ = + Reason_attributes.extract_raw_literal x.pexp_attributes + in + self#constant ?raw_literal constant + | _ -> + (* Currently spreading a list, or having a list as a child must be + * wrapped in { }. You can remove the entire even_wrap_simple arg + * when that is fixed (there is a conflict in grammar when allowing + * a [] without {[]} as child. *) + (* Simple child that has jsx: *) + (* Simple child that doesn't have jsx: "hello" *) + (* Simple child that doesn't have jsx but is a "::" and requires + braces: [a, b] *) + self#inline_braces#simplifyUnparseExpr + ~inline:true + ~wrap:("{", "}") + x + in + match expr with + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> + (match processedRev with + | [] -> None + | _ :: _ -> Some (List.rev processedRev)) + | { pexp_desc = + Pexp_construct + ( { txt = Lident "::" } + , Some { pexp_desc = Pexp_tuple [ hd; tl ] } ) + } -> + self#formatJsxChildrenNonSpread + tl + (formatJsxChild hd :: processedRev) + | _ -> None + + method direction_flag = + function Upto -> atom "to" | Downto -> atom "downto" + + method payload ppxToken ppxId e = + let wrap = "[" ^ ppxToken ^ ppxId.txt, "]" in + let wrap_prefix str (x, y) = x ^ str, y in + let pad = true, false in + let postSpace = true in + match e with + | PStr [] -> atom ("[" ^ ppxToken ^ ppxId.txt ^ "]") + | PStr [ itm ] -> + makeList ~break:Layout.IfNeed ~wrap ~pad [ self#structure_item itm ] + | PStr (_ :: _ as items) -> + let rows = List.map self#structure_item items in + makeList + ~wrap + ~break:Layout.Always + ~pad + ~postSpace + ~sep:(Layout.Sep ";") + rows + | PTyp x -> + let wrap = wrap_prefix ":" wrap in + makeList ~wrap ~break:Layout.IfNeed ~pad [ self#core_type x ] + (* Signatures in attributes were added recently *) + | PSig [] -> atom ("[" ^ ppxToken ^ ppxId.txt ^ ":]") + | PSig [ x ] -> + let wrap = wrap_prefix ":" wrap in + makeList ~break:Layout.IfNeed ~wrap ~pad [ self#signature_item x ] + | PSig items -> + let wrap = wrap_prefix ":" wrap in + let rows = List.map self#signature_item items in + makeList + ~wrap + ~break:Layout.IfNeed + ~pad + ~postSpace + ~sep:(Layout.Sep ";") + rows + | PPat (x, None) -> + let wrap = wrap_prefix "?" wrap in + makeList + ~wrap + ~break:Layout.IfNeed + ~pad + [ self#pattern_at_least_as_simple_as_alias_or_or x ] + | PPat (x, Some e) -> + let wrap = wrap_prefix "?" wrap in + makeList + ~wrap + ~break:Layout.IfNeed + ~pad + ~postSpace + [ self#pattern_at_least_as_simple_as_alias_or_or x + ; label ~space:true (atom "when") (self#unparseExpr e) + ] + + (* [% ...] *) + method extension (s, p) = + match s.txt with + (* We special case "mel.obj" for now to allow for a nicer interop with + * BuckleScript. We might be able to generalize to any kind of record + * looking thing with struct keys. *) + | "mel.obj" -> self#formatBsObjExtensionSugar p + | _ -> self#payload "%" s p + + method item_extension (s, e) = self#payload "%%" s e + + (* [@ ...] Simple attributes *) + method attribute = + function + | { attr_name = { Location.txt = "ocaml.doc" | "ocaml.text" } + ; attr_payload = + PStr + [ { pstr_desc = + Pstr_eval + ( { pexp_desc = + Pexp_constant (Pconst_string (text, _, None)) + } + , _ ) + ; pstr_loc + } + ] + ; _ + } -> + let break = if text = "" then Layout.IfNeed else Always_rec in + let text = if text = "" then "/**/" else "/**" ^ text ^ "*/" in + makeList + ~inline:(true, true) + ~postSpace:true + ~preSpace:true + ~indent:0 + ~break + [ atom ~loc:pstr_loc text ] + | { attr_name; attr_payload; _ } -> + self#payload "@" attr_name attr_payload + + (* [@@ ... ] Attributes that occur after a major item in a + structure/class *) + method item_attribute = self#attribute + + (* [@@ ...] Attributes that occur not *after* an item in some + structure/class/sig, but rather as their own standalone item. Note + that syntactic distinction between item_attribute and + floating_attribute is no longer necessary with Reason. Thank you + semicolons. *) + method floating_attribute = self#item_attribute + method attributes l = List.map self#attribute l + + method attach_std_attrs l toThis = + let l = Reason_attributes.extractStdAttrs l in + match l with + | [] -> toThis + | _ :: _ -> + makeList + ~postSpace:true + (List.concat [ self#attributes l; [ toThis ] ]) + + method attach_std_item_attrs ?(allowUncurry = true) ?extension l toThis + = + let attrs = Reason_attributes.partitionAttributes ~allowUncurry l in + match extension, attrs.stdAttrs with + | None, [] -> toThis + | Some id, _ -> + makeList + ~wrap:("[", "]") + ~postSpace:true + ~indent:0 + ~break:Layout.IfNeed + ~inline:(true, true) + ([ atom ("%" ^ id.txt) ] + @ List.map self#item_attribute l + @ [ toThis ]) + | None, _ -> + makeList + ~postSpace:true + ~indent:0 + ~break:Always + ~inline:(true, true) + (List.map self#item_attribute l @ [ toThis ]) + + method exception_declaration ed = + let pcd_name = ed.pext_name in + let pcd_loc = ed.pext_loc in + let pcd_attributes = [] in + let exn_arg = + match ed.pext_kind with + | Pext_decl (vars, args, type_opt) -> + let pcd_args, pcd_res = args, type_opt in + [ self#type_variant_leaf_nobar + { pcd_name + ; pcd_args + ; pcd_res + ; pcd_loc + ; pcd_attributes + ; pcd_vars = vars + } + ] + | Pext_rebind id -> + [ atom pcd_name.txt; atom "="; self#longident_loc id ] + in + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + ed.pext_attributes + in + let layout = + self#attach_std_item_attrs + stdAttrs + (label + ~space:true + (atom "exception") + (makeList ~postSpace:true ~inline:(true, true) exn_arg)) + in + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:ed.pext_loc + ~layout + () + + (* Note: that override doesn't appear in class_sig_field, but does occur + in class/object expressions. TODO: TODOATTRIBUTES *) + method method_sig_flags_for s = + function + | Virtual -> [ atom "virtual"; atom s ] | Concrete -> [ atom s ] + + method value_type_flags_for s = + function + | Virtual, Mutable -> [ atom "virtual"; atom "mutable"; atom s ] + | Virtual, Immutable -> [ atom "virtual"; atom s ] + | Concrete, Mutable -> [ atom "mutable"; atom s ] + | Concrete, Immutable -> [ atom s ] + + method class_sig_field x = + match x.pctf_desc with + | Pctf_inherit ct -> + label ~space:true (atom "inherit") (self#class_constructor_type ct) + | Pctf_val (s, mf, vf, ct) -> + let valueFlags = self#value_type_flags_for (s.txt ^ ":") (vf, mf) in + label + ~space:true + (label + ~space:true + (atom "val") + (makeList + ~postSpace:true + ~inline:(false, true) + ~break:IfNeed + valueFlags)) + (self#core_type ct) + | Pctf_method (s, pf, vf, ct) -> + let methodFlags = self#method_sig_flags_for (s.txt ^ ":") vf in + let pubOrPrivate = + match pf with Private -> "pri" | Public -> "pub" in - let loc = e1.pexp_loc in - let layout = source_map ~loc e1Layout in - processLetList ((loc, layout)::acc) e2 - | _ -> - let expr = { expr with pexp_attributes = (arityAttrs @ stdAttrs @ jsxAttrs) } - in - match expression_not_immediate_extension_sugar expr with - | Some (extension, {pexp_attributes = []; pexp_desc = Pexp_let (rf, l, e)}) -> - let bindingsLayout = self#bindings ~extension (rf, l) in - let bindingsLoc = self#bindingsLocationRange ~extension:expr l in - let layout = source_map ~loc:bindingsLoc bindingsLayout in - processLetList ((extractLocationFromValBindList expr l, layout)::acc) e - | Some (extension, {pexp_attributes = []; pexp_desc = Pexp_letmodule (s, me, e)}) -> - let loc, layout = letModuleBinding ~extension s me in - processLetList ((loc, layout)::acc) e - | Some (extension, {pexp_attributes = attrs; pexp_desc = Pexp_open (me, e)}) -> - let loc, layout = self#pexp_open ~attrs ~extension expr me in - processLetList ((loc, layout)::acc) e - | Some (extension, e) -> - let layout = self#attach_std_item_attrs ~extension [] (self#unparseExpr e) in - (expr.pexp_loc, layout)::acc - | None -> - (* Should really do something to prevent infinite loops here. Never - allowing a top level call into letList to recurse back to - self#unparseExpr- top level calls into letList *must* be one of the - special forms above whereas lower level recursive calls may be of - any form. *) - let layout = source_map ~loc:expr.pexp_loc (self#unparseExpr expr) in - (expr.pexp_loc, layout)::acc - in - let es = processLetList [] expr in - (* Interleave whitespace between the "let-items" when appropriate *) - groupAndPrint - ~xf:(fun (_, layout) -> layout) - ~getLoc:(fun (loc, _) -> loc) - ~comments:self#comments - (List.rev es) - - method constructor_expression ?(polyVariant=false) ~arityIsClear stdAttrs ctor eo = - let (implicit_arity, arguments) = - match eo.pexp_desc with - | Pexp_construct ( {txt= Lident "()"},_) -> - (* `foo() is a polymorphic variant that contains a single unit construct as expression - * This requires special formatting: `foo(()) -> `foo() *) - (false, atom "()") - (* special printing: MyConstructor(()) -> MyConstructor() *) - | Pexp_tuple l when is_single_unit_construct l -> - (false, atom "()") - | Pexp_tuple l when polyVariant == true -> - (false, self#unparseSequence ~wrap:("(", ")") ~construct:`Tuple l) - | Pexp_tuple l -> - (* There is no ambiguity when the number of tuple components is 1. - We don't need put implicit_arity in that case *) - (match l with - | exprList when isSingleArgParenApplication exprList -> - (false, self#singleArgParenApplication exprList) - | _ -> - (not arityIsClear, makeTup (List.map self#unparseProtectedExpr l))) - | _ when isSingleArgParenApplication [eo] -> - (false, self#singleArgParenApplication [eo]) - | _ -> - (false, makeTup [self#unparseProtectedExpr eo]) - in - let arguments = source_map ~loc:eo.pexp_loc arguments in - let construction = - label ctor (if isSequencey arguments - then arguments - else (ensureSingleTokenSticksToLabel arguments)) - in - let attrs = - if implicit_arity && (not polyVariant) then - { attr_name = { txt="implicit_arity"; loc=eo.pexp_loc } - ; attr_payload = PStr [] - ; attr_loc = eo.pexp_loc - } :: stdAttrs - else - stdAttrs - in - match attrs with - | [] -> construction - | _::_ -> formatAttributed construction (self#attributes attrs) - - (* TODOATTRIBUTES: Handle stdAttrs here (merge with implicit_arity) *) - method constructor_pattern ?(polyVariant=false) ~arityIsClear ctor po = - let (implicit_arity, arguments) = - match po.ppat_desc with - (* There is no ambiguity when the number of tuple components is 1. - We don't need put implicit_arity in that case *) - | Ppat_tuple (([] | _::[]) as l) -> - (false, l) - | Ppat_tuple l -> - (not arityIsClear, l) - - | _ -> (false, [po]) - in - let space, arguments = match arguments with - | [x] when is_direct_pattern x -> (true, self#simple_pattern x) - | xs when isSingleArgParenPattern xs -> (false, self#singleArgParenPattern xs) - (* Optimize the case when it's a variant holding a shot variable - avoid trailing*) - | [{ppat_desc=Ppat_constant (Pconst_string (s, _, None))} as x] - | [{ppat_desc=Ppat_construct (({txt=Lident s}), None)} as x] - | [{ppat_desc=Ppat_var ({txt = s})} as x] - when Reason_heuristics.singleTokenPatternOmmitTrail s -> - let layout = makeTup ~trailComma:false [self#pattern x] in - (false, source_map ~loc:po.ppat_loc layout) - | [{ppat_desc=Ppat_any} as x] - | [{ppat_desc=Ppat_constant (Pconst_char _)} as x] - | [{ppat_desc=Ppat_constant (Pconst_integer _)} as x] -> - let layout = makeTup ~trailComma:false [self#pattern x] in - (false, source_map ~loc:po.ppat_loc layout) - | xs -> - let layout = makeTup (List.map self#pattern xs) in - (false, source_map ~loc:po.ppat_loc layout) - in - let construction = label ~space ctor arguments in - if implicit_arity && (not polyVariant) then - formatAttributed construction - (self#attributes - [ { attr_name = { txt="implicit_arity"; loc=po.ppat_loc } - ; attr_payload = PStr [] - ; attr_loc = po.ppat_loc }]) - else - construction - - (* - * Provides special printing for constructor arguments: - * iff there's one argument & they have some kind of wrapping, - * they're wrapping need to 'hug' the surrounding parens. - * Example: - * switch x { - * | Some({ - * a, - * b, - * }) => () - * } - * - * Notice how ({ and }) hug. - * This applies for records, arrays, tuples & lists. - * Also see `isSingleArgParenPattern` to determine if this kind of wrapping applies. - *) - method singleArgParenPattern = function - | [{ppat_desc = Ppat_record (l, closed); ppat_loc = loc}] -> - source_map ~loc (self#patternRecord ~wrap:("(", ")") l closed) - | [{ppat_desc = Ppat_array l; ppat_loc = loc}] -> - source_map ~loc (self#patternArray ~wrap:("(", ")") l) - | [{ppat_desc = Ppat_tuple l; ppat_loc = loc}] -> - source_map ~loc (self#patternTuple ~wrap:("(", ")") l) - | [{ppat_desc = Ppat_construct (({txt=Lident "::"}), _); ppat_loc} as listPattern] -> - source_map ~loc:ppat_loc (self#patternList ~wrap:("(", ")") listPattern) - | _ -> assert false - - (* TODO: Similar to tuples, do not print parens around type constraints (same for lists) *) - method patternArray ?(wrap=("","")) l = - let (left, right) = wrap in - let wrap = (left ^ "[|", "|]" ^ right) in - makeList ~wrap ~break:IfNeed ~postSpace:true ~sep:commaTrail (List.map self#pattern l) - - method patternTuple ?(wrap=("","")) l = - let (left, right) = wrap in - let wrap = (left ^ "(", ")" ^ right) in - makeList ~wrap ~sep:commaTrail ~postSpace:true ~break:IfNeed (List.map self#pattern l) - - method patternRecord ?(wrap=("","")) l closed = - let longident_x_pattern (li, p) = - match (li, p.ppat_desc) with - | ({txt = ident}, Ppat_var {txt}) when Longident.last_exn ident = txt -> - (* record field punning when destructuring. {x: x, y: y} becomes {x, y} *) - (* works with module prefix too: {MyModule.x: x, y: y} becomes {MyModule.x, y} *) - self#longident_loc li - | ({txt = ident}, - Ppat_alias ({ppat_desc = (Ppat_var {txt = ident2}) }, {txt = aliasIdent})) - when Longident.last_exn ident = ident2 -> - (* record field punning when destructuring with renaming. {state: state as prevState} becomes {state as prevState *) - (* works with module prefix too: {ReasonReact.state: state as prevState} becomes {ReasonReact.state as prevState *) - makeList ~sep:(Sep " ") [self#longident_loc li; atom "as"; atom aliasIdent] - | _ -> - let pattern = - let formatted = self#pattern p in - let wrap = - match p.ppat_desc with - | Ppat_constraint (_, _) -> Some("(", ")") - | _ -> None + let m = + label + ~space:true + (label + ~space:true + (atom pubOrPrivate) + (makeList + ~postSpace:true + ~inline:(false, true) + ~break:IfNeed + methodFlags)) + (self#core_type ct) + in + self#attach_std_item_attrs x.pctf_attributes m + | Pctf_constraint (ct1, ct2) -> + label + ~space:true + (atom "constraint") + (label + ~space:true + (makeList ~postSpace:true [ self#core_type ct1; atom "=" ]) + (self#core_type ct2)) + | Pctf_attribute a -> self#floating_attribute a + | Pctf_extension e -> self#item_extension e + + (* + * /** doc comment */ (* formattedDocs *) + * [@bs.val] [@bs.module "react-dom"] (* formattedAttrs *) + * external render : reactElement => element => unit = (* frstHalf *) + * "render"; (* sndHalf *) + + * To improve the formatting with breaking & indentation: + * * consider the part before the '=' as a label + * * combine that label with '=' in a list + * * consider the part after the '=' as a list + * * combine both parts as a label + * * format the doc comment with a ~postSpace:true (inline, not inline) list + * * format the attributes with a ~postSpace:true (inline, inline) list + * * format everything together in a ~postSpace:true (inline, inline) list + * for nicer breaking + *) + method primitive_declaration ?extension vd = + let external_label = add_extension_sugar "external" extension in + let lblBefore = + label + ~space:true + (makeList + [ makeList + ~postSpace:true + [ atom external_label; protectIdentifier vd.pval_name.txt ] + ; atom ":" + ]) + (self#core_type vd.pval_type) + in + let primDecl = + match vd.pval_prim with + | [ "" ] -> lblBefore + | _ -> + let frstHalf = makeList ~postSpace:true [ lblBefore; atom "=" ] in + let sndHalf = + makeSpacedBreakableInlineList + (List.map self#constant_string_for_primitive vd.pval_prim) in - makeList ~inline:(true, true) ?wrap [ formatted ] + label ~space:true frstHalf sndHalf + in + match vd.pval_attributes with + | [] -> primDecl + | attrs -> + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes ~partDoc:true attrs in - label ~space:true (makeList [self#longident_loc li; atom ":"]) pattern - in - let rows = (List.map longident_x_pattern l)@( - match closed with - | Closed -> [] - | _ -> [atom "_"] - ) in - let (left, right) = wrap in - let wrap = (left ^ "{", "}" ^ right) in - makeList - ~wrap - ~break:IfNeed - ~sep:commaTrail - ~postSpace:true - rows - - method patternFunction ?extension loc l = - let estimatedFunLocation = { - loc_start = loc.loc_start; - loc_end = {loc.loc_start with pos_cnum = loc.loc_start.Lexing.pos_cnum + 3}; - loc_ghost = false; - } in - makeList - ~postSpace:true - ~break:IfNeed - ~inline:(true, true) - ~pad:(false, false) - ((atom ~loc:estimatedFunLocation (add_extension_sugar funToken extension)) :: (self#case_list l)) - - method parenthesized_expr ?break expr = - let result = self#unparseExpr expr in - match expr.pexp_attributes, expr.pexp_desc with - | [], (Pexp_tuple _ | Pexp_construct ({txt=Lident "()"}, None)) -> result - | _ -> makeList ~wrap:("(",")") ?break [self#unparseExpr expr] - - (* Expressions requiring parens, in most contexts such as separated by infix *) - method expression_requiring_parens_in_infix x = - let {Reason_attributes.stdAttrs} = Reason_attributes.partitionAttributes x.pexp_attributes in - assert (stdAttrs == []); - (* keep the incoming expression around, an expr with - * immediate extension sugar might contain less than perfect location - * info in its children (used for comment interleaving), the expression passed to - * 'expression_requiring_parens_in_infix' contains the correct location *) - let originalExpr = x in - let extension, x = expression_immediate_extension_sugar x in - match x.pexp_desc with - (* The only reason Pexp_fun must also be wrapped in parens when under - pipe, is that its => token will be confused with the match token. - Simple expression will also invoke `#reset`. *) - | Pexp_function _ when pipe || semi -> None (* Would be rendered as simplest_expression *) - (* Pexp_function, on the other hand, doesn't need wrapping in parens in - most cases anymore, since `fun` is not ambiguous anymore (we print Pexp_fun - as ES6 functions). *) - | Pexp_function l -> - let prec = Custom funToken in - let expr = self#patternFunction ?extension x.pexp_loc l in - Some (SpecificInfixPrecedence - ({reducePrecedence=prec; shiftPrecedence=prec}, LayoutNode expr)) - | _ -> - (* The Pexp_function cases above don't use location because comment printing - breaks for them. *) - let itm = match x.pexp_desc with - | Pexp_fun _ - | Pexp_newtype _ -> - (* let uncurried = *) - let (args, ret) = self#curriedPatternsAndReturnVal x in - (match args with - | [] -> raise (NotPossible ("no arrow args in unparse ")) - | firstArg::tl -> - (* Suboptimal printing of parens: - - something >>= fun x => x + 1; - - Will be printed as: - - something >>= (fun x => x + 1); - - Because the arrow has lower precedence than >>=, but it wasn't - needed because - - (something >>= fun x) => x + 1; - - Is not a valid parse. Parens around the `=>` weren't needed to - prevent reducing instead of shifting. To optimize this part, we need - a much deeper encoding of the parse rules to print parens only when - needed, testing which rules will be reduced. It really should be - integrated deeply with Menhir. - - One question is, if it's this difficult to describe when parens are - needed, should we even print them with the minimum amount? We can - instead model everything as "infix" with ranked precedences. *) - let retValUnparsed = self#unparseExprApplicationItems ret in - Some (self#wrapCurriedFunctionBinding - ~sweet:(extension = None) - (add_extension_sugar funToken extension) - ~arrow:"=>" firstArg tl retValUnparsed) - ) - | Pexp_try (e, l) -> - let estimatedBracePoint = { - loc_start = e.pexp_loc.loc_end; - loc_end = x.pexp_loc.loc_end; - loc_ghost = false; - } + let docs = List.map self#item_attribute docAttrs in + let formattedDocs = makeList ~postSpace:true docs in + let attrs = List.map self#item_attribute stdAttrs in + let formattedAttrs = makeSpacedBreakableInlineList attrs in + let layouts = + match docAttrs, stdAttrs with + | [], _ -> [ formattedAttrs; primDecl ] + | _, [] -> [ formattedDocs; primDecl ] + | _ -> [ formattedDocs; formattedAttrs; primDecl ] in - let cases = (self#case_list ~allowUnguardedSequenceBodies:true l) in - let switchWith = self#dont_preserve_braces#formatSingleArgLabelApplication - (atom (add_extension_sugar "try" extension)) - e + makeSpacedBreakableInlineList layouts + + method classTypeSigsAndRest x = + match x.pcty_desc with + | Pcty_signature cs -> + let { pcsig_self = ct; pcsig_fields = l } = cs in + let instTypeFields = List.map self#class_sig_field l in + let allItems = + match ct.ptyp_desc with + | Ptyp_any -> instTypeFields + | _ -> + label ~space:true (atom "as") (self#core_type ct) + :: instTypeFields in - Some ( - label - ~space:true - switchWith - (source_map ~loc:estimatedBracePoint - (makeList ~indent:settings.trySwitchIndent ~wrap:("{", "}") - ~break:Always_rec ~postSpace:true cases)) - ) - (* These should have already been handled and we should never havgotten this far. *) - | Pexp_setinstvar _ -> raise (Invalid_argument "Cannot handle setinstvar here - call unparseExpr") - | Pexp_setfield (_, _, _) -> raise (Invalid_argument "Cannot handle setfield here - call unparseExpr") - | Pexp_apply _ -> raise (Invalid_argument "Cannot handle apply here - call unparseExpr") - | Pexp_match (e, l) -> - let estimatedBracePoint = { - loc_start = e.pexp_loc.loc_end; - (* See originalExpr binding, for more info. - * It contains the correct location under immediate extension sugar *) - loc_end = originalExpr.pexp_loc.loc_end; - loc_ghost = false; - } - in - let cases = (self#case_list ~allowUnguardedSequenceBodies:true l) in - let switchWith = - label ~space:true (atom (add_extension_sugar "switch" extension)) - (self#parenthesized_expr ~break:IfNeed e) - in - let lbl = - label - ~space:true - switchWith - (source_map ~loc:estimatedBracePoint - (makeList ~indent:settings.trySwitchIndent ~wrap:("{", "}") - ~break:Always_rec ~postSpace:true cases)) - in - Some lbl - | Pexp_ifthenelse (e1, e2, eo) -> - let (blocks, finalExpression) = sequentialIfBlocks eo in - let rec singleExpression exp = - match exp.pexp_desc with - | Pexp_ident _ -> true - | Pexp_constant _ -> true - | Pexp_construct (_, arg) -> - (match arg with - | None -> true - | Some x -> singleExpression x) - | _ -> false + allItems + | _ -> [ self#class_instance_type x ] + + method class_instance_type x = + match x.pcty_desc with + | Pcty_signature _ | Pcty_open _ -> + let opens, rest = self#classTypeOpens x in + let cs = self#classTypeSigsAndRest rest in + self#attach_std_item_attrs + ~allowUncurry:false + x.pcty_attributes + (makeList + ~wrap:("{", "}") + ~postSpace:true + ~break:Layout.Always_rec + (List.map semiTerminated (List.concat [ opens; cs ]))) + | Pcty_constr (li, l) -> + self#attach_std_attrs + x.pcty_attributes + (match l with + | [] -> self#longident_loc li + | _ :: _ -> + label + (self#longident_loc li) + (makeList + ~wrap:("(", ")") + ~sep:commaTrail + (List.map self#core_type l))) + | Pcty_extension e -> + self#attach_std_item_attrs x.pcty_attributes (self#extension e) + | Pcty_arrow _ -> + failwith "class_instance_type should not be printed with Pcty_arrow" + + method classTypeOpens x = + let rec gatherOpens acc opn = + match opn.pcty_desc with + | Pcty_open (md, ct) -> + let li = md.popen_expr in + gatherOpens + (source_map + ~loc:li.loc + (label + ~space:true + (atom ("open" ^ override md.popen_override)) + (self#longident_loc li)) + :: acc) + ct + | _ -> List.rev acc, opn + in + gatherOpens [] x + + method class_declaration_list l = + let class_declaration + ?(class_keyword = false) + ({ pci_params = ls; pci_name = { txt }; pci_virt; pci_loc } as x) + = + let firstToken, pattern, patternAux = + self#class_opening class_keyword txt pci_virt ls in - let singleLineIf = - (singleExpression e1) && - (singleExpression e2) && - (match eo with - | Some expr -> singleExpression expr - | None -> true - ) + let classBinding = + self#wrappedClassBinding firstToken pattern patternAux x.pci_expr + in + source_map + ~loc:pci_loc + (self#attach_std_item_attrs x.pci_attributes classBinding) + in + match l with + | [] -> + raise (NotPossible "Class definitions will have at least one item.") + | x :: rest -> + makeNonIndentedBreakingList + (class_declaration ~class_keyword:true x + :: List.map class_declaration rest) + + (* For use with [class type a = class_instance_type]. Class type + declarations/definitions declare the types of instances generated by + class constructors. We have to call self#class_instance_type because + self#class_constructor_type would add a "new" before the type. TODO: + TODOATTRIBUTES: *) + method class_type_declaration_list l = + let class_type_declaration + kwd + ({ pci_params = ls; pci_name; pci_attributes } as x) + = + let opener = + match x.pci_virt with + | Virtual -> kwd ^ " " ^ "virtual" + | Concrete -> kwd in - let makeLetSequence = - if singleLineIf then - makeLetSequenceSingleLine + + let upToName = + if ls == [] + then label ~space:true (atom opener) (atom pci_name.txt) else - makeLetSequence + label + ~space:true + (label ~space:true (atom opener) (atom pci_name.txt)) + (self#class_params_def ls) in - let rec sequence soFar remaining = ( - match (remaining, finalExpression) with - | ([], None) -> soFar - | ([], Some e) -> - let soFarWithElseAppended = makeList ~postSpace:true [soFar; atom "else"] in - label ~space:true soFarWithElseAppended - (source_map ~loc:e.pexp_loc (makeLetSequence (self#letList e))) - | (hd::tl, _) -> - let (e1, e2) = hd in - let soFarWithElseIfAppended = - label - ~space:true - (makeList ~postSpace:true [soFar; atom "else if"]) - (makeList ~wrap:("(",")") [self#unparseExpr e1]) - in - let nextSoFar = - label ~space:true soFarWithElseIfAppended - (source_map ~loc:e2.pexp_loc (makeLetSequence (self#letList e2))) - in - sequence nextSoFar tl - ) in - let init = - let if_ = atom (add_extension_sugar "if" extension) in - let cond = self#parenthesized_expr e1 in - label ~space:true - (source_map ~loc:e1.pexp_loc (label ~space:true if_ cond)) - (source_map ~loc:e2.pexp_loc (makeLetSequence (self#letList e2))) + let includingEqual = + makeList ~postSpace:true [ upToName; atom "=" ] in - Some (sequence init blocks) - | Pexp_while (e1, e2) -> - let lbl = - let while_ = atom (add_extension_sugar "while" extension) in - let cond = self#parenthesized_expr e1 in - label ~space:true - (label ~space:true while_ cond) - (source_map ~loc:e2.pexp_loc (makeLetSequence (self#letList e2))) + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes ~partDoc:true pci_attributes in - Some lbl - | Pexp_for (s, e1, e2, df, e3) -> - (* - * for longIdentifier in - * (longInit expr) to - * (longEnd expr) { - * print_int longIdentifier; - * }; - *) - let identifierIn = (makeList ~postSpace:true [self#pattern s; atom "in";]) in - let dockedToFor = makeList + let layout = + self#attach_std_item_attrs stdAttrs + @@ label + ~space:true + includingEqual + (self#class_instance_type x.pci_expr) + in + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:pci_name.loc + ~layout + () + in + match l with + | [] -> + failwith "Should not call class_type_declaration with no classes" + | [ x ] -> class_type_declaration "class type" x + | x :: xs -> + makeList + ~break:Always_rec + ~indent:0 + ~inline:(true, true) + (class_type_declaration "class type" x + :: List.map (class_type_declaration "and") xs) + + (* Formerly the [class_type] Notice how class_constructor_type doesn't + have any type attributes - class_instance_type does. TODO: Divide + into class_constructor_types that allow arrows and ones that + don't. *) + method class_constructor_type x = + match x.pcty_desc with + | Pcty_arrow _ -> + let rec allArrowSegments acc = function + | { pcty_desc = Pcty_arrow (l, ct1, ct2) } -> + allArrowSegments + (self#type_with_label (l, ct1, false) :: acc) + ct2 + (* This "new" is unfortunate. See reason_parser.mly for + details. *) + | xx -> List.rev acc, self#class_constructor_type xx + in + let params, return = allArrowSegments [] x in + let normalized = + makeList ~break:IfNeed + ~sep:(Sep "=>") + ~preSpace:true ~postSpace:true ~inline:(true, true) - ~wrap:("(",")") - [ - identifierIn; - makeList ~postSpace:true [self#unparseExpr e1; self#direction_flag df]; - (self#unparseExpr e2); - ] - in - let upToBody = makeList ~inline:(true, true) ~postSpace:true - [atom (add_extension_sugar "for" extension); dockedToFor] + [ makeCommaBreakableListSurround "(" ")" params; return ] in - Some (label ~space:true upToBody - (source_map ~loc:e3.pexp_loc (makeLetSequence (self#letList e3)))) - | Pexp_new li -> - Some (label ~space:true (atom "new") (self#longident_class_or_type_loc li)) - | Pexp_assert e -> - Some ( + source_map ~loc:x.pcty_loc normalized + | _ -> + (* Unfortunately, we have to have final components of a + class_constructor_type be prefixed with the `new` keyword. + Hopefully this is temporary. *) + self#class_instance_type x + + method non_arrowed_class_constructor_type x = + match x.pcty_desc with + | Pcty_arrow _ -> + source_map + ~loc:x.pcty_loc + (formatPrecedence (self#class_constructor_type x)) + | _ -> self#class_instance_type x + + method class_field x = + let itm = + match x.pcf_desc with + | Pcf_inherit (ovf, ce, so) -> + let inheritText = "inherit" ^ override ovf in + let inheritExp = self#class_expr ce in label - (atom "assert") - (makeTup [(self#unparseExpr e)]); - ) - | Pexp_lazy e -> - Some (self#formatSingleArgLabelApplication (atom "lazy") e) - | Pexp_poly _ -> - failwith ( - "This version of the pretty printer assumes it is impossible to " ^ - "construct a Pexp_poly outside of a method definition - yet it sees one." - ) - | _ -> None - in - match itm with - | None -> None - | Some i -> Some (PotentiallyLowPrecedence (source_map ~loc:x.pexp_loc i)) + ~space:true + (atom inheritText) + (match so with + | None -> inheritExp + | Some s -> label ~space:true inheritExp (atom ("as " ^ s.txt))) + | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> + let opening = + match mf with + | Mutable -> + let mutableName = [ atom "mutable"; atom s.txt ] in + label + ~space:true + (atom ("val" ^ override ovf)) + (makeList + ~postSpace:true + ~inline:(false, true) + ~break:IfNeed + mutableName) + | Immutable -> + label ~space:true (atom ("val" ^ override ovf)) (atom s.txt) + in + let valExprAndConstraint = + match e.pexp_desc with + | Pexp_constraint (ex, ct) -> + let openingWithTypeConstraint = + formatTypeConstraint opening (self#core_type ct) + in + label + ~space:true + (makeList + ~postSpace:true + [ openingWithTypeConstraint; atom "=" ]) + (self#unparseExpr ex) + | _ -> + label + ~space:true + (makeList ~postSpace:true [ opening; atom "=" ]) + (self#unparseExpr e) + in + valExprAndConstraint + | Pcf_val (s, mf, Cfk_virtual ct) -> + let opening = + match mf with + | Mutable -> + let mutableVirtualName = + [ atom "mutable"; atom "virtual"; atom s.txt ] + in + let openingTokens = + makeList + ~postSpace:true + ~inline:(false, true) + ~break:IfNeed + mutableVirtualName + in + label ~space:true (atom "val") openingTokens + | Immutable -> + let virtualName = [ atom "virtual"; atom s.txt ] in + let openingTokens = + makeList + ~postSpace:true + ~inline:(false, true) + ~break:IfNeed + virtualName + in + label ~space:true (atom "val") openingTokens + in + formatTypeConstraint opening (self#core_type ct) + | Pcf_method (s, pf, Cfk_virtual ct) -> + let opening = + match pf with + | Private -> + let privateVirtualName = [ atom "virtual"; atom s.txt ] in + let openingTokens = + makeList + ~postSpace:true + ~inline:(false, true) + ~break:IfNeed + privateVirtualName + in + label ~space:true (atom "pri") openingTokens + | Public -> + let virtualName = [ atom "virtual"; atom s.txt ] in + let openingTokens = + makeList + ~postSpace:true + ~inline:(false, true) + ~break:IfNeed + virtualName + in + label ~space:true (atom "pub") openingTokens + in + formatTypeConstraint opening (self#core_type ct) + | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> + let methodText = + let postFix = if ovf == Override then "!" else "" in + match pf with + | Private -> "pri" ^ postFix + | Public -> "pub" ^ postFix + in + (* Should refactor the binding logic so faking out the AST isn't + needed, currently, it includes a ton of nuanced logic around + recovering explicitly polymorphic type definitions, and that + furthermore, that representation... Actually, let's do it. + + For some reason, concrete methods are only ever parsed as + Pexp_poly. If there *is* no polymorphic function for the + method, then the return value of the function is wrapped in a + ghost Pexp_poly with [None] for the type vars.*) + (match e.pexp_desc with + | Pexp_poly + ( { pexp_desc = + Pexp_constraint + (methodFunWithNewtypes, nonVarifiedExprType) + } + , Some { ptyp_desc = Ptyp_poly (typeVars, varifiedPolyType) } + ) + when let leadingAbstractVars, _ = + self#leadingCurriedAbstractTypes methodFunWithNewtypes + in + self#isRenderableAsPolymorphicAbstractTypes + typeVars + (* If even artificially varified. Don't know until this + returns*) + varifiedPolyType + leadingAbstractVars + nonVarifiedExprType -> + let leadingAbstractVars, _ = + self#leadingCurriedAbstractTypes methodFunWithNewtypes + in + self#locallyAbstractPolymorphicFunctionBinding + methodText + (atom s.txt) + methodFunWithNewtypes + leadingAbstractVars + nonVarifiedExprType + | Pexp_poly (e, Some ct) -> + self#formatSimplePatternBinding + methodText + (atom s.txt) + (Some (source_map ~loc:ct.ptyp_loc (self#core_type ct))) + (self#unparseExprApplicationItems e) + (* This form means that there is no type constraint - it's a + strange node name.*) + | Pexp_poly (e, None) -> + self#wrappedBinding methodText ~arrow:"=>" (atom s.txt) [] e + | _ -> + failwith "Concrete methods should only ever have Pexp_poly.") + | Pcf_constraint (ct1, ct2) -> + label + ~space:true + (atom "constraint") + (makeList + ~postSpace:true + ~inline:(true, false) + [ makeList ~postSpace:true [ self#core_type ct1; atom "=" ] + ; self#core_type ct2 + ]) + | Pcf_initializer e -> + label + ~space:true + (atom "initializer") + (self#simplifyUnparseExpr e) + | Pcf_attribute a -> self#floating_attribute a + | Pcf_extension e -> + (* And don't forget, we still need to print post_item_attributes + even for this case *) + self#item_extension e + in + let layout = self#attach_std_attrs x.pcf_attributes itm in + source_map ~loc:x.pcf_loc layout + + method class_self_pattern_and_structure + { pcstr_self = p; pcstr_fields = l } = + let fields = List.map self#class_field l in + (* Recall that by default self is bound to "this" at parse time. You'd + have to go out of your way to bind it to "_". *) + match p.ppat_attributes, p.ppat_desc with + | [], Ppat_var { txt = "this" } -> fields + | _ -> + let field = label ~space:true (atom "as") (self#pattern p) in + source_map ~loc:p.ppat_loc field :: fields - method potentiallyConstrainedExpr x = - match x.pexp_desc with - | Pexp_constraint (e, ct) -> - formatTypeConstraint (self#unparseExpr e) (self#core_type ct) - | _ -> self#unparseExpr x - - - (* - * Because the rule BANG simple_expr was given %prec below_DOT_AND_SHARP, - * !x.y.z will parse as !(x.y.z) and not (!x).y.z. - * - * !x.y.z == !((x.y).z) - * !x#y#z == !((x#y)#z) - * - * So the intuition is: In general, any simple expression can exist to the - * left of a `.`, except `BANG simple_expr`, which has special precedence, - * and must be guarded in this one case. - * - * TODO: Instead of special casing this here, we should continue to extend - * unparseExpr to also unparse simple expressions, (by encoding the - * rules precedence below_DOT_AND_SHARP). - * - * TODO: - * Some would even have the prefix application be parsed with lower - * precedence function *application*. In the case of !, where ! means not, - * it makes a lot of sense because (!identifier)(arg) would be meaningless. - * - * !callTheFunction(1, 2, 3)(andEvenCurriedArgs) - * - * Only problem is that it could then not appear anywhere simple expressions - * would appear. - * - * We could make a special case for ! followed by one simple expression, and - * consider the result simple. - * - * Alternatively, we can figure out a way to not require simple expressions - * in the most common locations such as if/while tests. This is really hard - * (impossible w/ grammars Menhir supports?) - * - * if ! myFunc argOne argTwo { - * - * } else { - * - * }; - * - *) - method simple_enough_to_be_lhs_dot_send x = - match x.pexp_desc with - | (Pexp_apply (eFun, _)) -> ( - match printedStringAndFixityExpr eFun with - | AlmostSimplePrefix _ - | UnaryPlusPrefix _ - | UnaryMinusPrefix _ - | UnaryNotPrefix _ - | UnaryPostfix _ - | Infix _ -> self#simplifyUnparseExpr x - | Letop _ | Andop _ - | Normal -> - if x.pexp_attributes == [] then - (* `let a = foo().bar` instead of `let a = (foo()).bar *) - (* same for foo()##bar, foo()#=bar, etc. *) - self#unparseExpr x + method simple_class_expr x = + let { Reason_attributes.stdAttrs } = + Reason_attributes.partitionAttributes x.pcl_attributes + in + if stdAttrs != [] + then + formatSimpleAttributed + (self#simple_class_expr { x with pcl_attributes = [] }) + (self#attributes stdAttrs) else - self#simplifyUnparseExpr x - ) - | _ -> self#simplifyUnparseExpr x - - method unparseRecord - ?wrap:((lwrap, rwrap)=("", "")) - ?withStringKeys:(withStringKeys=false) - ?allowPunning:(allowPunning=true) - ?forceBreak:(forceBreak=false) - l eo = - (* forceBreak is a ref which can be set to always break the record rows. - * Example, when we have a row which contains a nested record, - * this ref can be set to true from inside the printing of that row, - * which forces breaks for the outer record structure. *) - let forceBreak = ref forceBreak in - let quote = (atom "\"") in - let maybeQuoteFirstElem fst rest = - if withStringKeys then (match fst.txt with - | Lident s -> quote::(atom s)::quote::rest - | Ldot _ | Lapply _ -> assert false - ) - else - (self#longident_loc fst)::rest - in - let makeRow (li, e) shouldPun = - let totalRowLoc = { - loc_start = li.Asttypes.loc.loc_start; - loc_end = e.pexp_loc.loc_end; - loc_ghost = false; - } in - let theRow = match (e.pexp_desc, shouldPun, allowPunning) with - (* record value punning. Turns {foo: foo, bar: 1} into {foo, bar: 1} *) - (* also turns {Foo.bar: bar, baz: 1} into {Foo.bar, baz: 1} *) - (* don't turn {bar: Foo.bar, baz: 1} into {bar, baz: 1}, naturally *) - | (Pexp_ident {txt = Lident value}, true, true) when Longident.last_exn li.txt = value -> - makeList (maybeQuoteFirstElem li []) - - (* Force breaks for nested records or mel.obj sugar - * Example: - * let person = {name: {first: "Bob", last: "Zhmith"}, age: 32}; - * is a lot less readable than - * let person = { - * "name": { - * "first": "Bob", - * "last": "Zhmith" - * }, - * "age": 32 - * }; - *) - | (Pexp_record (recordRows, optionalGadt), _, _) -> - forceBreak := true; - let keyWithColon = makeList (maybeQuoteFirstElem li [atom ":"]) in - let value = self#unparseRecord ~forceBreak:true recordRows optionalGadt in - label ~space:true keyWithColon value - | (Pexp_extension (s, p), _, _) when s.txt = "mel.obj" -> - forceBreak := true; - let keyWithColon = makeList (maybeQuoteFirstElem li [atom ":"]) in - let value = self#formatBsObjExtensionSugar ~forceBreak:true p in - label ~space:true keyWithColon value - | (Pexp_object classStructure, _, _) -> - forceBreak := true; - let keyWithColon = makeList (maybeQuoteFirstElem li [atom ":"]) in - let value = self#classStructure ~forceBreak:true classStructure in - label ~space:true keyWithColon value - | _ -> - let (argsList, return) = self#curriedPatternsAndReturnVal e in - match argsList with - | [] -> - let appTerms = self#unparseExprApplicationItems e in - let upToColon = makeList (maybeQuoteFirstElem li [atom ":"]) in - formatAttachmentApplication applicationFinalWrapping (Some (true, upToColon)) appTerms - | firstArg :: tl -> - let upToColon = makeList (maybeQuoteFirstElem li [atom ":"]) in - let returnedAppTerms = self#unparseExprApplicationItems return in - self#wrapCurriedFunctionBinding - ~sweet:true ~attachTo:upToColon funToken ~arrow:"=>" - firstArg tl returnedAppTerms - in (source_map ~loc:totalRowLoc theRow, totalRowLoc) - in - let rec getRows l = - match l with - | [] -> [] - | hd::[] -> [makeRow hd true] - | hd::hd2::tl -> (makeRow hd true)::(getRows (hd2::tl)) - in + let itm = + match x.pcl_desc with + | Pcl_constraint (ce, ct) -> + formatTypeConstraint + (self#class_expr ce) + (self#class_constructor_type ct) + (* In OCaml, + * - In the most recent version of OCaml, when in the top level of a + * module, let _ = ... is a PStr_eval. + * - When in a function, it is a Pexp_let PPat_any + * - When in class pre-member let bindings it is a Pcl_let PPat_any + * + * Reason normalizes all of these to be simple imperative expressions + * with trailing semicolons, *except* in the case of classes because it + * will likely introduce a conflict with some proposed syntaxes for + * objects. + *) + | Pcl_let _ | Pcl_structure _ | Pcl_open _ -> + let opens, rest = self#classExprOpens x in + let rows = self#classExprLetsAndRest rest in + makeList + ~wrap:("{", "}") + ~inline:(true, false) + ~postSpace:true + ~break:Always_rec + (List.map semiTerminated (List.concat [ opens; rows ])) + | Pcl_extension e -> self#extension e + | _ -> formatPrecedence (self#class_expr x) + in + source_map ~loc:x.pcl_loc itm + + method classExprLetsAndRest x = + match x.pcl_desc with + | Pcl_structure cs -> self#class_self_pattern_and_structure cs + | Pcl_let (rf, l, ce) -> + (* For "letList" bindings, the start/end isn't as simple as with + * module value bindings. For "let lists", the sequences were formed + * within braces {}. The parser relocates the first let binding to the + * first brace. *) + let binding = + source_map + ~loc:(self#bindingsLocationRange l) + (self#bindings (rf, l)) + in + binding :: self#classExprLetsAndRest ce + | Pcl_open (_, ce) -> self#classExprLetsAndRest ce + | _ -> [ self#class_expr x ] + + method classExprOpens x = + let rec gatherOpens acc opn = + match opn.pcl_desc with + | Pcl_open (md, ce) -> + let li = md.popen_expr in + gatherOpens + (source_map + ~loc:li.loc + (label + ~space:true + (atom ("open" ^ override md.popen_override)) + (self#longident_loc li)) + :: acc) + ce + | _ -> List.rev acc, opn + in + gatherOpens [] x - let allRows = match eo with - | None -> ( - match l with - (* No punning (or comma) for records with only a single field. It's ambiguous with an expression in a scope *) - (* See comment in parser.mly for lbl_expr_list_with_at_least_one_non_punned_field *) - | [hd] -> [makeRow hd false] - | _ -> getRows l - ) - (* This case represents a "spread" being present -> {...x, a: 1, b: 2} *) - | Some withRecord -> - let firstRow = - let row = ( - (* Unclear why "sugar_expr" was special cased hre. *) - let appTerms = self#unparseExprApplicationItems withRecord in - formatAttachmentApplication applicationFinalWrapping (Some (false, (atom "..."))) appTerms - ) - in ( - source_map ~loc:withRecord.pexp_loc row, - withRecord.pexp_loc - ) - in - firstRow::(getRows l) - in - let break = - (* if a record has more than 1 row, always break *) - match !forceBreak, allRows with - | false, ([] | [ _ ]) -> Layout.IfNeed - | _ -> Layout.Always_rec - in - makeList - ~wrap:(lwrap ^ "{" ,"}" ^ rwrap) - ~break - ~sep:commaTrail - ~postSpace:true - (groupAndPrint ~xf:fst ~getLoc:snd ~comments:self#comments allRows) - - method isSeriesOfOpensFollowedByNonSequencyExpression expr = - match (expr.pexp_attributes, expr.pexp_desc) with - | ([], Pexp_let _) -> false - | ([], Pexp_letop _) -> false - | ([], Pexp_sequence _) -> false - | ([], Pexp_letmodule _) -> false - | ([], Pexp_open ({ popen_override; popen_expr = { pmod_desc = Pmod_ident _; _ }; _ }, e)) -> - popen_override == Fresh && self#isSeriesOfOpensFollowedByNonSequencyExpression e - | ([], Pexp_open _) -> false - | ([], Pexp_letexception _) -> false - | ([], Pexp_extension ({txt}, _)) -> txt = "mel.obj" - | _ -> true - - method unparseObject ?wrap:((lwrap,rwrap)=("", "")) ?(withStringKeys=false) l o = - let core_field_type = fun { pof_desc; pof_attributes; _ } -> match pof_desc with - | Otag ({txt}, ct) -> - let l = Reason_attributes.extractStdAttrs pof_attributes in - let row = - let rowKey = if withStringKeys then - (makeList ~wrap:("\"", "\"") [atom txt]) - else (atom txt) - in - label ~space:true - (makeList ~break:Layout.Never [rowKey; (atom ":")]) - (self#core_type ct) - in - (match l with - | [] -> row - | _::_ -> - makeList - ~postSpace:true - ~break:IfNeed - ~inline:(true, true) - (List.concat [self#attributes pof_attributes; [row]])) - | Oinherit ct -> makeList ~break:Layout.Never [atom "..."; self#core_type ct] - in - let rows = List.map core_field_type l in - let openness = match o with - | Closed -> atom "." - | Open -> atom ".." - in - (* if an object has more than 2 rows, always break for readability *) - let rows_layout = - let break = match rows with - | [] | [ _ ] -> Layout.IfNeed - | _ -> Layout.Always_rec - in - makeList ~break ~inline:(true, true) ~postSpace:true ~sep:commaTrail rows - in - makeList - ~break:Layout.IfNeed - ~preSpace:(rows != []) - ~wrap:(lwrap ^ "{", "}" ^ rwrap) - (openness::[rows_layout]) - - method unparseSequence ?wrap:(wrap=("", "")) ~construct l = - match construct with - | `ES6List -> - let seq, ext = (match List.rev l with - | ext :: seq_rev -> (List.rev seq_rev, ext) - | [] -> assert false) in - makeES6List ~wrap (List.map self#unparseExpr seq) (self#unparseExpr ext) - | _ -> - let (left, right) = wrap in - let (xf, (leftDelim, rightDelim)) = (match construct with - | `List -> (self#unparseExpr, ("[", "]")) - | `Array -> (self#unparseExpr, ("[|", "|]")) - | `Tuple -> (self#potentiallyConstrainedExpr, ("(", ")")) - | `ES6List -> assert false) - in - let wrap = (left ^ leftDelim, rightDelim ^ right) in - makeList - ~wrap - ~sep:commaTrail - ~break:IfNeed - ~postSpace:true - (List.map xf l) - - - method formatBsObjExtensionSugar ?wrap:(wrap=("", "")) ?(forceBreak=false) payload = - match payload with - | PStr [itm] -> ( - match itm with - | {pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (l, eo) }, []) } -> - self#unparseRecord ~forceBreak ~wrap ~withStringKeys:true ~allowPunning:false l eo - | {pstr_desc = Pstr_eval ({ pexp_desc = Pexp_extension ({txt = "mel.obj"}, payload) }, []) } -> - (* some folks write `[%mel.obj [%mel.obj {foo: bar}]]`. This looks improbable but - it happens often if you use the sugared version: `[%mel.obj {"foo": bar}]`. - We're gonna be lenient here and treat it as if they wanted to just write - `{"foo": bar}`. BuckleScript does the same relaxation when parsing mel.obj - *) - self#formatBsObjExtensionSugar ~wrap ~forceBreak payload - | _ -> raise (Invalid_argument "mel.obj only accepts a record. You've passed something else")) - | _ -> assert false - - method should_preserve_requested_braces expr = - let {Reason_attributes.stylisticAttrs} = Reason_attributes.partitionAttributes expr.pexp_attributes in - match expr.pexp_desc with - | Pexp_ifthenelse _ - | Pexp_try _ -> false - | Pexp_sequence _ -> - (* `let ... in` should _always_ preserve braces *) - true - | _ -> - preserve_braces && - Reason_attributes.has_preserve_braces_attrs stylisticAttrs - - method simplest_expression x = - let {Reason_attributes.stdAttrs; jsxAttrs; stylisticAttrs; arityAttrs} = - Reason_attributes.partitionAttributes x.pexp_attributes in - let hasJsxAttribute = jsxAttrs != [] in - if stdAttrs != [] then - None - else if self#should_preserve_requested_braces x then - let layout = - makeList - ~break:(if inline_braces then Always else Always_rec) - ~inline:(true, inline_braces) - ~wrap:("{", "}") - ~postSpace:true - ~sep:(if inline_braces then (Sep ";") else (SepFinal (";", ";"))) - (self#letList x) - in - Some layout - else - let item = - match x.pexp_desc with - (* The only reason Pexp_fun must also be wrapped in parens is that its => - token will be confused with the match token. *) - | Pexp_fun _ when pipe || semi -> Some (self#reset#simplifyUnparseExpr x) - | Pexp_function l when pipe || semi -> Some (formatPrecedence ~loc:x.pexp_loc (self#reset#patternFunction x.pexp_loc l)) - | Pexp_apply _ -> ( - match self#simple_get_application x with - (* If it's the simple form of application. *) - | Some simpleGet -> Some simpleGet - | None -> None - ) - | Pexp_object cs -> Some (self#classStructure cs) - | Pexp_override l -> (* FIXME *) - let string_x_expression (s, e) = - label ~space:true (atom (s.txt ^ ":")) (self#unparseExpr e) - in - Some ( - makeList - ~postSpace:true - ~wrap:("{<", ">}") - ~sep:(Sep ",") - (List.map string_x_expression l) - ) - | Pexp_construct ( {txt= Lident "[]"},_) when hasJsxAttribute -> Some (atom "<> ") - | Pexp_construct ( {txt= Lident"::"},Some _) when hasJsxAttribute -> - (match self#formatJsxChildrenNonSpread x [] with - | None -> - (* Back out of the standard jsx child formatting *) - (* This is actually not a useful construct to have written: - * <> ... x - * Is the same as: - * x - * There is also a bug in the parser where a space is needed - * between <> and ..., but no one would write the ... form of - * <> anyways. *) - let withoutJsxAttributes = {x with pexp_attributes=(stylisticAttrs @ arityAttrs)} in - self#simplest_expression withoutJsxAttributes - | Some chldn -> - Some (makeList - ~break:IfNeed - ~inline:(false, false) - ~postSpace:true - ~wrap:("<>", "") - ~pad:(true, true) - chldn)) - | Pexp_construct _ when is_simple_construct (view_expr x) -> - Some ( - match view_expr x with - | `nil -> atom "[]" - | `tuple -> atom "()" - | `list xs -> (* LIST EXPRESSION *) - self#unparseSequence ~construct:`List xs - | `cons xs -> - self#unparseSequence ~construct:`ES6List xs - | `simple x -> self#longident x - | _ -> assert false - ) - | Pexp_ident li -> - (* Lone identifiers shouldn't break when to the right of a label *) - Some (ensureSingleTokenSticksToLabel (self#longident_loc li)) - | Pexp_constant c -> - (* Constants shouldn't break when to the right of a label *) - let raw_literal, _ = Reason_attributes.extract_raw_literal x.pexp_attributes in - Some (ensureSingleTokenSticksToLabel - (self#constant ?raw_literal c)) - | Pexp_pack me -> - Some ( - makeList - ~break:IfNeed - ~postSpace:true - ~wrap:("(", ")") - ~inline:(true, true) - [atom "module"; self#module_expr me;] - ) - | Pexp_tuple l -> - (* TODO: These may be simple, non-simple, or type constrained - non-simple expressions *) - Some (self#unparseSequence ~construct:`Tuple l) - | Pexp_constraint (e, ct) -> - Some ( - makeList - ~break:IfNeed - ~wrap:("(", ")") - [formatTypeConstraint (self#unparseExpr e) (self#core_type ct)] - ) - | Pexp_coerce (e, cto1, ct) -> - let optFormattedType = match cto1 with - | None -> None - | Some typ -> Some (self#core_type typ) in - Some ( - makeList - ~break:IfNeed - ~wrap:("(", ")") - [formatCoerce (self#unparseExpr e) optFormattedType (self#core_type ct)] - ) - | Pexp_variant (l, None) -> - Some (ensureSingleTokenSticksToLabel (atom ("`" ^ l))) - | Pexp_record (l, eo) -> Some (self#unparseRecord l eo) - | Pexp_array l -> - Some (self#unparseSequence ~construct:`Array l) - | Pexp_let _ | Pexp_sequence _ - | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_letop _ -> - Some (makeLetSequence (self#letList x)) - | Pexp_extension e -> - begin match expression_immediate_extension_sugar x with - | (Some _, _) -> None - | (None, _) -> - match expression_extension_sugar x with - | None -> Some (self#extension e) - | Some (_, x') -> - match x'.pexp_desc with - | Pexp_let _ | Pexp_letop _ | Pexp_letmodule _ -> - Some (makeLetSequence (self#letList x)) - | _ -> Some (self#extension e) - end - | Pexp_open (me, e) -> - if self#isSeriesOfOpensFollowedByNonSequencyExpression x then - Some - (label - (label - (self#moduleExpressionToFormattedApplicationItems me.popen_expr) - (atom ("."))) - (self#formatNonSequencyExpression ~parent:x e)) - else - Some (makeLetSequence (self#letList x)) - | Pexp_send (e, s) -> - let needparens = match e.pexp_desc with - | Pexp_apply (ee, _) -> - (match printedStringAndFixityExpr ee with - | UnaryPostfix "^" -> true - | _ -> false) - | _ -> false - in - let lhs = self#simple_enough_to_be_lhs_dot_send e in - let lhs = if needparens then makeList ~wrap:("(",")") [lhs] else lhs in - Some (label (makeList [lhs; atom "#";]) (atom s.txt)) - | Pexp_unreachable -> Some (atom ".") - | _ -> None - in - match item with - | None -> None - | Some i -> Some (source_map ~loc:x.pexp_loc i) - - (* Renders jsx children. Returns None if it is not a valid JSX child - * structure and must be rendered as spread. You cannot render any list of - * JSX children in Reason unless it is nil-terminated. Otherwise you must use - * spread. *) - method formatJsxChildrenNonSpread expr processedRev = - let formatJsxChild x = - match x with - | ({pexp_desc = Pexp_apply _} as e) -> - (* Pipe first behaves differently according to the expression on the - * right. In example (1) below, it's a `SpecificInfixPrecedence`; in - * (2), however, it's `Simple` and doesn't need to be wrapped in parens. - * - * (1).
{items->Belt.Array.map(ReasonReact.string)->ReasonReact.array}
; - * (2). (title === "" ? [1, 2, 3] : blocks)->Foo.toString ; *) - if Reason_heuristics.isPipeFirst e && - not (Reason_heuristics.isPipeFirstWithNonSimpleJSXChild e) + method class_expr x = + let { Reason_attributes.stdAttrs } = + Reason_attributes.partitionAttributes x.pcl_attributes + in + (* We cannot handle the attributes here. Must handle them in each + item *) + if stdAttrs != [] then - self#formatPipeFirst e + (* Do not need a "simple" attributes precedence wrapper. *) + formatAttributed + (self#simple_class_expr { x with pcl_attributes = [] }) + (self#attributes stdAttrs) else - self#inline_braces#simplifyUnparseExpr ~inline:true ~wrap:("{", "}") e - - (* No braces - very simple *) - | {pexp_desc = Pexp_ident li} -> self#longident_loc li - | {pexp_desc = Pexp_constant constant} as x -> - let raw_literal, _ = Reason_attributes.extract_raw_literal x.pexp_attributes in - self#constant ?raw_literal constant - | _ -> - (* Currently spreading a list, or having a list as a child must be - * wrapped in { }. You can remove the entire even_wrap_simple arg - * when that is fixed (there is a conflict in grammar when allowing - * a [] without {[]} as child. *) - (* Simple child that has jsx: *) - (* Simple child that doesn't have jsx: "hello" *) - (* Simple child that doesn't have jsx but is a "::" and requires braces: [a, b] *) - self#inline_braces#simplifyUnparseExpr ~inline:true ~wrap:("{", "}") x - in - match expr with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> - (match processedRev with - | [] -> None - | _::_ -> Some (List.rev processedRev)) - | {pexp_desc = Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [hd; tl]} )} -> - self#formatJsxChildrenNonSpread tl (formatJsxChild hd :: processedRev) - | _ -> None - - method direction_flag = function - | Upto -> atom "to" - | Downto -> atom "downto" - - method payload ppxToken ppxId e = - let wrap = ("[" ^ ppxToken ^ ppxId.txt, "]") in - let wrap_prefix str (x,y) = (x^str, y) in - let pad = (true, false) in - let postSpace = true in - match e with - | PStr [] -> atom ("[" ^ ppxToken ^ ppxId.txt ^ "]") - | PStr [itm] -> - makeList ~break:Layout.IfNeed ~wrap ~pad [self#structure_item itm] - | PStr (_::_ as items) -> - let rows = List.map self#structure_item items in - makeList ~wrap ~break:Layout.Always ~pad ~postSpace ~sep:(Layout.Sep ";") rows - | PTyp x -> - let wrap = wrap_prefix ":" wrap in - makeList ~wrap ~break:Layout.IfNeed ~pad [self#core_type x] - (* Signatures in attributes were added recently *) - | PSig [] -> atom ("[" ^ ppxToken ^ ppxId.txt ^ ":]") - | PSig [x] -> - let wrap = wrap_prefix ":" wrap in - makeList ~break:Layout.IfNeed ~wrap ~pad [self#signature_item x] - | PSig items -> - let wrap = wrap_prefix ":" wrap in - let rows = List.map self#signature_item items in - makeList ~wrap ~break:Layout.IfNeed ~pad ~postSpace ~sep:(Layout.Sep ";") rows - | PPat (x, None) -> - let wrap = wrap_prefix "?" wrap in - makeList ~wrap ~break:Layout.IfNeed ~pad [self#pattern_at_least_as_simple_as_alias_or_or x] - | PPat (x, Some e) -> - let wrap = wrap_prefix "?" wrap in - makeList ~wrap ~break:Layout.IfNeed ~pad ~postSpace [ - self#pattern_at_least_as_simple_as_alias_or_or x; - label ~space:true (atom "when") (self#unparseExpr e) - ] - - (* [% ...] *) - method extension (s, p) = - match s.txt with - (* We special case "mel.obj" for now to allow for a nicer interop with - * BuckleScript. We might be able to generalize to any kind of record - * looking thing with struct keys. *) - | "mel.obj" -> self#formatBsObjExtensionSugar p - | _ -> (self#payload "%" s p) - - method item_extension (s, e) = (self#payload "%%" s e) - - (* [@ ...] Simple attributes *) - method attribute = function - | { attr_name = { Location. txt = ("ocaml.doc" | "ocaml.text") } - ; attr_payload = - PStr [{ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string(text, _, None)) } , _); - pstr_loc }] - ; _ } -> - let break = if text = "" then Layout.IfNeed else Always_rec in - let text = if text = "" then "/**/" else "/**" ^ text ^ "*/" in - makeList - ~inline:(true, true) - ~postSpace:true - ~preSpace:true - ~indent:0 - ~break - [atom ~loc:pstr_loc text] - | { attr_name; attr_payload; _ } -> self#payload "@" attr_name attr_payload - - (* [@@ ... ] Attributes that occur after a major item in a structure/class *) - method item_attribute = self#attribute - - (* [@@ ...] Attributes that occur not *after* an item in some structure/class/sig, but - rather as their own standalone item. Note that syntactic distinction - between item_attribute and floating_attribute is no longer necessary with - Reason. Thank you semicolons. *) - method floating_attribute = self#item_attribute - - method attributes l = List.map self#attribute l - - method attach_std_attrs l toThis = - let l = Reason_attributes.extractStdAttrs l in - match l with - | [] -> toThis - | _::_ -> makeList ~postSpace:true (List.concat [self#attributes l; [toThis]]) - - method attach_std_item_attrs ?(allowUncurry=true) ?extension l toThis = - let attrs = Reason_attributes.partitionAttributes ~allowUncurry l in - match extension, attrs.stdAttrs with - | None, [] -> toThis - | Some id, _ -> - makeList - ~wrap:("[", "]") - ~postSpace:true ~indent:0 ~break:Layout.IfNeed ~inline:(true, true) - ([atom ("%" ^ id.txt)] @ List.map self#item_attribute l @ [toThis]) - | None, _ -> - makeList - ~postSpace:true ~indent:0 ~break:Always ~inline:(true, true) - (List.map self#item_attribute l @ [toThis]) - - method exception_declaration ed = - let pcd_name = ed.pext_name in - let pcd_loc = ed.pext_loc in - let pcd_attributes = [] in - let exn_arg = match ed.pext_kind with - | Pext_decl (vars, args, type_opt) -> - let pcd_args, pcd_res = args, type_opt in - [self#type_variant_leaf_nobar {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes; pcd_vars = vars}] - | Pext_rebind id -> - [atom pcd_name.txt; atom "="; (self#longident_loc id)] in - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true ed.pext_attributes - in - let layout = - self#attach_std_item_attrs - stdAttrs - (label ~space:true - (atom "exception") - (makeList ~postSpace:true ~inline:(true, true) exn_arg)) - in - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:ed.pext_loc - ~layout - () - - (* - Note: that override doesn't appear in class_sig_field, but does occur in - class/object expressions. - TODO: TODOATTRIBUTES - *) - method method_sig_flags_for s = function - | Virtual -> [atom "virtual"; atom s] - | Concrete -> [atom s] - - method value_type_flags_for s = function - | (Virtual, Mutable) -> [atom "virtual"; atom "mutable"; atom s] - | (Virtual, Immutable) -> [atom "virtual"; atom s] - | (Concrete, Mutable) -> [atom "mutable"; atom s] - | (Concrete, Immutable) -> [atom s] - - method class_sig_field x = - match x.pctf_desc with - | Pctf_inherit ct -> - label ~space:true (atom "inherit") (self#class_constructor_type ct) - | Pctf_val (s, mf, vf, ct) -> - let valueFlags = self#value_type_flags_for (s.txt ^ ":") (vf, mf) in - label - ~space:true - ( - label ~space:true - (atom "val") - (makeList ~postSpace:true ~inline:(false, true) ~break:IfNeed valueFlags) - ) - (self#core_type ct) - | Pctf_method (s, pf, vf, ct) -> - let methodFlags = self#method_sig_flags_for (s.txt ^ ":") vf - in - let pubOrPrivate = - match pf with - | Private -> "pri" - | Public -> "pub" - in - let m = label - ~space:true - (label ~space:true - (atom pubOrPrivate) - (makeList ~postSpace:true ~inline:(false, true) ~break:IfNeed methodFlags) - ) - (self#core_type ct) - in - (self#attach_std_item_attrs x.pctf_attributes m) - | Pctf_constraint (ct1, ct2) -> - label - ~space:true - (atom "constraint") - (label ~space:true - (makeList ~postSpace:true [self#core_type ct1; atom "="]) - (self#core_type ct2) - ) - | Pctf_attribute a -> self#floating_attribute a - | Pctf_extension e -> self#item_extension e - - (* - /** doc comment */ (* formattedDocs *) - [@bs.val] [@bs.module "react-dom"] (* formattedAttrs *) - external render : reactElement => element => unit = (* frstHalf *) - "render"; (* sndHalf *) - - To improve the formatting with breaking & indentation: - * consider the part before the '=' as a label - * combine that label with '=' in a list - * consider the part after the '=' as a list - * combine both parts as a label - * format the doc comment with a ~postSpace:true (inline, not inline) list - * format the attributes with a ~postSpace:true (inline, inline) list - * format everything together in a ~postSpace:true (inline, inline) list - for nicer breaking - *) - method primitive_declaration ?extension vd = - let external_label = add_extension_sugar "external" extension in - let lblBefore = - label - ~space:true - (makeList - [(makeList ~postSpace:true [atom external_label; protectIdentifier vd.pval_name.txt]); (atom ":")]) - (self#core_type vd.pval_type) - in - let primDecl = - match vd.pval_prim with - | [""] -> lblBefore - | _ -> - let frstHalf = makeList ~postSpace:true [lblBefore; atom "="] in - let sndHalf = - makeSpacedBreakableInlineList (List.map self#constant_string_for_primitive vd.pval_prim) in - label ~space:true frstHalf sndHalf - in - match vd.pval_attributes with - | [] -> primDecl - | attrs -> - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true attrs in - let docs = List.map self#item_attribute docAttrs in - let formattedDocs = makeList ~postSpace:true docs in - let attrs = List.map self#item_attribute stdAttrs in - let formattedAttrs = makeSpacedBreakableInlineList attrs in - let layouts = match (docAttrs, stdAttrs) with - | ([], _) -> [formattedAttrs; primDecl] - | (_, []) -> [formattedDocs; primDecl] - | _ -> [formattedDocs; formattedAttrs; primDecl] in - makeSpacedBreakableInlineList layouts - - method classTypeSigsAndRest x = - match x.pcty_desc with - | Pcty_signature cs -> - let {pcsig_self = ct; pcsig_fields = l} = cs in - let instTypeFields = List.map self#class_sig_field l in - let allItems = match ct.ptyp_desc with - | Ptyp_any -> instTypeFields - | _ -> - label ~space:true (atom "as") (self#core_type ct) :: - instTypeFields - in - allItems - | _ -> [self#class_instance_type x] - - method class_instance_type x = - match x.pcty_desc with - | Pcty_signature _ - | Pcty_open _ -> - let opens, rest = self#classTypeOpens x in - let cs = self#classTypeSigsAndRest rest in - self#attach_std_item_attrs ~allowUncurry:false x.pcty_attributes ( - makeList - ~wrap:("{", "}") - ~postSpace:true - ~break:Layout.Always_rec - (List.map semiTerminated (List.concat [opens; cs])) - ) - | Pcty_constr (li, l) -> - self#attach_std_attrs x.pcty_attributes ( - match l with - | [] -> self#longident_loc li - | _::_ -> - label - (self#longident_loc li) - (makeList ~wrap:("(", ")") ~sep:commaTrail (List.map self#core_type l)) - ) - | Pcty_extension e -> - self#attach_std_item_attrs x.pcty_attributes (self#extension e) - | Pcty_arrow _ -> failwith "class_instance_type should not be printed with Pcty_arrow" - - method classTypeOpens x = - let rec gatherOpens acc opn = - match opn.pcty_desc with - | Pcty_open (md, ct) -> - let li = md.popen_expr in - gatherOpens - (source_map ~loc:li.loc - (label ~space:true - (atom ("open" ^ (override md.popen_override))) - (self#longident_loc li)) - :: acc) - ct - | _ -> List.rev acc, opn - in - gatherOpens [] x - - method class_declaration_list l = - let class_declaration ?(class_keyword=false) - ({pci_params=ls; pci_name={txt}; pci_virt; pci_loc} as x) = - let (firstToken, pattern, patternAux) = self#class_opening class_keyword txt pci_virt ls in - let classBinding = self#wrappedClassBinding firstToken pattern patternAux x.pci_expr in - source_map ~loc:pci_loc - (self#attach_std_item_attrs x.pci_attributes classBinding) - in - (match l with - | [] -> raise (NotPossible "Class definitions will have at least one item.") - | x::rest -> - makeNonIndentedBreakingList ( - class_declaration ~class_keyword:true x :: - List.map class_declaration rest - ) - ) - (* For use with [class type a = class_instance_type]. Class type - declarations/definitions declare the types of instances generated by class - constructors. - We have to call self#class_instance_type because self#class_constructor_type - would add a "new" before the type. - TODO: TODOATTRIBUTES: - *) - method class_type_declaration_list l = - let class_type_declaration kwd ({pci_params=ls;pci_name;pci_attributes} as x) = - let opener = match x.pci_virt with - | Virtual -> kwd ^ " " ^ "virtual" - | Concrete -> kwd - in - - let upToName = - if ls == [] then - label ~space:true (atom opener) (atom pci_name.txt) - else - label - ~space:true - (label ~space:true (atom opener) (atom pci_name.txt)) - (self#class_params_def ls) - in - let includingEqual = makeList ~postSpace:true [upToName; atom "="] in - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true pci_attributes - in - let layout = - self#attach_std_item_attrs stdAttrs @@ - label ~space:true includingEqual (self#class_instance_type x.pci_expr) - in - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:pci_name.loc - ~layout - () - in - match l with - | [] -> failwith "Should not call class_type_declaration with no classes" - | [x] -> class_type_declaration "class type" x - | x :: xs -> - makeList - ~break:Always_rec - ~indent:0 - ~inline:(true, true) - ( - (class_type_declaration "class type" x):: - List.map (class_type_declaration "and") xs - ) - - (* - Formerly the [class_type] - Notice how class_constructor_type doesn't have any type attributes - - class_instance_type does. - TODO: Divide into class_constructor_types that allow arrows and ones - that don't. - *) - method class_constructor_type x = - match x.pcty_desc with - | Pcty_arrow _ -> - let rec allArrowSegments acc = function - | { pcty_desc = Pcty_arrow (l, ct1, ct2); } -> - allArrowSegments (self#type_with_label (l, ct1, false) :: acc) ct2 - (* This "new" is unfortunate. See reason_parser.mly for details. *) - | xx -> (List.rev acc, self#class_constructor_type xx) - in - let (params, return) = allArrowSegments [] x in - let normalized = - makeList ~break:IfNeed - ~sep:(Sep "=>") - ~preSpace:true ~postSpace:true ~inline:(true, true) - [makeCommaBreakableListSurround "(" ")" params; return] - in - source_map ~loc:x.pcty_loc normalized - | _ -> - (* Unfortunately, we have to have final components of a class_constructor_type - be prefixed with the `new` keyword. Hopefully this is temporary. *) - self#class_instance_type x - - method non_arrowed_class_constructor_type x = - match x.pcty_desc with - | Pcty_arrow _ -> - source_map ~loc:x.pcty_loc - (formatPrecedence (self#class_constructor_type x)) - | _ -> self#class_instance_type x - - method class_field x = - let itm = - match x.pcf_desc with - | Pcf_inherit (ovf, ce, so) -> - let inheritText = ("inherit" ^ override ovf) in - let inheritExp = self#class_expr ce in - label - ~space:true - (atom inheritText) - ( - match so with - | None -> inheritExp; - | Some s -> label ~space:true inheritExp (atom ("as " ^ s.txt)) - ) - | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> - let opening = match mf with - | Mutable -> - let mutableName = [atom "mutable"; atom s.txt] in - label - ~space:true - (atom ("val" ^ override ovf)) - (makeList ~postSpace:true ~inline:(false, true) ~break:IfNeed mutableName) - | Immutable -> label ~space:true (atom ("val" ^ override ovf)) (atom s.txt) - in - let valExprAndConstraint = match e.pexp_desc with - | Pexp_constraint (ex, ct) -> - let openingWithTypeConstraint = formatTypeConstraint opening (self#core_type ct) in - label - ~space:true - (makeList ~postSpace:true [openingWithTypeConstraint; atom "="]) - (self#unparseExpr ex) - | _ -> - label ~space:true (makeList ~postSpace:true [opening; atom "="]) (self#unparseExpr e) - in - valExprAndConstraint - | Pcf_val (s, mf, Cfk_virtual ct) -> - let opening = match mf with - | Mutable -> - let mutableVirtualName = [atom "mutable"; atom "virtual"; atom s.txt] in - let openingTokens = - (makeList ~postSpace:true ~inline:(false, true) ~break:IfNeed mutableVirtualName) in - label ~space:true (atom "val") openingTokens - | Immutable -> - let virtualName = [atom "virtual"; atom s.txt] in - let openingTokens = - (makeList ~postSpace:true ~inline:(false, true) ~break:IfNeed virtualName) in - label ~space:true (atom "val") openingTokens - in - formatTypeConstraint opening (self#core_type ct) - | Pcf_method (s, pf, Cfk_virtual ct) -> - let opening = match pf with - | Private -> - let privateVirtualName = [atom "virtual"; atom s.txt] in - let openingTokens = - (makeList ~postSpace:true ~inline:(false, true) ~break:IfNeed privateVirtualName) in - label ~space:true (atom "pri") openingTokens - | Public -> - let virtualName = [atom "virtual"; atom s.txt] in - let openingTokens = - (makeList ~postSpace:true ~inline:(false, true) ~break:IfNeed virtualName) in - label ~space:true (atom "pub") openingTokens - in - formatTypeConstraint opening (self#core_type ct) - | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> - let methodText = - let postFix = if ovf == Override then "!" else "" in - ( - match pf with - | Private -> "pri" ^ postFix - | Public -> "pub" ^ postFix - ) in - (* Should refactor the binding logic so faking out the AST isn't needed, - currently, it includes a ton of nuanced logic around recovering explicitly - polymorphic type definitions, and that furthermore, that representation... - Actually, let's do it. - - For some reason, concrete methods are only ever parsed as Pexp_poly. - If there *is* no polymorphic function for the method, then the return - value of the function is wrapped in a ghost Pexp_poly with [None] for - the type vars.*) - (match e.pexp_desc with - | (Pexp_poly - ({pexp_desc=Pexp_constraint (methodFunWithNewtypes, nonVarifiedExprType)}, - Some ({ptyp_desc=Ptyp_poly (typeVars, varifiedPolyType)}) - ) - ) when ( - let (leadingAbstractVars, _) = - self#leadingCurriedAbstractTypes methodFunWithNewtypes in - self#isRenderableAsPolymorphicAbstractTypes - typeVars - (* If even artificially varified. Don't know until this returns*) - varifiedPolyType - leadingAbstractVars - nonVarifiedExprType - ) -> - let (leadingAbstractVars, _) = - self#leadingCurriedAbstractTypes methodFunWithNewtypes in - self#locallyAbstractPolymorphicFunctionBinding - methodText - (atom s.txt) - methodFunWithNewtypes - leadingAbstractVars - nonVarifiedExprType - | Pexp_poly (e, Some ct) -> - self#formatSimplePatternBinding methodText (atom s.txt) - (Some (source_map ~loc:ct.ptyp_loc (self#core_type ct))) - (self#unparseExprApplicationItems e) - (* This form means that there is no type constraint - it's a strange node name.*) - | Pexp_poly (e, None) -> - self#wrappedBinding methodText ~arrow:"=>" (atom s.txt) [] e - | _ -> failwith "Concrete methods should only ever have Pexp_poly." - ) - | Pcf_constraint (ct1, ct2) -> - label - ~space:true - (atom "constraint") - ( - makeList ~postSpace:true ~inline:(true, false) [ - makeList ~postSpace:true [self#core_type ct1; atom "="]; - self#core_type ct2 - ] - ) - | Pcf_initializer e -> - label - ~space:true - (atom "initializer") - (self#simplifyUnparseExpr e) - | Pcf_attribute a -> self#floating_attribute a - | Pcf_extension e -> - (* And don't forget, we still need to print post_item_attributes even for - this case *) - self#item_extension e - in - let layout = self#attach_std_attrs x.pcf_attributes itm in - source_map ~loc:x.pcf_loc layout - - method class_self_pattern_and_structure {pcstr_self = p; pcstr_fields = l} = - let fields = List.map self#class_field l in - (* Recall that by default self is bound to "this" at parse time. You'd - have to go out of your way to bind it to "_". *) - match (p.ppat_attributes, p.ppat_desc) with - | ([], Ppat_var ({txt = "this"})) -> fields - | _ -> - let field = label ~space:true (atom "as") (self#pattern p) in - source_map ~loc:p.ppat_loc field :: fields - - method simple_class_expr x = - let {Reason_attributes.stdAttrs} = Reason_attributes.partitionAttributes x.pcl_attributes in - if stdAttrs != [] then - formatSimpleAttributed - (self#simple_class_expr {x with pcl_attributes=[]}) - (self#attributes stdAttrs) - else - let itm = - match x.pcl_desc with - | Pcl_constraint (ce, ct) -> - formatTypeConstraint (self#class_expr ce) (self#class_constructor_type ct) - (* In OCaml, - - In the most recent version of OCaml, when in the top level of a - module, let _ = ... is a PStr_eval. - - When in a function, it is a Pexp_let PPat_any - - When in class pre-member let bindings it is a Pcl_let PPat_any - - Reason normalizes all of these to be simple imperative expressions - with trailing semicolons, *except* in the case of classes because it - will likely introduce a conflict with some proposed syntaxes for - objects. - *) - | Pcl_let _ - | Pcl_structure _ - | Pcl_open _ -> - let opens, rest = self#classExprOpens x in - let rows = self#classExprLetsAndRest rest in - makeList ~wrap:("{", "}") ~inline:(true, false) ~postSpace:true ~break:Always_rec - (List.map semiTerminated (List.concat [opens; rows])) - | Pcl_extension e -> self#extension e - | _ -> formatPrecedence (self#class_expr x) - in source_map ~loc:x.pcl_loc itm - - method classExprLetsAndRest x = - match x.pcl_desc with - | Pcl_structure cs -> self#class_self_pattern_and_structure cs - | Pcl_let (rf, l, ce) -> - (* For "letList" bindings, the start/end isn't as simple as with - * module value bindings. For "let lists", the sequences were formed - * within braces {}. The parser relocates the first let binding to the - * first brace. *) - let binding = - source_map ~loc:(self#bindingsLocationRange l) - (self#bindings (rf, l)) - in - (binding :: self#classExprLetsAndRest ce) - | Pcl_open (_, ce) -> self#classExprLetsAndRest ce - | _ -> [self#class_expr x] - - method classExprOpens x = - let rec gatherOpens acc opn = - match opn.pcl_desc with - | Pcl_open (md, ce) -> - let li = md.popen_expr in - gatherOpens - (source_map ~loc:li.loc - (label ~space:true - (atom ("open" ^ (override md.popen_override))) - (self#longident_loc li)) - :: acc) - ce - | _ -> List.rev acc, opn - in - gatherOpens [] x - - method class_expr x = - let {Reason_attributes.stdAttrs} = Reason_attributes.partitionAttributes x.pcl_attributes in - (* We cannot handle the attributes here. Must handle them in each item *) - if stdAttrs != [] then - (* Do not need a "simple" attributes precedence wrapper. *) - formatAttributed - (self#simple_class_expr {x with pcl_attributes=[]}) - (self#attributes stdAttrs) - else - match x.pcl_desc with - | Pcl_fun _ -> - (match self#curriedConstructorPatternsAndReturnVal x with - | None, _ -> - (* x just matched Pcl_fun, there is at least one parameter *) - assert false - | Some args, e -> - label ~space:true - (makeList ~postSpace:true - [label ~space:true (atom funToken) args; atom "=>"]) - (self#class_expr e)) - | Pcl_apply _ -> - formatAttachmentApplication applicationFinalWrapping None - (self#classExpressionToFormattedApplicationItems x, None) - | Pcl_constr (li, []) -> - label ~space:true (atom "class") (self#longident_loc li) - | Pcl_constr (li, l) -> - label - (makeList ~postSpace:true [atom "class"; self#longident_loc li]) - (makeTup (List.map self#non_arrowed_non_simple_core_type l)) - | Pcl_open _ - | Pcl_constraint _ - | Pcl_extension _ - | Pcl_let _ - | Pcl_structure _ -> self#simple_class_expr x; - - method classStructure ?(forceBreak=false) ?(wrap=("", "")) cs = - let (left, right) = wrap in - makeList - ~sep:(Layout.Sep ";") - ~wrap:(left ^ "{", "}" ^ right) - ~break:(if forceBreak then Layout.Always else Layout.IfNeed) - ~postSpace:true - ~inline:(true, false) - (self#class_self_pattern_and_structure cs) - - method signature signatureItems = - match signatureItems with - | [] -> atom "" - | first::_ as signatureItems -> - let last = match (List.rev signatureItems) with | last::_ -> last | [] -> assert false in - let loc_start = first.psig_loc.loc_start in - let loc_end = last.psig_loc.loc_end in - let items = - groupAndPrint - ~xf:self#signature_item - ~getLoc:(fun x -> x.psig_loc) - ~comments:self#comments - signatureItems - in - source_map ~loc:{loc_start; loc_end; loc_ghost=false} - (makeList - ~postSpace:true - ~break:Layout.Always_rec - ~indent:0 - ~inline:(true, false) - ~sep:(SepFinal (";", ";")) - items) - - method signature_item item : Layout.t = - match item.psig_desc with - | Psig_extension ((extension, PSig [item]), _attrs) -> - begin match item.psig_desc with - (* In case of a value or `external`, the extension gets inlined - `let%private a = 1` *) - | Psig_value ({ pval_prim = [_]; _ } as vd) -> self#primitive_declaration ~extension vd - | Psig_value vd -> self#val_binding ~extension vd - | Psig_module pmd -> self#psig_module ~extension pmd - | Psig_recmodule pmd -> self#psig_recmodule ~extension pmd - | Psig_open od -> self#psig_open ~extension od - | _ -> self#payload "%%" extension (PSig [item]) - end - | _ -> self#signature_item' item - - method val_binding ?extension vd = - let intro = add_extension_sugar "let" extension in - let {Reason_attributes.stdAttrs; docAttrs} = Reason_attributes.partitionAttributes ~partDoc:true vd.pval_attributes in - let layout = self#attach_std_item_attrs stdAttrs - (formatTypeConstraint - (label ~space:true (atom intro) - (source_map ~loc:vd.pval_name.loc - (protectIdentifier vd.pval_name.txt))) - (self#core_type vd.pval_type)) - in - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:vd.pval_loc - ~layout - () - - method psig_module ?extension pmd = - let layout = - let prefix = add_extension_sugar "module" extension in - match pmd.pmd_type.pmty_desc with - | Pmty_alias alias -> - label ~space:true - (makeList ~postSpace:true [ - atom prefix; - atom (moduleIdent pmd.pmd_name); - atom "=" - ]) - (self#longident_loc alias) - | _ -> - let letPattern = + match x.pcl_desc with + | Pcl_fun _ -> + (match self#curriedConstructorPatternsAndReturnVal x with + | None, _ -> + (* x just matched Pcl_fun, there is at least one parameter *) + assert false + | Some args, e -> + label + ~space:true + (makeList + ~postSpace:true + [ label ~space:true (atom funToken) args; atom "=>" ]) + (self#class_expr e)) + | Pcl_apply _ -> + formatAttachmentApplication + applicationFinalWrapping + None + (self#classExpressionToFormattedApplicationItems x, None) + | Pcl_constr (li, []) -> + label ~space:true (atom "class") (self#longident_loc li) + | Pcl_constr (li, l) -> + label + (makeList + ~postSpace:true + [ atom "class"; self#longident_loc li ]) + (makeTup (List.map self#non_arrowed_non_simple_core_type l)) + | Pcl_open _ | Pcl_constraint _ | Pcl_extension _ | Pcl_let _ + | Pcl_structure _ -> + self#simple_class_expr x + + method classStructure ?(forceBreak = false) ?(wrap = "", "") cs = + let left, right = wrap in makeList - [makeList ~postSpace:true [atom prefix; (atom (moduleIdent pmd.pmd_name))]; - atom ":"] - in - (self#module_type letPattern pmd.pmd_type) - in - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true pmd.pmd_attributes - in - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:pmd.pmd_name.loc - ~layout:(self#attach_std_item_attrs stdAttrs @@ layout) - () - - method psig_recmodule ?extension decls = - let items = List.mapi (fun i xx -> - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true xx.pmd_attributes - in - let letPattern = - makeList [ - makeList ~postSpace:true [ - atom (if i == 0 - then - add_extension_sugar "module" extension ^ " rec" - else "and"); - atom (moduleIdent xx.pmd_name) - ]; - atom ":" - ] - in - let layout = - self#attach_std_item_attrs stdAttrs - (self#module_type ~space:true letPattern xx.pmd_type) - in - let layoutWithDocAttrs = - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:xx.pmd_name.loc - ~layout - () - in - (extractLocModDecl xx, layoutWithDocAttrs) - ) decls - in - makeNonIndentedBreakingList - (groupAndPrint - ~xf:(fun (_, layout) -> layout) - ~getLoc:(fun (loc, _) -> loc) - ~comments:self#comments - items) - - method psig_open ?extension od = - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true od.popen_attributes - in - let layout = - let open_prefix = - add_open_extension_sugar ~override:od.popen_override extension - in - self#attach_std_item_attrs stdAttrs @@ - label ~space:true - (atom open_prefix) - (self#longident_loc od.popen_expr) - in - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:od.popen_expr.loc - ~layout - () - - method modtype x ~delim = - let name = atom x.pmtd_name.txt in - let letPattern = makeList ~postSpace:true [atom "module type"; name; atom delim] in - let main = match x.pmtd_type with - | None -> makeList ~postSpace:true [atom "module type"; name] - | Some mt -> self#module_type letPattern mt - in - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true x.pmtd_attributes - in - let layout = - self#attach_std_item_attrs stdAttrs main - in - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:x.pmtd_name.loc - ~layout - () - - method signature_item' x : Layout.t = - let item: Layout.t = - match x.psig_desc with - | Psig_type (rf, l) -> - self#type_def_list (rf, l) - | Psig_value vd -> - if vd.pval_prim != [] then - self#primitive_declaration vd - else - self#val_binding vd - | Psig_typext te -> - self#type_extension te - | Psig_exception ed -> - self#exception_declaration - { ed.ptyexn_constructor - with pext_attributes = ed.ptyexn_attributes @ ed.ptyexn_constructor.pext_attributes} - | Psig_class l -> - let class_description - ?(class_keyword=false) - ({pci_params=ls; pci_name={txt}; pci_loc} as x) = - let (firstToken, pattern, patternAux) = self#class_opening class_keyword txt x.pci_virt ls in - let withColon = self#wrapCurriedFunctionBinding - ~arrow:":" - ~spaceBeforeArrow:false - firstToken - pattern - patternAux - ([(self#class_constructor_type x.pci_expr)], None) - in - let {Reason_attributes.stdAttrs; docAttrs} = Reason_attributes.partitionAttributes ~partDoc:true x.pci_attributes in - let layout = self#attach_std_item_attrs stdAttrs withColon in - source_map ~loc:pci_loc - (self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:x.pci_name.loc - ~layout - ()) + ~sep:(Layout.Sep ";") + ~wrap:(left ^ "{", "}" ^ right) + ~break:(if forceBreak then Layout.Always else Layout.IfNeed) + ~postSpace:true + ~inline:(true, false) + (self#class_self_pattern_and_structure cs) + + method signature signatureItems = + match signatureItems with + | [] -> atom "" + | first :: _ as signatureItems -> + let last = + match List.rev signatureItems with + | last :: _ -> last + | [] -> assert false in - makeNonIndentedBreakingList ( - match l with - | [] -> raise (NotPossible "No recursive class bindings") - | [x] -> [class_description ~class_keyword:true x] - | x :: xs -> - (class_description ~class_keyword:true x):: - (List.map class_description xs) - ) - | Psig_module pmd -> self#psig_module pmd - | Psig_open od -> self#psig_open od - | Psig_include incl -> - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true incl.pincl_attributes + let loc_start = first.psig_loc.loc_start in + let loc_end = last.psig_loc.loc_end in + let items = + groupAndPrint + ~xf:self#signature_item + ~getLoc:(fun x -> x.psig_loc) + ~comments:self#comments + signatureItems + in + source_map + ~loc:{ loc_start; loc_end; loc_ghost = false } + (makeList + ~postSpace:true + ~break:Layout.Always_rec + ~indent:0 + ~inline:(true, false) + ~sep:(SepFinal (";", ";")) + items) + + method signature_item item : Layout.t = + match item.psig_desc with + | Psig_extension ((extension, PSig [ item ]), _attrs) -> + (match item.psig_desc with + (* In case of a value or `external`, the extension gets inlined + `let%private a = 1` *) + | Psig_value ({ pval_prim = [ _ ]; _ } as vd) -> + self#primitive_declaration ~extension vd + | Psig_value vd -> self#val_binding ~extension vd + | Psig_module pmd -> self#psig_module ~extension pmd + | Psig_recmodule pmd -> self#psig_recmodule ~extension pmd + | Psig_open od -> self#psig_open ~extension od + | _ -> self#payload "%%" extension (PSig [ item ])) + | _ -> self#signature_item' item + + method val_binding ?extension vd = + let intro = add_extension_sugar "let" extension in + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + vd.pval_attributes in let layout = - self#attach_std_item_attrs stdAttrs @@ - (self#module_type (atom "include") incl.pincl_mod) + self#attach_std_item_attrs + stdAttrs + (formatTypeConstraint + (label + ~space:true + (atom intro) + (source_map + ~loc:vd.pval_name.loc + (protectIdentifier vd.pval_name.txt))) + (self#core_type vd.pval_type)) in self#attachDocAttrsToLayout ~stdAttrs ~docAttrs - ~loc:incl.pincl_mod.pmty_loc + ~loc:vd.pval_loc ~layout () - | Psig_modtype x -> self#modtype x ~delim:"=" - | Psig_class_type l -> self#class_type_declaration_list l - | Psig_recmodule decls -> self#psig_recmodule decls - | Psig_attribute a -> self#floating_attribute a - | Psig_extension (({loc}, _) as ext, attrs) -> - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true attrs + + method psig_module ?extension pmd = + let layout = + let prefix = add_extension_sugar "module" extension in + match pmd.pmd_type.pmty_desc with + | Pmty_alias alias -> + label + ~space:true + (makeList + ~postSpace:true + [ atom prefix; atom (moduleIdent pmd.pmd_name); atom "=" ]) + (self#longident_loc alias) + | _ -> + let letPattern = + makeList + [ makeList + ~postSpace:true + [ atom prefix; atom (moduleIdent pmd.pmd_name) ] + ; atom ":" + ] + in + self#module_type letPattern pmd.pmd_type + in + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + pmd.pmd_attributes + in + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:pmd.pmd_name.loc + ~layout:(self#attach_std_item_attrs stdAttrs @@ layout) + () + + method psig_recmodule ?extension decls = + let items = + List.mapi + (fun i xx -> + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + xx.pmd_attributes + in + let letPattern = + makeList + [ makeList + ~postSpace:true + [ atom + (if i == 0 + then + add_extension_sugar "module" extension ^ " rec" + else "and") + ; atom (moduleIdent xx.pmd_name) + ] + ; atom ":" + ] + in + let layout = + self#attach_std_item_attrs + stdAttrs + (self#module_type ~space:true letPattern xx.pmd_type) + in + let layoutWithDocAttrs = + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:xx.pmd_name.loc + ~layout + () + in + extractLocModDecl xx, layoutWithDocAttrs) + decls + in + makeNonIndentedBreakingList + (groupAndPrint + ~xf:(fun (_, layout) -> layout) + ~getLoc:(fun (loc, _) -> loc) + ~comments:self#comments + items) + + method psig_open ?extension od = + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + od.popen_attributes in let layout = - self#attach_std_item_attrs stdAttrs (self#item_extension ext) + let open_prefix = + add_open_extension_sugar ~override:od.popen_override extension + in + self#attach_std_item_attrs stdAttrs + @@ label + ~space:true + (atom open_prefix) + (self#longident_loc od.popen_expr) in self#attachDocAttrsToLayout ~stdAttrs ~docAttrs - ~loc + ~loc:od.popen_expr.loc ~layout () - | Psig_modsubst { pms_name; pms_manifest; pms_attributes; pms_loc } -> - let name = atom pms_name.txt in - let main = makeList ~postSpace:true - [atom "module"; name; atom ":="; self#longident_loc pms_manifest] + + method modtype x ~delim = + let name = atom x.pmtd_name.txt in + let letPattern = + makeList ~postSpace:true [ atom "module type"; name; atom delim ] in - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true pms_attributes + let main = + match x.pmtd_type with + | None -> makeList ~postSpace:true [ atom "module type"; name ] + | Some mt -> self#module_type letPattern mt in - let layout = - self#attach_std_item_attrs stdAttrs main + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + x.pmtd_attributes in + let layout = self#attach_std_item_attrs stdAttrs main in self#attachDocAttrsToLayout ~stdAttrs ~docAttrs - ~loc:pms_loc + ~loc:x.pmtd_name.loc ~layout () - | Psig_typesubst l -> - self#type_def_list ~eq_symbol:":=" (Recursive, l) - | Psig_modtypesubst x -> self#modtype x ~delim:":=" - in - source_map ~loc:x.psig_loc item - - method non_arrowed_module_type ?(space=true) letPattern x = - match x.pmty_desc with - | Pmty_alias li -> - label ~space - letPattern - (formatPrecedence (label ~space:true (atom "module") (self#longident_loc li))) - | Pmty_typeof me -> - let labelWithoutFinalWrap = - label ~space:true - (label ~space:true - letPattern - (makeList - ~inline:(false, false) - ~wrap:("(","") - ~postSpace:true - [atom "module type of"])) - (self#module_expr me) - in - makeList ~wrap:("",")") [labelWithoutFinalWrap] - | _ -> self#simple_module_type ~space letPattern x - - method simple_module_type ?(space=true) letPattern x = - match x.pmty_desc with - | Pmty_ident li -> label ~space letPattern (self#longident_loc li) - | Pmty_signature s -> - let items = - groupAndPrint - ~xf:self#signature_item - ~getLoc:(fun x -> x.psig_loc) - ~comments:self#comments - s - in - let shouldBreakLabel = - match s with - | [] -> `Auto - | _ -> `Always - in - label - ~indent:0 - ~break:shouldBreakLabel - (makeList - [label - ~break:shouldBreakLabel - (makeList + + method signature_item' x : Layout.t = + let item : Layout.t = + match x.psig_desc with + | Psig_type (rf, l) -> self#type_def_list (rf, l) + | Psig_value vd -> + if vd.pval_prim != [] + then self#primitive_declaration vd + else self#val_binding vd + | Psig_typext te -> self#type_extension te + | Psig_exception ed -> + self#exception_declaration + { ed.ptyexn_constructor with + pext_attributes = + ed.ptyexn_attributes @ ed.ptyexn_constructor.pext_attributes + } + | Psig_class l -> + let class_description + ?(class_keyword = false) + ({ pci_params = ls; pci_name = { txt }; pci_loc } as x) + = + let firstToken, pattern, patternAux = + self#class_opening class_keyword txt x.pci_virt ls + in + let withColon = + self#wrapCurriedFunctionBinding + ~arrow:":" + ~spaceBeforeArrow:false + firstToken + pattern + patternAux + ([ self#class_constructor_type x.pci_expr ], None) + in + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + x.pci_attributes + in + let layout = self#attach_std_item_attrs stdAttrs withColon in + source_map + ~loc:pci_loc + (self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:x.pci_name.loc + ~layout + ()) + in + makeNonIndentedBreakingList + (match l with + | [] -> raise (NotPossible "No recursive class bindings") + | [ x ] -> [ class_description ~class_keyword:true x ] + | x :: xs -> + class_description ~class_keyword:true x + :: List.map class_description xs) + | Psig_module pmd -> self#psig_module pmd + | Psig_open od -> self#psig_open od + | Psig_include incl -> + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + incl.pincl_attributes + in + let layout = + self#attach_std_item_attrs stdAttrs + @@ self#module_type (atom "include") incl.pincl_mod + in + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:incl.pincl_mod.pmty_loc + ~layout + () + | Psig_modtype x -> self#modtype x ~delim:"=" + | Psig_class_type l -> self#class_type_declaration_list l + | Psig_recmodule decls -> self#psig_recmodule decls + | Psig_attribute a -> self#floating_attribute a + | Psig_extension ((({ loc }, _) as ext), attrs) -> + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes ~partDoc:true attrs + in + let layout = + self#attach_std_item_attrs stdAttrs (self#item_extension ext) + in + self#attachDocAttrsToLayout ~stdAttrs ~docAttrs ~loc ~layout () + | Psig_modsubst { pms_name; pms_manifest; pms_attributes; pms_loc } + -> + let name = atom pms_name.txt in + let main = + makeList ~postSpace:true - [letPattern; (atom "{")]) - (source_map - ~loc:x.pmty_loc - (makeList - ~break:(match s with | [] -> IfNeed | _ -> Always) - ~inline:(true, true) - ~postSpace:true - ~sep:(SepFinal (";", ";")) - items))]) - (atom "}") - | Pmty_extension (s, e) -> label ~space letPattern (self#payload "%" s e) - | _ -> - makeList ~break:IfNeed ~wrap:("", ")") - [self#module_type ~space:false (makeList ~pad:(false,true) ~wrap:("","(") [letPattern]) x] - - method module_type ?(space=true) letPattern x = - let pmty = match x.pmty_desc with - | Pmty_functor _ -> - (* The segments that should be separated by arrows. *) - let rec extract_args args xx = match xx.pmty_desc with - | Pmty_functor (Unit, mt2) -> extract_args (`Unit :: args) mt2 - | Pmty_functor (Named ({ txt = s; _ }, mt1), mt2) -> - let arg = - match s with - | None -> self#module_type ~space:false (atom "") mt1 - | Some s -> self#module_type ~space (makeList [(atom s); atom ":"]) mt1 - in - extract_args (`Arg arg :: args) mt2 - | _ -> - let prepare_arg = function - | `Unit -> atom "()" - | `Arg x -> x + [ atom "module" + ; name + ; atom ":=" + ; self#longident_loc pms_manifest + ] + in + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + pms_attributes + in + let layout = self#attach_std_item_attrs stdAttrs main in + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:pms_loc + ~layout + () + | Psig_typesubst l -> + self#type_def_list ~eq_symbol:":=" (Recursive, l) + | Psig_modtypesubst x -> self#modtype x ~delim:":=" + in + source_map ~loc:x.psig_loc item + + method non_arrowed_module_type ?(space = true) letPattern x = + match x.pmty_desc with + | Pmty_alias li -> + label + ~space + letPattern + (formatPrecedence + (label ~space:true (atom "module") (self#longident_loc li))) + | Pmty_typeof me -> + let labelWithoutFinalWrap = + label + ~space:true + (label + ~space:true + letPattern + (makeList + ~inline:(false, false) + ~wrap:("(", "") + ~postSpace:true + [ atom "module type of" ])) + (self#module_expr me) in - let args = match args with - | [`Unit] -> [] - | _ -> List.rev_map prepare_arg args + makeList ~wrap:("", ")") [ labelWithoutFinalWrap ] + | _ -> self#simple_module_type ~space letPattern x + + method simple_module_type ?(space = true) letPattern x = + match x.pmty_desc with + | Pmty_ident li -> label ~space letPattern (self#longident_loc li) + | Pmty_signature s -> + let items = + groupAndPrint + ~xf:self#signature_item + ~getLoc:(fun x -> x.psig_loc) + ~comments:self#comments + s in - (args, self#module_type (atom "") xx) - in - let args, ret = extract_args [] x in - label ~space letPattern - (makeList - ~break:IfNeed - ~sep:(Sep "=>") - ~preSpace:true - ~inline:(true, true) - [makeTup args; ret]) - - (* See comments in sugar_parser.mly about why WITH constraints aren't "non - * arrowed" *) - | Pmty_with (mt, l) -> - let modSub atm li2 token = makeList ~postSpace:true [ - atom "module"; - atm; - atom token; - self#longident_loc li2 - ] - in - let modtypeSub atm li modtype = + let shouldBreakLabel = match s with [] -> `Auto | _ -> `Always in label - (makeList ~break:IfNeed ~sep:(Sep " ") [ - atom "module type"; - (self#longident li); - atm; - ]) - (self#module_type (atom "") modtype) - in - let typeAtom = atom "type" in - let eqAtom = atom "=" in - let destrAtom = atom ":=" in - let with_constraint = function - | Pwith_type (li, td) -> - self#formatOneTypeDef - typeAtom - (makeList ~preSpace:true [(self#longident_loc li)]) - eqAtom - td - | Pwith_module (li, li2) -> - modSub (self#longident_loc li) li2 "=" - | Pwith_typesubst (_, td) -> - self#formatOneTypeDef - typeAtom - (atom ~loc:td.ptype_name.loc td.ptype_name.txt) - destrAtom - td - | Pwith_modsubst (s, li2) -> modSub (self#longident s.txt) li2 ":=" - | Pwith_modtype (s, modtype) -> modtypeSub eqAtom s.txt modtype - | Pwith_modtypesubst (s, modtype) -> modtypeSub destrAtom s.txt modtype - in - (match l with - | [] -> self#module_type ~space letPattern mt - | _ -> - label ~space letPattern - (label ~space:true - (makeList ~preSpace:true [self#module_type ~space:false (atom "") mt; atom "with"]) + ~indent:0 + ~break:shouldBreakLabel + (makeList + [ label + ~break:shouldBreakLabel + (makeList ~postSpace:true [ letPattern; atom "{" ]) + (source_map + ~loc:x.pmty_loc + (makeList + ~break:(match s with [] -> IfNeed | _ -> Always) + ~inline:(true, true) + ~postSpace:true + ~sep:(SepFinal (";", ";")) + items)) + ]) + (atom "}") + | Pmty_extension (s, e) -> + label ~space letPattern (self#payload "%" s e) + | _ -> + makeList + ~break:IfNeed + ~wrap:("", ")") + [ self#module_type + ~space:false + (makeList ~pad:(false, true) ~wrap:("", "(") [ letPattern ]) + x + ] + + method module_type ?(space = true) letPattern x = + let pmty = + match x.pmty_desc with + | Pmty_functor _ -> + (* The segments that should be separated by arrows. *) + let rec extract_args args xx = + match xx.pmty_desc with + | Pmty_functor (Unit, mt2) -> extract_args (`Unit :: args) mt2 + | Pmty_functor (Named ({ txt = s; _ }, mt1), mt2) -> + let arg = + match s with + | None -> self#module_type ~space:false (atom "") mt1 + | Some s -> + self#module_type + ~space + (makeList [ atom s; atom ":" ]) + mt1 + in + extract_args (`Arg arg :: args) mt2 + | _ -> + let prepare_arg = function + | `Unit -> atom "()" + | `Arg x -> x + in + let args = + match args with + | [ `Unit ] -> [] + | _ -> List.rev_map prepare_arg args + in + args, self#module_type (atom "") xx + in + let args, ret = extract_args [] x in + label + ~space + letPattern + (makeList + ~break:IfNeed + ~sep:(Sep "=>") + ~preSpace:true + ~inline:(true, true) + [ makeTup args; ret ]) + (* See comments in sugar_parser.mly about why WITH constraints aren't "non + * arrowed" *) + | Pmty_with (mt, l) -> + let modSub atm li2 token = + makeList + ~postSpace:true + [ atom "module"; atm; atom token; self#longident_loc li2 ] + in + let modtypeSub atm li modtype = + label (makeList ~break:IfNeed - ~inline:(true, true) - ~sep:(Sep "and") - ~postSpace:true - ~preSpace:true - (List.map with_constraint l))) - ) - (* Seems like an infinite loop just waiting to happen. *) - | _ -> self#non_arrowed_module_type ~space letPattern x - in - source_map ~loc:x.pmty_loc pmty - - method simple_module_expr ?(hug=false) x = - match x.pmod_desc with - | Pmod_unpack e -> - let exprLayout = match e.pexp_desc with - | Pexp_constraint (e, {ptyp_desc = Ptyp_package(lid, cstrs)}) -> - formatTypeConstraint - (makeList ~postSpace:true [atom "val"; (self#unparseExpr e)]) - (self#typ_package ~mod_prefix:false lid cstrs) - | _ -> makeList ~postSpace:true [atom "val"; (self#unparseExpr e)] - in formatPrecedence exprLayout - | Pmod_ident li -> - ensureSingleTokenSticksToLabel (self#longident_loc li) - | Pmod_constraint (unconstrainedRet, mt) -> - let letPattern = makeList [(self#module_expr unconstrainedRet); atom ":"] - in - formatPrecedence (self#module_type letPattern mt) - | Pmod_structure s -> - let wrap = if hug then - if s = [] then - ("(", ")") - else - ("({", "})") - else ("{", "}") in - self#structure ~indent:None ~wrap s - | _ -> - (* For example, functor application will be wrapped. *) - formatPrecedence ~wrap:("", "") (self#module_expr x) - - method module_expr x = - match x.pmod_desc with - | Pmod_functor _ -> - let (argsList, return) = self#curriedFunctorPatternsAndReturnStruct x in - (* See #19/20 in syntax.mls - cannot annotate return type at - the moment. *) - self#wrapCurriedFunctionBinding funToken ~sweet:true ~arrow:"=>" (makeTup argsList) [] - ([self#moduleExpressionToFormattedApplicationItems return], None) - | Pmod_apply _ -> - self#moduleExpressionToFormattedApplicationItems x - | Pmod_extension (s, e) -> self#payload "%" s e - | Pmod_unpack _ - | Pmod_ident _ - | Pmod_constraint _ - | Pmod_structure _ -> self#simple_module_expr x - - method recmodule ?extension decls = - let items = List.mapi (fun i xx -> - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true xx.pmb_attributes - in - let layout = - self#attach_std_item_attrs stdAttrs @@ - self#let_module_binding - (if i == 0 - then - add_extension_sugar "module" extension ^ " rec" - else "and") - (atom (moduleIdent xx.pmb_name)) - xx.pmb_expr - in - let layoutWithDocAttrs = - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:xx.pmb_name.loc - ~layout - () - in - (extractLocModuleBinding xx, layoutWithDocAttrs) - ) decls - in - makeNonIndentedBreakingList - (groupAndPrint - ~xf:(fun (_, layout) -> layout) - ~getLoc:(fun (loc, _) -> loc) - ~comments:self#comments - items) - - method pstr_open ?extension od = - let open_prefix = - add_open_extension_sugar ~override:od.popen_override extension - in - self#attach_std_item_attrs od.popen_attributes @@ - label ~space:true - (atom open_prefix) - (self#moduleExpressionToFormattedApplicationItems od.popen_expr) - - method structure ?(indent=Some 0) ?wrap structureItems = - (* We don't have any way to know if an extension is placed at the top level by the parsetree - while there's a difference syntactically (% for structure_items/expressons and %% for top_level). - This small fn detects this particular case (structure > structure_item > extension > value) and - prints with double % *) - let structure_item item = - match item.pstr_desc with - | Pstr_extension ((extension, PStr [item]), attrs) -> - begin match item.pstr_desc with - (* In case of a value or `external`, the extension gets inlined - `let%private a = 1` *) - | Pstr_value (rf, vb_list) -> self#bindings ~extension (rf, vb_list) - | Pstr_primitive vd -> self#primitive_declaration ~extension vd - | Pstr_module binding -> - let bindingName = atom ~loc:binding.pmb_name.loc (moduleIdent binding.pmb_name) in + ~sep:(Sep " ") + [ atom "module type"; self#longident li; atm ]) + (self#module_type (atom "") modtype) + in + let typeAtom = atom "type" in + let eqAtom = atom "=" in + let destrAtom = atom ":=" in + let with_constraint = function + | Pwith_type (li, td) -> + self#formatOneTypeDef + typeAtom + (makeList ~preSpace:true [ self#longident_loc li ]) + eqAtom + td + | Pwith_module (li, li2) -> + modSub (self#longident_loc li) li2 "=" + | Pwith_typesubst (_, td) -> + self#formatOneTypeDef + typeAtom + (atom ~loc:td.ptype_name.loc td.ptype_name.txt) + destrAtom + td + | Pwith_modsubst (s, li2) -> + modSub (self#longident s.txt) li2 ":=" + | Pwith_modtype (s, modtype) -> modtypeSub eqAtom s.txt modtype + | Pwith_modtypesubst (s, modtype) -> + modtypeSub destrAtom s.txt modtype + in + (match l with + | [] -> self#module_type ~space letPattern mt + | _ -> + label + ~space + letPattern + (label + ~space:true + (makeList + ~preSpace:true + [ self#module_type ~space:false (atom "") mt + ; atom "with" + ]) + (makeList + ~break:IfNeed + ~inline:(true, true) + ~sep:(Sep "and") + ~postSpace:true + ~preSpace:true + (List.map with_constraint l)))) + (* Seems like an infinite loop just waiting to happen. *) + | _ -> self#non_arrowed_module_type ~space letPattern x + in + source_map ~loc:x.pmty_loc pmty + + method simple_module_expr ?(hug = false) x = + match x.pmod_desc with + | Pmod_unpack e -> + let exprLayout = + match e.pexp_desc with + | Pexp_constraint (e, { ptyp_desc = Ptyp_package (lid, cstrs) }) + -> + formatTypeConstraint + (makeList ~postSpace:true [ atom "val"; self#unparseExpr e ]) + (self#typ_package ~mod_prefix:false lid cstrs) + | _ -> makeList ~postSpace:true [ atom "val"; self#unparseExpr e ] + in + formatPrecedence exprLayout + | Pmod_ident li -> + ensureSingleTokenSticksToLabel (self#longident_loc li) + | Pmod_constraint (unconstrainedRet, mt) -> + let letPattern = + makeList [ self#module_expr unconstrainedRet; atom ":" ] + in + formatPrecedence (self#module_type letPattern mt) + | Pmod_structure s -> + let wrap = + if hug then if s = [] then "(", ")" else "({", "})" else "{", "}" + in + self#structure ~indent:None ~wrap s + | _ -> + (* For example, functor application will be wrapped. *) + formatPrecedence ~wrap:("", "") (self#module_expr x) + + method module_expr x = + match x.pmod_desc with + | Pmod_functor _ -> + let argsList, return = + self#curriedFunctorPatternsAndReturnStruct x + in + (* See #19/20 in syntax.mls - cannot annotate return type at the + moment. *) + self#wrapCurriedFunctionBinding + funToken + ~sweet:true + ~arrow:"=>" + (makeTup argsList) + [] + ([ self#moduleExpressionToFormattedApplicationItems return ], None) + | Pmod_apply _ -> self#moduleExpressionToFormattedApplicationItems x + | Pmod_extension (s, e) -> self#payload "%" s e + | Pmod_unpack _ | Pmod_ident _ | Pmod_constraint _ | Pmod_structure _ + -> + self#simple_module_expr x + + method recmodule ?extension decls = + let items = + List.mapi + (fun i xx -> + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + xx.pmb_attributes + in + let layout = + self#attach_std_item_attrs stdAttrs + @@ self#let_module_binding + (if i == 0 + then add_extension_sugar "module" extension ^ " rec" + else "and") + (atom (moduleIdent xx.pmb_name)) + xx.pmb_expr + in + let layoutWithDocAttrs = + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:xx.pmb_name.loc + ~layout + () + in + extractLocModuleBinding xx, layoutWithDocAttrs) + decls + in + makeNonIndentedBreakingList + (groupAndPrint + ~xf:(fun (_, layout) -> layout) + ~getLoc:(fun (loc, _) -> loc) + ~comments:self#comments + items) + + method pstr_open ?extension od = + let open_prefix = + add_open_extension_sugar ~override:od.popen_override extension + in + self#attach_std_item_attrs od.popen_attributes + @@ label + ~space:true + (atom open_prefix) + (self#moduleExpressionToFormattedApplicationItems od.popen_expr) + + method structure ?(indent = Some 0) ?wrap structureItems = + (* We don't have any way to know if an extension is placed at the top + level by the parsetree while there's a difference syntactically (% + for structure_items/expressons and %% for top_level). This small fn + detects this particular case (structure > structure_item > + extension > value) and prints with double % *) + let structure_item item = + match item.pstr_desc with + | Pstr_extension ((extension, PStr [ item ]), attrs) -> + (match item.pstr_desc with + (* In case of a value or `external`, the extension gets inlined + `let%private a = 1` *) + | Pstr_value (rf, vb_list) -> + self#bindings ~extension (rf, vb_list) + | Pstr_primitive vd -> self#primitive_declaration ~extension vd + | Pstr_module binding -> + let bindingName = + atom ~loc:binding.pmb_name.loc (moduleIdent binding.pmb_name) + in let module_binding = let prefix = add_extension_sugar "module" (Some extension) in - self#let_module_binding prefix bindingName binding.pmb_expr in + self#let_module_binding prefix bindingName binding.pmb_expr + in self#attach_std_item_attrs binding.pmb_attributes module_binding - | Pstr_recmodule decls -> self#recmodule ~extension decls - | Pstr_open od -> self#pstr_open ~extension od - | _ -> self#attach_std_item_attrs attrs (self#payload "%%" extension (PStr [item])) - end - | _ -> self#structure_item item - in - match structureItems with - | [] -> makeList ?wrap [] - | first :: _ as structureItems -> - let last = match (List.rev structureItems) with | last::_ -> last | [] -> assert false in - let loc_start = first.pstr_loc.loc_start in - let loc_end = last.pstr_loc.loc_end in - let items = - groupAndPrint - ~xf:structure_item - ~getLoc:(fun x -> x.pstr_loc) - ~comments:self#comments - structureItems - in - source_map ~loc:{loc_start; loc_end; loc_ghost = false} - (makeList - ~postSpace:true - ~break:Always_rec - ?wrap - ?indent - ~inline:(true, false) - ~sep:(SepFinal (";", ";")) - items) - - (* - How do modules become parsed? - let module (X: sig) = blah; - Will not parse! (Should just make it parse to let [X:sig =]). - let module X: sig = blah; - Becomes Pmod_constraint - let module X: sig = (blah:sig); - Becomes Pmod_constraint .. Pmod_constraint - let module X = blah:typ; - Becomes Pmod_constraint - let module X (Y:y) (Z:z):r => Q - Becomes Pmod_functor...=> Pmod_constraint - - let module X (Y:y) (Z:z):r => (Q:r2) - Probably becomes Pmod_functor...=> (Pmod_constraint.. - Pmod_constraint) - - let (module X) = - Is a *completely* different thing (unpacking/packing first class modules). - We should make sure this is very well distinguished. - - Just replace all "let module" with a new three letter keyword (mod)? - - Reserve let (module X) for unpacking first class modules. - - See the notes about how Ppat_constraint become parsed and attempt to unify - those as well. - *) - - method let_module_binding prefixText bindingName moduleExpr = - let (argsList, return) = self#curriedFunctorPatternsAndReturnStruct moduleExpr in ( - match (argsList, return.pmod_desc) with - (* Simple module with type constraint, no functor args. *) - | ([], Pmod_constraint (unconstrainedRetTerm, ct)) -> + | Pstr_recmodule decls -> self#recmodule ~extension decls + | Pstr_open od -> self#pstr_open ~extension od + | _ -> + self#attach_std_item_attrs + attrs + (self#payload "%%" extension (PStr [ item ]))) + | _ -> self#structure_item item + in + match structureItems with + | [] -> makeList ?wrap [] + | first :: _ as structureItems -> + let last = + match List.rev structureItems with + | last :: _ -> last + | [] -> assert false + in + let loc_start = first.pstr_loc.loc_start in + let loc_end = last.pstr_loc.loc_end in + let items = + groupAndPrint + ~xf:structure_item + ~getLoc:(fun x -> x.pstr_loc) + ~comments:self#comments + structureItems + in + source_map + ~loc:{ loc_start; loc_end; loc_ghost = false } + (makeList + ~postSpace:true + ~break:Always_rec + ?wrap + ?indent + ~inline:(true, false) + ~sep:(SepFinal (";", ";")) + items) + + (* + * How do modules become parsed? + * let module (X: sig) = blah; + * Will not parse! (Should just make it parse to let [X:sig =]). + * let module X: sig = blah; + * Becomes Pmod_constraint + * let module X: sig = (blah:sig); + * Becomes Pmod_constraint .. Pmod_constraint + * let module X = blah:typ; + * Becomes Pmod_constraint + * let module X (Y:y) (Z:z):r => Q + * Becomes Pmod_functor...=> Pmod_constraint + + * let module X (Y:y) (Z:z):r => (Q:r2) + * Probably becomes Pmod_functor...=> (Pmod_constraint.. + * Pmod_constraint) + + * let (module X) = + * Is a *completely* different thing (unpacking/packing first class modules). + * We should make sure this is very well distinguished. + * - Just replace all "let module" with a new three letter keyword (mod)? + * - Reserve let (module X) for unpacking first class modules. + + * See the notes about how Ppat_constraint become parsed and attempt to unify + * those as well. + *) + + method let_module_binding prefixText bindingName moduleExpr = + let argsList, return = + self#curriedFunctorPatternsAndReturnStruct moduleExpr + in + match argsList, return.pmod_desc with + (* Simple module with type constraint, no functor args. *) + | [], Pmod_constraint (unconstrainedRetTerm, ct) -> let letPattern = makeList - [makeList ~postSpace:true [atom prefixText; bindingName]; - atom ":"] + [ makeList ~postSpace:true [ atom prefixText; bindingName ] + ; atom ":" + ] in let typeConstraint = self#module_type letPattern ct in - let includingEqual = makeList ~postSpace:true [typeConstraint; atom "="] + let includingEqual = + makeList ~postSpace:true [ typeConstraint; atom "=" ] in - formatAttachmentApplication applicationFinalWrapping (Some (true, includingEqual)) - ([self#moduleExpressionToFormattedApplicationItems unconstrainedRetTerm], None) - - (* Simple module with type no constraint, no functor args. *) - | ([], _) -> - self#formatSimplePatternBinding prefixText bindingName None - ([self#moduleExpressionToFormattedApplicationItems return], None) - | (_, _) -> + formatAttachmentApplication + applicationFinalWrapping + (Some (true, includingEqual)) + ( [ self#moduleExpressionToFormattedApplicationItems + unconstrainedRetTerm + ] + , None ) + (* Simple module with type no constraint, no functor args. *) + | [], _ -> + self#formatSimplePatternBinding + prefixText + bindingName + None + ([ self#moduleExpressionToFormattedApplicationItems return ], None) + | _, _ -> (* A functor *) - let (argsWithConstraint, actualReturn) = ( + let argsWithConstraint, actualReturn = match return.pmod_desc with - (* A functor with constrained return type: - * - * let module X = (A) (B) : Ret => ... - * *) - | Pmod_constraint (me, ct) -> - ([makeTup argsList; - self#non_arrowed_module_type (atom ":") ct], me) - | _ -> ([makeTup argsList], return) - ) in - self#wrapCurriedFunctionBinding prefixText ~arrow:"=>" - (makeList [bindingName; atom " ="]) argsWithConstraint - ([self#moduleExpressionToFormattedApplicationItems actualReturn], None) - ) - - method class_opening class_keyword name pci_virt ls = - let firstToken = if class_keyword then "class" else "and" in - match (pci_virt, ls) with - (* When no class params, it's a very simple formatting for the - opener - no breaking. *) - | (Virtual, []) -> - (firstToken, atom "virtual", [atom name]) - | (Concrete, []) -> - (firstToken, atom name, []) - | (Virtual, _::_) -> - (firstToken, atom "virtual", [atom name; self#class_params_def ls]) - | (Concrete, _::_) -> - (firstToken, atom name, [self#class_params_def ls]) - - - (* TODO: TODOATTRIBUTES: Structure items don't have attributes, but each - pstr_desc *) - method structure_item term = - let item = ( - match term.pstr_desc with - | Pstr_eval (e, attrs) -> - let {Reason_attributes.stdAttrs; jsxAttrs; uncurried} = - Reason_attributes.partitionAttributes attrs in - if uncurried then Hashtbl.add uncurriedTable e.pexp_loc true; - let layout = self#attach_std_item_attrs stdAttrs (self#unparseUnattributedExpr e) in - (* If there was a JSX attribute BUT JSX component wasn't detected, - that JSX attribute needs to be pretty printed so it doesn't get - lost *) - (match jsxAttrs with - | [] -> layout - | _::_ -> - let jsxAttrNodes = List.map self#attribute jsxAttrs in - makeList ~sep:(Sep " ") (jsxAttrNodes @ [layout])) - | Pstr_type (_, []) -> assert false - | Pstr_type (rf, l) -> (self#type_def_list (rf, l)) - | Pstr_value (rf, l) -> (self#bindings (rf, l)) - | Pstr_typext te -> (self#type_extension te) - | Pstr_exception ed -> - self#exception_declaration - { ed.ptyexn_constructor - with pext_attributes = ed.ptyexn_attributes @ ed.ptyexn_constructor.pext_attributes} - | Pstr_module binding -> - let bindingName = atom ~loc:binding.pmb_name.loc (moduleIdent binding.pmb_name) in - let module_binding = self#let_module_binding "module" bindingName binding.pmb_expr in - self#attach_std_item_attrs binding.pmb_attributes module_binding - | Pstr_open od -> self#pstr_open od - | Pstr_modtype x -> - let name = atom x.pmtd_name.txt in - let letPattern = makeList ~postSpace:true [atom "module type"; name; atom "="] in - let main = match x.pmtd_type with - | None -> makeList ~postSpace:true [atom "module type"; name] - | Some mt -> self#module_type letPattern mt + (* A functor with constrained return type: + * + * let module X = (A) (B) : Ret => ... + * *) + | Pmod_constraint (me, ct) -> + ( [ makeTup argsList + ; self#non_arrowed_module_type (atom ":") ct + ] + , me ) + | _ -> [ makeTup argsList ], return in - self#attach_std_item_attrs x.pmtd_attributes main - | Pstr_class l -> self#class_declaration_list l - | Pstr_class_type l -> self#class_type_declaration_list l - | Pstr_primitive vd -> self#primitive_declaration vd - | Pstr_include incl -> - self#attach_std_item_attrs incl.pincl_attributes @@ - (* Kind of a hack *) - let moduleExpr = incl.pincl_mod in - self#moduleExpressionToFormattedApplicationItems - ~prefix:"include" - moduleExpr - | Pstr_recmodule decls -> self#recmodule decls - | Pstr_attribute a -> self#floating_attribute a - | Pstr_extension ((_extension, PStr []) as extension, attrs) -> - (* Extension with attributes and without PStr gets printed inline *) - self#attach_std_attrs attrs (self#item_extension extension) - | Pstr_extension ((extension, PStr [item]), attrs) -> - begin match item.pstr_desc with - (* In case of a value, the extension gets inlined `let%lwt a = 1` *) - | Pstr_value (rf, l) -> self#bindings ~extension (rf, l) - | _ -> - let {Reason_attributes.stdAttrs; docAttrs} = + self#wrapCurriedFunctionBinding + prefixText + ~arrow:"=>" + (makeList [ bindingName; atom " =" ]) + argsWithConstraint + ( [ self#moduleExpressionToFormattedApplicationItems actualReturn ] + , None ) + + method class_opening class_keyword name pci_virt ls = + let firstToken = if class_keyword then "class" else "and" in + match pci_virt, ls with + (* When no class params, it's a very simple formatting for the + * opener - no breaking. + *) + | Virtual, [] -> firstToken, atom "virtual", [ atom name ] + | Concrete, [] -> firstToken, atom name, [] + | Virtual, _ :: _ -> + firstToken, atom "virtual", [ atom name; self#class_params_def ls ] + | Concrete, _ :: _ -> + firstToken, atom name, [ self#class_params_def ls ] + + (* TODO: TODOATTRIBUTES: Structure items don't have attributes, but each + pstr_desc *) + method structure_item term = + let item = + match term.pstr_desc with + | Pstr_eval (e, attrs) -> + let { Reason_attributes.stdAttrs; jsxAttrs; uncurried } = + Reason_attributes.partitionAttributes attrs + in + if uncurried then Hashtbl.add uncurriedTable e.pexp_loc true; + let layout = + self#attach_std_item_attrs + stdAttrs + (self#unparseUnattributedExpr e) + in + (* If there was a JSX attribute BUT JSX component wasn't detected, + that JSX attribute needs to be pretty printed so it doesn't get + lost *) + (match jsxAttrs with + | [] -> layout + | _ :: _ -> + let jsxAttrNodes = List.map self#attribute jsxAttrs in + makeList ~sep:(Sep " ") (jsxAttrNodes @ [ layout ])) + | Pstr_type (_, []) -> assert false + | Pstr_type (rf, l) -> self#type_def_list (rf, l) + | Pstr_value (rf, l) -> self#bindings (rf, l) + | Pstr_typext te -> self#type_extension te + | Pstr_exception ed -> + self#exception_declaration + { ed.ptyexn_constructor with + pext_attributes = + ed.ptyexn_attributes @ ed.ptyexn_constructor.pext_attributes + } + | Pstr_module binding -> + let bindingName = + atom ~loc:binding.pmb_name.loc (moduleIdent binding.pmb_name) + in + let module_binding = + self#let_module_binding "module" bindingName binding.pmb_expr + in + self#attach_std_item_attrs binding.pmb_attributes module_binding + | Pstr_open od -> self#pstr_open od + | Pstr_modtype x -> + let name = atom x.pmtd_name.txt in + let letPattern = + makeList ~postSpace:true [ atom "module type"; name; atom "=" ] + in + let main = + match x.pmtd_type with + | None -> makeList ~postSpace:true [ atom "module type"; name ] + | Some mt -> self#module_type letPattern mt + in + self#attach_std_item_attrs x.pmtd_attributes main + | Pstr_class l -> self#class_declaration_list l + | Pstr_class_type l -> self#class_type_declaration_list l + | Pstr_primitive vd -> self#primitive_declaration vd + | Pstr_include incl -> + self#attach_std_item_attrs incl.pincl_attributes + @@ + (* Kind of a hack *) + let moduleExpr = incl.pincl_mod in + self#moduleExpressionToFormattedApplicationItems + ~prefix:"include" + moduleExpr + | Pstr_recmodule decls -> self#recmodule decls + | Pstr_attribute a -> self#floating_attribute a + | Pstr_extension (((_extension, PStr []) as extension), attrs) -> + (* Extension with attributes and without PStr gets printed + inline *) + self#attach_std_attrs attrs (self#item_extension extension) + | Pstr_extension ((extension, PStr [ item ]), attrs) -> + (match item.pstr_desc with + (* In case of a value, the extension gets inlined `let%lwt a = + 1` *) + | Pstr_value (rf, l) -> self#bindings ~extension (rf, l) + | _ -> + let { Reason_attributes.stdAttrs; docAttrs } = Reason_attributes.partitionAttributes ~partDoc:true attrs in let item = self#structure_item item in let layout = self#attach_std_item_attrs ~extension stdAttrs item in - makeList ((List.map self#attribute docAttrs) @ [layout]) - end - | Pstr_extension (e, a) -> - (* Notice how extensions have attributes - but not every structure - item does. *) - self#attach_std_item_attrs a (self#item_extension e) - ) in - source_map ~loc:term.pstr_loc item - - method type_extension te = - let formatOneTypeExtStandard prepend ({ptyext_path} as te) = - let name = self#longident_loc ptyext_path in - let item = self#formatOneTypeExt prepend name (atom "+=") te in - let {Reason_attributes.stdAttrs; docAttrs} = - Reason_attributes.partitionAttributes ~partDoc:true te.ptyext_attributes - in - let layout = self#attach_std_item_attrs stdAttrs item in - self#attachDocAttrsToLayout - ~stdAttrs - ~docAttrs - ~loc:ptyext_path.loc - ~layout - () - in - formatOneTypeExtStandard (atom "type") te - - (* [allowUnguardedSequenceBodies] allows sequence expressions {} to the right of `=>` to not - be guarded in `{}` braces. *) - method case_list ?(allowUnguardedSequenceBodies=false) l = - let rec appendLabelToLast items rhs = - match items with - | hd::[] -> (label ~indent:0 ~space:true hd rhs)::[] - | hd::tl -> hd::(appendLabelToLast tl rhs) - | [] -> raise (NotPossible "Cannot append to last of nothing") - in + makeList (List.map self#attribute docAttrs @ [ layout ])) + | Pstr_extension (e, a) -> + (* Notice how extensions have attributes - but not every structure + item does. *) + self#attach_std_item_attrs a (self#item_extension e) + in + source_map ~loc:term.pstr_loc item + + method type_extension te = + let formatOneTypeExtStandard prepend ({ ptyext_path } as te) = + let name = self#longident_loc ptyext_path in + let item = self#formatOneTypeExt prepend name (atom "+=") te in + let { Reason_attributes.stdAttrs; docAttrs } = + Reason_attributes.partitionAttributes + ~partDoc:true + te.ptyext_attributes + in + let layout = self#attach_std_item_attrs stdAttrs item in + self#attachDocAttrsToLayout + ~stdAttrs + ~docAttrs + ~loc:ptyext_path.loc + ~layout + () + in + formatOneTypeExtStandard (atom "type") te + + (* [allowUnguardedSequenceBodies] allows sequence expressions {} to the + right of `=>` to not be guarded in `{}` braces. *) + method case_list ?(allowUnguardedSequenceBodies = false) l = + let rec appendLabelToLast items rhs = + match items with + | hd :: [] -> label ~indent:0 ~space:true hd rhs :: [] + | hd :: tl -> hd :: appendLabelToLast tl rhs + | [] -> raise (NotPossible "Cannot append to last of nothing") + in - let case_row {pc_lhs; pc_guard; pc_rhs} = - let theOrs = orList pc_lhs in - - (* match x with *) - (* | AnotherReallyLongVariantName (_, _, _) *) - (* | AnotherReallyLongVariantName2 (_, _, _) - when true => { *) - - (* } *) - - (*match x with *) - (* everythingElse *) - (* *) - - - - (* ............................................................ - : each or segment has a spaced list <> that ties its : - : bar "|" to its pattern : - ...:..........................................................:..... - : : each or-patterned match is grouped in SpacedBreakableInline : - : : : : - v v v v - <>|<> FirstThingStandalone t =>t - <>| AnotherReallyLongVariantName (_, _, _) - ^ <>|<>AnotherReallyLongVariantNam2 (_, _, _) (label the last in or ptn for or and label it again for arrow) - : ^ ^ ^ when true =>{ - : : : : } ^ ^ - : : : : ^ ^ : : - : : : : : : : : - : : : :If there is :a WHERE : : - : : : :an extra :label is : : - : : : :inserted bef:ore the : : - : : : :arrow. : : : : - : : : :............:.....:...: : - : : : : : : - : : : : : : - : : : : : : - : : :The left side of:this final label: - : : :uses a list to :append the arrow: - : : :................:.....:..........: - : : : : - : : : : - : : : : - : :Final or segment is: : - : :wrapped in lbl that: : - : :partitions pattern : : - : :and arrow from : : - : :expression. : : - : : : : - : :...................: : - : [orsWithWhereAndArrowOnLast] : - : : - :..................................: - [row] - - *) - let bar xx = makeList ~postSpace:true [atom "|"; xx] in - let appendWhereAndArrow p = match pc_guard with - | None -> makeList ~postSpace:true [p; atom "=>"] - | Some g -> - (* when x should break as a whole - extra list added around it to make it break as one *) - let withWhen = label ~space:true p - (makeList ~break:Layout.Never ~inline:(true, true) ~postSpace:true - [label ~space:true (atom "when") (self#unparseExpr g)]) - in - makeList ~inline:(true, true) ~postSpace:true [withWhen; atom "=>"] - in - let rec appendWhereAndArrowToLastOr = function - | [] -> [] - | hd::tl -> - let formattedHd = self#pattern hd in - let formattedHd = match hd.ppat_desc with - | Ppat_constraint _ -> formatPrecedence formattedHd - | _ -> formattedHd - in - let formattedHd = - if tl == [] then appendWhereAndArrow formattedHd else formattedHd - in - (formattedHd :: appendWhereAndArrowToLastOr tl) - in - let orsWithWhereAndArrowOnLast = appendWhereAndArrowToLastOr theOrs in - let rhs = - if allowUnguardedSequenceBodies then - match (self#under_pipe#letList pc_rhs) with - (* TODO: Still render a list with located information here so that - comments (eol) are interleaved *) - | [hd] -> hd - (* In this case, we don't need any additional indentation, because there aren't - wrapping {} which would cause zero indentation to look strange. *) - | lst -> makeUnguardedLetSequence lst - else self#under_pipe#unparseExpr pc_rhs - in - source_map - (* Fake shift the location to accommodate for the bar, to make sure - * the wrong comments don't make their way past the next bar. *) - ~loc:(expandLocation ~expand:(0, 0) { - loc_start = pc_lhs.ppat_loc.loc_start; - loc_end = pc_rhs.pexp_loc.loc_end; - loc_ghost = false; - }) - (makeList ~break:Always_rec ~inline:(true, true) - (List.map bar (appendLabelToLast orsWithWhereAndArrowOnLast rhs))) - in - groupAndPrint - ~xf:case_row - ~getLoc:(fun {pc_lhs; pc_rhs} -> {pc_lhs.ppat_loc with loc_end = pc_rhs.pexp_loc.loc_end}) - ~comments:self#comments - l - - (* Formats a list of a single expr param in such a way that the parens of the function or - * (poly)-variant application and the wrapping of the param stick together when the layout breaks. - * Example: `foo({a: 1, b: 2})` needs to be formatted as - * foo({ - * a: 1, - * b: 2 - * }) - * when the line length dictates breaking. Notice how `({` and `})` 'hug'. - * Also see "isSingleArgParenApplication" which determines if - * this kind of formatting should happen. *) - method singleArgParenApplication ?(wrap=("", "")) ?(uncurried=false) es = - let (lwrap, rwrap) = wrap in - let lparen = lwrap ^ (if uncurried then "(. " else "(") in - let rparen = ")" ^ rwrap in - match es with - | [{pexp_attributes = []; pexp_desc = Pexp_record (l, eo)}] -> - self#unparseRecord ~wrap:(lparen, rparen) l eo - | [{pexp_attributes = []; pexp_desc = Pexp_tuple l}] -> - self#unparseSequence ~wrap:(lparen, rparen) ~construct:`Tuple l - | [{pexp_attributes = []; pexp_desc = Pexp_array l}] -> - self#unparseSequence ~wrap:(lparen, rparen) ~construct:`Array l - | [{pexp_attributes = []; pexp_desc = Pexp_object cs}] -> - self#classStructure ~wrap:(lparen, rparen) cs - | [{pexp_attributes = []; pexp_desc = Pexp_extension (s, p)}] when s.txt = "mel.obj" -> - self#formatBsObjExtensionSugar ~wrap:(lparen, rparen) p - | [({pexp_attributes = []} as exp)] when (is_simple_list_expr exp) -> - (match view_expr exp with - | `list xs -> + let case_row { pc_lhs; pc_guard; pc_rhs } = + let theOrs = orList pc_lhs in + + (* match x with *) + (* | AnotherReallyLongVariantName (_, _, _) *) + (* | AnotherReallyLongVariantName2 (_, _, _) when true => { *) + + (* } *) + + (*match x with *) + (* everythingElse *) + (* *) + + (* ............................................................ + * : each or segment has a spaced list <> that ties its : + * : bar "|" to its pattern : + * ...:..........................................................:..... + * : : each or-patterned match is grouped in SpacedBreakableInline : + * : : : : + * v v v v + * <>|<> FirstThingStandalone t =>t + * <>| AnotherReallyLongVariantName (_, _, _) + * ^ <>|<>AnotherReallyLongVariantNam2 (_, _, _) (label the last in or ptn for or and label it again for arrow) + * : ^ ^ ^ when true =>{ + * : : : : } ^ ^ + * : : : : ^ ^ : : + * : : : : : : : : + * : : : :If there is :a WHERE : : + * : : : :an extra :label is : : + * : : : :inserted bef:ore the : : + * : : : :arrow. : : : : + * : : : :............:.....:...: : + * : : : : : : + * : : : : : : + * : : : : : : + * : : :The left side of:this final label: + * : : :uses a list to :append the arrow: + * : : :................:.....:..........: + * : : : : + * : : : : + * : : : : + * : :Final or segment is: : + * : :wrapped in lbl that: : + * : :partitions pattern : : + * : :and arrow from : : + * : :expression. : : + * : : : : + * : :...................: : + * : [orsWithWhereAndArrowOnLast] : + * : : + * :..................................: + * [row] + *) + let bar xx = makeList ~postSpace:true [ atom "|"; xx ] in + let appendWhereAndArrow p = + match pc_guard with + | None -> makeList ~postSpace:true [ p; atom "=>" ] + | Some g -> + (* when x should break as a whole - extra list added around it + to make it break as one *) + let withWhen = + label + ~space:true + p + (makeList + ~break:Layout.Never + ~inline:(true, true) + ~postSpace:true + [ label ~space:true (atom "when") (self#unparseExpr g) ]) + in + makeList + ~inline:(true, true) + ~postSpace:true + [ withWhen; atom "=>" ] + in + let rec appendWhereAndArrowToLastOr = function + | [] -> [] + | hd :: tl -> + let formattedHd = self#pattern hd in + let formattedHd = + match hd.ppat_desc with + | Ppat_constraint _ -> formatPrecedence formattedHd + | _ -> formattedHd + in + let formattedHd = + if tl == [] + then appendWhereAndArrow formattedHd + else formattedHd + in + formattedHd :: appendWhereAndArrowToLastOr tl + in + let orsWithWhereAndArrowOnLast = + appendWhereAndArrowToLastOr theOrs + in + let rhs = + if allowUnguardedSequenceBodies + then + match self#under_pipe#letList pc_rhs with + (* TODO: Still render a list with located information here so + that comments (eol) are interleaved *) + | [ hd ] -> hd + (* In this case, we don't need any additional indentation, + because there aren't wrapping {} which would cause zero + indentation to look strange. *) + | lst -> makeUnguardedLetSequence lst + else self#under_pipe#unparseExpr pc_rhs + in + source_map + (* Fake shift the location to accommodate for the bar, to make sure + * the wrong comments don't make their way past the next bar. *) + ~loc: + (expandLocation + ~expand:(0, 0) + { loc_start = pc_lhs.ppat_loc.loc_start + ; loc_end = pc_rhs.pexp_loc.loc_end + ; loc_ghost = false + }) + (makeList + ~break:Always_rec + ~inline:(true, true) + (List.map + bar + (appendLabelToLast orsWithWhereAndArrowOnLast rhs))) + in + groupAndPrint + ~xf:case_row + ~getLoc:(fun { pc_lhs; pc_rhs } -> + { pc_lhs.ppat_loc with loc_end = pc_rhs.pexp_loc.loc_end }) + ~comments:self#comments + l + + (* Formats a list of a single expr param in such a way that the parens of the function or + * (poly)-variant application and the wrapping of the param stick together when the layout breaks. + * Example: `foo({a: 1, b: 2})` needs to be formatted as + * foo({ + * a: 1, + * b: 2 + * }) + * when the line length dictates breaking. Notice how `({` and `})` 'hug'. + * Also see "isSingleArgParenApplication" which determines if + * this kind of formatting should happen. *) + method singleArgParenApplication + ?(wrap = "", "") + ?(uncurried = false) + es = + let lwrap, rwrap = wrap in + let lparen = lwrap ^ if uncurried then "(. " else "(" in + let rparen = ")" ^ rwrap in + match es with + | [ { pexp_attributes = []; pexp_desc = Pexp_record (l, eo) } ] -> + self#unparseRecord ~wrap:(lparen, rparen) l eo + | [ { pexp_attributes = []; pexp_desc = Pexp_tuple l } ] -> + self#unparseSequence ~wrap:(lparen, rparen) ~construct:`Tuple l + | [ { pexp_attributes = []; pexp_desc = Pexp_array l } ] -> + self#unparseSequence ~wrap:(lparen, rparen) ~construct:`Array l + | [ { pexp_attributes = []; pexp_desc = Pexp_object cs } ] -> + self#classStructure ~wrap:(lparen, rparen) cs + | [ { pexp_attributes = []; pexp_desc = Pexp_extension (s, p) } ] + when s.txt = "mel.obj" -> + self#formatBsObjExtensionSugar ~wrap:(lparen, rparen) p + | [ ({ pexp_attributes = [] } as exp) ] when is_simple_list_expr exp + -> + (match view_expr exp with + | `list xs -> self#unparseSequence ~construct:`List ~wrap:(lparen, rparen) xs - | `cons xs -> + | `cons xs -> self#unparseSequence ~construct:`ES6List ~wrap:(lparen, rparen) xs - | _ -> assert false) - | _ -> assert false - - method formatSingleArgLabelApplication labelTerm rightExpr = - let layout_right = match rightExpr with - | {pexp_desc = Pexp_let _} -> - makeLetSequence ~wrap:("({", "})") (self#letList rightExpr) - | e when isSingleArgParenApplication [rightExpr] -> - self#singleArgParenApplication [e] - | {pexp_desc = Pexp_construct ( {txt= Lident"()"},_)} -> - (* special case unit such that we don't end up with double parens *) - self#simplifyUnparseExpr rightExpr - | _ -> - formatPrecedence (self#unparseExpr rightExpr) - in - label labelTerm layout_right - - method label_x_expression_param (l, e) = - let term = self#unparseProtectedExpr e in - let param = match (l, e) with - | (Nolabel, _) -> term - | (Labelled lbl, _) when Reason_heuristics.is_punned_labelled_expression e lbl -> - makeList [atom namedArgSym; term] - | (Optional lbl, _) when Reason_heuristics.is_punned_labelled_expression e lbl -> - makeList [atom namedArgSym; label term (atom "?")] - | (Labelled lbl, _) -> - label (atom (namedArgSym ^ lbl ^ "=")) term - | (Optional lbl, _) -> - label (atom (namedArgSym ^ lbl ^ "=?")) term - in - source_map ~loc:e.pexp_loc param - - method label_x_expression_params ?wrap ?(uncurried=false) xs = - match xs with - (* function applications with unit as only argument should be printed differently - * e.g. print_newline(()) should be printed as print_newline() *) - | [(Nolabel, {pexp_attributes = []; pexp_desc = Pexp_construct ( {txt= Lident "()"}, None)})] - -> makeList + | _ -> assert false) + | _ -> assert false + + method formatSingleArgLabelApplication labelTerm rightExpr = + let layout_right = + match rightExpr with + | { pexp_desc = Pexp_let _ } -> + makeLetSequence ~wrap:("({", "})") (self#letList rightExpr) + | e when isSingleArgParenApplication [ rightExpr ] -> + self#singleArgParenApplication [ e ] + | { pexp_desc = Pexp_construct ({ txt = Lident "()" }, _) } -> + (* special case unit such that we don't end up with double + parens *) + self#simplifyUnparseExpr rightExpr + | _ -> formatPrecedence (self#unparseExpr rightExpr) + in + label labelTerm layout_right + + method label_x_expression_param (l, e) = + let term = self#unparseProtectedExpr e in + let param = + match l, e with + | Nolabel, _ -> term + | Labelled lbl, _ + when Reason_heuristics.is_punned_labelled_expression e lbl -> + makeList [ atom namedArgSym; term ] + | Optional lbl, _ + when Reason_heuristics.is_punned_labelled_expression e lbl -> + makeList [ atom namedArgSym; label term (atom "?") ] + | Labelled lbl, _ -> label (atom (namedArgSym ^ lbl ^ "=")) term + | Optional lbl, _ -> label (atom (namedArgSym ^ lbl ^ "=?")) term + in + source_map ~loc:e.pexp_loc param + + method label_x_expression_params ?wrap ?(uncurried = false) xs = + match xs with + (* function applications with unit as only argument should be printed differently + * e.g. print_newline(()) should be printed as print_newline() *) + | [ ( Nolabel + , { pexp_attributes = [] + ; pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) + } ) + ] -> + makeList ~break:Never ?wrap - [if uncurried then atom "(.)" else atom "()"] - - (* The following cases provide special formatting when there's only one expr_param that is a tuple/array/list/record etc. - * e.g. foo({a: 1, b: 2}) - * becomes -> - * foo({ - * a: 1, - * b: 2, - * }) - * when the line-length indicates breaking. - *) - | [(Nolabel, exp)] when isSingleArgParenApplication [exp] -> - self#singleArgParenApplication ?wrap ~uncurried [exp] - | params -> - makeTup ?wrap ~uncurried (List.map self#label_x_expression_param params) - - (* - * Prefix represents an optional layout. When passed it will be "prefixed" to - * the funExpr. Example, given `bar(x, y)` with prefix `foo`, we get - * foobar(x,y). When the arguments break, the closing `)` is nicely aligned - * on the height of the prefix: - * foobar( - * x, - * y, - * ) --> notice how `)` sits on the height of `foo` instead of `bar` - * - * ~wrap -> represents optional "wrapping", might be useful in context of jsx - * where braces are required: - * prop={bar( -> `{` is formatted before the funExpr - * x, - * y, - * )} -> notice how the closing brace hugs: `)}` - *) - method formatFunAppl ?(prefix=(atom "")) ?(wrap=("", "")) ~jsxAttrs ~args ~funExpr ~applicationExpr ?(uncurried=false) () = - let (leftWrap, rightWrap) = wrap in - let uncurriedApplication = uncurried in - (* If there was a JSX attribute BUT JSX component wasn't detected, - that JSX attribute needs to be pretty printed so it doesn't get - lost *) - let maybeJSXAttr = List.map self#attribute jsxAttrs in - let categorizeFunApplArgs args = - let reverseArgs = List.rev args in - match reverseArgs with - | ((_, {pexp_desc = Pexp_fun _}) as callback)::args - when - [] == List.filter (fun (_, e) -> match e.pexp_desc with Pexp_fun _ -> true | _ -> false) args - (* default to normal formatting if there's more than one callback *) - -> `LastArgIsCallback(callback, List.rev args) - | _ -> `NormalFunAppl args - in - let formattedFunExpr = match funExpr.pexp_desc with - (* pipe first chain or sharpop chain as funExpr, no parens needed, we know how to parse *) - | Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident s}}, _) - when requireNoSpaceFor s -> - self#unparseExpr funExpr - | Pexp_field _ -> self#unparseExpr funExpr - | _ -> self#simplifyUnparseExpr funExpr - in - let formattedFunExpr = makeList [prefix; atom leftWrap; formattedFunExpr] in - begin match categorizeFunApplArgs args with - | `LastArgIsCallback(callbackArg, args) -> - (* This is the following case: - * Thing.map(foo, bar, baz, (abc, z) => - * MyModuleBlah.toList(argument) - *) - let (argLbl, cb) = callbackArg in - let {Reason_attributes.stdAttrs; uncurried} = - Reason_attributes.partitionAttributes cb.pexp_attributes in - let cbAttrs = stdAttrs in - if uncurried then Hashtbl.add uncurriedTable cb.pexp_loc true; - let (cbArgs, retCb) = self#curriedPatternsAndReturnVal {cb with pexp_attributes = []} in - let cbArgs = if cbAttrs != [] then - makeList ~break:IfNeed ~inline:(true, true) ~postSpace:true - (List.map self#attribute cbAttrs @ cbArgs) - else makeList cbArgs in - let (retCb, cbArgs) = (match retCb.pexp_desc with - | Pexp_constraint (a, t) -> (a, makeList [cbArgs; atom ": "; self#core_type t]) - | _ -> (retCb, cbArgs) - ) - in - let theCallbackArg = match argLbl with - | Optional s -> makeList ([atom namedArgSym; atom s; atom "=?"]@[cbArgs]) - | Labelled s -> makeList ([atom namedArgSym; atom s; atom "="]@[cbArgs]) - | Nolabel -> cbArgs - in - let theFunc = - source_map ~loc:funExpr.pexp_loc - (makeList - ~wrap:("", (if uncurriedApplication then "(." else "(")) - [formattedFunExpr]) - in - let formattedFunAppl = begin match self#letList retCb with - | [x] -> - (* force breaks for test assertion style callbacks, e.g. - * describe("App", () => test("math", () => Expect.expect(1 + 2) |> toBe(3))); - * should always break for readability of the tests: - * describe("App", () => - * test("math", () => - * Expect.expect(1 + 2) |> toBe(3) - * ) - * ); + [ (if uncurried then atom "(.)" else atom "()") ] + (* The following cases provide special formatting when there's only one expr_param that is a tuple/array/list/record etc. + * e.g. foo({a: 1, b: 2}) + * becomes -> + * foo({ + * a: 1, + * b: 2, + * }) + * when the line-length indicates breaking. *) - let forceBreak = match funExpr.pexp_desc with - | Pexp_ident ident when - let lastIdent = Longident.last_exn ident.txt in - List.mem lastIdent ["test"; "describe"; "it"; "expect"] -> true - | _ -> false - in - let (leftWrap, rightWrap) as wrap = ("=> ", ")" ^ rightWrap) in - let wrap = if self#should_preserve_requested_braces retCb then - (leftWrap ^ "{", "}" ^ rightWrap) - else - wrap + | [ (Nolabel, exp) ] when isSingleArgParenApplication [ exp ] -> + self#singleArgParenApplication ?wrap ~uncurried [ exp ] + | params -> + makeTup + ?wrap + ~uncurried + (List.map self#label_x_expression_param params) + + (* + * Prefix represents an optional layout. When passed it will be "prefixed" to + * the funExpr. Example, given `bar(x, y)` with prefix `foo`, we get + * foobar(x,y). When the arguments break, the closing `)` is nicely aligned + * on the height of the prefix: + * foobar( + * x, + * y, + * ) --> notice how `)` sits on the height of `foo` instead of `bar` + * + * ~wrap -> represents optional "wrapping", might be useful in context of jsx + * where braces are required: + * prop={bar( -> `{` is formatted before the funExpr + * x, + * y, + * )} -> notice how the closing brace hugs: `)}` + *) + method formatFunAppl + ?(prefix = atom "") + ?(wrap = "", "") + ~jsxAttrs + ~args + ~funExpr + ~applicationExpr + ?(uncurried = false) + () = + let leftWrap, rightWrap = wrap in + let uncurriedApplication = uncurried in + (* If there was a JSX attribute BUT JSX component wasn't detected, + that JSX attribute needs to be pretty printed so it doesn't get + lost *) + let maybeJSXAttr = List.map self#attribute jsxAttrs in + let categorizeFunApplArgs args = + let reverseArgs = List.rev args in + match reverseArgs with + | ((_, { pexp_desc = Pexp_fun _ }) as callback) :: args + when [] + == List.filter + (fun (_, e) -> + match e.pexp_desc with + | Pexp_fun _ -> true + | _ -> false) + args + (* default to normal formatting if there's more than one + callback *) -> + `LastArgIsCallback (callback, List.rev args) + | _ -> `NormalFunAppl args in - let returnValueCallback = - makeList - ~break:(if forceBreak then Always else IfNeed) - ~wrap - [x] - in - let argsWithCallbackArgs = List.concat [(List.map self#label_x_expression_param args); [theCallbackArg]] in - let left = label - theFunc - (makeList - ~pad:(uncurriedApplication, false) - ~wrap:("", " ") ~break:IfNeed ~inline:(true, true) ~sep:(Sep ",") ~postSpace:true - argsWithCallbackArgs) - in - label left returnValueCallback - | xs -> - let printWidthExceeded = Reason_heuristics.funAppCallbackExceedsWidth ~printWidth:settings.width ~args ~funExpr () in - if not printWidthExceeded then - (* - * Thing.map(foo, bar, baz, (abc, z) => - * MyModuleBlah.toList(argument) - * ) - * - * To get this kind of formatting we need to construct the following tree: - * - * - * where left is - * - * - * The part of that label could be a with wrap:("", " ") break:IfNeed inline:(true, true) - * with items: "foo", "bar", "baz", "(abc, z)", separated by commas. - * - * this is also necessary to achieve the following formatting where }) hugs : - * test("my test", () => { - * let x = a + b; - * let y = z + c; - * x + y - * }); - *) - let (leftWrap, rightWrap) as wrap = ("=> ", ")" ^ rightWrap) in - let wrap = if self#should_preserve_requested_braces retCb then - (leftWrap ^ "{", "}" ^ rightWrap) - else - wrap + let formattedFunExpr = + match funExpr.pexp_desc with + (* pipe first chain or sharpop chain as funExpr, no parens needed, + we know how to parse *) + | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident s } }, _) + when requireNoSpaceFor s -> + self#unparseExpr funExpr + | Pexp_field _ -> self#unparseExpr funExpr + | _ -> self#simplifyUnparseExpr funExpr + in + let formattedFunExpr = + makeList [ prefix; atom leftWrap; formattedFunExpr ] + in + match categorizeFunApplArgs args with + | `LastArgIsCallback (callbackArg, args) -> + (* This is the following case: + * Thing.map(foo, bar, baz, (abc, z) => + * MyModuleBlah.toList(argument) + *) + let argLbl, cb = callbackArg in + let { Reason_attributes.stdAttrs; uncurried } = + Reason_attributes.partitionAttributes cb.pexp_attributes in - let right = - source_map ~loc:retCb.pexp_loc - (makeList ~break:Always_rec ~wrap ~sep:(SepFinal (";", ";")) xs) + let cbAttrs = stdAttrs in + if uncurried then Hashtbl.add uncurriedTable cb.pexp_loc true; + let cbArgs, retCb = + self#curriedPatternsAndReturnVal { cb with pexp_attributes = [] } in - let argsWithCallbackArgs = - List.map self#label_x_expression_param args @ [theCallbackArg] + let cbArgs = + if cbAttrs != [] + then + makeList + ~break:IfNeed + ~inline:(true, true) + ~postSpace:true + (List.map self#attribute cbAttrs @ cbArgs) + else makeList cbArgs in - let left = label - theFunc - (makeList ~wrap:("", " ") ~break:IfNeed ~inline:(true, true) ~sep:(Sep ",") ~postSpace:true - argsWithCallbackArgs) + let retCb, cbArgs = + match retCb.pexp_desc with + | Pexp_constraint (a, t) -> + a, makeList [ cbArgs; atom ": "; self#core_type t ] + | _ -> retCb, cbArgs in - label left right - else - (* Since the heuristic says the line length is exceeded in this case, - * we conveniently format everything as - * - *) - let args = - makeList ~break:Always ~wrap:("", ")" ^ rightWrap) ~sep:commaTrail ( - (List.map self#label_x_expression_param args) @ - [label ~space:true (makeList ~wrap:("", " =>") [theCallbackArg]) - (source_map ~loc:retCb.pexp_loc (makeLetSequence xs))] - ) + let theCallbackArg = + match argLbl with + | Optional s -> + makeList ([ atom namedArgSym; atom s; atom "=?" ] @ [ cbArgs ]) + | Labelled s -> + makeList ([ atom namedArgSym; atom s; atom "=" ] @ [ cbArgs ]) + | Nolabel -> cbArgs in - (* This will need to be (theFunc, args) *) - label theFunc args - end in - maybeJSXAttr @ [formattedFunAppl] - | `NormalFunAppl args -> - let theFunc = - source_map ~loc:funExpr.pexp_loc formattedFunExpr - in - (* reset here only because [function,match,try,sequence] are lower priority *) - (* The "expression location" might be different than the location of the actual - * function application because things like surrounding { } expand the - * parsed location (in body of while loop for example). - * We recover the most meaningful function application location we can.*) - let (syntheticApplicationLocation, syntheticArgLoc) = match args with - | [] -> (funExpr.pexp_loc, funExpr.pexp_loc) - | _::_ -> - {funExpr.pexp_loc with loc_end = applicationExpr.pexp_loc.loc_end}, - {funExpr.pexp_loc with loc_start = funExpr.pexp_loc.loc_end; loc_end = applicationExpr.pexp_loc.loc_end} - in - let theArgs = self#reset#label_x_expression_params ~wrap:("", rightWrap) ~uncurried args in - maybeJSXAttr @ [source_map ~loc:syntheticApplicationLocation - (label theFunc (source_map ~loc:syntheticArgLoc theArgs))] - end -end;; - -let toplevel_phrase ppf x = - match x with - | Ptop_def s -> format_layout ppf (printer#structure s) - | Ptop_dir _ -> print_string "(* top directives not supported *)" - -let case_list ppf x = - List.iter (format_layout ppf) (printer#case_list x) + let theFunc = + source_map + ~loc:funExpr.pexp_loc + (makeList + ~wrap:("", if uncurriedApplication then "(." else "(") + [ formattedFunExpr ]) + in + let formattedFunAppl = + match self#letList retCb with + | [ x ] -> + (* force breaks for test assertion style callbacks, e.g. + * describe("App", () => test("math", () => Expect.expect(1 + 2) |> toBe(3))); + * should always break for readability of the tests: + * describe("App", () => + * test("math", () => + * Expect.expect(1 + 2) |> toBe(3) + * ) + * ); + *) + let forceBreak = + match funExpr.pexp_desc with + | Pexp_ident ident + when let lastIdent = Longident.last_exn ident.txt in + List.mem + lastIdent + [ "test"; "describe"; "it"; "expect" ] -> + true + | _ -> false + in + let ((leftWrap, rightWrap) as wrap) = "=> ", ")" ^ rightWrap in + let wrap = + if self#should_preserve_requested_braces retCb + then leftWrap ^ "{", "}" ^ rightWrap + else wrap + in + let returnValueCallback = + makeList + ~break:(if forceBreak then Always else IfNeed) + ~wrap + [ x ] + in + let argsWithCallbackArgs = + List.concat + [ List.map self#label_x_expression_param args + ; [ theCallbackArg ] + ] + in + let left = + label + theFunc + (makeList + ~pad:(uncurriedApplication, false) + ~wrap:("", " ") + ~break:IfNeed + ~inline:(true, true) + ~sep:(Sep ",") + ~postSpace:true + argsWithCallbackArgs) + in + label left returnValueCallback + | xs -> + let printWidthExceeded = + Reason_heuristics.funAppCallbackExceedsWidth + ~printWidth:settings.width + ~args + ~funExpr + () + in + if not printWidthExceeded + then + (* + * Thing.map(foo, bar, baz, (abc, z) => + * MyModuleBlah.toList(argument) + * ) + * + * To get this kind of formatting we need to construct the following tree: + * + * + * where left is + * foo, bar, baz, (abc, z) + * + * The part of that label could be a with wrap:("", " ") break:IfNeed inline:(true, true) + * with items: "foo", "bar", "baz", "(abc, z)", separated by commas. + * + * this is also necessary to achieve the following formatting where }) hugs : + * test("my test", () => { + * let x = a + b; + * let y = z + c; + * x + y + * }); + *) + let ((leftWrap, rightWrap) as wrap) = + "=> ", ")" ^ rightWrap + in + let wrap = + if self#should_preserve_requested_braces retCb + then leftWrap ^ "{", "}" ^ rightWrap + else wrap + in + let right = + source_map + ~loc:retCb.pexp_loc + (makeList + ~break:Always_rec + ~wrap + ~sep:(SepFinal (";", ";")) + xs) + in + let argsWithCallbackArgs = + List.map self#label_x_expression_param args + @ [ theCallbackArg ] + in + let left = + label + theFunc + (makeList + ~wrap:("", " ") + ~break:IfNeed + ~inline:(true, true) + ~sep:(Sep ",") + ~postSpace:true + argsWithCallbackArgs) + in + label left right + else + (* Since the heuristic says the line length is exceeded in this case, + * we conveniently format everything as + * + *) + let args = + makeList + ~break:Always + ~wrap:("", ")" ^ rightWrap) + ~sep:commaTrail + (List.map self#label_x_expression_param args + @ [ label + ~space:true + (makeList ~wrap:("", " =>") [ theCallbackArg ]) + (source_map + ~loc:retCb.pexp_loc + (makeLetSequence xs)) + ]) + in + (* This will need to be (theFunc, args) *) + label theFunc args + in + maybeJSXAttr @ [ formattedFunAppl ] + | `NormalFunAppl args -> + let theFunc = source_map ~loc:funExpr.pexp_loc formattedFunExpr in + (* reset here only because [function,match,try,sequence] are lower + priority *) + (* The "expression location" might be different than the location of the actual + * function application because things like surrounding { } expand the + * parsed location (in body of while loop for example). + * We recover the most meaningful function application location we can.*) + let syntheticApplicationLocation, syntheticArgLoc = + match args with + | [] -> funExpr.pexp_loc, funExpr.pexp_loc + | _ :: _ -> + ( { funExpr.pexp_loc with + loc_end = applicationExpr.pexp_loc.loc_end + } + , { funExpr.pexp_loc with + loc_start = funExpr.pexp_loc.loc_end + ; loc_end = applicationExpr.pexp_loc.loc_end + } ) + in + let theArgs = + self#reset#label_x_expression_params + ~wrap:("", rightWrap) + ~uncurried + args + in + maybeJSXAttr + @ [ source_map + ~loc:syntheticApplicationLocation + (label theFunc (source_map ~loc:syntheticArgLoc theArgs)) + ] + end -(* Convert a Longident to a list of strings. - E.g. M.Constructor will be ["Constructor"; "M.Constructor"] - Also support ".Constructor" to specify access without a path. - *) -let longident_for_arity lid = - let rec toplevel = function - | Lident s -> - [s] - | Ldot (lid, s) -> - let append_s x = x ^ "." ^ s in - s :: (List.map append_s (toplevel lid)) - | Lapply (_,s) -> - toplevel s in - match lid with - | Lident s -> - ("." ^ s) :: toplevel lid - | _ -> - toplevel lid - -(* add expilcit_arity to a list of attributes - *) -let add_explicit_arity loc attributes = - { attr_name = { txt="explicit_arity"; loc } - ; attr_payload = PStr [] - ; attr_loc = loc - } :: Reason_syntax_util.normalized_attributes "explicit_arity" attributes + let toplevel_phrase ppf x = + match x with + | Ptop_def s -> format_layout ppf (printer#structure s) + | Ptop_dir _ -> print_string "(* top directives not supported *)" + + let case_list ppf x = List.iter (format_layout ppf) (printer#case_list x) + + (* Convert a Longident to a list of strings. E.g. M.Constructor will be + ["Constructor"; "M.Constructor"] Also support ".Constructor" to specify + access without a path. *) + let longident_for_arity lid = + let rec toplevel = function + | Lident s -> [ s ] + | Ldot (lid, s) -> + let append_s x = x ^ "." ^ s in + s :: List.map append_s (toplevel lid) + | Lapply (_, s) -> toplevel s + in + match lid with Lident s -> ("." ^ s) :: toplevel lid | _ -> toplevel lid -(* explicit_arity_exists check if expilcit_arity exists - *) -let explicit_arity_not_exists attributes = - not (Reason_syntax_util.attribute_exists "explicit_arity" attributes) + (* add expilcit_arity to a list of attributes *) + let add_explicit_arity loc attributes = + { attr_name = { txt = "explicit_arity"; loc } + ; attr_payload = PStr [] + ; attr_loc = loc + } + :: Reason_syntax_util.normalized_attributes "explicit_arity" attributes -(* wrap_expr_with_tuple wraps an expression - * with tuple as a sole argument. - *) -let wrap_expr_with_tuple exp = - {exp with pexp_desc = Pexp_tuple [exp]} + (* explicit_arity_exists check if expilcit_arity exists *) + let explicit_arity_not_exists attributes = + not (Reason_syntax_util.attribute_exists "explicit_arity" attributes) -(* wrap_pat_with_tuple wraps an pattern - * with tuple as a sole argument. - *) -let wrap_pat_with_tuple pat = - {pat with ppat_desc = Ppat_tuple [pat]} + (* wrap_expr_with_tuple wraps an expression + * with tuple as a sole argument. + *) + let wrap_expr_with_tuple exp = { exp with pexp_desc = Pexp_tuple [ exp ] } + (* wrap_pat_with_tuple wraps an pattern + * with tuple as a sole argument. + *) + let wrap_pat_with_tuple pat = { pat with ppat_desc = Ppat_tuple [ pat ] } + (* explicit_arity_constructors is a set of constructors that are known to have + * multiple arguments + * + *) -(* explicit_arity_constructors is a set of constructors that are known to have - * multiple arguments - * - *) + module StringSet = Stdlib.Set.Make (String) -module StringSet = Stdlib.Set.Make(String) + let built_in_explicit_arity_constructors = + [ "Some"; "Assert_failure"; "Match_failure" ] -let built_in_explicit_arity_constructors = ["Some"; "Assert_failure"; "Match_failure"] + let explicit_arity_constructors = + StringSet.of_list + (built_in_explicit_arity_constructors + @ !configuredSettings.constructorLists) -let explicit_arity_constructors = StringSet.of_list(built_in_explicit_arity_constructors @ (!configuredSettings).constructorLists) + let preprocessing_mapper = + let escape_slashes = new Reason_syntax_util.escape_stars_slashes_mapper in + object + inherit Ast_traverse.map as super + method! expression expr = + let expr = + match expr with + | { pexp_desc = Pexp_construct (lid, Some sp) + ; pexp_loc + ; pexp_attributes + } + when List.exists + (fun c -> StringSet.mem c explicit_arity_constructors) + (longident_for_arity lid.txt) + && explicit_arity_not_exists pexp_attributes -> + { pexp_desc = Pexp_construct (lid, Some (wrap_expr_with_tuple sp)) + ; pexp_loc + ; pexp_attributes = add_explicit_arity pexp_loc pexp_attributes + ; pexp_loc_stack = [] + } + | x -> x + in + escape_slashes#expression (super#expression expr) + + method! pattern pat = + let pat = + match pat with + | { ppat_desc = Ppat_construct (lid, Some (x, sp)) + ; ppat_loc + ; ppat_attributes + } + when List.exists + (fun c -> StringSet.mem c explicit_arity_constructors) + (longident_for_arity lid.txt) + && explicit_arity_not_exists ppat_attributes -> + { ppat_desc = + Ppat_construct (lid, Some (x, wrap_pat_with_tuple sp)) + ; ppat_loc + ; ppat_attributes = add_explicit_arity ppat_loc ppat_attributes + ; ppat_loc_stack = [] + } + | x -> x + in + escape_slashes#pattern (super#pattern pat) + end -let preprocessing_mapper = - let escape_slashes = new Reason_syntax_util.escape_stars_slashes_mapper in + let ml_to_reason_swap_operator_mapper = + new Reason_syntax_util.ml_to_reason_swap_operator_mapper + + let preprocessing_mapper f a = + a |> f ml_to_reason_swap_operator_mapper |> f preprocessing_mapper + + let core_type ppf x = + format_layout + ppf + (printer#core_type + (preprocessing_mapper Reason_syntax_util.apply_mapper_to_type x)) + + let pattern ppf x = + format_layout + ppf + (printer#pattern + (preprocessing_mapper Reason_syntax_util.apply_mapper_to_pattern x)) + + let signature (comments : Comment.t list) ppf x = + List.iter (fun comment -> printer#trackComment comment) comments; + format_layout + ppf + ~comments + (printer#signature + (preprocessing_mapper Reason_syntax_util.apply_mapper_to_signature x)) + + let structure (comments : Comment.t list) ppf x = + List.iter (fun comment -> printer#trackComment comment) comments; + format_layout + ppf + ~comments + (printer#structure + (preprocessing_mapper Reason_syntax_util.apply_mapper_to_structure x)) + + let expression ppf x = + format_layout + ppf + (printer#unparseExpr + (preprocessing_mapper Reason_syntax_util.apply_mapper_to_expr x)) + + let case_list = case_list + end + in object - inherit Ast_traverse.map as super - - method! expression expr = - let expr = - match expr with - | {pexp_desc=Pexp_construct(lid, Some sp); - pexp_loc; - pexp_attributes} when - List.exists - (fun c -> StringSet.mem c explicit_arity_constructors) - (longident_for_arity lid.txt) && - explicit_arity_not_exists pexp_attributes -> - {pexp_desc=Pexp_construct(lid, Some (wrap_expr_with_tuple sp)); - pexp_loc; - pexp_attributes=add_explicit_arity pexp_loc pexp_attributes; - pexp_loc_stack = []} - | x -> x - in - escape_slashes#expression (super#expression expr) - - method! pattern pat = - let pat = - match pat with - | {ppat_desc=Ppat_construct(lid, Some (x, sp)); - ppat_loc; - ppat_attributes} when - List.exists - (fun c -> StringSet.mem c explicit_arity_constructors) - (longident_for_arity lid.txt) && - explicit_arity_not_exists ppat_attributes -> - {ppat_desc=Ppat_construct(lid, Some (x, wrap_pat_with_tuple sp)); - ppat_loc; - ppat_attributes=add_explicit_arity ppat_loc ppat_attributes; - ppat_loc_stack = []} - | x -> x - in - escape_slashes#pattern (super#pattern pat) + method core_type = Formatter.core_type + method pattern = Formatter.pattern + method signature = Formatter.signature + method structure = Formatter.structure + + (* For merlin-destruct *) + method toplevel_phrase = Formatter.toplevel_phrase + method expression = Formatter.expression + method case_list = Formatter.case_list end - -let ml_to_reason_swap_operator_mapper = new Reason_syntax_util.ml_to_reason_swap_operator_mapper - -let preprocessing_mapper f a = - a - |> f ml_to_reason_swap_operator_mapper - |> f preprocessing_mapper - -let core_type ppf x = - format_layout ppf - (printer#core_type - (preprocessing_mapper Reason_syntax_util.apply_mapper_to_type x)) - -let pattern ppf x = - format_layout ppf - (printer#pattern - (preprocessing_mapper Reason_syntax_util.apply_mapper_to_pattern x)) - -let signature (comments : Comment.t list) ppf x = - List.iter (fun comment -> printer#trackComment comment) comments; - format_layout ppf ~comments - (printer#signature - (preprocessing_mapper Reason_syntax_util.apply_mapper_to_signature x)) - -let structure (comments : Comment.t list) ppf x = - List.iter (fun comment -> printer#trackComment comment) comments; - format_layout ppf ~comments - (printer#structure - (preprocessing_mapper Reason_syntax_util.apply_mapper_to_structure x)) - -let expression ppf x = - format_layout ppf - (printer#unparseExpr - (preprocessing_mapper Reason_syntax_util.apply_mapper_to_expr x)) - -let case_list = case_list - -end -in -object - method core_type = Formatter.core_type - method pattern = Formatter.pattern - method signature = Formatter.signature - method structure = Formatter.structure - (* For merlin-destruct *) - method toplevel_phrase = Formatter.toplevel_phrase - method expression = Formatter.expression - method case_list = Formatter.case_list -end diff --git a/src/reason-parser/reason_pprint_ast.mli b/src/reason-parser/reason_pprint_ast.mli index 513d2a1b9..99ea665e4 100644 --- a/src/reason-parser/reason_pprint_ast.mli +++ b/src/reason-parser/reason_pprint_ast.mli @@ -1,16 +1,25 @@ open Ppxlib val configure : - width:int -> - assumeExplicitArity:bool -> constructorLists:string list -> unit + width:int + -> assumeExplicitArity:bool + -> constructorLists:string list + -> unit -val createFormatter : unit -> - < - case_list : Format.formatter -> Parsetree.case list -> unit; - core_type : Format.formatter -> Parsetree.core_type -> unit; - expression : Format.formatter -> Parsetree.expression -> unit; - pattern : Format.formatter -> Parsetree.pattern -> unit; - signature : Reason_comment.t list -> Format.formatter -> Parsetree.signature -> unit; - structure : Reason_comment.t list -> Format.formatter -> Parsetree.structure -> unit; - toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit; - > +val createFormatter : + unit + -> < case_list : Format.formatter -> Parsetree.case list -> unit + ; core_type : Format.formatter -> Parsetree.core_type -> unit + ; expression : Format.formatter -> Parsetree.expression -> unit + ; pattern : Format.formatter -> Parsetree.pattern -> unit + ; signature : + Reason_comment.t list + -> Format.formatter + -> Parsetree.signature + -> unit + ; structure : + Reason_comment.t list + -> Format.formatter + -> Parsetree.structure + -> unit + ; toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit > diff --git a/src/reason-parser/reason_recover_parser.ml b/src/reason-parser/reason_recover_parser.ml index 3ab04aa9e..a9ec23991 100644 --- a/src/reason-parser/reason_recover_parser.ml +++ b/src/reason-parser/reason_recover_parser.ml @@ -1,6 +1,8 @@ module M = Reason_multi_parser + module R = - Merlin_recovery.Make(Reason_parser.MenhirInterpreter) + Merlin_recovery.Make + (Reason_parser.MenhirInterpreter) (struct include Reason_parser_recover @@ -15,8 +17,7 @@ type 'a parser = | Correct of 'a M.parser | Recovering of 'a R.candidates * Reason_lexer.invalid_docstrings -let initial entry_point position = - Correct (M.initial entry_point position) +let initial entry_point position = Correct (M.initial entry_point position) type 'a step = | Intermediate of 'a parser @@ -26,36 +27,29 @@ type 'a step = let step parser token = match parser with | Correct parser -> - begin match M.step parser token with - | M.Intermediate parser -> Intermediate (Correct parser) - | M.Success (x, ds) -> Success (x, ds) - | M.Error -> - let (_, loc_start, loc_end) = token in - let loc = {Location. loc_start; loc_end; loc_ghost = false} in - let env, ds = M.recovery_env parser in - let message = Reason_parser_explain.message env token in - Reason_errors.raise_error - (Reason_errors.Parsing_error message) loc; - Intermediate (Recovering (R.generate env, ds)) - end + (match M.step parser token with + | M.Intermediate parser -> Intermediate (Correct parser) + | M.Success (x, ds) -> Success (x, ds) + | M.Error -> + let _, loc_start, loc_end = token in + let loc = { Location.loc_start; loc_end; loc_ghost = false } in + let env, ds = M.recovery_env parser in + let message = Reason_parser_explain.message env token in + Reason_errors.raise_error (Reason_errors.Parsing_error message) loc; + Intermediate (Recovering (R.generate env, ds))) | Recovering (candidates, ds) -> - begin match token with - | Reason_parser.DOCSTRING text, startp, endp -> - let ds = Reason_lexer.add_invalid_docstring text startp endp ds in - Intermediate (Recovering (candidates, ds)) - | _ -> - begin match R.attempt candidates token with - | `Ok (cp, _) -> Intermediate (Correct (M.recover cp ds)) - | `Accept x -> Success (x, ds) - | `Fail -> - begin match token with - | Reason_parser.EOF, _, _ -> - begin match candidates.final with - | None -> Error - | Some x -> Success (x, ds) - end - | _ -> Intermediate parser - end - end - end - + (match token with + | Reason_parser.DOCSTRING text, startp, endp -> + let ds = Reason_lexer.add_invalid_docstring text startp endp ds in + Intermediate (Recovering (candidates, ds)) + | _ -> + (match R.attempt candidates token with + | `Ok (cp, _) -> Intermediate (Correct (M.recover cp ds)) + | `Accept x -> Success (x, ds) + | `Fail -> + (match token with + | Reason_parser.EOF, _, _ -> + (match candidates.final with + | None -> Error + | Some x -> Success (x, ds)) + | _ -> Intermediate parser))) diff --git a/src/reason-parser/reason_recover_parser.mli b/src/reason-parser/reason_recover_parser.mli index 30ccd0f9e..17226b4d3 100644 --- a/src/reason-parser/reason_recover_parser.mli +++ b/src/reason-parser/reason_recover_parser.mli @@ -1,8 +1,9 @@ type 'a parser val initial : - (Lexing.position -> 'a Reason_parser.MenhirInterpreter.checkpoint) -> - Lexing.position -> 'a parser + (Lexing.position -> 'a Reason_parser.MenhirInterpreter.checkpoint) + -> Lexing.position + -> 'a parser type 'a step = | Intermediate of 'a parser diff --git a/src/reason-parser/reason_single_parser.ml b/src/reason-parser/reason_single_parser.ml index 6b1e2dde0..78f724bee 100644 --- a/src/reason-parser/reason_single_parser.ml +++ b/src/reason-parser/reason_single_parser.ml @@ -5,6 +5,7 @@ type invalid_docstrings = Reason_lexer.invalid_docstrings module Step : sig type 'a parser + type 'a step = | Intermediate of 'a parser | Success of 'a * invalid_docstrings @@ -12,20 +13,24 @@ module Step : sig val initialize : 'a I.checkpoint -> 'a step val offer : 'a parser -> token Reason_lexer.positioned -> 'a step + val add_docstring : - string -> Lexing.position -> Lexing.position -> 'a parser -> 'a parser + string + -> Lexing.position + -> Lexing.position + -> 'a parser + -> 'a parser val recover : 'a I.checkpoint -> invalid_docstrings -> 'a parser val recovery_env : 'a parser -> 'a I.env * invalid_docstrings end = struct - - type 'a postfix_state = { - checkpoint: 'a I.checkpoint; - docstrings: invalid_docstrings; - fallback: 'a I.checkpoint; - postfix_ops: int; - postfix_pos: Lexing.position; - } + type 'a postfix_state = + { checkpoint : 'a I.checkpoint + ; docstrings : invalid_docstrings + ; fallback : 'a I.checkpoint + ; postfix_ops : int + ; postfix_pos : Lexing.position + } type 'a parser = | Normal of 'a I.checkpoint * invalid_docstrings @@ -43,38 +48,40 @@ end = struct let valid = ref true in while !i < len && !valid do valid := f s.[!i]; - incr i; + incr i done; !valid in match token with - | (Reason_parser.INFIXOP1 s, pos, _) - when string_forall ((=) '^') s -> - (fun checkpoint docstrings -> - After_potential_postfix { - checkpoint; fallback; docstrings; - postfix_ops = String.length s; - postfix_pos = pos; - }) - | _ -> - (fun checkpoint docstrings -> - Normal (checkpoint, docstrings)) + | Reason_parser.INFIXOP1 s, pos, _ when string_forall (( = ) '^') s -> + fun checkpoint docstrings -> + After_potential_postfix + { checkpoint + ; fallback + ; docstrings + ; postfix_ops = String.length s + ; postfix_pos = pos + } + | _ -> fun checkpoint docstrings -> Normal (checkpoint, docstrings) let rec offer_postfix count pos = function - | I.Shifting _ | I.AboutToReduce _ as checkpoint -> + | (I.Shifting _ | I.AboutToReduce _) as checkpoint -> offer_postfix count pos (I.resume checkpoint) | I.InputNeeded _ as checkpoint -> - if count <= 0 then checkpoint else ( + if count <= 0 + then checkpoint + else let pos_cnum = pos.Lexing.pos_cnum in - let pos' = {pos with Lexing.pos_cnum = pos_cnum + 1} in - offer_postfix (count - 1) pos' + let pos' = { pos with Lexing.pos_cnum = pos_cnum + 1 } in + offer_postfix + (count - 1) + pos' (I.offer checkpoint (Reason_parser.POSTFIXOP "^", pos, pos')) - ) | other -> other let rec step mark_potential_postfix safepoint docstrings = function - | I.Shifting _ | I.AboutToReduce _ as checkpoint -> - step mark_potential_postfix safepoint docstrings (I.resume checkpoint) + | (I.Shifting _ | I.AboutToReduce _) as checkpoint -> + step mark_potential_postfix safepoint docstrings (I.resume checkpoint) | I.InputNeeded _ as checkpoint -> Intermediate (mark_potential_postfix checkpoint docstrings) | I.Accepted x -> Success (x, docstrings) @@ -83,21 +90,30 @@ end = struct let offer parser token = match parser with | Normal (checkpoint, docstrings) -> - step (mark_potential_postfix token checkpoint) checkpoint - docstrings (I.offer checkpoint token) + step + (mark_potential_postfix token checkpoint) + checkpoint + docstrings + (I.offer checkpoint token) | After_potential_postfix r -> - match step (mark_potential_postfix token r.checkpoint) r.checkpoint - r.docstrings (I.offer r.checkpoint token) - with + (match + step + (mark_potential_postfix token r.checkpoint) + r.checkpoint + r.docstrings + (I.offer r.checkpoint token) + with | Error -> - begin (* Try applying postfix operators on fallback parser *) - match offer_postfix r.postfix_ops r.postfix_pos r.fallback with - | I.InputNeeded _ as checkpoint -> - step (mark_potential_postfix token checkpoint) checkpoint - r.docstrings (I.offer checkpoint token) - | _ -> Error - end - | result -> result + (* Try applying postfix operators on fallback parser *) + (match offer_postfix r.postfix_ops r.postfix_pos r.fallback with + | I.InputNeeded _ as checkpoint -> + step + (mark_potential_postfix token checkpoint) + checkpoint + r.docstrings + (I.offer checkpoint token) + | _ -> Error) + | result -> result) let add_docstring text startp endp parser = match parser with @@ -110,30 +126,30 @@ end = struct let docstrings = Reason_lexer.add_invalid_docstring text startp endp r.docstrings in - After_potential_postfix {r with docstrings} + After_potential_postfix { r with docstrings } let initialize checkpoint = - step (fun parser ds -> Normal (parser, ds)) checkpoint - Reason_lexer.empty_invalid_docstrings checkpoint + step + (fun parser ds -> Normal (parser, ds)) + checkpoint + Reason_lexer.empty_invalid_docstrings + checkpoint let recover cp ds = - begin match cp with - | I.InputNeeded _ -> () - | _ -> assert false - end; + (match cp with I.InputNeeded _ -> () | _ -> assert false); Normal (cp, ds) let recovery_env parser = - let cp, ds = match parser with - | Normal (cp, ds) -> (cp, ds) - | After_potential_postfix r -> (r.checkpoint, r.docstrings) + let cp, ds = + match parser with + | Normal (cp, ds) -> cp, ds + | After_potential_postfix r -> r.checkpoint, r.docstrings in - match cp with - | I.InputNeeded env -> (env, ds) - | _ -> assert false + match cp with I.InputNeeded env -> env, ds | _ -> assert false end type 'a parser = 'a Step.parser + type 'a step = 'a Step.step = | Intermediate of 'a parser | Success of 'a * invalid_docstrings @@ -146,46 +162,44 @@ let initial entry position = let rec offer_many parser = function | [] -> Step.Intermediate parser - | [token] -> Step.offer parser token + | [ token ] -> Step.offer parser token | token :: tokens -> - match Step.offer parser token with - | Step.Intermediate parser -> offer_many parser tokens - | other -> other + (match Step.offer parser token with + | Step.Intermediate parser -> offer_many parser tokens + | other -> other) (* Logic for inserting ';' *) let try_insert_semi_on = function | Reason_parser.LET | Reason_parser.TYPE | Reason_parser.MODULE - | Reason_parser.OPEN | Reason_parser.EXCEPTION - | Reason_parser.INCLUDE | Reason_parser.DOCSTRING _ - | Reason_parser.LIDENT _ | Reason_parser.UIDENT _ - | Reason_parser.IF | Reason_parser.WHILE - | Reason_parser.FOR | Reason_parser.SWITCH - | Reason_parser.TRY | Reason_parser.ASSERT - | Reason_parser.EXTERNAL | Reason_parser.LAZY - | Reason_parser.LBRACKETAT -> true + | Reason_parser.OPEN | Reason_parser.EXCEPTION | Reason_parser.INCLUDE + | Reason_parser.DOCSTRING _ | Reason_parser.LIDENT _ | Reason_parser.UIDENT _ + | Reason_parser.IF | Reason_parser.WHILE | Reason_parser.FOR + | Reason_parser.SWITCH | Reason_parser.TRY | Reason_parser.ASSERT + | Reason_parser.EXTERNAL | Reason_parser.LAZY | Reason_parser.LBRACKETAT -> + true | _ -> false (* Logic for splitting '=?...' operators into '=' '?' '...' *) -let advance p n = {p with Lexing.pos_cnum = p.Lexing.pos_cnum + n} +let advance p n = { p with Lexing.pos_cnum = p.Lexing.pos_cnum + n } let rec split_greaters acc pcur = function | '>' :: tl -> - let pnext = (advance pcur 1) in + let pnext = advance pcur 1 in split_greaters ((Reason_parser.GREATER, pcur, pnext) :: acc) pnext tl - | nonGts -> (List.rev acc), nonGts, pcur + | nonGts -> List.rev acc, nonGts, pcur let common_remaining_infix_token pcur = let pnext = advance pcur 1 in function - | ['-'] -> Some(Reason_parser.MINUS, pcur, pnext) - | ['-'; '.'] -> Some(Reason_parser.MINUSDOT, pcur, advance pnext 1) - | ['+'] -> Some(Reason_parser.PLUS, pcur, pnext) - | ['+'; '.'] -> Some(Reason_parser.PLUSDOT, pcur, advance pnext 1) - | ['!'] -> Some(Reason_parser.BANG, pcur, pnext) - | ['>'] -> Some(Reason_parser.GREATER, pcur, pnext) - | ['<'] -> Some(Reason_parser.LESS, pcur, pnext) + | [ '-' ] -> Some (Reason_parser.MINUS, pcur, pnext) + | [ '-'; '.' ] -> Some (Reason_parser.MINUSDOT, pcur, advance pnext 1) + | [ '+' ] -> Some (Reason_parser.PLUS, pcur, pnext) + | [ '+'; '.' ] -> Some (Reason_parser.PLUSDOT, pcur, advance pnext 1) + | [ '!' ] -> Some (Reason_parser.BANG, pcur, pnext) + | [ '>' ] -> Some (Reason_parser.GREATER, pcur, pnext) + | [ '<' ] -> Some (Reason_parser.LESS, pcur, pnext) | _ -> None let rec decompose_token pos0 split = @@ -195,79 +209,81 @@ let rec decompose_token pos0 split = (* Empty token is a valid decomposition *) | [] -> None | '=' :: tl -> - let eq = (Reason_parser.EQUAL, pcur, pnext) in - let (revFirstTwo, tl, pcur, _pnext) = match tl with - | '?' :: tlTl -> - [(Reason_parser.QUESTION, pcur, pnext); eq], tlTl, pnext, (advance pnext 1) - | _ -> [eq], tl, pcur, pnext + let eq = Reason_parser.EQUAL, pcur, pnext in + let revFirstTwo, tl, pcur, _pnext = + match tl with + | '?' :: tlTl -> + ( [ Reason_parser.QUESTION, pcur, pnext; eq ] + , tlTl + , pnext + , advance pnext 1 ) + | _ -> [ eq ], tl, pcur, pnext in - if tl == [] then Some(List.rev revFirstTwo) - else - (match common_remaining_infix_token pcur tl with + if tl == [] + then Some (List.rev revFirstTwo) + else ( + match common_remaining_infix_token pcur tl with | None -> None - | Some(r) -> Some(List.rev (r :: revFirstTwo))) - (* For type parameters type t<+'a> = .. *) + | Some r -> Some (List.rev (r :: revFirstTwo))) + (* For type parameters type t<+'a> = .. *) | '<' :: tl -> - let less = [Reason_parser.LESS, pcur, pnext] in - if tl == [] then Some less - else - (match common_remaining_infix_token pcur tl with - | None -> None (* Couldn't parse the non-empty tail - invalidates whole thing *) - | Some(r) -> Some(List.rev (r :: less))) + let less = [ Reason_parser.LESS, pcur, pnext ] in + if tl == [] + then Some less + else ( + match common_remaining_infix_token pcur tl with + | None -> + None (* Couldn't parse the non-empty tail - invalidates whole thing *) + | Some r -> Some (List.rev (r :: less))) | '>' :: _tl -> - (* Recurse to take advantage of all the logic in case the remaining - * begins with an equal sign. *) - let gt_tokens, rest_split, prest = split_greaters [] pcur split in - if rest_split == [] then - Some gt_tokens - else - (match decompose_token prest rest_split with - | None -> None (* Couldn't parse the non-empty tail - invalidates whole thing *) - | Some(r) -> Some(List.rev gt_tokens @ r)) + (* Recurse to take advantage of all the logic in case the remaining + * begins with an equal sign. *) + let gt_tokens, rest_split, prest = split_greaters [] pcur split in + if rest_split == [] + then Some gt_tokens + else ( + match decompose_token prest rest_split with + | None -> + None (* Couldn't parse the non-empty tail - invalidates whole thing *) + | Some r -> Some (List.rev gt_tokens @ r)) | _ -> None - let rec init_tailrec_aux acc i n f = - if i >= n then acc - else init_tailrec_aux (f i :: acc) (i+1) n f + if i >= n then acc else init_tailrec_aux (f i :: acc) (i + 1) n f let list_init len f = List.rev (init_tailrec_aux [] 0 len f) - let explode s = list_init (String.length s) (String.get s) let try_split_label (tok_kind, pos0, _posn) = match tok_kind with | Reason_parser.INFIXOP0 s -> - (match decompose_token pos0 (explode s) with - | None -> [] - | Some(l) -> l) + (match decompose_token pos0 (explode s) with None -> [] | Some l -> l) | _ -> [] -(* Logic for attempting to consume a token - and try alternatives on failure *) +(* Logic for attempting to consume a token and try alternatives on failure *) let step parser token = match Step.offer parser token with | (Success _ | Intermediate _) as step -> step | Error -> - let try_alternative_tokens = function - | [] -> Error - | tokens -> - match offer_many parser tokens with - | (Step.Intermediate _ | Step.Success _) as result -> result - (* Alternative failed... Return original failure *) - | Step.Error -> Error - in - let alternative = - match token with - | tok_kind, pos, _ when try_insert_semi_on tok_kind -> - try_alternative_tokens [(Reason_parser.SEMI, pos, pos); token] - | _ -> try_alternative_tokens (try_split_label token) - in - match alternative, token with - | Error, (Reason_parser.DOCSTRING text, startp, endp) -> - Intermediate (Step.add_docstring text startp endp parser) - | _ -> alternative + let try_alternative_tokens = function + | [] -> Error + | tokens -> + (match offer_many parser tokens with + | (Step.Intermediate _ | Step.Success _) as result -> result + (* Alternative failed... Return original failure *) + | Step.Error -> Error) + in + let alternative = + match token with + | tok_kind, pos, _ when try_insert_semi_on tok_kind -> + try_alternative_tokens [ Reason_parser.SEMI, pos, pos; token ] + | _ -> try_alternative_tokens (try_split_label token) + in + (match alternative, token with + | Error, (Reason_parser.DOCSTRING text, startp, endp) -> + Intermediate (Step.add_docstring text startp endp parser) + | _ -> alternative) (* Interface for recovery *) diff --git a/src/reason-parser/reason_single_parser.mli b/src/reason-parser/reason_single_parser.mli index f9c1853a5..47b700928 100644 --- a/src/reason-parser/reason_single_parser.mli +++ b/src/reason-parser/reason_single_parser.mli @@ -1,8 +1,9 @@ type 'a parser val initial : - (Lexing.position -> 'a Reason_parser.MenhirInterpreter.checkpoint) -> - Lexing.position -> 'a parser + (Lexing.position -> 'a Reason_parser.MenhirInterpreter.checkpoint) + -> Lexing.position + -> 'a parser type 'a step = | Intermediate of 'a parser @@ -14,10 +15,10 @@ val step : 'a parser -> Reason_parser.token Reason_lexer.positioned -> 'a step (* Interface for recovery *) val recover : - 'a Reason_parser.MenhirInterpreter.checkpoint -> - Reason_lexer.invalid_docstrings -> - 'a parser + 'a Reason_parser.MenhirInterpreter.checkpoint + -> Reason_lexer.invalid_docstrings + -> 'a parser val recovery_env : - 'a parser -> - 'a Reason_parser.MenhirInterpreter.env * Reason_lexer.invalid_docstrings + 'a parser + -> 'a Reason_parser.MenhirInterpreter.env * Reason_lexer.invalid_docstrings diff --git a/src/reason-parser/reason_toolchain.ml b/src/reason-parser/reason_toolchain.ml index 5fd7bdd6a..a7f950ca2 100644 --- a/src/reason-parser/reason_toolchain.ml +++ b/src/reason-parser/reason_toolchain.ml @@ -10,11 +10,9 @@ * LICENSE file in the root directory of this source tree. *) - - (* Entry points in the parser *) -(** +(* * Provides a simple interface to the most common parsing entrypoints required * by editor/IDE toolchains, preprocessors, and pretty printers. * @@ -81,48 +79,51 @@ open Ppxlib let setup_lexbuf use_stdin filename = - (* Use custom method of lexing from the channel to keep track of the input so that we can - reformat tokens in the toolchain*) + (* Use custom method of lexing from the channel to keep track of the input so + that we can reformat tokens in the toolchain*) let lexbuf = match use_stdin with - | true -> Lexing.from_channel - stdin - | false -> - let file_chan = open_in filename in - seek_in file_chan 0; - Lexing.from_channel file_chan + | true -> Lexing.from_channel stdin + | false -> + let file_chan = open_in filename in + seek_in file_chan 0; + Lexing.from_channel file_chan in Location.init lexbuf filename; lexbuf - let rec left_expand_comment should_scan_prev_line source loc_start = - if loc_start = 0 then - (String.unsafe_get source 0, true, 0) + if loc_start = 0 + then String.unsafe_get source 0, true, 0 else let c = String.unsafe_get source (loc_start - 1) in match c with - | '\t' | ' ' -> left_expand_comment should_scan_prev_line source (loc_start - 1) - | '\n' when should_scan_prev_line -> left_expand_comment should_scan_prev_line source (loc_start - 1) - | '\n' -> (c, true, loc_start) - | _ -> (c, false, loc_start) + | '\t' | ' ' -> + left_expand_comment should_scan_prev_line source (loc_start - 1) + | '\n' when should_scan_prev_line -> + left_expand_comment should_scan_prev_line source (loc_start - 1) + | '\n' -> c, true, loc_start + | _ -> c, false, loc_start let rec right_expand_comment should_scan_next_line source loc_start = - if loc_start = String.length source then - (String.unsafe_get source (String.length source - 1), true, String.length source) + if loc_start = String.length source + then + ( String.unsafe_get source (String.length source - 1) + , true + , String.length source ) else let c = String.unsafe_get source loc_start in match c with - | '\t' | ' ' -> right_expand_comment should_scan_next_line source (loc_start + 1) - | '\n' when should_scan_next_line -> right_expand_comment should_scan_next_line source (loc_start + 1) - | '\n' -> (c, true, loc_start) - | _ -> (c, false, loc_start) - + | '\t' | ' ' -> + right_expand_comment should_scan_next_line source (loc_start + 1) + | '\n' when should_scan_next_line -> + right_expand_comment should_scan_next_line source (loc_start + 1) + | '\n' -> c, true, loc_start + | _ -> c, false, loc_start module Create_parse_entrypoint - (Toolchain_impl: Reason_toolchain_conf.Toolchain_spec) - : Reason_toolchain_conf.Toolchain = struct - + (Toolchain_impl : Reason_toolchain_conf.Toolchain_spec) : + Reason_toolchain_conf.Toolchain = struct let buffer_add_lexbuf buf skip lexbuf = let bytes = lexbuf.Lexing.lex_buffer in let start = lexbuf.Lexing.lex_start_pos + skip in @@ -135,26 +136,27 @@ module Create_parse_entrypoint buffer_add_lexbuf buf skip lb; result - (* replaces Lexing.from_channel so we can keep track of the input for comment modification *) + (* replaces Lexing.from_channel so we can keep track of the input for comment + modification *) let keep_from_lexbuf buffer lexbuf = buffer_add_lexbuf buffer 0 lexbuf; let refill_buff = refill_buff buffer lexbuf.Lexing.refill_buff in - {lexbuf with refill_buff} + { lexbuf with refill_buff } let extensions_of_errors errors = ignore (Format.flush_str_formatter () : string); let error_extension (err, loc) = Reason_errors.report_error Format.str_formatter ~loc err; let msg = Format.flush_str_formatter () in - let due_to_recovery = match err with + let due_to_recovery = + match err with | Reason_errors.Parsing_error _ -> true | Reason_errors.Lexing_error _ -> false | Reason_errors.Ast_error _ -> false in - if due_to_recovery then - Reason_errors.error_extension_node_from_recovery loc msg - else - Reason_errors.error_extension_node loc msg + if due_to_recovery + then Reason_errors.error_extension_node_from_recovery loc msg + else Reason_errors.error_extension_node loc msg in List.map error_extension errors @@ -164,19 +166,20 @@ module Create_parse_entrypoint Toolchain_impl.safeguard_parsing lexbuf (fun () -> let lexer = let insert_completion_ident = - !Reason_toolchain_conf.insert_completion_ident in + !Reason_toolchain_conf.insert_completion_ident + in Toolchain_impl.Lexer.init ?insert_completion_ident lexbuf in let ast, invalid_docstrings = let result = if !Reason_config.recoverable - then Reason_errors.recover_non_fatal_errors - (fun () -> parsing_fun lexer) - else (Ok (parsing_fun lexer), []) + then + Reason_errors.recover_non_fatal_errors (fun () -> parsing_fun lexer) + else Ok (parsing_fun lexer), [] in match result with | Ok x, [] -> x - | Ok (x, ds), errors -> (attach_fun x (extensions_of_errors errors), ds) + | Ok (x, ds), errors -> attach_fun x (extensions_of_errors errors), ds | Error exn, _ -> raise exn in let unmodified_comments = @@ -184,35 +187,38 @@ module Create_parse_entrypoint in let contents = Buffer.contents input_copy in Buffer.reset input_copy; - if contents = "" then - let _ = Parsing.clear_parser() in + if contents = "" + then + let _ = Parsing.clear_parser () in let make_regular (text, location) = - Reason_comment.make ~location Reason_comment.Regular text in - (ast, List.map make_regular unmodified_comments) + Reason_comment.make ~location Reason_comment.Regular text + in + ast, List.map make_regular unmodified_comments else let rec classifyAndNormalizeComments unmodified_comments = match unmodified_comments with | [] -> [] - | hd :: tl -> ( - let classifiedTail = classifyAndNormalizeComments tl in - let (txt, physical_loc) = hd in - (* When searching for "^" regexp, returns location of newline + 1 *) - let (stop_char, eol_start, virtual_start_pos) = - left_expand_comment false contents physical_loc.loc_start.pos_cnum - in - if Reason_syntax_util.isLineComment txt then - let comment = Reason_comment.make + | hd :: tl -> + let classifiedTail = classifyAndNormalizeComments tl in + let txt, physical_loc = hd in + (* When searching for "^" regexp, returns location of newline + 1 *) + let stop_char, eol_start, virtual_start_pos = + left_expand_comment false contents physical_loc.loc_start.pos_cnum + in + if Reason_syntax_util.isLineComment txt + then + let comment = + Reason_comment.make ~location:physical_loc (if eol_start then SingleLine else EndOfLine) txt - in - comment :: classifiedTail - else + in + comment :: classifiedTail + else let one_char_before_stop_char = - if virtual_start_pos <= 1 then - ' ' - else - String.unsafe_get contents (virtual_start_pos - 2) + if virtual_start_pos <= 1 + then ' ' + else String.unsafe_get contents (virtual_start_pos - 2) in (* * @@ -228,35 +234,54 @@ module Create_parse_entrypoint * false * *) - let should_scan_next_line = stop_char = '|' && - (one_char_before_stop_char = ' ' || - one_char_before_stop_char = '\n' || - one_char_before_stop_char = '\t' ) in - let (_, eol_end, virtual_end_pos) = right_expand_comment should_scan_next_line contents physical_loc.loc_end.pos_cnum in + let should_scan_next_line = + stop_char = '|' + && (one_char_before_stop_char = ' ' + || one_char_before_stop_char = '\n' + || one_char_before_stop_char = '\t') + in + let _, eol_end, virtual_end_pos = + right_expand_comment + should_scan_next_line + contents + physical_loc.loc_end.pos_cnum + in let end_pos_plus_one = physical_loc.loc_end.pos_cnum in - let comment_length = (end_pos_plus_one - physical_loc.loc_start.pos_cnum - 4) in - let original_comment_contents = String.sub contents (physical_loc.loc_start.pos_cnum + 2) comment_length in - let location = { - physical_loc with - loc_start = {physical_loc.loc_start with pos_cnum = virtual_start_pos}; - loc_end = {physical_loc.loc_end with pos_cnum = virtual_end_pos} - } in + let comment_length = + end_pos_plus_one - physical_loc.loc_start.pos_cnum - 4 + in + let original_comment_contents = + String.sub + contents + (physical_loc.loc_start.pos_cnum + 2) + comment_length + in + let location = + { physical_loc with + loc_start = + { physical_loc.loc_start with pos_cnum = virtual_start_pos } + ; loc_end = + { physical_loc.loc_end with pos_cnum = virtual_end_pos } + } + in let just_after loc' = - loc'.loc_start.pos_cnum == location.loc_end.pos_cnum - 1 && - loc'.loc_start.pos_lnum == location.loc_end.pos_lnum + loc'.loc_start.pos_cnum == location.loc_end.pos_cnum - 1 + && loc'.loc_start.pos_lnum == location.loc_end.pos_lnum in - let category = match (eol_start, eol_end, classifiedTail) with - | (true, true, _) -> Reason_comment.SingleLine - | (false, true, _) -> Reason_comment.EndOfLine - | (false, false, comment :: _) - (* End of line comment is one that has nothing but newlines or - * other comments its right, and has some AST to the left of it. - * For example, there are two end of line comments in: - * - * | Y(int, int); /* eol1 */ /* eol2 */ - *) - when Reason_comment.category comment = Reason_comment.EndOfLine - && just_after (Reason_comment.location comment) -> + let category = + match eol_start, eol_end, classifiedTail with + | true, true, _ -> Reason_comment.SingleLine + | false, true, _ -> Reason_comment.EndOfLine + | false, false, comment :: _ + (* End of line comment is one that has nothing but newlines or + * other comments its right, and has some AST to the left of it. + * For example, there are two end of line comments in: + * + * | Y(int, int); /* eol1 */ /* eol2 */ + *) + when Reason_comment.category comment + = Reason_comment.EndOfLine + && just_after (Reason_comment.location comment) -> Reason_comment.EndOfLine | _ -> Reason_comment.Regular in @@ -264,30 +289,29 @@ module Create_parse_entrypoint Reason_comment.make ~location category original_comment_contents in comment :: classifiedTail - ) in - let modified_and_comment_with_category = classifyAndNormalizeComments unmodified_comments in - let _ = Parsing.clear_parser() in - (ast, modified_and_comment_with_category) - ) + let modified_and_comment_with_category = + classifyAndNormalizeComments unmodified_comments + in + let _ = Parsing.clear_parser () in + ast, modified_and_comment_with_category) let default_error lexbuf err = - if !Reason_config.recoverable then - let loc, msg = match err with - | Location.Error err -> - Reason_syntax_util.split_compiler_error err + if !Reason_config.recoverable + then + let loc, msg = + match err with + | Location.Error err -> Reason_syntax_util.split_compiler_error err | Reason_errors.Reason_error (e, loc) -> Reason_errors.report_error Format.str_formatter ~loc e; - (loc, Format.flush_str_formatter ()) + loc, Format.flush_str_formatter () | exn -> - (Location.of_lexbuf lexbuf, "default_error: " ^ Printexc.to_string exn) + Location.of_lexbuf lexbuf, "default_error: " ^ Printexc.to_string exn in - (loc, Reason_errors.error_extension_node loc msg) - else - raise err + loc, Reason_errors.error_extension_node loc msg + else raise err - let ignore_attach_errors x _extensions = - (* FIXME: attach errors in AST *) x + let ignore_attach_errors x _extensions = (* FIXME: attach errors in AST *) x (* * The canonical interface/implementations (with comments) are used with @@ -300,48 +324,46 @@ module Create_parse_entrypoint *) let implementation_with_comments lexbuf = let attach impl extensions = - (impl @ List.map Ast_helper.Str.extension extensions) + impl @ List.map Ast_helper.Str.extension extensions in - try wrap_with_comments Toolchain_impl.implementation attach lexbuf - with err -> + try wrap_with_comments Toolchain_impl.implementation attach lexbuf with + | err -> let loc, error = default_error lexbuf err in - ([Ast_helper.Str.mk ~loc (Parsetree.Pstr_extension (error, []))], []) + [ Ast_helper.Str.mk ~loc (Parsetree.Pstr_extension (error, [])) ], [] let core_type_with_comments lexbuf = - try wrap_with_comments Toolchain_impl.core_type ignore_attach_errors lexbuf - with err -> + try + wrap_with_comments Toolchain_impl.core_type ignore_attach_errors lexbuf + with + | err -> let loc, error = default_error lexbuf err in - (Ast_helper.Typ.mk ~loc (Parsetree.Ptyp_extension error), []) + Ast_helper.Typ.mk ~loc (Parsetree.Ptyp_extension error), [] let interface_with_comments lexbuf = let attach impl extensions = - (impl @ List.map Ast_helper.Sig.extension extensions) + impl @ List.map Ast_helper.Sig.extension extensions in - try wrap_with_comments Toolchain_impl.interface attach lexbuf - with err -> + try wrap_with_comments Toolchain_impl.interface attach lexbuf with + | err -> let loc, error = default_error lexbuf err in - ([Ast_helper.Sig.mk ~loc (Parsetree.Psig_extension (error, []))], []) + [ Ast_helper.Sig.mk ~loc (Parsetree.Psig_extension (error, [])) ], [] let toplevel_phrase_with_comments lexbuf = wrap_with_comments - Toolchain_impl.toplevel_phrase ignore_attach_errors lexbuf + Toolchain_impl.toplevel_phrase + ignore_attach_errors + lexbuf let use_file_with_comments lexbuf = wrap_with_comments Toolchain_impl.use_file ignore_attach_errors lexbuf - (** [ast_only] wraps a function to return only the ast component - *) - let ast_only f = - (fun lexbuf -> lexbuf |> f |> fst) + (** [ast_only] wraps a function to return only the ast component *) + let ast_only f lexbuf = lexbuf |> f |> fst let implementation = ast_only implementation_with_comments - let core_type = ast_only core_type_with_comments - let interface = ast_only interface_with_comments - let toplevel_phrase = ast_only toplevel_phrase_with_comments - let use_file = ast_only use_file_with_comments (* Printing *) diff --git a/src/reason-parser/reason_toolchain_conf.ml b/src/reason-parser/reason_toolchain_conf.ml index 87d1f6b85..48c45312b 100644 --- a/src/reason-parser/reason_toolchain_conf.ml +++ b/src/reason-parser/reason_toolchain_conf.ml @@ -4,6 +4,7 @@ module From_current = struct include Selected_ast.Of_ocaml include Reason_omp.Convert (Reason_omp.OCaml_current) (Reason_omp.OCaml_414) end + module To_current = struct include Selected_ast.To_ocaml include Reason_omp.Convert (Reason_omp.OCaml_414) (Reason_omp.OCaml_current) @@ -11,44 +12,71 @@ end module type Toolchain = sig (* Parsing *) - val core_type_with_comments: Lexing.lexbuf -> (Parsetree.core_type * Reason_comment.t list) - val implementation_with_comments: Lexing.lexbuf -> (Parsetree.structure * Reason_comment.t list) - val interface_with_comments: Lexing.lexbuf -> (Parsetree.signature * Reason_comment.t list) + val core_type_with_comments : + Lexing.lexbuf + -> Parsetree.core_type * Reason_comment.t list + + val implementation_with_comments : + Lexing.lexbuf + -> Parsetree.structure * Reason_comment.t list - val core_type: Lexing.lexbuf -> Parsetree.core_type - val implementation: Lexing.lexbuf -> Parsetree.structure - val interface: Lexing.lexbuf -> Parsetree.signature - val toplevel_phrase: Lexing.lexbuf -> Parsetree.toplevel_phrase - val use_file: Lexing.lexbuf -> Parsetree.toplevel_phrase list + val interface_with_comments : + Lexing.lexbuf + -> Parsetree.signature * Reason_comment.t list + + val core_type : Lexing.lexbuf -> Parsetree.core_type + val implementation : Lexing.lexbuf -> Parsetree.structure + val interface : Lexing.lexbuf -> Parsetree.signature + val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase + val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list (* Printing *) - val print_interface_with_comments: Format.formatter -> (Parsetree.signature * Reason_comment.t list) -> unit - val print_implementation_with_comments: Format.formatter -> (Parsetree.structure * Reason_comment.t list) -> unit + val print_interface_with_comments : + Format.formatter + -> Parsetree.signature * Reason_comment.t list + -> unit + val print_implementation_with_comments : + Format.formatter + -> Parsetree.structure * Reason_comment.t list + -> unit end module type Toolchain_spec = sig - val safeguard_parsing: Lexing.lexbuf -> - (unit -> ('a * Reason_comment.t list)) -> ('a * Reason_comment.t list) + val safeguard_parsing : + Lexing.lexbuf + -> (unit -> 'a * Reason_comment.t list) + -> 'a * Reason_comment.t list type token type invalid_docstrings module Lexer : sig type t - val init: ?insert_completion_ident:Lexing.position -> - Lexing.lexbuf -> t - val get_comments: t -> invalid_docstrings -> (string * Location.t) list + + val init : ?insert_completion_ident:Lexing.position -> Lexing.lexbuf -> t + val get_comments : t -> invalid_docstrings -> (string * Location.t) list end - val core_type: Lexer.t -> Parsetree.core_type * invalid_docstrings - val implementation: Lexer.t -> Parsetree.structure * invalid_docstrings - val interface: Lexer.t -> Parsetree.signature * invalid_docstrings - val toplevel_phrase: Lexer.t -> Parsetree.toplevel_phrase * invalid_docstrings - val use_file: Lexer.t -> Parsetree.toplevel_phrase list * invalid_docstrings + val core_type : Lexer.t -> Parsetree.core_type * invalid_docstrings + val implementation : Lexer.t -> Parsetree.structure * invalid_docstrings + val interface : Lexer.t -> Parsetree.signature * invalid_docstrings + + val toplevel_phrase : + Lexer.t + -> Parsetree.toplevel_phrase * invalid_docstrings + + val use_file : Lexer.t -> Parsetree.toplevel_phrase list * invalid_docstrings + + val format_interface_with_comments : + Parsetree.signature * Reason_comment.t list + -> Format.formatter + -> unit - val format_interface_with_comments: (Parsetree.signature * Reason_comment.t list) -> Format.formatter -> unit - val format_implementation_with_comments: (Parsetree.structure * Reason_comment.t list) -> Format.formatter -> unit + val format_implementation_with_comments : + Parsetree.structure * Reason_comment.t list + -> Format.formatter + -> unit end let insert_completion_ident : Lexing.position option ref = ref None diff --git a/src/reason-parser/reason_toolchain_ocaml.ml b/src/reason-parser/reason_toolchain_ocaml.ml index b9084e9ca..908554956 100644 --- a/src/reason-parser/reason_toolchain_ocaml.ml +++ b/src/reason-parser/reason_toolchain_ocaml.ml @@ -1,73 +1,92 @@ open Ppxlib -(* The OCaml parser keep doc strings in the comment list. - To avoid duplicating comments, we need to filter comments that appear - as doc strings is the AST out of the comment list. *) +(* The OCaml parser keep doc strings in the comment list. To avoid duplicating + comments, we need to filter comments that appear as doc strings is the AST + out of the comment list. *) let doc_comments_filter () = let seen = Hashtbl.create 7 in let mapper = object inherit Ast_traverse.map as super - method! attribute attr = - match attr with - | { attr_name = { Location. txt = ("ocaml.doc" | "ocaml.text")}; - attr_payload = - PStr [{ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string(_text, _loc, None)) } , _); - pstr_loc = loc }]} as attribute -> - (* Workaround: OCaml 4.02.3 kept an initial '*' in docstrings. - * For other versions, we have to put the '*' back. *) - Hashtbl.add seen loc (); - super#attribute attribute - | attribute -> super#attribute attribute + + method! attribute attr = + match attr with + | { attr_name = { Location.txt = "ocaml.doc" | "ocaml.text" } + ; attr_payload = + PStr + [ { pstr_desc = + Pstr_eval + ( { pexp_desc = + Pexp_constant (Pconst_string (_text, _loc, None)) + } + , _ ) + ; pstr_loc = loc + } + ] + } as attribute -> + (* Workaround: OCaml 4.02.3 kept an initial '*' in docstrings. + * For other versions, we have to put the '*' back. *) + Hashtbl.add seen loc (); + super#attribute attribute + | attribute -> super#attribute attribute end in let filter (_text, loc) = not (Hashtbl.mem seen loc) in - (mapper, filter) + mapper, filter module Lexer_impl = struct type t = Lexing.lexbuf + let init ?insert_completion_ident:_ lexbuf = - Lexer.init (); lexbuf - let token = Lexer.token + Lexer.init (); + lexbuf + let token = Lexer.token let filtered_comments = ref [] + let filter_comments filter = filtered_comments := List.filter filter (Lexer.comments ()) + let get_comments _lexbuf _docstrings = !filtered_comments end + module OCaml_parser = Ocaml_common.Parser + type token = OCaml_parser.token type invalid_docstrings = unit -(* OCaml parser parses into compiler-libs version of Ast. - Parsetrees are converted to Reason version on the fly. *) +(* OCaml parser parses into compiler-libs version of Ast. Parsetrees are + converted to Reason version on the fly. *) -let parse_and_filter_doc_comments iter fn lexbuf= +let parse_and_filter_doc_comments iter fn lexbuf = let it, filter = doc_comments_filter () in let result = fn lexbuf in ignore (iter it result); Lexer_impl.filter_comments filter; - (result, ()) + result, () let implementation lexbuf = parse_and_filter_doc_comments (fun it stru -> it#structure stru) - (fun lexbuf -> Reason_toolchain_conf.From_current.copy_structure - (OCaml_parser.implementation Lexer.token lexbuf)) + (fun lexbuf -> + Reason_toolchain_conf.From_current.copy_structure + (OCaml_parser.implementation Lexer.token lexbuf)) lexbuf let core_type lexbuf = parse_and_filter_doc_comments (fun it ty -> it#core_type ty) - (fun lexbuf -> Reason_toolchain_conf.From_current.copy_core_type - (OCaml_parser.parse_core_type Lexer.token lexbuf)) + (fun lexbuf -> + Reason_toolchain_conf.From_current.copy_core_type + (OCaml_parser.parse_core_type Lexer.token lexbuf)) lexbuf let interface lexbuf = parse_and_filter_doc_comments (fun it sig_ -> it#signature sig_) - (fun lexbuf -> Reason_toolchain_conf.From_current.copy_signature - (OCaml_parser.interface Lexer.token lexbuf)) + (fun lexbuf -> + Reason_toolchain_conf.From_current.copy_signature + (OCaml_parser.interface Lexer.token lexbuf)) lexbuf let filter_toplevel_phrase it = function @@ -77,17 +96,18 @@ let filter_toplevel_phrase it = function let toplevel_phrase lexbuf = parse_and_filter_doc_comments filter_toplevel_phrase - (fun lexbuf -> Reason_toolchain_conf.From_current.copy_toplevel_phrase - (OCaml_parser.toplevel_phrase Lexer.token lexbuf)) + (fun lexbuf -> + Reason_toolchain_conf.From_current.copy_toplevel_phrase + (OCaml_parser.toplevel_phrase Lexer.token lexbuf)) lexbuf let use_file lexbuf = parse_and_filter_doc_comments (fun it result -> List.map (filter_toplevel_phrase it) result) (fun lexbuf -> - List.map - Reason_toolchain_conf.From_current.copy_toplevel_phrase - (OCaml_parser.use_file Lexer.token lexbuf)) + List.map + Reason_toolchain_conf.From_current.copy_toplevel_phrase + (OCaml_parser.use_file Lexer.token lexbuf)) lexbuf (* Skip tokens to the end of the phrase *) @@ -96,14 +116,14 @@ let use_file lexbuf = let rec skip_phrase lexbuf = try match Lexer.token lexbuf with - OCaml_parser.SEMISEMI | OCaml_parser.EOF -> () - | _ -> skip_phrase lexbuf + | OCaml_parser.SEMISEMI | OCaml_parser.EOF -> () + | _ -> skip_phrase lexbuf with | Lexer.Error (Lexer.Unterminated_comment _, _) - | Lexer.Error (Lexer.Unterminated_string, _) - | Lexer.Error (Lexer.Unterminated_string_in_comment _, _) - | Lexer.Error (Lexer.Illegal_character _, _) -> - skip_phrase lexbuf + | Lexer.Error (Lexer.Unterminated_string, _) + | Lexer.Error (Lexer.Unterminated_string_in_comment _, _) + | Lexer.Error (Lexer.Illegal_character _, _) -> + skip_phrase lexbuf let maybe_skip_phrase lexbuf = if Parsing.is_current_lookahead OCaml_parser.SEMISEMI @@ -114,38 +134,37 @@ let maybe_skip_phrase lexbuf = module Location = Ocaml_common.Location let safeguard_parsing lexbuf fn = - try fn () - with - | Lexer.Error(Lexer.Illegal_character _, _) as err - when !Location.input_name = "//toplevel//"-> - skip_phrase lexbuf; - raise err - | Syntaxerr.Error _ as err - when !Location.input_name = "//toplevel//" -> - maybe_skip_phrase lexbuf; - raise err + try fn () with + | Lexer.Error (Lexer.Illegal_character _, _) as err + when !Location.input_name = "//toplevel//" -> + skip_phrase lexbuf; + raise err + | Syntaxerr.Error _ as err when !Location.input_name = "//toplevel//" -> + maybe_skip_phrase lexbuf; + raise err (* Escape error is raised as a general catchall when a syntax_error() is - thrown in the parser. - *) + thrown in the parser. *) | Parsing.Parse_error | Syntaxerr.Escape_error -> - let loc = Location.curr lexbuf in - if !Location.input_name = "//toplevel//" - then maybe_skip_phrase lexbuf; - raise(Syntaxerr.Error(Syntaxerr.Other loc)) + let loc = Location.curr lexbuf in + if !Location.input_name = "//toplevel//" then maybe_skip_phrase lexbuf; + raise (Syntaxerr.Error (Syntaxerr.Other loc)) (* Unfortunately we drop the comments because there doesn't exist an ML * printer that formats comments *and* line wrapping! (yet) *) let format_interface_with_comments (signature, _) formatter = - Ocaml_common.Pprintast.signature formatter + Ocaml_common.Pprintast.signature + formatter (Reason_toolchain_conf.To_current.copy_signature signature) let format_implementation_with_comments (structure, _) formatter = let structure = structure |> Reason_syntax_util.(apply_mapper_to_structure backport_letopt_mapper) - |> Reason_syntax_util.(apply_mapper_to_structure remove_stylistic_attrs_mapper) + |> Reason_syntax_util.( + apply_mapper_to_structure remove_stylistic_attrs_mapper) in - Ocaml_common.Pprintast.structure formatter + Ocaml_common.Pprintast.structure + formatter (Reason_toolchain_conf.To_current.copy_structure structure) module Lexer = Lexer_impl diff --git a/src/reason-parser/reason_toolchain_reason.ml b/src/reason-parser/reason_toolchain_reason.ml index a2b429500..287411ef5 100644 --- a/src/reason-parser/reason_toolchain_reason.ml +++ b/src/reason-parser/reason_toolchain_reason.ml @@ -2,22 +2,22 @@ module P = Reason_recover_parser module Lexer = Reason_lexer (* From Reason source text to OCaml AST - - 1. Make a lexbuf from source text - 2. Reason_lexer: - a. Using OCamllex: - extract one token from stream of characters - b. post-process token: - - store comments separately - - insert ES6_FUN token - - insert completion identifier - 3. Reason_parser, using Menhir: - A parser with explicit continuations, which take a new token and return: - - an AST when parse succeeded - - a new continuation if more tokens are needed - - nothing, if the parser got stuck (token is invalid in current state) - 4. Reason_toolchain connect lexer and parser: -*) + * + * 1. Make a lexbuf from source text + * 2. Reason_lexer: + * a. Using OCamllex: + * extract one token from stream of characters + * b. post-process token: + * - store comments separately + * - insert ES6_FUN token + * - insert completion identifier + * 3. Reason_parser, using Menhir: + * A parser with explicit continuations, which take a new token and return: + * - an AST when parse succeeded + * - a new continuation if more tokens are needed + * - nothing, if the parser got stuck (token is invalid in current state) + * 4. Reason_toolchain connect lexer and parser: + *) type token = Reason_parser.token type invalid_docstrings = Reason_lexer.invalid_docstrings @@ -25,25 +25,21 @@ type invalid_docstrings = Reason_lexer.invalid_docstrings let rec loop lexer parser = let token = Lexer.token lexer in match P.step parser token with - | P.Intermediate parser' -> - loop lexer parser' + | P.Intermediate parser' -> loop lexer parser' | P.Error -> (* Impossible to reach this case? *) let _, loc_start, loc_end = token in - let loc = {Location. loc_start; loc_end; loc_ghost = false} in + let loc = { Location.loc_start; loc_end; loc_ghost = false } in Reason_errors.raise_fatal_error (Parsing_error "Syntax error") loc - | P.Success (x, docstrings) -> - (x, docstrings) + | P.Success (x, docstrings) -> x, docstrings let initial_run entry_point lexer = - loop lexer - (P.initial entry_point (Lexer.lexbuf lexer).Lexing.lex_curr_p) + loop lexer (P.initial entry_point (Lexer.lexbuf lexer).Lexing.lex_curr_p) let implementation lexer = initial_run Reason_parser.Incremental.implementation lexer -let interface lexer = - initial_run Reason_parser.Incremental.interface lexer +let interface lexer = initial_run Reason_parser.Incremental.interface lexer let core_type lexer = initial_run Reason_parser.Incremental.parse_core_type lexer @@ -51,8 +47,7 @@ let core_type lexer = let toplevel_phrase lexer = initial_run Reason_parser.Incremental.toplevel_phrase lexer -let use_file lexer = - initial_run Reason_parser.Incremental.use_file lexer +let use_file lexer = initial_run Reason_parser.Incremental.use_file lexer (* Skip tokens to the end of the phrase *) let rec skip_phrase lexer = @@ -60,31 +55,32 @@ let rec skip_phrase lexer = match Lexer.token lexer with | (Reason_parser.SEMI | Reason_parser.EOF), _, _ -> () | _ -> skip_phrase lexer - with Reason_errors.Reason_error (Lexing_error ( Unterminated_comment _ - | Unterminated_string - | Unterminated_string_in_comment _ - | Illegal_character _) , _ ) -> + with + | Reason_errors.Reason_error + ( Lexing_error + ( Unterminated_comment _ | Unterminated_string + | Unterminated_string_in_comment _ | Illegal_character _ ) + , _ ) -> skip_phrase lexer let safeguard_parsing lexbuf fn = - try fn () - with + try fn () with | Reason_errors.Reason_error _ as err - when !Location.input_name = "//toplevel//"-> + when !Location.input_name = "//toplevel//" -> skip_phrase (Lexer.init lexbuf); raise err | Location.Error _ as x -> - let loc = Location.curr lexbuf in - if !Location.input_name = "//toplevel//" - then - let _ = skip_phrase (Lexer.init lexbuf) in - raise(Syntaxerr.Error(Syntaxerr.Other loc)) - else - raise x + let loc = Location.curr lexbuf in + if !Location.input_name = "//toplevel//" + then + let _ = skip_phrase (Lexer.init lexbuf) in + raise (Syntaxerr.Error (Syntaxerr.Other loc)) + else raise x let format_interface_with_comments (signature, comments) formatter = let reason_formatter = Reason_pprint_ast.createFormatter () in reason_formatter#signature comments formatter signature + let format_implementation_with_comments (implementation, comments) formatter = let reason_formatter = Reason_pprint_ast.createFormatter () in reason_formatter#structure comments formatter implementation diff --git a/src/refmt/eol_convert.ml b/src/refmt/eol_convert.ml index bb2e9a6e1..488cd2de0 100644 --- a/src/refmt/eol_convert.ml +++ b/src/refmt/eol_convert.ml @@ -5,9 +5,10 @@ let lf_to_crlf s = match String.index sz '\n' with | exception Not_found -> sz | idx -> - let l = (String.sub sz 0 idx) ^ "\r\n" in - let length = String.length sz in - l ^ (loop (String.sub sz (idx + 1) ((length - idx) - 1))) in + let l = String.sub sz 0 idx ^ "\r\n" in + let length = String.length sz in + l ^ loop (String.sub sz (idx + 1) (length - idx - 1)) + in loop s let get_formatter output_channel eol = @@ -17,8 +18,10 @@ let get_formatter output_channel eol = match eol with | LF -> out_functions.out_string s p n | CRLF -> - let str = String.sub s p n in - let str = lf_to_crlf str in - out_functions.out_string str 0 (String.length str) in + let str = String.sub s p n in + let str = lf_to_crlf str in + out_functions.out_string str 0 (String.length str) + in let new_functions = { out_functions with out_string } in - Format.pp_set_formatter_out_functions f new_functions; f + Format.pp_set_formatter_out_functions f new_functions; + f diff --git a/src/refmt/eol_detect.ml b/src/refmt/eol_detect.ml index cc2c3ad92..ab01541ce 100644 --- a/src/refmt/eol_detect.ml +++ b/src/refmt/eol_detect.ml @@ -1,21 +1,23 @@ type eol = - | LF - | CRLF -let show eol = match eol with | LF -> "lf" | CRLF -> "crlf" -let default_eol = match Sys.win32 with | true -> CRLF | _ -> LF + | LF + | CRLF + +let show eol = match eol with LF -> "lf" | CRLF -> "crlf" +let default_eol = match Sys.win32 with true -> CRLF | _ -> LF + let get_eol_for_file filename = let ic = open_in_bin filename in let line = ref "" in let c = ref ' ' in let prev = ref None in try - while (!c) <> '\n' do - (prev := (Some (!c)); - c := (input_char ic); - line := ((!line) ^ (String.make 1 (!c)))) - done; - (match !prev with - | None -> default_eol - | Some '\r' -> CRLF - | Some _ -> LF) - with | End_of_file -> (close_in ic; default_eol) \ No newline at end of file + while !c <> '\n' do + prev := Some !c; + c := input_char ic; + line := !line ^ String.make 1 !c + done; + match !prev with None -> default_eol | Some '\r' -> CRLF | Some _ -> LF + with + | End_of_file -> + close_in ic; + default_eol diff --git a/src/refmt/git_commit.mli b/src/refmt/git_commit.mli index d8801deb2..e6c7eb2cd 100644 --- a/src/refmt/git_commit.mli +++ b/src/refmt/git_commit.mli @@ -1,5 +1,4 @@ (* Interface file to ensure git_commit is generated properly with dune *) -val version: string - -val short_version: string +val version : string +val short_version : string diff --git a/src/refmt/package.ml b/src/refmt/package.ml index 01a51a762..5e328efed 100644 --- a/src/refmt/package.ml +++ b/src/refmt/package.ml @@ -1,7 +1,7 @@ -let version = (match Build_info.V1.version () with +let version = + match Build_info.V1.version () with | None -> "n/a" - | Some v -> Build_info.V1.Version.to_string v) + | Some v -> Build_info.V1.Version.to_string v let git_version = Git_commit.version - let git_short_version = Git_commit.short_version diff --git a/src/refmt/printer_maker.ml b/src/refmt/printer_maker.ml index b938cb482..6b5c3d692 100644 --- a/src/refmt/printer_maker.ml +++ b/src/refmt/printer_maker.ml @@ -1,58 +1,71 @@ -type parse_itype = [ `ML | `Reason | `Binary | `BinaryReason | `Auto ] -type print_itype = [ `ML | `Reason | `Binary | `BinaryReason | `AST | `None ] +type parse_itype = + [ `ML + | `Reason + | `Binary + | `BinaryReason + | `Auto + ] -exception Invalid_config of string +type print_itype = + [ `ML + | `Reason + | `Binary + | `BinaryReason + | `AST + | `None + ] -module type PRINTER = - sig - type t +exception Invalid_config of string - val parse : use_stdin:bool -> - parse_itype -> - string -> - ((t * Reason_comment.t list) * bool) +module type PRINTER = sig + type t + val parse : + use_stdin:bool + -> parse_itype + -> string + -> (t * Reason_comment.t list) * bool - val print : print_itype -> - string -> - bool -> - out_channel -> - Format.formatter -> - ((t * Reason_comment.t list) -> unit) - end + val print : + print_itype + -> string + -> bool + -> out_channel + -> Format.formatter + -> t * Reason_comment.t list + -> unit +end let err s = raise (Invalid_config s) let prepare_output_file name = - match name with - | Some name -> open_out_bin name - | None -> set_binary_mode_out stdout true; stdout + match name with + | Some name -> open_out_bin name + | None -> + set_binary_mode_out stdout true; + stdout let close_output_file output_file output_chan = - match output_file with - | Some _ -> close_out output_chan - | None -> () + match output_file with Some _ -> close_out output_chan | None -> () let ocamlBinaryParser use_stdin filename = let module Ast_io = Ppxlib__.Utils.Ast_io in let input_source = - match use_stdin with - | true -> Ast_io.Stdin - | false -> File filename + match use_stdin with true -> Ast_io.Stdin | false -> File filename in match Ast_io.read input_source ~input_kind:Necessarily_binary with | Error _ -> assert false - | Ok ({ ast = Impl ast; _ }) -> ((Obj.magic ast, []), true, false) - | Ok ({ ast = Intf ast; _ }) -> ((Obj.magic ast, []), true, true) + | Ok { ast = Impl ast; _ } -> (Obj.magic ast, []), true, false + | Ok { ast = Intf ast; _ } -> (Obj.magic ast, []), true, true let reasonBinaryParser use_stdin filename = let chan = match use_stdin with - | true -> stdin - | false -> - let file_chan = open_in_bin filename in - seek_in file_chan 0; - file_chan + | true -> stdin + | false -> + let file_chan = open_in_bin filename in + seek_in file_chan 0; + file_chan in - let (_, _, ast, comments, parsedAsML, parsedAsInterface) = input_value chan in - ((ast, comments), parsedAsML, parsedAsInterface) + let _, _, ast, comments, parsedAsML, parsedAsInterface = input_value chan in + (ast, comments), parsedAsML, parsedAsInterface diff --git a/src/refmt/reason_implementation_printer.ml b/src/refmt/reason_implementation_printer.ml index 11b0e6b6d..f4c83be6b 100644 --- a/src/refmt/reason_implementation_printer.ml +++ b/src/refmt/reason_implementation_printer.ml @@ -1,70 +1,86 @@ open Ppxlib type t = Parsetree.structure + let err = Printer_maker.err (* Note: filename should only be used with .ml files. See reason_toolchain. *) let defaultImplementationParserFor use_stdin filename = let open Reason_toolchain in - let (theParser, parsedAsML) = + let theParser, parsedAsML = if Filename.check_suffix filename ".re" - then (RE.implementation_with_comments, false) + then RE.implementation_with_comments, false else if Filename.check_suffix filename ".ml" - then (ML.implementation_with_comments, true) - else err ("Cannot determine default implementation parser for filename '" ^ filename ^ "'.") + then ML.implementation_with_comments, true + else + err + ("Cannot determine default implementation parser for filename '" + ^ filename + ^ "'.") in theParser (setup_lexbuf use_stdin filename), parsedAsML, false let parse ~use_stdin filetype filename = - let ((ast, comments), parsedAsML, parsedAsInterface) = - (match filetype with - | `Auto -> defaultImplementationParserFor use_stdin filename - | `BinaryReason -> Printer_maker.reasonBinaryParser use_stdin filename - | `Binary -> Printer_maker.ocamlBinaryParser use_stdin filename - | `ML -> - let lexbuf = Reason_toolchain.setup_lexbuf use_stdin filename in - let impl = Reason_toolchain.ML.implementation_with_comments in - (impl lexbuf, true, false) - | `Reason -> - let lexbuf = Reason_toolchain.setup_lexbuf use_stdin filename in - let impl = Reason_toolchain.RE.implementation_with_comments in - (impl lexbuf, false, false)) + let (ast, comments), parsedAsML, parsedAsInterface = + match filetype with + | `Auto -> defaultImplementationParserFor use_stdin filename + | `BinaryReason -> Printer_maker.reasonBinaryParser use_stdin filename + | `Binary -> Printer_maker.ocamlBinaryParser use_stdin filename + | `ML -> + let lexbuf = Reason_toolchain.setup_lexbuf use_stdin filename in + let impl = Reason_toolchain.ML.implementation_with_comments in + impl lexbuf, true, false + | `Reason -> + let lexbuf = Reason_toolchain.setup_lexbuf use_stdin filename in + let impl = Reason_toolchain.RE.implementation_with_comments in + impl lexbuf, false, false in - if parsedAsInterface then - err "The file parsed does not appear to be an implementation file." - else - ((ast, comments), parsedAsML) + if parsedAsInterface + then err "The file parsed does not appear to be an implementation file." + else (ast, comments), parsedAsML let print printtype filename parsedAsML output_chan output_formatter = match printtype with - | `BinaryReason -> fun (ast, comments) -> ( - (* Our special format for interchange between reason should keep the - * comments separate. This is not compatible for input into the - * ocaml compiler - only for input into another version of Reason. We - * also store whether or not the binary was originally *parsed* as an - * interface file. - *) - output_value output_chan ( - Ocaml_common.Config.ast_impl_magic_number, filename, ast, comments, parsedAsML, false - ); - ) - | `Binary -> fun (ast, _) -> - let ast = - ast - |> Reason_syntax_util.(apply_mapper_to_structure remove_stylistic_attrs_mapper) - |> Reason_syntax_util.(apply_mapper_to_structure backport_letopt_mapper) - in - Ppxlib__.Utils.Ast_io.write - output_chan - { Ppxlib__.Utils.Ast_io.input_name = filename; - input_version = Obj.magic (module Ppxlib_ast.Compiler_version: Ppxlib_ast.OCaml_version); - ast = Impl ast - } - ~add_ppx_context:false - | `AST -> fun (ast, _) -> ( - Ocaml_common.Printast.implementation output_formatter - (Reason_toolchain.To_current.copy_structure ast) - ) - | `None -> (fun _ -> ()) - | `ML -> Reason_toolchain.ML.print_implementation_with_comments output_formatter - | `Reason -> Reason_toolchain.RE.print_implementation_with_comments output_formatter + | `BinaryReason -> + fun (ast, comments) -> + (* Our special format for interchange between reason should keep the + * comments separate. This is not compatible for input into the + * ocaml compiler - only for input into another version of Reason. We + * also store whether or not the binary was originally *parsed* as an + * interface file. + *) + output_value + output_chan + ( Ocaml_common.Config.ast_impl_magic_number + , filename + , ast + , comments + , parsedAsML + , false ) + | `Binary -> + fun (ast, _) -> + let ast = + ast + |> Reason_syntax_util.( + apply_mapper_to_structure remove_stylistic_attrs_mapper) + |> Reason_syntax_util.(apply_mapper_to_structure backport_letopt_mapper) + in + Ppxlib__.Utils.Ast_io.write + output_chan + { Ppxlib__.Utils.Ast_io.input_name = filename + ; input_version = + Obj.magic + (module Ppxlib_ast.Compiler_version : Ppxlib_ast.OCaml_version) + ; ast = Impl ast + } + ~add_ppx_context:false + | `AST -> + fun (ast, _) -> + Ocaml_common.Printast.implementation + output_formatter + (Reason_toolchain.To_current.copy_structure ast) + | `None -> fun _ -> () + | `ML -> + Reason_toolchain.ML.print_implementation_with_comments output_formatter + | `Reason -> + Reason_toolchain.RE.print_implementation_with_comments output_formatter diff --git a/src/refmt/reason_interface_printer.ml b/src/refmt/reason_interface_printer.ml index 8aaf9b2ea..46b5d4e7e 100644 --- a/src/refmt/reason_interface_printer.ml +++ b/src/refmt/reason_interface_printer.ml @@ -1,70 +1,85 @@ open Ppxlib type t = Parsetree.signature + let err = Printer_maker.err (* Note: filename should only be used with .mli files. See reason_toolchain. *) let defaultInterfaceParserFor use_stdin filename = let open Reason_toolchain in - let (theParser, parsedAsML) = + let theParser, parsedAsML = if Filename.check_suffix filename ".rei" - then (RE.interface_with_comments, false) + then RE.interface_with_comments, false else if Filename.check_suffix filename ".mli" - then (ML.interface_with_comments, true) - else err ("Cannot determine default interface parser for filename '" ^ filename ^ "'.") + then ML.interface_with_comments, true + else + err + ("Cannot determine default interface parser for filename '" + ^ filename + ^ "'.") in theParser (setup_lexbuf use_stdin filename), parsedAsML, true let parse ~use_stdin filetype filename = - let ((ast, comments), parsedAsML, parsedAsInterface) = - (match filetype with - | `Auto -> defaultInterfaceParserFor use_stdin filename - | `BinaryReason -> Printer_maker.reasonBinaryParser use_stdin filename - | `Binary -> Printer_maker.ocamlBinaryParser use_stdin filename - | `ML -> - let lexbuf = Reason_toolchain.setup_lexbuf use_stdin filename in - let intf = Reason_toolchain.ML.interface_with_comments in - ((intf lexbuf), true, true) - | `Reason -> - let lexbuf = Reason_toolchain.setup_lexbuf use_stdin filename in - let intf = Reason_toolchain.RE.interface_with_comments in - ((intf lexbuf), false, true)) + let (ast, comments), parsedAsML, parsedAsInterface = + match filetype with + | `Auto -> defaultInterfaceParserFor use_stdin filename + | `BinaryReason -> Printer_maker.reasonBinaryParser use_stdin filename + | `Binary -> Printer_maker.ocamlBinaryParser use_stdin filename + | `ML -> + let lexbuf = Reason_toolchain.setup_lexbuf use_stdin filename in + let intf = Reason_toolchain.ML.interface_with_comments in + intf lexbuf, true, true + | `Reason -> + let lexbuf = Reason_toolchain.setup_lexbuf use_stdin filename in + let intf = Reason_toolchain.RE.interface_with_comments in + intf lexbuf, false, true in - if not parsedAsInterface then - err "The file parsed does not appear to be an interface file." - else ((ast, comments), parsedAsML) + if not parsedAsInterface + then err "The file parsed does not appear to be an interface file." + else (ast, comments), parsedAsML let print printtype filename parsedAsML output_chan output_formatter = match printtype with - | `BinaryReason -> fun (ast, comments) -> ( - (* Our special format for interchange between reason should keep the - * comments separate. This is not compatible for input into the - * ocaml compiler - only for input into another version of Reason. We - * also store whether or not the binary was originally *parsed* as an - * interface file. - *) - output_value output_chan ( - Ocaml_common.Config.ast_intf_magic_number, filename, ast, comments, parsedAsML, true - ); - ) - | `Binary -> fun (ast, _) -> ( + | `BinaryReason -> + fun (ast, comments) -> + (* Our special format for interchange between reason should keep the + * comments separate. This is not compatible for input into the + * ocaml compiler - only for input into another version of Reason. We + * also store whether or not the binary was originally *parsed* as an + * interface file. + *) + output_value + output_chan + ( Ocaml_common.Config.ast_intf_magic_number + , filename + , ast + , comments + , parsedAsML + , true ) + | `Binary -> + fun (ast, _) -> let ast = ast - |> Reason_syntax_util.(apply_mapper_to_signature remove_stylistic_attrs_mapper) + |> Reason_syntax_util.( + apply_mapper_to_signature remove_stylistic_attrs_mapper) |> Reason_syntax_util.(apply_mapper_to_signature backport_letopt_mapper) in Ppxlib__.Utils.Ast_io.write output_chan - { Ppxlib__.Utils.Ast_io.input_name = filename; - input_version = Obj.magic (module Ppxlib_ast.Compiler_version: Ppxlib_ast.OCaml_version); - ast = Intf ast + { Ppxlib__.Utils.Ast_io.input_name = filename + ; input_version = + Obj.magic + (module Ppxlib_ast.Compiler_version : Ppxlib_ast.OCaml_version) + ; ast = Intf ast } ~add_ppx_context:false - ) - | `AST -> fun (ast, _) -> ( - Ocaml_common.Printast.interface output_formatter + | `AST -> + fun (ast, _) -> + Ocaml_common.Printast.interface + output_formatter (Reason_toolchain.To_current.copy_signature ast) - ) - | `None -> (fun _ -> ()) + | `None -> fun _ -> () | `ML -> Reason_toolchain.ML.print_interface_with_comments output_formatter - | `Reason -> Reason_toolchain.RE.print_interface_with_comments output_formatter + | `Reason -> + Reason_toolchain.RE.print_interface_with_comments output_formatter diff --git a/src/refmt/refmt.ml b/src/refmt/refmt.ml index f539f41f2..fcb1df049 100644 --- a/src/refmt/refmt.ml +++ b/src/refmt/refmt.ml @@ -16,7 +16,8 @@ let read_text_lines file = list := input_line chan :: !list done; [] - with End_of_file -> + with + | End_of_file -> close_in chan; List.rev !list @@ -32,59 +33,62 @@ let refmt input_files = let refmt_single input_file = - let (use_stdin, input_file) = match input_file with - | Some name -> (false, name) - | None -> (true, "") + let use_stdin, input_file = + match input_file with Some name -> false, name | None -> true, "" in - let eol = match use_stdin, input_file with - | (true, _) -> Eol_detect.default_eol - | (false, name) -> Eol_detect.get_eol_for_file name + let eol = + match use_stdin, input_file with + | true, _ -> Eol_detect.default_eol + | false, name -> Eol_detect.get_eol_for_file name in - let parse_ast = match parse_ast, use_stdin with - | (Some x, _) -> x - | (None, false) -> `Auto - | (None, true) -> `Reason (* default *) + let parse_ast = + match parse_ast, use_stdin with + | Some x, _ -> x + | None, false -> `Auto + | None, true -> `Reason (* default *) in - let constructorLists = match heuristics_file with + let constructorLists = + match heuristics_file with | Some f_name -> read_text_lines f_name | None -> [] in - let interface = match interface with + let interface = + match interface with | true -> true - | false -> (Filename.check_suffix input_file ".rei" || Filename.check_suffix input_file ".mli") + | false -> + Filename.check_suffix input_file ".rei" + || Filename.check_suffix input_file ".mli" in let output_file = match in_place, use_stdin with - | (true, true) -> Printer_maker.err "Cannot write in place to stdin." - | (true, _) -> Some input_file - | (false, _) -> None + | true, true -> Printer_maker.err "Cannot write in place to stdin." + | true, _ -> Some input_file + | false, _ -> None in let (module Printer : Printer_maker.PRINTER) = - if interface then (module Reason_interface_printer) + if interface + then (module Reason_interface_printer) else (module Reason_implementation_printer) in Reason_config.configure ~r:is_recoverable; Location.input_name := input_file; - let _ = Reason_pprint_ast.configure - ~width: print_width - ~assumeExplicitArity: explicit_arity + let _ = + Reason_pprint_ast.configure + ~width:print_width + ~assumeExplicitArity:explicit_arity ~constructorLists in - let (ast, parsedAsML) = - Printer.parse ~use_stdin parse_ast input_file - in + let ast, parsedAsML = Printer.parse ~use_stdin parse_ast input_file in let output_chan = Printer_maker.prepare_output_file output_file in - (* If you run into trouble with this (or need to use std_formatter by - itself at the same time for some reason), try breaking this out so that - it's not possible to call Format.formatter_of_out_channel on stdout. *) + (* If you run into trouble with this (or need to use std_formatter by itself + at the same time for some reason), try breaking this out so that it's not + possible to call Format.formatter_of_out_channel on stdout. *) let output_formatter = Eol_convert.get_formatter output_chan eol in - ( - Printer.print print input_file parsedAsML output_chan output_formatter ast; - (* Also closes all open boxes. *) - Format.pp_print_flush output_formatter (); - flush output_chan; - Printer_maker.close_output_file output_file output_chan; - ) + Printer.print print input_file parsedAsML output_chan output_formatter ast; + (* Also closes all open boxes. *) + Format.pp_print_flush output_formatter (); + flush output_chan; + Printer_maker.close_output_file output_file output_chan in try match input_files with @@ -97,20 +101,20 @@ let refmt exit 1 | exn -> prerr_endline (Printexc.to_string exn); - (* FIXME: Reason_syntax_util.report_error Format.err_formatter exn; *) + (* FIXME: Reason_syntax_util.report_error Format.err_formatter exn; *) exit 1 let split_lines s = let rec loop ~last_is_cr ~acc i j = if j = String.length s - then ( + then let acc = if j = i || (j = i + 1 && last_is_cr) then acc else String.sub s i (j - i) :: acc in - List.rev acc) - else ( + List.rev acc + else match s.[j] with | '\r' -> loop ~last_is_cr:true ~acc i (j + 1) | '\n' -> @@ -119,14 +123,14 @@ let split_lines s = String.sub s i len in loop ~acc:(line :: acc) (j + 1) (j + 1) ~last_is_cr:false - | _ -> loop ~acc i (j + 1) ~last_is_cr:false) + | _ -> loop ~acc i (j + 1) ~last_is_cr:false in loop ~acc:[] 0 0 ~last_is_cr:false -;; let[@tail_mod_cons] rec concat_map f = function | [] -> [] - | x::xs -> prepend_concat_map (f x) f xs + | x :: xs -> prepend_concat_map (f x) f xs + and[@tail_mod_cons] prepend_concat_map ys f xs = match ys with | [] -> concat_map f xs @@ -149,41 +153,46 @@ let examples = function in let example_blocks = examples |> List.mapi block_of_example in `Blocks (`S "EXAMPLES" :: example_blocks) -;; - let top_level_info = let doc = "Reason's Parser & Pretty-printer" in let man = - [`S "DESCRIPTION" - ; `P "refmt lets you format Reason files, parse them, and convert them between OCaml syntax and Reason syntax." - ; (examples - [ "Initialise a new project named `foo'", "dune init project foo" - ; "Format a Reason implementation file", "refmt file.re" - ; "Format a Reason interface file", "refmt file.rei" - ; "Format interface code from the command line", "echo 'let x: int' | refmt --interface=true" - ; "Convert an OCaml file to Reason", "refmt file.ml" - ; "Convert a Reason file to OCaml", "refmt file.re --print ml" - ; "Convert OCaml from the command line to Reason", "echo 'let x = 1' | refmt --parse ml" - ]) + [ `S "DESCRIPTION" + ; `P + "refmt lets you format Reason files, parse them, and convert them \ + between OCaml syntax and Reason syntax." + ; examples + [ "Initialise a new project named `foo'", "dune init project foo" + ; "Format a Reason implementation file", "refmt file.re" + ; "Format a Reason interface file", "refmt file.rei" + ; ( "Format interface code from the command line" + , "echo 'let x: int' | refmt --interface=true" ) + ; "Convert an OCaml file to Reason", "refmt file.ml" + ; "Convert a Reason file to OCaml", "refmt file.re --print ml" + ; ( "Convert OCaml from the command line to Reason" + , "echo 'let x = 1' | refmt --parse ml" ) + ] ] in -let version = "Reason " ^ Package.version ^ " @ " ^ Package.git_short_version + let version = + "Reason " ^ Package.version ^ " @ " ^ Package.git_short_version in Cmd.info "refmt" ~version ~doc ~man let refmt_t = let open Term in let open Refmt_args in - let term = const refmt $ interface - $ recoverable - $ explicit_arity - $ parse_ast - $ print - $ print_width - $ heuristics_file - $ in_place - $ input + let term = + const refmt + $ interface + $ recoverable + $ explicit_arity + $ parse_ast + $ print + $ print_width + $ heuristics_file + $ in_place + $ input in Cmd.v top_level_info (Term.ret term) diff --git a/src/refmt/refmt_args.ml b/src/refmt/refmt_args.ml index 2767eea8a..706bf902e 100644 --- a/src/refmt/refmt_args.ml +++ b/src/refmt/refmt_args.ml @@ -1,64 +1,78 @@ - open Vendored_cmdliner let interface = let doc = "parse AST as an interface" in - Arg.(value & opt (bool) false & info ["i"; "interface"] ~doc) + Arg.(value & opt bool false & info [ "i"; "interface" ] ~doc) let recoverable = let doc = "enable recoverable parser" in - Arg.(value & flag & info ["r"; "recoverable"] ~doc) + Arg.(value & flag & info [ "r"; "recoverable" ] ~doc) let explicit_arity = let doc = - "if a constructor's argument is a tuple, always interpret it as \ - multiple arguments" + "if a constructor's argument is a tuple, always interpret it as multiple \ + arguments" in - Arg.(value & flag & info ["e"; "assume-explicit-arity"] ~doc) + Arg.(value & flag & info [ "e"; "assume-explicit-arity" ] ~doc) let parse_ast = let docv = "FORM" in - let doc = "parse AST in FORM, which is one of: (ml | re | \ - binary (for compiler input) | \ - binary_reason (for interchange between Reason versions))" + let doc = + "parse AST in FORM, which is one of: (ml | re | binary (for compiler \ + input) | binary_reason (for interchange between Reason versions))" in - let opts = Arg.enum ["ml", `ML; "re", `Reason; "binary", `Binary; - "binary_reason", `BinaryReason; "auto", `Auto] + let opts = + Arg.enum + [ "ml", `ML + ; "re", `Reason + ; "binary", `Binary + ; "binary_reason", `BinaryReason + ; "auto", `Auto + ] in - Arg.(value & opt (some opts) None & info ["parse"] ~docv ~doc) + Arg.(value & opt (some opts) None & info [ "parse" ] ~docv ~doc) let print = let docv = "FORM" in - let doc = "print AST in FORM, which is one of: (ml | re (default) | \ - binary (for compiler input) | \ - binary_reason (for interchange between Reason versions) | \ - ast (print human readable AST directly) | none)" + let doc = + "print AST in FORM, which is one of: (ml | re (default) | binary (for \ + compiler input) | binary_reason (for interchange between Reason versions) \ + | ast (print human readable AST directly) | none)" in - let opts = Arg.enum ["ml", `ML; "re", `Reason; "binary", `Binary; - "binary_reason", `BinaryReason; "ast", `AST; - "none", `None] + let opts = + Arg.enum + [ "ml", `ML + ; "re", `Reason + ; "binary", `Binary + ; "binary_reason", `BinaryReason + ; "ast", `AST + ; "none", `None + ] in - Arg.(value & opt opts `Reason & info ["p"; "print"] ~docv ~doc) + Arg.(value & opt opts `Reason & info [ "p"; "print" ] ~docv ~doc) let print_width = let docv = "COLS" in let doc = "wrapping width for printing the AST" in let env = Cmd.Env.info "REFMT_PRINT_WIDTH" ~doc in - Arg.(value & opt (int) (80) & info ["w"; "print-width"] ~docv ~doc ~env) + Arg.(value & opt int 80 & info [ "w"; "print-width" ] ~docv ~doc ~env) let heuristics_file = let doc = - "load path as a heuristics file to specify which constructors carry a tuple \ - rather than multiple arguments. Mostly used in removing [@implicit_arity] introduced from \ - OCaml conversion.\n\t\texample.txt:\n\t\tConstructor1\n\t\tConstructor2" + "load path as a heuristics file to specify which constructors carry a \ + tuple rather than multiple arguments. Mostly used in removing \ + [@implicit_arity] introduced from OCaml conversion.\n\ + \t\texample.txt:\n\ + \t\tConstructor1\n\ + \t\tConstructor2" in - Arg.(value & opt (some file) None & info ["h"; "heuristics-file"] ~doc) + Arg.(value & opt (some file) None & info [ "h"; "heuristics-file" ] ~doc) let in_place = let doc = "reformat a file in-place" in - Arg.(value & flag & info ["in-place"] ~doc) + Arg.(value & flag & info [ "in-place" ] ~doc) let input = let docv = "FILENAMES" in let doc = "input files; if empty, assume stdin" in - Arg.(value & (pos_all non_dir_file []) & info [] ~docv ~doc) + Arg.(value & pos_all non_dir_file [] & info [] ~docv ~doc) diff --git a/src/refmttype/reason_format_type.ml b/src/refmttype/reason_format_type.ml index b8ccafcbf..df97e9d88 100644 --- a/src/refmttype/reason_format_type.ml +++ b/src/refmttype/reason_format_type.ml @@ -5,7 +5,6 @@ * LICENSE file in the root directory of this source tree. *) - (* No String.split in stdlib... *) let split str ~by = let rec split' str ~by accum = @@ -16,29 +15,35 @@ let split str ~by = (String.sub str (foundIdx + 1) (String.length str - foundIdx - 1)) ~by (subStr :: accum) - with Not_found -> - List.rev (str :: accum) + with + | Not_found -> List.rev (str :: accum) in split' str ~by [] let () = - if Array.length Sys.argv <> 2 then - print_endline @@ "Please provide a single, quoted string of all the " ^ - "types you want transformed, separated by the escaped double quote \\\"" + if Array.length Sys.argv <> 2 + then + print_endline + @@ "Please provide a single, quoted string of all the " + ^ "types you want transformed, separated by the escaped double quote \\\"" else try Sys.argv.(1) |> split ~by:'"' |> List.map (fun input -> - try Reason_type_of_ocaml_type.convert input |> String.trim |> String.escaped - with Syntaxerr.Error _ -> - (* Can't parse the input for some reason? Return the (slightly modified) result and don't crash. *) - "ML: " ^ input - ) + try + Reason_type_of_ocaml_type.convert input + |> String.trim + |> String.escaped + with + | Syntaxerr.Error _ -> + (* Can't parse the input for some reason? Return the (slightly + modified) result and don't crash. *) + "ML: " ^ input) |> String.concat "\n" (* We omit printing one last line break in order to conserve the invariant - that 1 type maps to 1 line. E.g. ["a"] maps to "a" and ["a", ""] maps to - "a\n" *) + that 1 type maps to 1 line. E.g. ["a"] maps to "a" and ["a", ""] maps + to "a\n" *) |> print_string - with Syntaxerr.Error _ -> - prerr_endline "Failed to parse the input type(s)." + with + | Syntaxerr.Error _ -> prerr_endline "Failed to parse the input type(s)." diff --git a/src/refmttype/reason_type_of_ocaml_type.ml b/src/refmttype/reason_type_of_ocaml_type.ml index 1f43200ea..648b034dd 100644 --- a/src/refmttype/reason_type_of_ocaml_type.ml +++ b/src/refmttype/reason_type_of_ocaml_type.ml @@ -5,17 +5,16 @@ * LICENSE file in the root directory of this source tree. *) - -let () = Reason_pprint_ast.configure - (* This can be made pluggable in the future. *) - ~width:80 - ~assumeExplicitArity:false - ~constructorLists:[] +let () = + Reason_pprint_ast.configure (* This can be made pluggable in the future. *) + ~width:80 + ~assumeExplicitArity:false + ~constructorLists:[] let reasonFormatter = Reason_pprint_ast.createFormatter () -(* "Why would you ever pass in some of these to print into Reason?" -"Because Merlin returns these as type signature sometimes" *) +(* "Why would you ever pass in some of these to print into Reason?" "Because + Merlin returns these as type signature sometimes" *) (* int list *) let parseAsCoreType str formatter = @@ -37,7 +36,8 @@ let parseAsInterface str formatter = (* sig val a: int list end *) (* This one is a hack; we should have our own parser entry point to module_type. -But that'd require modifying compiler-libs, which we'll refrain from doing. *) + But that'd require modifying compiler-libs, which we'll refrain from + doing. *) let parseAsCoreModuleType str formatter = Lexing.from_string ("module X: " ^ str) |> Reason_toolchain.ML.interface @@ -45,18 +45,32 @@ let parseAsCoreModuleType str formatter = (* Quirky merlin/ocaml output that doesn't really parse. *) let parseAsWeirdListSyntax str a = - if str = "type 'a list = [] | :: of 'a * 'a list" then "type list 'a = [] | :: of list 'a 'a" - (* Manually creating an error is tedious, so we'll put a hack here to throw the previous error. *) + if str = "type 'a list = [] | :: of 'a * 'a list" + then + "type list 'a = [] | :: of list 'a 'a" + (* Manually creating an error is tedious, so we'll put a hack here to throw + the previous error. *) else raise (Syntaxerr.Error a) let convert str = let formatter = Format.str_formatter in - try (parseAsCoreType str formatter; Format.flush_str_formatter ()) - with Syntaxerr.Error _ -> - try (parseAsImplementation str formatter; Format.flush_str_formatter ()) - with Syntaxerr.Error _ -> - try (parseAsInterface str formatter; Format.flush_str_formatter ()) - with Syntaxerr.Error _ -> - try (parseAsCoreModuleType str formatter; Format.flush_str_formatter ()) - with Syntaxerr.Error a -> - (parseAsWeirdListSyntax str a) + try + parseAsCoreType str formatter; + Format.flush_str_formatter () + with + | Syntaxerr.Error _ -> + (try + parseAsImplementation str formatter; + Format.flush_str_formatter () + with + | Syntaxerr.Error _ -> + (try + parseAsInterface str formatter; + Format.flush_str_formatter () + with + | Syntaxerr.Error _ -> + (try + parseAsCoreModuleType str formatter; + Format.flush_str_formatter () + with + | Syntaxerr.Error a -> parseAsWeirdListSyntax str a)))